467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
|
ptype: 'server)))
;; ya, fake it for now
;;
(define (register-server-in-db db-file)
#t)
(define (get-pkts-dir)
(assert *toppath* "ERROR: get-pkts-dir called without *toppath* set. Exiting.")
(let* ((pdir (conc *toppath* "/.meta/srvpkts")))
(if (file-exists? pdir)
pdir
(begin
(create-directory pdir #t)
pdir))))
|
|
>
>
|
|
|
|
|
|
|
|
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
|
ptype: 'server)))
;; ya, fake it for now
;;
(define (register-server-in-db db-file)
#t)
(define (get-pkts-dir #!optional (apath #f))
(let* ((effective-toppath (or *toppath* apath)))
(assert effective-toppath
"ERROR: get-pkts-dir called without *toppath* set. Exiting.")
(let* ((pdir (conc effective-toppath "/.meta/srvpkts")))
(if (file-exists? pdir)
pdir
(begin
(create-directory pdir #t)
pdir)))))
;; given a pkts dir read
;;
(define (get-all-server-pkts pktsdir-in pktspec)
(let* ((pktsdir (if (file-exists? pktsdir-in)
pktsdir-in
(begin
|
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
|
;; server last used then start shutdown
;; This thread waits for the server to come alive
(debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server")
(let* ((run-id (let ((rid (args:get-arg "-run-id")))
(if rid
(string->number rid)
#f)))
(db-file (db:run-id->path run-id))
(sdat #f)
(tmp-area (common:get-db-tmp-area))
(server-start-time (current-seconds))
(pkts-dir (get-pkts-dir))
(server-key (server:mk-signature))
(server-info (let loop ((start-time (current-seconds))
(changed #t)
|
|
|
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
|
;; server last used then start shutdown
;; This thread waits for the server to come alive
(debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server")
(let* ((run-id (let ((rid (args:get-arg "-run-id")))
(if rid
(string->number rid)
#f)))
(db-file (db:run-id->path *toppath* run-id))
(sdat #f)
(tmp-area (common:get-db-tmp-area))
(server-start-time (current-seconds))
(pkts-dir (get-pkts-dir))
(server-key (server:mk-signature))
(server-info (let loop ((start-time (current-seconds))
(changed #t)
|