| ︙ | | | ︙ | |
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
|
;; ;;(declare (uses rpc-transport))
;; (declare (uses launch))
;; ;; (declare (uses daemon))
;;
;; (include "common_records.scm")
;; (include "db_records.scm")
(define (server:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
|
<
<
<
<
<
<
<
|
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
;; ;;(declare (uses rpc-transport))
;; (declare (uses launch))
;; ;; (declare (uses daemon))
;;
;; (include "common_records.scm")
;; (include "db_records.scm")
;;======================================================================
;; P K T S S T U F F
;;======================================================================
;; ???
;;======================================================================
|
| ︙ | | | ︙ | |
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
(if dbprep-found
(begin
(debug:print-info 0 *default-log-port* "Server is in dbprep at " (current-seconds))
(thread-sleep! 25)
)
(debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (current-seconds))
)
(list #f #f #f #f)))))))))
;; get a list of servers with all relevant data
;; ( mod-time host port start-time pid )
;;
(define (server:get-list areapath #!key (limit #f))
(let ((fname-rx (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))
(day-seconds (* 24 60 60)))
|
|
|
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
|
(if dbprep-found
(begin
(debug:print-info 0 *default-log-port* "Server is in dbprep at " (current-seconds))
(thread-sleep! 25)
)
(debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (current-seconds))
)
(list #f #f #f #f)))))))))
;; get a list of servers with all relevant data
;; ( mod-time host port start-time pid )
;;
(define (server:get-list areapath #!key (limit #f))
(let ((fname-rx (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))
(day-seconds (* 24 60 60)))
|
| ︙ | | | ︙ | |
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
|
(create-directory (conc areapath "/logs") #t)
(exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
(exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn)))
(directory-exists? (conc areapath "/logs")))
'()))
;; Get the list of server logs that do not contain "exiting". Ignore logs for servers that have exited.
(let* ((server-logs-cmd (conc "grep -iL exiting " areapath "/logs/server-*-*.log"))
(server-logs (string-split (string-chomp (call-with-input-pipe server-logs-cmd read-string))))
(num-serv-logs (length server-logs)))
(if (or (null? server-logs) (= num-serv-logs 0))
(let ()
(debug:print 1 *default-log-port* "There are no servers running")
'()
)
(let loop ((hed (string-chomp (car server-logs)))
|
|
<
|
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
|
(create-directory (conc areapath "/logs") #t)
(exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
(exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn)))
(directory-exists? (conc areapath "/logs")))
'()))
;; Get the list of server logs that do not contain "exiting". Ignore logs for servers that have exited.
(let* ((server-logs (server:get-logs-list areapath))
(num-serv-logs (length server-logs)))
(if (or (null? server-logs) (= num-serv-logs 0))
(let ()
(debug:print 1 *default-log-port* "There are no servers running")
'()
)
(let loop ((hed (string-chomp (car server-logs)))
|
| ︙ | | | ︙ | |
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
|
(all-go (> delta reftime)))
(if (and all-go
(begin
(debug:print-info 0 *default-log-port* "Writing " start-flag)
(with-output-to-file start-flag
(lambda ()
(print server-key)))
(thread-sleep! 0.25)
(let ((res (with-input-from-file start-flag
(lambda ()
(read-line)))))
(equal? server-key res))))
#t ;; (system (conc "touch " start-flag)) ;; lazy but safe
(begin
(debug:print-info 0 *default-log-port* "Gating server start, last start: "
|
|
|
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
|
(all-go (> delta reftime)))
(if (and all-go
(begin
(debug:print-info 0 *default-log-port* "Writing " start-flag)
(with-output-to-file start-flag
(lambda ()
(print server-key)))
(thread-sleep! 0.254)
(let ((res (with-input-from-file start-flag
(lambda ()
(read-line)))))
(equal? server-key res))))
#t ;; (system (conc "touch " start-flag)) ;; lazy but safe
(begin
(debug:print-info 0 *default-log-port* "Gating server start, last start: "
|
| ︙ | | | ︙ | |
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
|
(final-sync)
(if (common:low-noise-print 30)
(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)
)))))
(define (server:writable-watchdog-deltasync dbstruct)
(thread-sleep! 0.05) ;; delay for startup
(let ((legacy-sync (common:run-sync?))
(sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
(debug-mode (debug:debug-mode 1))
(last-time (current-seconds))
(no-sync-db (db:open-no-sync-db))
(stmt-cache (dbr:dbstruct-stmt-cache dbstruct))
(sync-duration 0) ;; run time of the sync in milliseconds
|
|
|
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
|
(final-sync)
(if (common:low-noise-print 30)
(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)
)))))
(define (server:writable-watchdog-deltasync dbstruct)
(thread-sleep! 0.054) ;; delay for startup
(let ((legacy-sync (common:run-sync?))
(sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
(debug-mode (debug:debug-mode 1))
(last-time (current-seconds))
(no-sync-db (db:open-no-sync-db))
(stmt-cache (dbr:dbstruct-stmt-cache dbstruct))
(sync-duration 0) ;; run time of the sync in milliseconds
|
| ︙ | | | ︙ | |