21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
(declare (uses margs))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "megatest-fossil-hash.scm")
|
>
|
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
(declare (uses margs))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
(declare (uses daemon))
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "megatest-fossil-hash.scm")
|
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
|
(if (not (null? (lset-intersection
equal?
(hash-table-keys args:arg-hash)
'("-runtests" "-list-runs" "-rollup"
"-remove-runs" "-lock" "-unlock"
"-update-meta" "-extract-ods"))))
(if (setup-for-run)
(let ((servers (open-run-close tasks:get-best-server tasks:open-db)))
(if (or (not servers)
(null? servers))
(begin
(debug:print 0 "INFO: Starting server as none running ...")
;; (server:launch (string->symbol (args:get-arg "-transport" "http"))))
(system (conc (car (argv)) " -server - -daemonize -transport " (args:get-arg "-transport" "http")))
(thread-sleep! 3)) ;; give the server a few seconds to start
(debug:print 0 "INFO: Servers already running " servers)
)))))
|
|
>
>
>
|
|
|
>
>
>
|
>
>
>
|
<
|
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
|
(if (not (null? (lset-intersection
equal?
(hash-table-keys args:arg-hash)
'("-runtests" "-list-runs" "-rollup"
"-remove-runs" "-lock" "-unlock"
"-update-meta" "-extract-ods"))))
(if (setup-for-run)
(let loop ((servers (open-run-close tasks:get-best-server tasks:open-db))
(trycount 0))
(if (or (not servers)
(null? servers))
(begin
(if (eq? trycount 0) ;; just do the server start once
(begin
(debug:print 0 "INFO: Starting server as none running ...")
;; (server:launch (string->symbol (args:get-arg "-transport" "http"))))
;; (process-run (car (argv)) (list "-server" "-" "-daemonize" "-transport" (args:get-arg "-transport" "http")))
(process-fork (lambda ()
(daemon:ize)
(server:launch (string->symbol (args:get-arg "-transport" "http")))))
(thread-sleep! 3))
(debug:print-info 0 "Waiting for server to start"))
(loop (open-run-close tasks:get-best-server tasks:open-db)
(+ trycount 1)))
(debug:print 0 "INFO: Server(s) running " servers)
)))))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-stop-server"))
(let ((tl (setup-for-run)))
(if tl
(let* ((servers (open-run-close tasks:get-all-servers tasks:open-db))
(fmtstr "~5a~8a~8a~20a~20a~10a~10a~10a~10a~10a\n")
|
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
|
(if (equal? id sid)
(begin
(debug:print-info 0 "Attempting to stop server with pid " pid)
(tasks:kill-server status hostname pullport pid transport)))))
servers)
(debug:print-info 1 "Done with listservers")
(set! *didsomething* #t)
(exit) ;; must do, would have to add checks to many/all calls below
)
(exit)))
;; if not list or kill then start a client (if appropriate)
(if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
(eq? (length (hash-table-keys args:arg-hash)) 0))
(debug:print-info 1 "Server connection not needed")
;; ok, so lets connect to the server
(client:launch)))
|
|
<
|
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
|
(if (equal? id sid)
(begin
(debug:print-info 0 "Attempting to stop server with pid " pid)
(tasks:kill-server status hostname pullport pid transport)))))
servers)
(debug:print-info 1 "Done with listservers")
(set! *didsomething* #t)
(exit)) ;; must do, would have to add checks to many/all calls below
(exit)))
;; if not list or kill then start a client (if appropriate)
(if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
(eq? (length (hash-table-keys args:arg-hash)) 0))
(debug:print-info 1 "Server connection not needed")
;; ok, so lets connect to the server
(client:launch)))
|