Overview
Context
Changes
Modified api.scm
from [d0f434c57c]
to [736048365d].
︙ | | |
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
|
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
|
-
-
-
-
-
-
-
+
+
+
+
+
+
+
|
;; These are called by the server on recipt of /api calls
;; - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;; - returns #( flag result )
;;
(define (api:execute-requests dbstruct dat)
(db:open-no-sync-db) ;; sets *no-sync-db*
(handle-exceptions
exn
(let ((call-chain (get-call-chain)))
(debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn)
(print-call-chain (current-error-port))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
;; (handle-exceptions
;; exn
;; (let ((call-chain (get-call-chain)))
;; (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn)
;; (print-call-chain (current-error-port))
;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
;; (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
(cond
((not (vector? dat)) ;; it is an error to not receive a vector
(vector #f (vector #f "remote must be called with a vector")))
((> *api-process-request-count* 200) ;; 20)
(debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.")
(set! *server-overloaded* #t)
(vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor!
|
︙ | | |
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
|
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
|
-
+
|
payload: `((params . ,params)
(ok-res . #t)))
(vector #f res))
(begin
#;(common:telemetry-log (conc "api-out:"(->string cmd))
payload: `((params . ,params)
(ok-res . #f)))
(vector #t res))))))))
(vector #t res))))))) ;; )
;; http-server send-response
;; api:process-request
;; db:*
;;
;; NB// Runs on the server as part of the server loop
;;
|
︙ | | |
Modified dbfile.scm
from [c56b4ac76c]
to [6257400a66].
︙ | | |
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
|
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
|
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(dbfile:print-err "INFO: db:lock-and-delta-sync copying db "runid" at "(current-seconds))
(set! *db-sync-in-progress* #t)
(db:sync-touched dbstruct runid keys dbinit)
(set! *db-sync-in-progress* #f)
(delete-file* lock-file)
#t)
(begin
(dbfile:print-err "ERROR: could not get lock for " from-db-file " from no-sync-db")
(dbfile:print-err "INFO: could not get lock for " from-db-file ", sync likely in progress.")
#f
))))
;; Get a lock from the no-sync-db for the from-db, then delta sync the from-db to the to-db, otherwise return #f
;;
(define (db:lock-and-delta-sync-orig no-sync-db dbstruct from-db-file runid keys dbinit)
(assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.")
;; (dbfile:print-err *default-log-port* "db:lock-and-delta-sync")
(let* ((lockdat (db:no-sync-get-lock-timeout no-sync-db from-db-file 60))
(gotlock (car lockdat))
(locktime (cdr lockdat)))
;; (debug:print-info 3 *default-log-port* "db:lock-and-delta-sync: got lock?")
(if gotlock
(begin
(dbfile:print-err "INFO: db:lock-and-delta-sync copying db "runid" at "(current-seconds))
(set! *db-sync-in-progress* #t)
(db:sync-touched dbstruct runid keys dbinit)
(set! *db-sync-in-progress* #f)
(db:no-sync-del! no-sync-db from-db-file)
#t)
(begin
(dbfile:print-err "ERROR: could not get lock for " from-db-file " from no-sync-db")
#f
))))
;; ;; Get a lock from the no-sync-db for the from-db, then delta sync the from-db to the to-db, otherwise return #f
;; ;;
;; (define (db:lock-and-delta-sync-orig no-sync-db dbstruct from-db-file runid keys dbinit)
;; (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.")
;; ;; (dbfile:print-err *default-log-port* "db:lock-and-delta-sync")
;; (let* ((lockdat (db:no-sync-get-lock-timeout no-sync-db from-db-file 60))
;; (gotlock (car lockdat))
;; (locktime (cdr lockdat)))
;; ;; (debug:print-info 3 *default-log-port* "db:lock-and-delta-sync: got lock?")
;;
;; (if gotlock
;; (begin
;; (dbfile:print-err "INFO: db:lock-and-delta-sync copying db "runid" at "(current-seconds))
;; (set! *db-sync-in-progress* #t)
;; (db:sync-touched dbstruct runid keys dbinit)
;; (set! *db-sync-in-progress* #f)
;; (db:no-sync-del! no-sync-db from-db-file)
;; #t)
;; (begin
;; (dbfile:print-err "ERROR: could not get lock for " from-db-file " from no-sync-db")
;; #f
;; ))))
;; sync run from tmp disk to nfs disk if touched
;;
;; call with dbinit=db:initialize-main-db
;;
(define (db:sync-touched dbstruct run-id keys #!key dbinit (force-sync #f))
(dbfile:print-err "db:sync-touched Syncing: " (conc (if run-id run-id "main") ".db"))
|
︙ | | |
Modified rmt.scm
from [f6063b275a]
to [8bbca69519].
︙ | | |
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
|
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
|
-
-
-
-
-
+
+
+
+
+
-
+
|
(let* ((qry-is-write (not (member cmd api:read-only-queries)))
(db-file-path (db:dbfile-path)) ;; 0))
(dbstructs-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t)))
(read-only (not (file-write-access? db-file-path)))
(start (current-milliseconds))
(resdat (if (not (and read-only qry-is-write))
(let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params))))
(handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
exn ;; This is an attempt to detect that situation and recover gracefully
(begin
(debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
(vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
;; (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
;; exn ;; This is an attempt to detect that situation and recover gracefully
;; (begin
;; (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
;; (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
(if (and (vector? v)
(> (vector-length v) 1))
(let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
(vector #t '())))) ;; we could also check that the returned types are valid
(vector #t '()))) ;; ) ;; we could also check that the returned types are valid
(vector #t '())))
(success (vector-ref resdat 0))
(res (vector-ref resdat 1))
(duration (- (current-milliseconds) start)))
(if (and read-only qry-is-write)
(debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
(if (not success)
|
︙ | | |
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
|
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
|
-
-
-
-
-
-
+
+
+
+
+
+
|
(mutex-lock! *db-multi-sync-mutex*)
/ (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client)
(mutex-unlock! *db-multi-sync-mutex*)))))
res))
(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
(let* ((run-id (if run-id run-id 0))
(res (handle-exceptions
exn
(begin
(print "transport failed. exn=" exn)
#f)
(http-transport:client-api-send-receive run-id connection-info cmd params))))
(res ;; (handle-exceptions
;; exn
;; (begin
;; (print "transport failed. exn=" exn)
;; #f)
(http-transport:client-api-send-receive run-id connection-info cmd params))) ;; )
(if (and res (vector-ref res 0))
(vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!!
#f)))
;;======================================================================
;;
;; A C T U A L A P I C A L L S
|
︙ | | |