︙ | | | ︙ | |
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
(declare (uses mtargs))
(declare (uses mtargs.import))
(declare (uses debugprint))
(declare (uses debugprint.import))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
;; (declare (uses daemon))
(declare (uses db))
;; (declare (uses dcommon))
|
<
|
32
33
34
35
36
37
38
39
40
41
42
43
44
45
|
(declare (uses mtargs))
(declare (uses mtargs.import))
(declare (uses debugprint))
(declare (uses debugprint.import))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses tests))
(declare (uses genexample))
;; (declare (uses daemon))
(declare (uses db))
;; (declare (uses dcommon))
|
︙ | | | ︙ | |
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
|
(if out-file (close-output-port out-port))
(exit) ;; yes, bending the rules here - need to exit since this is a utility
))
(if (args:get-arg "-ping")
(let* ((server-id (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":"
(host:port (args:get-arg "-ping")))
(server:ping (or server-id host:port) #f do-exit: #t)))
;;======================================================================
;; Capture, save and manipulate environments
;;======================================================================
;; NOTE: Keep these above the section where the server or client code is setup
|
>
>
|
|
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
|
(if out-file (close-output-port out-port))
(exit) ;; yes, bending the rules here - need to exit since this is a utility
))
(if (args:get-arg "-ping")
(let* ((server-id (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":"
(host:port (args:get-arg "-ping")))
(debug:print 0 *default-log-port* "NOT YET REIMPLEMENTED FOR TCP/INMEM") ;; bug
(exit)))
;; (server:ping (or server-id host:port) #f do-exit: #t)))
;;======================================================================
;; Capture, save and manipulate environments
;;======================================================================
;; NOTE: Keep these above the section where the server or client code is setup
|
︙ | | | ︙ | |
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
|
;;
(if (args:get-arg "-server")
(let* (;; (run-id (args:get-arg "-run-id"))
(dbfname (args:get-arg "-db"))
(tl (launch:setup))
(keys (keys:config-get-fields *configdat*)))
(case (rmt:transport-mode)
((http)(http-transport:launch))
((tcp)
(let* ((timeout (server:expiration-timeout)))
(debug:print 0 *default-log-port* "INFO: Running using tcp method with server timeout of "timeout)
(tt-server-timeout-param timeout)
(if dbfname
(tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys)
(begin
|
<
|
952
953
954
955
956
957
958
959
960
961
962
963
964
965
|
;;
(if (args:get-arg "-server")
(let* (;; (run-id (args:get-arg "-run-id"))
(dbfname (args:get-arg "-db"))
(tl (launch:setup))
(keys (keys:config-get-fields *configdat*)))
(case (rmt:transport-mode)
((tcp)
(let* ((timeout (server:expiration-timeout)))
(debug:print 0 *default-log-port* "INFO: Running using tcp method with server timeout of "timeout)
(tt-server-timeout-param timeout)
(if dbfname
(tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys)
(begin
|
︙ | | | ︙ | |
975
976
977
978
979
980
981
982
983
984
985
986
987
988
|
(begin
(adjutant-run)
(set! *didsomething* #t)))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-kill-servers"))
(let ((tl (launch:setup)))
(if tl ;; all roads from here exit
(let* ((servers (server:choose-server *toppath* 'all-valid)) ;; (server:get-list *toppath*))
(fmtstr "~33a~22a~20a~20a~8a\n"))
(if (not servers)
(begin
(debug:print-info 1 *default-log-port* "No servers found")
(exit)
|
>
>
|
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
|
(begin
(adjutant-run)
(set! *didsomething* #t)))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-kill-servers"))
(let ((tl (launch:setup)))
(debug:print 0 *default-log-port* "NOT YET REIMPLEMENTED FOR TCP/INMEM") ;; BUG
(exit)
(if tl ;; all roads from here exit
(let* ((servers (server:choose-server *toppath* 'all-valid)) ;; (server:get-list *toppath*))
(fmtstr "~33a~22a~20a~20a~8a\n"))
(if (not servers)
(begin
(debug:print-info 1 *default-log-port* "No servers found")
(exit)
|
︙ | | | ︙ | |
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
|
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
(if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area))
(change-directory work-area)
;; can setup as client for server mode now
;; (client:setup)
(if (args:get-arg "-load-test-data")
;; has sub commands that are rdb:
;; DO NOT put this one into either rmt: or open-run-close
(tdb:load-test-data run-id test-id))
(if (args:get-arg "-setlog")
(let ((logfname (args:get-arg "-setlog")))
|
<
|
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
|
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
(if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area))
(change-directory work-area)
;; can setup as client for server mode now
(if (args:get-arg "-load-test-data")
;; has sub commands that are rdb:
;; DO NOT put this one into either rmt: or open-run-close
(tdb:load-test-data run-id test-id))
(if (args:get-arg "-setlog")
(let ((logfname (args:get-arg "-setlog")))
|
︙ | | | ︙ | |
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
|
(if (args:get-arg "-import-sexpr")
(begin
(launch:setup)
(rmt:import-sexpr (args:get-arg "-import-sexpr"))
(set! *didsomething* #t)))
(when (args:get-arg "-sync-brute-force")
(launch:setup)
((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t))
(set! *didsomething* #t))
(if (args:get-arg "-sync-to-megatest.db")
(let* ((duh (launch:setup))
(dbstruct (db:setup #t))
(tmpdbpth (dbr:dbstruct-tmppath dbstruct))
(lockfile (conc tmpdbpth ".lock"))
(locked (common:simple-file-lock lockfile))
(res (if locked
|
<
<
<
<
<
|
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
|
(if (args:get-arg "-import-sexpr")
(begin
(launch:setup)
(rmt:import-sexpr (args:get-arg "-import-sexpr"))
(set! *didsomething* #t)))
(if (args:get-arg "-sync-to-megatest.db")
(let* ((duh (launch:setup))
(dbstruct (db:setup #t))
(tmpdbpth (dbr:dbstruct-tmppath dbstruct))
(lockfile (conc tmpdbpth ".lock"))
(locked (common:simple-file-lock lockfile))
(res (if locked
|
︙ | | | ︙ | |