44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
;;
;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id)
;; (if (server:check-if-running run-id)
;; a server is already running
;; (exit)
;; (define (server:launch-no-exit run-id)
;; (if (server:check-if-running run-id)
;; #t ;; if running
;; (http-transport:launch run-id)))
;; Flush the queue every third of a second. Can we assume that setup-for-run
;; has already been done?
;; (define (server:write-queue-handler)
;; (if (setup-for-run)
;; (let ((db (open-db)))
;; (let loop ()
;; (let ((last-write-flush-time #f))
;; (mutex-lock! *incoming-mutex*)
;; (set! last-write-flush-time *server:last-write-flush*)
;; (mutex-unlock! *incoming-mutex*)
;; (if (> (- (current-milliseconds) last-write-flush-time) 10)
;; (begin
;; (mutex-lock! *db:process-queue-mutex*)
;; (db:process-cached-writes db)
;; (mutex-unlock! *db:process-queue-mutex*)
;; (thread-sleep! 0.005))))
;; (loop)))
;; (begin
;; (debug:print 0 "ERROR: failed to setup for Megatest in server:write-queue-handler")
;; (exit 1))))
;; > file 2>&1
(define (server:try-running run-id)
(let* ((rand-name (random 100))
(cmdln (conc (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest")
;; " -server - -run-id " run-id " name=" rand-name " > " *toppath* "/db/" run-id "-" rand-name ".log 2>&1 &")))
(system cmdln)
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
>
>
>
|
|
<
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
;;
;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id)
(http-transport:launch run-id))
;;======================================================================
;; Q U E U E M A N A G E M E N T
;;======================================================================
;; We don't want to flush the queue if it was just flushed
(define *server:last-write-flush* (current-milliseconds))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
;; Generate a unique signature for this server
(define (server:mk-signature)
(message-digest-string (md5-primitive)
(with-output-to-string
(lambda ()
(write (list (current-directory)
(argv)))))))
;; When using zmq this would send the message back (two step process)
;; with spiffy or rpc this simply returns the return data to be returned
;;
(define (server:reply return-addr query-sig success/fail result)
(db:obj->string (vector success/fail query-sig result)))
;; Given a run id start a server process ### NOTE ### > file 2>&1
;; if the run-id is zero and the target-host is set
;; try running on that host
;;
(define (server:run run-id)
(let* ((target-host (configf:lookup *configdat* "server" "homehost" ))
(cmdln (conc (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest")
" -server - -run-id " run-id " >> " *toppath* "/db/" run-id ".log 2>&1 &")))
(debug:print 0 "INFO: Starting server (" cmdln ") as none running ...")
(push-directory *toppath*)
(if target-host
(begin
(set-environment-variable "TARGETHOST" target-host)
(system (conc "nbfake " cmdln)))
(system cmdln))
(pop-directory)))
;; kind start up of servers, wait 40 seconds before allowing another server for a given
;; run-id to be launched
(define (server:kind-run run-id)
(let ((last-run-time (hash-table-ref/default *server-kind-run* run-id #f)))
(if (or (not last-run-time)
(> (- (current-seconds) last-run-time) 40))
(begin
(server:run run-id)
(hash-table-set! *server-kind-run* run-id (current-seconds))))))
;; The generic run a server command. Dispatches the call to server 0 if run-id != 0
;;
(define (server:try-running run-id)
(if (eq? run-id 0)
(server:run run-id)
(rmt:start-server run-id)))
(define (server:check-if-running run-id)
(let loop ((server (open-run-close tasks:get-server tasks:open-db run-id))
(trycount 0))
(thread-sleep! 2)
(if server
;; note: client:start will set *runremote*. this needs to be changed
|