Overview
Comment: | Remove some (most?) of http-transport, client and server stuff |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.80-mbi |
Files: | files | file ages | folders |
SHA1: |
c43db14a6df10be845c0d8dbe7c1aa66 |
User & Date: | matt on 2023-03-29 21:59:25 |
Other Links: | branch diff | manifest | tags |
Context
2023-03-30
| ||
09:28 | Added rmtmod where needed check-in: 5aedc5c5f0 user: matt tags: v1.80-mbi | |
2023-03-29
| ||
21:59 | Remove some (most?) of http-transport, client and server stuff check-in: c43db14a6d user: matt tags: v1.80-mbi | |
2023-03-27
| ||
19:33 | Changed version to 1.8012. check-in: bcc22ebf3c user: mmgraham tags: v1.80, v1.8012 | |
Changes
Modified Makefile from [dd8860eb70] to [0724779afb].
︙ | ︙ | |||
20 21 22 23 24 25 26 | SHELL=/bin/bash PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \ server.scm configf.scm db.scm keys.scm margs.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | SHELL=/bin/bash PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \ server.scm configf.scm db.scm keys.scm margs.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ tdb.scm mt.scm \ ezsteps.scm lock-queue.scm rmt.scm api.scm \ subrun.scm portlogger.scm archive.scm env.scm \ diff-report.scm cgisetup/models/pgdb.scm # module source files MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \ tcp-transportmod.scm rmtmod.scm |
︙ | ︙ | |||
114 115 116 117 118 119 120 | # include makefile.inc TCMTOBJS = \ api.o \ archive.o \ cgisetup/models/pgdb.o \ | < < | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 | # include makefile.inc TCMTOBJS = \ api.o \ archive.o \ cgisetup/models/pgdb.o \ common.o \ configf.o \ db.o \ env.o \ items.o \ keys.o \ launch.o \ lock-queue.o \ margs.o \ mt.o \ ods.o \ |
︙ | ︙ | |||
190 191 192 193 194 195 196 | runs.o : test_records.scm mofiles-made : $(MOFILES) make $(MOIMPFILES) megatest.o : mofiles-made megatest-fossil-hash.scm megatest-version.scm $(MOFILES) $(MOIMPFILES) | | | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 | runs.o : test_records.scm mofiles-made : $(MOFILES) make $(MOIMPFILES) megatest.o : mofiles-made megatest-fossil-hash.scm megatest-version.scm $(MOFILES) $(MOIMPFILES) rmt.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm common_records.scm : altdb.scm mofiles/dbfile.o : mofiles/commonmod.o # mofiles/stml2.o : mofiles/cookie.o # configf.o : mofiles/commonmod.o |
︙ | ︙ | |||
493 494 495 496 497 498 499 | if csi -ne '(import mysql-client)'&> /dev/null;then \ echo "(import mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \ fi if csi -ne '(import postgresql)'&> /dev/null;then \ echo "(import postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi | | | | 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 | if csi -ne '(import mysql-client)'&> /dev/null;then \ echo "(import mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \ fi if csi -ne '(import postgresql)'&> /dev/null;then \ echo "(import postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi portlogger-example : portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o synchash.o tasks.o tdb.o tests.o tree.o csc $(CSCOPTS) portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o synchash.o tasks.o tdb.o tests.o tree.o # create a pdf dot graphviz diagram from notations in rmt.scm rmt.pdf : rmt.scm grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf buildmanual: cd docs/manual && make |
︙ | ︙ |
Renamed and modified client.scm [091f168690] to attic/client.scm [f0a5f3a990].
︙ | ︙ | |||
40 41 42 43 44 45 46 | ) (import client) (include "common_records.scm") (include "db_records.scm") | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 40 41 42 43 44 45 46 | ) (import client) (include "common_records.scm") (include "db_records.scm") |
Renamed and modified http-transport.scm [8c4ecd6362] to attic/http-transport.scm [235baaba81].
︙ | ︙ | |||
27 28 29 30 31 32 33 | ;; (declare (uses daemon)) (declare (uses portlogger)) (declare (uses rmt)) (declare (uses dbfile)) (declare (uses commonmod)) (declare (uses mtargs)) | | | | > > | > > > > | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | ;; (declare (uses daemon)) (declare (uses portlogger)) (declare (uses rmt)) (declare (uses dbfile)) (declare (uses commonmod)) (declare (uses mtargs)) (module http-transport * (import srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing (srfi 18) extras tcp s11n) (import scheme chicken (prefix mtargs args:) debugprint) ;; Configurations for server (tcp-buffer-size 2048) (max-connections 2048) (include "common_records.scm") |
︙ | ︙ | |||
695 696 697 698 699 700 701 | (conc "<table>" (string-intersperse (map (lambda (stat) (conc "<tr><td>" (car stat) "</td><td>" (cadr stat) "</td></tr>")) stats) " ") "</table>"))) | > | 701 702 703 704 705 706 707 708 | (conc "<table>" (string-intersperse (map (lambda (stat) (conc "<tr><td>" (car stat) "</td><td>" (cadr stat) "</td></tr>")) stats) " ") "</table>"))) ) |
Modified common.scm from [c775026c92] to [eef97f150a].
︙ | ︙ | |||
172 173 174 175 176 177 178 | ;; (define *db-access-mutex* (make-mutex)) ;; moved to dbfile ;; (define *db-transaction-mutex* (make-mutex)) (define *db-cache-path* #f) ;; (define *db-with-db-mutex* (make-mutex)) (define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times) ;; SERVER | < | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 | ;; (define *db-access-mutex* (make-mutex)) ;; moved to dbfile ;; (define *db-transaction-mutex* (make-mutex)) (define *db-cache-path* #f) ;; (define *db-with-db-mutex* (make-mutex)) (define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times) ;; SERVER (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg (define *runremote* #f) ;; if set up for server communication this will hold <host port> ;; (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) (define *server-id* #f) (define *server-info* #f) ;; good candidate for easily convert to non-global (define *time-to-exit* #f) |
︙ | ︙ |
Modified commonmod.scm from [e30eedddba] to [bbd943f11f].
︙ | ︙ | |||
109 110 111 112 113 114 115 116 117 118 119 120 121 122 | (currtime (current-seconds))) (if (> (- currtime lasttime) waitval) (begin (hash-table-set! *common:denoise* key currtime) #t) #f))) ;;====================================================================== ;; config file utils ;;====================================================================== (define (lookup cfgdat section var) (if (hash-table? cfgdat) (let ((sectdat (hash-table-ref/default cfgdat section '()))) | > > > > > > > > > > > > | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | (currtime (current-seconds))) (if (> (- currtime lasttime) waitval) (begin (hash-table-set! *common:denoise* key currtime) #t) #f))) ;; KEEP THIS ONE ;; ;; client:get-signature (define *my-client-signature* #f) (define (client:get-signature) (if *my-client-signature* *my-client-signature* (let ((sig (conc (get-host-name) " " (current-process-id)))) (set! *my-client-signature* sig) *my-client-signature*))) ;;====================================================================== ;; config file utils ;;====================================================================== (define (lookup cfgdat section var) (if (hash-table? cfgdat) (let ((sectdat (hash-table-ref/default cfgdat section '()))) |
︙ | ︙ |
Modified db.scm from [64bc5f4f0d] to [705cf1f135].
︙ | ︙ | |||
27 28 29 30 31 32 33 | (declare (unit db)) (declare (uses common)) (declare (uses debugprint)) (declare (uses dbmod)) (declare (uses dbfile)) (declare (uses keys)) (declare (uses ods)) | < | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | (declare (unit db)) (declare (uses common)) (declare (uses debugprint)) (declare (uses dbmod)) (declare (uses dbfile)) (declare (uses keys)) (declare (uses ods)) (declare (uses mt)) (declare (uses commonmod)) (declare (uses mtargs)) (import commonmod (prefix mtargs args:)) |
︙ | ︙ |
Modified megatest.scm from [93e1fcbbf1] to [d6019e0e19].
︙ | ︙ | |||
32 33 34 35 36 37 38 | (declare (uses mtargs)) (declare (uses mtargs.import)) (declare (uses debugprint)) (declare (uses debugprint.import)) (declare (uses runs)) (declare (uses launch)) (declare (uses server)) | < | 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 | (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"))) | > > | | 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 | ;; (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) | < | 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 | (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 | < | 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 | (if (args:get-arg "-import-sexpr") (begin (launch:setup) (rmt:import-sexpr (args:get-arg "-import-sexpr")) (set! *didsomething* #t))) | < < < < < | 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 |
︙ | ︙ |
Modified rmt.scm from [7b6e5d850e] to [f4c4086df0].
︙ | ︙ | |||
19 20 21 22 23 24 25 | ;;====================================================================== (use format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses debugprint)) (declare (uses api)) | < < | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | ;;====================================================================== (use format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses debugprint)) (declare (uses api)) (declare (uses commonmod)) (declare (uses dbfile)) (declare (uses dbmod)) (declare (uses tcp-transportmod)) (include "common_records.scm") (declare (uses rmtmod)) ;; used by http-transport (import dbfile |
︙ | ︙ | |||
55 56 57 58 59 60 61 | ;; ;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== | < < < < < < < < < < < < < < | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | ;; ;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== (define (rmt:on-homehost? runremote) (let* ((hh-dat (remote-hh-dat runremote))) (if (pair? hh-dat) (cdr hh-dat) (begin (debug:print-info 0 *default-log-port* "hh-dat="hh-dat) #f)))) |
︙ | ︙ | |||
147 148 149 150 151 152 153 | (if (not runremote) (let* ((newremote (make-and-init-remote areapath))) (set! *runremote* newremote) (set! runremote newremote))) (let* ((dbfname (conc (dbfile:run-id->dbnum run-id)".db"))) ;;(dbfile:run-id->path areapath run-id))) (tt:handler runremote cmd run-id params attemptnum area-dat areapath readonly-mode dbfname testsuite mtexe))) | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | (if (not runremote) (let* ((newremote (make-and-init-remote areapath))) (set! *runremote* newremote) (set! runremote newremote))) (let* ((dbfname (conc (dbfile:run-id->dbnum run-id)".db"))) ;;(dbfile:run-id->path areapath run-id))) (tt:handler runremote cmd run-id params attemptnum area-dat areapath readonly-mode dbfname testsuite mtexe))) (define (rmt:print-db-stats) (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" (debug:print 18 *default-log-port* "DB Stats\n========") (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) (for-each (lambda (cmd) (let ((cmd-dat (hash-table-ref *db-stats* cmd))) |
︙ | ︙ | |||
396 397 398 399 400 401 402 | (if qry-is-write (let ((start-time (current-seconds))) (mutex-lock! *db-multi-sync-mutex*) / (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) (mutex-unlock! *db-multi-sync-mutex*))))) res)) | < < < < < < < | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 | (if qry-is-write (let ((start-time (current-seconds))) (mutex-lock! *db-multi-sync-mutex*) / (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) (mutex-unlock! *db-multi-sync-mutex*))))) res)) ;;====================================================================== ;; ;; A C T U A L A P I C A L L S ;; ;;====================================================================== ;;====================================================================== |
︙ | ︙ | |||
429 430 431 432 433 434 435 | (define (rmt:login run-id) (rmt:send-receive 'login run-id (list *toppath* megatest-version (client:get-signature)))) ;; This login does no retries under the hood - it acts a bit like a ping. ;; Deprecated for nmsg-transport. ;; | | | | 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 | (define (rmt:login run-id) (rmt:send-receive 'login run-id (list *toppath* megatest-version (client:get-signature)))) ;; This login does no retries under the hood - it acts a bit like a ping. ;; Deprecated for nmsg-transport. ;; ;; (define (rmt:login-no-auto-client-setup runremote) ;; (rmt:send-receive-no-auto-client-setup runremote 'login 0 (list *toppath* megatest-version (client:get-signature)))) ;; hand off a call to one of the db:queries statements ;; added run-id to make looking up the correct db possible ;; (define (rmt:general-call stmtname run-id . params) (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params))) |
︙ | ︙ | |||
1032 1033 1034 1035 1036 1037 1038 | (if runremote (begin (tt-ro-mode-set! runremote ro-mode) (tt-ro-mode-checked-set! runremote #t) ro-mode) ro-mode)))))) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 842 843 844 845 846 847 848 | (if runremote (begin (tt-ro-mode-set! runremote ro-mode) (tt-ro-mode-checked-set! runremote #t) ro-mode) ro-mode)))))) |
Modified server.scm from [ca005a962e] to [a78488d9e1].
︙ | ︙ | |||
20 21 22 23 24 25 26 | (declare (uses commonmod)) (declare (uses debugprint)) (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. ;; (declare (uses synchash)) | < | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | (declare (uses commonmod)) (declare (uses debugprint)) (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. ;; (declare (uses synchash)) ;;(declare (uses rpc-transport)) (declare (uses launch)) ;; (declare (uses daemon)) (declare (uses mtargs)) (require-extension (srfi 18) extras tcp s11n) |
︙ | ︙ | |||
663 664 665 666 667 668 669 | (begin (debug:print-info 0 *default-log-port* "Unable to get host and/or port from " servr ", exn=" exn) #f) (match-let (((hostname port start-time server-id pid) servr)) (tasks:kill-server hostname pid)))) | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 | (begin (debug:print-info 0 *default-log-port* "Unable to get host and/or port from " servr ", exn=" exn) #f) (match-let (((hostname port start-time server-id pid) servr)) (tasks:kill-server hostname pid)))) ;; ;; called in megatest.scm, host-port is string hostname:port ;; ;; ;; ;; NOTE: This is NOT called directly from clients as not all transports support a client running ;; ;; in the same process as the server. ;; ;; ;; (define (server:ping host:port server-id #!key (do-exit #f)) ;; (let* ((host-port (cond ;; ((string? host:port) ;; (let ((slst (string-split host:port ":"))) ;; (if (eq? (length slst) 2) ;; (list (car slst)(string->number (cadr slst))) ;; #f))) ;; (else ;; #f)))) ;; (cond ;; ((and (list? host-port) ;; (eq? (length host-port) 2)) ;; (let* ((myrunremote (make-and-init-remote *toppath*)) ;; (iface (car host-port)) ;; (port (cadr host-port)) ;; (server-dat (client:connect iface port server-id myrunremote)) ;; (login-res (rmt:login-no-auto-client-setup myrunremote))) ;; (http-transport:close-connections myrunremote) ;; (if (and (list? login-res) ;; (car login-res)) ;; (begin ;; ;; (print "LOGIN_OK") ;; (if do-exit (exit 0)) ;; #t) ;; (begin ;; ;; (print "LOGIN_FAILED") ;; (if do-exit (exit 1)) ;; #f)))) ;; (else ;; (if host:port ;; (debug:print 0 *default-log-port* "ERROR: bad host:port "host:port)) ;; (if do-exit ;; (exit 1) ;; #f))))) ;; ;; ;; run ping in separate process, safest way in some cases ;; ;; ;; (define (server:ping-server ifaceport) ;; (with-input-from-pipe ;; (conc (common:get-megatest-exe) " -ping " ifaceport) ;; (lambda () ;; (let loop ((inl (read-line)) ;; (res "NOREPLY")) ;; (if (eof-object? inl) ;; (case (string->symbol res) ;; ((NOREPLY) #f) ;; ((LOGIN_OK) #t) ;; (else #f)) ;; (loop (read-line) inl)))))) ;; ;; ;; NOT USED (well, ok, reference in rpc-transport but otherwise not used). ;; ;; ;; (define (server:login toppath) ;; (lambda (toppath) ;; (set! *db-last-access* (current-seconds)) ;; might not be needed. ;; (if (equal? *toppath* toppath) ;; #t ;; #f))) ;; timeout is hms string: 1h 5m 3s, default is 1 minute ;; This is currently broken. Just use the number of hours with no unit. ;; Default is 60 seconds. ;; (define (server:expiration-timeout) (let* ((tmo (configf:lookup *configdat* "server" "timeout"))) |
︙ | ︙ |
Modified tdb.scm from [a4bdcfd23f] to [765beec05e].
︙ | ︙ | |||
23 24 25 26 27 28 29 | ;;====================================================================== (declare (unit tdb)) (declare (uses debugprint)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) | < | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | ;;====================================================================== (declare (unit tdb)) (declare (uses debugprint)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) (declare (uses mt)) (declare (uses db)) (declare (uses commonmod)) (declare (uses mtargs)) (require-extension (srfi 18) extras tcp) (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) |
︙ | ︙ |