Changes In Branch v2.0001 Through [3b9599228a] Excluding Merge-Ins
This is equivalent to a diff from e80ba42389 to 3b9599228a
2022-01-02
| ||
18:09 | wip, merged remotedat and servdat and put single copy in *db-serv-info* check-in: e7444b7d34 user: matt tags: v2.0001 | |
2021-12-31
| ||
21:50 | updates, wip check-in: 3b9599228a user: matt tags: v2.0001 | |
19:24 | wip check-in: 4622e2fbb0 user: matt tags: v2.0001 | |
2021-12-26
| ||
20:14 | Attempt to switch from nng to ulex check-in: 6c52169286 user: matt tags: v2.0001 | |
2021-12-23
| ||
20:16 | get host name automatically in test Leaf check-in: e80ba42389 user: matt tags: v2.001, Uses-nng-nanomsg | |
19:36 | Fixed typo, added a bit to the test check-in: a0652877c1 user: matt tags: v2.001 | |
Modified Makefile from [89e357068d] to [c6a8cae70d].
︙ | ︙ | |||
25 26 27 28 29 30 31 | # all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard all : $(PREFIX)/bin/.$(ARCHSTR) mtest # add dboard mtut and tcmt back later # module source files MSRCFILES = autoload.scm dbi.scm ducttape-lib.scm pkts.scm stml2.scm \ | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | # all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard all : $(PREFIX)/bin/.$(ARCHSTR) mtest # add dboard mtut and tcmt back later # module source files MSRCFILES = autoload.scm dbi.scm ducttape-lib.scm pkts.scm stml2.scm \ cookie.scm mutils.scm mtargs.scm apimod.scm ulex.scm \ configfmod.scm commonmod.scm dbmod.scm rmtmod.scm \ debugprint.scm mtver.scm csv-xml.scm servermod.scm \ hostinfo.scm adjutant.scm processmod.scm testsmod.scm \ itemsmod.scm keysmod.scm mtmod.scm rmtmod.scm \ tasksmod.scm pgdb.scm launchmod.scm runsmod.scm \ portloggermod.scm archivemod.scm ezstepsmod.scm \ subrunmod.scm bigmod.scm testsmod.scm |
︙ | ︙ | |||
97 98 99 100 101 102 103 | mofiles/launchmod.o : mofiles/bigmod.o mofiles/launchmod.o : mofiles/ezstepsmod.o mofiles/launchmod.o : mofiles/rmtmod.o mofiles/servermod.o mofiles/mtmod.o : mofiles/debugprint.o mofiles/portloggermod.o : mofiles/tasksmod.o mofiles/rmtmod.o : mofiles/apimod.o mofiles/rmtmod.o : mofiles/commonmod.o mofiles/portloggermod.o | | > > > > | 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 | mofiles/launchmod.o : mofiles/bigmod.o mofiles/launchmod.o : mofiles/ezstepsmod.o mofiles/launchmod.o : mofiles/rmtmod.o mofiles/servermod.o mofiles/mtmod.o : mofiles/debugprint.o mofiles/portloggermod.o : mofiles/tasksmod.o mofiles/rmtmod.o : mofiles/apimod.o mofiles/rmtmod.o : mofiles/commonmod.o mofiles/portloggermod.o mofiles/rmtmod.o : mofiles/itemsmod.o mofiles/ulex.o mofiles/runsmod.o : mofiles/rmtmod.o mofiles/archivemod.o mofiles/servermod.o : mofiles/commonmod.o mofiles/stml2.o : mofiles/cookie.o mofiles/dbi.o mofiles/tasksmod.o : mofiles/pgdb.o mofiles/dbmod.o mofiles/testsmod.o : mofiles/commonmod.o mofiles/testsmod.o : mofiles/itemsmod.o mofiles/rmtmod.o mofiles/tasksmod.o # split modules mofiles/ulex.o : ulex/ulex.scm dashboard.o megatest.o : db_records.scm megatest-fossil-hash.scm ADTLSCR=mt_laststep mt_runstep mt_ezstep HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR)) DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR)) MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}') ifeq ($(MTESTHASH),) |
︙ | ︙ |
Modified apimod.scm from [f47a08f057] to [d0ed8f0a49].
︙ | ︙ | |||
27 28 29 30 31 32 33 | (module apimod ( api:run-server-process api:start-server api:dispatch-cmd api:execute-requests | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | (module apimod ( api:run-server-process api:start-server api:dispatch-cmd api:execute-requests ;; api:process-request ) (import scheme chicken.base chicken.process-context.posix chicken.string chicken.time |
︙ | ︙ | |||
418 419 420 421 422 423 424 | ;; http-server send-response ;; api:process-request ;; db:* ;; ;; NB// Runs on the server as part of the server loop ;; | | | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 | ;; http-server send-response ;; api:process-request ;; db:* ;; ;; NB// Runs on the server as part of the server loop ;; #;(define (api:process-request dbstruct indat) ;; the $ is the request vars proc (let* ((cmd-in (alist-ref 'cmd indat)) ;; ($ 'cmd)) (cmd (if (string? cmd-in)(string->symbol cmd-in) cmd-in)) (params (alist-ref 'params indat)) (key (alist-ref 'key indat)) ;; TODO - add this back ;; (doprint (apply common:low-noise-print 10 params)) ) ;; (if doprint (debug:print 0 *default-log-port* "cmd: " cmd " with params: " params ", key: " key)) |
︙ | ︙ |
Modified build-assist/README from [d108fc0f5b] to [ac3067734e].
|
| < | < < < < | < | < | < < | < < | < | < < < | < | 1 2 3 4 5 6 7 8 9 10 11 12 | README for IUP IUP is a portable toolkit for building graphical user interfaces. It offers a configuration API in three basic languages: C, Lua and LED. IUP's purpose is to allow a program to be executed in different systems without any modification, therefore it is highly portable. Its main advantages are: * high performance, due to the fact that it uses native interface elements. * fast learning by the user, due to the simplicity of its API. Build instructions and usage are available in the IUP documentation. For complete information, visit IUP's web site at http://www.tecgraf.puc-rio.br/iup or access its documentation in the HTML folder. (end of README) |
Modified build-assist/ck5-eggs.list from [339d250117] to [da39a3ee5e].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added build-assist/ck5-full-eggs.list version [3bac908752].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | csm address-info ansi-escape-sequences apropos base64 breadline crypt csv-abnf directory-utils dot-locking filepath fmt format http-client itemsmod json linenoise mailbox md5 message-digest nanomsg postgresql queues regex regex-case rfc3339 s11n sha1 simple-exceptions slice sparse-vectors spiffy spiffy-directory-listing spiffy-request-vars sql-de-lite sqlite3 sql-null srfi-1 srfi-13 srfi-19 sxml-modifications sxml-serializer sxml-transforms system-information tcp6 test typed-records uri-common z3 |
Modified build-assist/iup-compile.sh from [f2fe37f920] to [8fc93bba73].
︙ | ︙ | |||
13 14 15 16 17 18 19 | echo " rsync -av include/ $PREFIX/include/" echo " or (depending on versions and what you see in the iup tars - they seem to vary" echo " cp *.a *.so $PREFIX/lib" echo " cp include/*.h $PREFIX/include" echo " 4. run the chicken-install like this:" echo "If you use a wrapper (e.g. ck5) to create the chicken environment:" | | | < | 13 14 15 16 17 18 19 20 21 22 23 24 25 | echo " rsync -av include/ $PREFIX/include/" echo " or (depending on versions and what you see in the iup tars - they seem to vary" echo " cp *.a *.so $PREFIX/lib" echo " cp include/*.h $PREFIX/include" echo " 4. run the chicken-install like this:" echo "If you use a wrapper (e.g. ck5) to create the chicken environment:" echo "CSC_OPTIONS=\"-I$PREFIX/include -I$PREFIX/include/im -I$PREFIX/include/cd -I$PREFIX/include/iup -L$PREFIX/lib -C -std=gnu99\" ck5 chicken-install iup canvas-draw -feature disable-iup-matrixex" echo "else:" echo "CSC_OPTIONS=\"-I$PREFIX/include -I$PREFIX/include/im -I$PREFIX/include/cd -I$PREFIX/include/iup -L$PREFIX/lib -C -std=gnu99\" chicken-install iup canvas-draw" # (export PREFIX=/home/matt/data/buildall/ck5.2;CSC_OPTIONS="-I/home/matt/data/buildall/ck5.2/include -I/home/matt/data/buildall/ck5.2/include/im -I/home/matt/data/buildall/ck5.2/include/cd -I/home/matt/data/buildall/ck5.2/include/iup -L/home/matt/data/buildall/ck5.2/lib -C -std=gnu99" ck5 chicken-install iup -feature disable-iup-matrixex) |
Modified megatest.scm from [c1c08ee586] to [b00e0e6122].
︙ | ︙ | |||
503 504 505 506 507 508 509 | Version " megatest-version ", built from " megatest-fossil-hash )) (define (main) (make-and-init-bigdata) ;; set up the functions in http transport | | | | | | | 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 | Version " megatest-version ", built from " megatest-fossil-hash )) (define (main) (make-and-init-bigdata) ;; set up the functions in http transport ;; (hash-table-set! *http-functions* 'api:process-request api:process-request) ;; (hash-table-set! *http-functions* 'http-transport:main-page http-transport:main-page) ;; (hash-table-set! *http-functions* 'http-transport:show-jquery http-transport:show-jquery) ;; (hash-table-set! *http-functions* 'http-transport:html-test-log http-transport:html-test-log) ;; (hash-table-set! *http-functions* 'http-transport:html-dboard http-transport:html-dboard) ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file ;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) (if (common:file-exists? debugcontrolf) (load debugcontrolf))) |
︙ | ︙ |
Modified pgdb.scm from [33d4965c91] to [d568c66421].
︙ | ︙ | |||
10 11 12 13 14 15 16 | (import scheme chicken.base chicken.condition chicken.string chicken.sort list-utils | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | (import scheme chicken.base chicken.condition chicken.string chicken.sort list-utils ;; postgresql srfi-1 srfi-69 typed-records (prefix dbi dbi:) configfmod (prefix mtargs args:) |
︙ | ︙ |
Modified rmtmod.scm from [e5bd6bd6c5] to [522cb2a247].
︙ | ︙ | |||
28 29 30 31 32 33 34 35 36 37 38 39 40 41 | (declare (uses itemsmod)) (declare (uses mtargs)) (declare (uses mtver)) (declare (uses pgdb)) (declare (uses portloggermod)) (declare (uses servermod)) (declare (uses tasksmod)) (module rmtmod * (import scheme chicken.base | > | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | (declare (uses itemsmod)) (declare (uses mtargs)) (declare (uses mtver)) (declare (uses pgdb)) (declare (uses portloggermod)) (declare (uses servermod)) (declare (uses tasksmod)) (declare (uses ulex)) (module rmtmod * (import scheme chicken.base |
︙ | ︙ | |||
61 62 63 64 65 66 67 | directory-utils format ;; http-client ;; intarweb matchable md5 message-digest | | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | directory-utils format ;; http-client ;; intarweb matchable md5 message-digest ;; nng ;; nanomsg (prefix base64 base64:) (prefix sqlite3 sqlite3:) regex s11n ;; spiffy ;; spiffy-directory-listing ;; spiffy-request-vars |
︙ | ︙ | |||
94 95 96 97 98 99 100 101 102 103 104 105 106 107 | pgdb pkts portloggermod (prefix mtargs args:) servermod stml2 tasksmod ) (defstruct alldat (areapath #f) (ulexdat #f) ) | > > | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | pgdb pkts portloggermod (prefix mtargs args:) servermod stml2 tasksmod ulex ) (defstruct alldat (areapath #f) (ulexdat #f) ) |
︙ | ︙ | |||
124 125 126 127 128 129 130 131 132 133 134 135 136 137 | (port #f) (uuid #f) (rep #f) (dbfile #f) (api-url #f) (api-uri #f) (api-req #f) (status 'starting) (trynum 0) ;; count the number of ports we've tried ) (define (servdat->url sdat) (conc (servdat-host sdat)":"(servdat-port sdat))) | > > | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | (port #f) (uuid #f) (rep #f) (dbfile #f) (api-url #f) (api-uri #f) (api-req #f) (uconn #f) ;; this is the listener (mode #f) (status 'starting) (trynum 0) ;; count the number of ports we've tried ) (define (servdat->url sdat) (conc (servdat-host sdat)":"(servdat-port sdat))) |
︙ | ︙ | |||
175 176 177 178 179 180 181 182 | ;; -> http://abc.com:900/<entrypoint> ;; (define (conndat->uri conn entrypoint) (conc "http://"(conndat-ipaddr conn)":"(conndat-port conn)"/"entrypoint)) ;; set up the api proc, seems like there should be a better place for this? (define api-proc (make-parameter conc)) | > > > | | | | > > > > > > > > > > > > > | | | | 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 | ;; -> http://abc.com:900/<entrypoint> ;; (define (conndat->uri conn entrypoint) (conc "http://"(conndat-ipaddr conn)":"(conndat-port conn)"/"entrypoint)) ;; set up the api proc, seems like there should be a better place for this? ;; ;; IS THIS NEEDED ANYMORE? TODO - REMOVE IF POSSIBLE ;; (define api-proc (make-parameter conc)) (api-proc api:execute-requests) ;; do we have a connection to apath dbname and ;; is it not expired? then return it ;; ;; else setup a connection ;; ;; if that fails, return '(#f "some reason") ;; NB// convert to raising an exception ;; (define (rmt:get-conn remdat apath dbname) (let* ((fullname (db:dbname->path apath dbname)) (conn (hash-table-ref/default (remotedat-conns remdat) fullname #f))) (if (and conn (< (current-seconds) (conndat-expires conn))) conn #f))) (define (rmt:find-main-server uconn apath dbname) (let* ((pktsdir (get-pkts-dir apath)) (all-srvpkts (get-all-server-pkts pktsdir *srvpktspec*)) ;; (dbpath (conc apath "/" dbname)) (viable-srvs (get-viable-servers all-srvpkts dbname))) (get-the-server uconn apath viable-srvs))) (define *connstart-mutex* (make-mutex)) (define *last-main-start* 0) ;; looks for a connection to main, returns if have and not exired ;; creates new otherwise ;; ;; connections for other servers happens by requesting from main ;; ;; TODO: This is unnecessarily re-creating the record in the hash table ;; (define (rmt:open-main-connection remdat apath) (let* ((fullpath (db:dbname->path apath "/.db/main.db")) (conns (remotedat-conns remdat)) (conn (hash-table-ref/default conns fullpath #f)) ;; TODO - create call for this (myconn (if *server-info* (servdat-uconn *server-info*) (let* ((th1 (make-thread (lambda ()(rmt:run (get-host-name))) "non-db mode server"))) (thread-start! th1) (let loop ((count 0)) (assert (< count 30) "FATAL: responder failed to initialize in rmt:open-main-connection") (if (not *server-info*) (begin (thread-sleep! 1) (loop (+ count 1))) (begin (servdat-mode-set! *server-info* 'non-db) (servdat-uconn *server-info*)))))))) (cond ((and conn ;; conn is NOT a socket, just saying ... (< (current-seconds) (conndat-expires conn))) #t) ;; we are current and good to go - we'll deal elsewhere with a server that was killed or died ((and conn (>= (current-seconds)(conndat-expires conn))) (debug:print-info 0 *default-log-port* "connection to "fullpath" server expired. Reconnecting.") #;(if (conndat-socket conn) (nng-close! (conndat-socket conn))) ;; TODO - close the ulex server here? (hash-table-set! conns fullpath #f) ;; clean up (rmt:open-main-connection remdat apath)) (else ;; Below we will find or create and connect to main (let* ((dbname (db:run-id->dbname #f)) (the-srv (rmt:find-main-server myconn apath dbname)) (start-main-srv (lambda () ;; call IF there is no the-srv found (mutex-lock! *connstart-mutex*) (if (> (- (current-seconds) *last-main-start*) 5) ;; at least four seconds since last attempt to start main server (begin (api:run-server-process apath dbname) (set! *last-main-start* (current-seconds)) (thread-sleep! 1))) |
︙ | ︙ | |||
253 254 255 256 257 258 259 | (fullpath (db:dbname->path apath dbname)) (new-the-srv (make-conndat apath: apath dbname: dbname fullname: fullpath hostport: srv-addr | | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 | (fullpath (db:dbname->path apath dbname)) (new-the-srv (make-conndat apath: apath dbname: dbname fullname: fullpath hostport: srv-addr ;; socket: (open-nn-connection srv-addr) - TODO - open ulex connection? ipaddr: ipaddr port: port srvpkt: the-srv srvkey: srvkey ;; generated by rmt:get-signature on the server side lastmsg: (current-seconds) expires: (+ (current-seconds) 60) ;; this needs to be gathered during the ping ))) |
︙ | ︙ | |||
283 284 285 286 287 288 289 | (debug:print-logger rmt:log-to-main))) (cond ((or (not mconn) ;; no channel open to main? (< (conndat-expires mconn)(+ (current-seconds) 2))) ;; restablish connection if less than 2 seconds on the lease (if mconn ;; previously opened - clean up NB// consolidate this with the similar code in open main above (begin (debug:print-info 0 *default-log-port* "Clearing out connection to main that has expired.") | | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 | (debug:print-logger rmt:log-to-main))) (cond ((or (not mconn) ;; no channel open to main? (< (conndat-expires mconn)(+ (current-seconds) 2))) ;; restablish connection if less than 2 seconds on the lease (if mconn ;; previously opened - clean up NB// consolidate this with the similar code in open main above (begin (debug:print-info 0 *default-log-port* "Clearing out connection to main that has expired.") ;; (nng-close! (conndat-socket mconn)) ;; TODO - close the ulex server/listener here? (hash-table-set! conns fullname #f))) (rmt:open-main-connection remdat apath) (rmt:general-open-connection remdat apath mdbname)) ((not (rmt:get-conn remdat apath dbname)) ;; no channel open to dbname? (let* ((res (rmt:send-receive-real remdat apath mdbname 'get-server `(,apath ,dbname)))) (case res ((server-started) |
︙ | ︙ | |||
315 316 317 318 319 320 321 | (debug:print-info 0 *default-log-port* "got "res) (hash-table-set! conns fullname (make-conndat apath: apath dbname: dbname hostport: (conc host":"port) | | | 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 | (debug:print-info 0 *default-log-port* "got "res) (hash-table-set! conns fullname (make-conndat apath: apath dbname: dbname hostport: (conc host":"port) ;; socket: (open-nn-connection (conc host":"port)) ;; TODO - open ulex connection? ipaddr: ipaddr port: port srvkey: servkey lastmsg: (current-seconds) expires: (+ (current-seconds) 60)))) (else (debug:print-info 0 *default-log-port* "return data from starting server did not match host port servkey pid ipaddr apath dbname " res))) |
︙ | ︙ | |||
348 349 350 351 352 353 354 | (let* ((apath *toppath*) (remdat *remotedat*) (conns (remotedat-conns remdat)) ;; just checking that remdat is a remotedat (dbname (db:run-id->dbname rid))) (if *localmode* (let* ((dbdat (dbr:dbstruct-get-dbdat *dbstruct* dbname)) (indat `((cmd . ,cmd)(params . ,params)))) | > | | 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 | (let* ((apath *toppath*) (remdat *remotedat*) (conns (remotedat-conns remdat)) ;; just checking that remdat is a remotedat (dbname (db:run-id->dbname rid))) (if *localmode* (let* ((dbdat (dbr:dbstruct-get-dbdat *dbstruct* dbname)) (indat `((cmd . ,cmd)(params . ,params)))) (api:execute-requests *dbstruct* cmd params) ;; (api:process-request *dbstruct* indat) ;; (api:process-request dbdat indat) ) (begin (rmt:open-main-connection remdat apath) (if rid (rmt:general-open-connection remdat apath dbname)) (rmt:send-receive-real remdat apath dbname cmd params))))) |
︙ | ︙ | |||
377 378 379 380 381 382 383 | (let* ((soc (conndat-socket conn)) (key #f) (host (conndat-ipaddr conn)) (port (conndat-port conn)) (payload `((cmd . ,cmd) (key . ,(conndat-srvkey conn)) (params . ,params))) | | < | 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 | (let* ((soc (conndat-socket conn)) (key #f) (host (conndat-ipaddr conn)) (port (conndat-port conn)) (payload `((cmd . ,cmd) (key . ,(conndat-srvkey conn)) (params . ,params))) (res (send-receive soc payload))) (if (member res '("#<unspecified>")) ;; TODO - fix this in string->sexpr #f (string->sexpr res))))) ;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed ;; sometime in the future. ;; |
︙ | ︙ | |||
1530 1531 1532 1533 1534 1535 1536 | (let* ((am-server (args:get-arg "-server")) (dbfile (args:get-arg "-db")) (apath *toppath*) (remdat *remotedat*)) ;; foundation for future fix (if *dbstruct-db* (let* ((dbdat (db:get-dbdat *dbstruct-db* apath dbfile)) (db (dbr:dbdat-db dbdat)) | | | 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 | (let* ((am-server (args:get-arg "-server")) (dbfile (args:get-arg "-db")) (apath *toppath*) (remdat *remotedat*)) ;; foundation for future fix (if *dbstruct-db* (let* ((dbdat (db:get-dbdat *dbstruct-db* apath dbfile)) (db (dbr:dbdat-db dbdat)) (inmem (dbr:dbdat-db dbdat)) ;; WRONG ) ;; do a final sync here (debug:print-info 0 *default-log-port* "Doing final sync for "apath" "dbfile" at "(current-seconds)) (db:sync-inmem->disk *dbstruct-db* apath dbfile force-sync: #t) ;; let's finalize here (debug:print-info 0 *default-log-port* "Finalizing db and inmem") (if (sqlite3:database? db) |
︙ | ︙ | |||
1582 1583 1584 1585 1586 1587 1588 | #t)))) (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.") (if (and no-hurry (debug:debug-mode 18)) (rmt:print-db-stats)) (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds (let* ((start-time (current-seconds))) | | | | | > > > | > | | 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 | #t)))) (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.") (if (and no-hurry (debug:debug-mode 18)) (rmt:print-db-stats)) (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds (let* ((start-time (current-seconds))) (if *server-info* (let* ((host (servdat-host *server-info*)) (port (servdat-port *server-info*))) (debug:print-info 0 *default-log-port* "Shutting down server/responder.") ;; ;; TODO - add flushing/waiting on the work queue ;; (rmt:server-shutdown host port) (portlogger:open-run-close portlogger:set-port port "released"))) (debug:print-info 0 *default-log-port* "Shutdown activities completed in "(- (current-seconds) start-time)" seconds")) ;; (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated #;(if (bdat-task-db *bdat*) ;; TODO: Check that this is correct for task db (let ((db (cdr (bdat-task-db *bdat*)))) (if (sqlite3:database? db) (begin (debug:print-info 0 *default-log-port* "Closing down task db "db) |
︙ | ︙ | |||
1637 1638 1639 1640 1641 1642 1643 | ;; ;; conn is a conndat record ;; (define (server:ping conn #!key (do-exit #f)) (let* ((req (conndat-socket conn)) (srvkey (conndat-srvkey conn)) (msg (sexpr->string '(ping ,srvkey)))) | | > < < | < | | < | > > | < < < | < > > | | | < < > | | | < < < | < < < < > | < | < < < < < | < | < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 | ;; ;; conn is a conndat record ;; (define (server:ping conn #!key (do-exit #f)) (let* ((req (conndat-socket conn)) (srvkey (conndat-srvkey conn)) (msg (sexpr->string '(ping ,srvkey)))) (send-receive req msg))) ;; (server-ready? host port server-id)) ;;====================================================================== ;; http-transportmod.scm contents moved here ;;====================================================================== (define (http-transport:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) ;;====================================================================== ;; S E R V E R ;; ====================================================================== (define (http-get-function fnkey) (hash-table-ref/default *http-functions* fnkey (lambda () "nothing here yet"))) ;; Main entry point to start a server. was start-server (define (rmt:run hostn) ;; (assert (not *server-info*) "FATAL: rmt:run called but *server-info* has already been initialized") ;; ;; Configurations for server ;; (tcp-buffer-size 2048) ;; (max-connections 2048) (debug:print 2 *default-log-port* "PID: "(current-process-id)". Attempting to start the server ...") (if *server-info* (let* ((uconn (servdat-uconn *server-info*))) (wait-and-close uconn)) (let* ((port (portlogger:open-run-close portlogger:find-port)) (handler-proc (lambda (rem-host-port qrykey cmd params) ;; (api:execute-requests *dbstruct-db* cmd params)))) ;; (api:process-request *dbstuct-db* (set! *server-info* (make-servdat host: hostn port: port)) (let* ((uconn (run-listener handler-proc port)) (rport (udat-port uconn))) ;; the real port (servdat-host-set! *server-info* hostn) (servdat-port-set! *server-info* rport) (servdat-uconn-set! *server-info* uconn) (wait-and-close uconn) (db:print-current-query-stats) ))) (let* ((host (servdat-host *server-info*)) (port (servdat-port *server-info*)) (mode (or (servdat-mode *server-info*) "non-db"))) ;; server exit stuff here ;; (rmt:server-shutdown host port) - always do in on-exit ;; (portlogger:open-run-close portlogger:set-port port "released") ;; moved to on-exit (debug:print-info 0 *default-log-port* "Server "host":"port" mode "mode"shutdown complete. Exiting") )) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;;====================================================================== ;; C L I E N T S |
︙ | ︙ | |||
1822 1823 1824 1825 1826 1827 1828 | ;; only use for main.db - need to re-write some of this :( ;; (define (get-lock-db sdat dbfile host port) (assert host "FATAL: get-lock-db called with host not set.") (assert port "FATAL: get-lock-db called with port not set.") (let* ((dbh (db:open-run-db dbfile db:initialize-db)) ;; open-run-db creates a standard db with schema used by all situations | | > | | 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 | ;; only use for main.db - need to re-write some of this :( ;; (define (get-lock-db sdat dbfile host port) (assert host "FATAL: get-lock-db called with host not set.") (assert port "FATAL: get-lock-db called with port not set.") (let* ((dbh (db:open-run-db dbfile db:initialize-db)) ;; open-run-db creates a standard db with schema used by all situations (res (db:get-iam-server-lock dbh dbfile host port)) (uconn (servdat-uconn sdat))) ;; res => list then already locked, check server is responsive ;; => #t then sucessfully got the lock ;; => #f reserved for future use as to indicate something went wrong (match res ((owner_pid owner_host owner_port event_time) (if (server-ready? uconn owner_host owner_port "abc") #f ;; locked by someone else (begin ;; locked by someone dead and gone (debug:print 0 *default-log-port* "WARNING: stale lock - have to steal it. This may fail.") (db:steal-lock-db dbh dbfile port)))) (#t #t) ;; placeholder so that we don't touch res if it is #t (else (set! res #f))) (sqlite3:finalize! dbh) |
︙ | ︙ | |||
1882 1883 1884 1885 1886 1887 1888 | (read-pkt->alist pkt-file pktspec: pktspec)) all-pkt-files))) (define (server-address srv-pkt) (conc (alist-ref 'host srv-pkt) ":" (alist-ref 'port srv-pkt))) | | | | | | | | 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 | (read-pkt->alist pkt-file pktspec: pktspec)) all-pkt-files))) (define (server-address srv-pkt) (conc (alist-ref 'host srv-pkt) ":" (alist-ref 'port srv-pkt))) (define (server-ready? uconn host port key) ;; server-address is host:port (let* ((data (sexpr->string `((cmd . ping) (key . ,key) (params . ())))) (res (send-receive uconn (conc host ":" port) 'ping data))) (if res (string->sexpr res) res))) ; from the pkts return servers associated with dbpath ;; NOTE: Only one can be alive - have to check on each ;; in the list of pkts returned ;; (define (get-viable-servers serv-pkts dbpath) (let loop ((tail serv-pkts) (res '())) (if (null? tail) res ;; NOTE: sort by age so oldest is considered first (let* ((spkt (car tail))) (loop (cdr tail) (if (equal? dbpath (alist-ref 'dbpath spkt)) (cons spkt res) res)))))) (define (remove-pkts-if-not-alive uconn serv-pkts) (filter (lambda (pkt) (let* ((host (alist-ref 'host pkt)) (port (alist-ref 'port pkt)) (key (alist-ref 'servkey pkt)) (pktz (alist-ref 'Z pkt)) (res (server-ready? uconn host port key))) (if res res (let* ((pktsdir (get-pkts-dir *toppath*)) (pktpath (conc pktsdir"/"pktz".pkt"))) (debug:print 0 *default-log-port* "WARNING: pkt with no server "pktpath) (delete-file* pktpath) #f)))) serv-pkts)) ;; from viable servers get one that is alive and ready ;; (define (get-the-server uconn apath serv-pkts) (let loop ((tail serv-pkts)) (if (null? tail) #f (let* ((spkt (car tail)) (host (alist-ref 'ipaddr spkt)) (port (alist-ref 'port spkt)) (dbpth (alist-ref 'dbpath spkt)) (srvkey (alist-ref 'Z spkt)) ;; (alist-ref 'srvkey spkt)) (addr (server-address spkt))) (if (server-ready? uconn host port srvkey) spkt (loop (cdr tail))))))) ;; am I the "first" in line server? I.e. my D card is smallest ;; use Z card as tie breaker ;; (define (get-best-candidate serv-pkts dbpath) |
︙ | ︙ | |||
1988 1989 1990 1991 1992 1993 1994 | (debug:print-info 0 *default-log-port* "Waiting for server alive signature") (mutex-lock! *heartbeat-mutex*) (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) (if (and sdat (not changed) (> (- (current-seconds) start-time) 2)) | | | | 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 | (debug:print-info 0 *default-log-port* "Waiting for server alive signature") (mutex-lock! *heartbeat-mutex*) (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) (if (and sdat (not changed) (> (- (current-seconds) start-time) 2)) (let* ((uconn (servdat-uconn sdat))) (servdat-status-set! sdat 'iface-stable) (debug:print-info 0 *default-log-port* "Received server alive signature, now attempting to lock in server") ;; create a server pkt in *toppath*/.meta/srvpkts ;; TODO: ;; 1. change sdat to stuct ;; 2. add uuid to struct ;; 3. update uuid in sdat here ;; (servdat-uuid-set! sdat (register-server pkts-dir *srvpktspec* (get-host-name) (servdat-port sdat) server-key (servdat-host sdat) db-file)) ;; (set! *my-signature* (servdat-uuid sdat)) ;; replace with Z, no, stick with proper key ;; now read pkts and see if we are a contender (let* ((all-pkts (get-all-server-pkts pkts-dir *srvpktspec*)) (viables (get-viable-servers all-pkts db-file)) (alive (remove-pkts-if-not-alive uconn viables)) (best-srv (get-best-candidate alive db-file)) (best-srv-key (if best-srv (alist-ref 'servkey best-srv) #f)) (i-am-srv (equal? best-srv-key server-key)) (delete-pkt (lambda () (let* ((pktfile (conc (get-pkts-dir *toppath*) "/" (servdat-uuid *server-info*) ".pkt"))) |
︙ | ︙ | |||
2143 2144 2145 2146 2147 2148 2149 | (server-start-time (current-seconds)) (pkts-dir (get-pkts-dir)) (server-key (rmt:get-signature)) ;; This servers key (is-main (equal? (args:get-arg "-db") ".db/main.db")) (last-access 0) (server-timeout (server:expiration-timeout)) (shutdown-server-sequence (lambda (host port) | | | | | | > | | | 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 | (server-start-time (current-seconds)) (pkts-dir (get-pkts-dir)) (server-key (rmt:get-signature)) ;; This servers key (is-main (equal? (args:get-arg "-db") ".db/main.db")) (last-access 0) (server-timeout (server:expiration-timeout)) (shutdown-server-sequence (lambda (host port) (set! *unclean-shutdown* #f) ;; Should not be needed anymore (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id)) ;; (rmt:server-shutdown host port) -- called in on-exit ;; (portlogger:open-run-close portlogger:set-port port "released") called in on-exit (exit))) (timed-out? (lambda () (<= (+ last-access server-timeout) (current-seconds))))) (servdat-dbfile-set! *server-info* (args:get-arg "-db")) ;; main and run db servers have both got wait logic (could/should merge it) (if is-main (rmt:wait-for-server pkts-dir dbname server-key) (rmt:wait-for-stable-interface)) ;; this is our forever loop (let* ((iface (servdat-host *server-info*)) (port (servdat-port *server-info*)) (uconn (servdat-uconn *server-info*))) (let loop ((count 0) (bad-sync-count 0) (start-time (current-milliseconds))) (if (and (not is-main) (common:low-noise-print 60 "servdat-status")) (debug:print-info 0 *default-log-port* "servdat-status is " (servdat-status *server-info*))) ;; set up the database handle (mutex-lock! *heartbeat-mutex*) (if (not *dbstruct-db*) ;; no db opened yet, open the db and register with main if appropriate (let ((watchdog (bdat-watchdog *bdat*))) (debug:print 0 *default-log-port* "SERVER: dbprep") (db:setup dbname) ;; sets *dbstruct-db* as side effect (servdat-status-set! *server-info* 'db-opened) ;; IFF I'm not main, call into main and register self (if (not is-main) (let ((res (rmt:register-server remdat *toppath* iface port server-key dbname))) (if res ;; we are the server (servdat-status-set! *server-info* 'have-interface-and-db) ;; now check that the db locker is alive, clear it out if not (let* ((serv-info (rmt:get-server-info *toppath* dbname))) (match serv-info ((host port servkey pid ipaddr apath dbpath) (if (not (server-ready? uconn host port servkey)) (begin (debug:print-info 0 *default-log-port* "Server registered but not alive. Removing and trying again.") (rmt:deregister-server remdat apath host port servkey dbpath) ;; servkey pid ipaddr apath dbpath) (loop (+ count 1) bad-sync-count start-time)))) (else (debug:print 0 *default-log-port* "We are not the server for "dbname", exiting. Server info is: "serv-info) |
︙ | ︙ | |||
2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 | (set! *unclean-shutdown* #f) (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) (shutdown-server-sequence (get-host-name) port) #;(debug:print-info 0 *default-log-port* "Sending 'quit to server, received: " (open-send-receive-nn (conc iface":"port) ;; do this here and not in server-shutdown (sexpr->string 'quit))) ))))))) ;; Call this to start the actual server ;; ;; all routes though here end in exit ... ;; ;; This is the point at which servers are started ;; (define (rmt:server-launch dbname) (debug:print-info 0 *default-log-port* "Entered rmt:server-launch") (let* ((th2 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server run thread started") | > > > > > > | < < | | 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 | (set! *unclean-shutdown* #f) (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) (shutdown-server-sequence (get-host-name) port) #;(debug:print-info 0 *default-log-port* "Sending 'quit to server, received: " (open-send-receive-nn (conc iface":"port) ;; do this here and not in server-shutdown (sexpr->string 'quit))) ))))))) (define (rmt:get-reasonable-hostname) (let* ((inhost (or (args:get-arg "-server") "-"))) (if (equal? inhost "-") (get-host-name) inhost))) ;; Call this to start the actual server ;; ;; all routes though here end in exit ... ;; ;; This is the point at which servers are started ;; (define (rmt:server-launch dbname) (debug:print-info 0 *default-log-port* "Entered rmt:server-launch") (let* ((th2 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server run thread started") (rmt:run (rmt:get-reasonable-hostname))) "Server run")) (th3 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server monitor thread started") (rmt:keep-running dbname) "Keep running")))) (thread-start! th2) (thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor. (thread-start! th3) |
︙ | ︙ | |||
2324 2325 2326 2327 2328 2329 2330 | (if (string-search (regexp (conc ":" port-num)) inl) (begin ;(print "Output: " inl) (set! ret #t)) (loop (read-line inp))))))) ret)) | < < < < < < < < < < < < < < | | | | 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 | (if (string-search (regexp (conc ":" port-num)) inl) (begin ;(print "Output: " inl) (set! ret #t)) (loop (read-line inp))))))) ret)) #;(define (open-nn-connection host-port) (let ((req (make-req-socket)) (uri (conc "tcp://" host-port))) (nng-dial req uri) (socket-set! req 'nng/recvtimeo 2000) req)) #;(define (send-receive-nn req msg) (nng-send req msg) (nng-recv req)) #;(define (close-nn-connection req) (nng-close! req)) ;; ;; open connection to server, send message, close connection ;; ;; ;; (define (open-send-close-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds ;; (let ((req (make-req-socket 'req)) ;; (uri (conc "tcp://" host-port)) |
︙ | ︙ | |||
2388 2389 2390 2391 2392 2393 2394 | ;; (thread-terminate! th1)) ;; "timer thread"))) ;; (thread-start! th1) ;; (thread-start! th2) ;; (thread-join! th1) ;; res)))) ;; | | | 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 | ;; (thread-terminate! th1)) ;; "timer thread"))) ;; (thread-start! th1) ;; (thread-start! th2) ;; (thread-join! th1) ;; res)))) ;; #;(define (open-send-receive-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds (let ((req (make-req-socket)) (uri (conc "tcp://" host-port)) (res #f)) (handle-exceptions exn (let ((emsg ((condition-property-accessor 'exn 'message) exn))) ;; Send notification |
︙ | ︙ |
Added rununit.sh version [0dba7a0924].
> > > > > | 1 2 3 4 5 | #!/bin/bash rm tests/*log tests/simplerun/logs/* script -c 'ck5 make unit' |
Modified tests/simplerun/Makefile from [38acf6b450] to [1a5a527039].
1 2 | cleanup : | | > > | 1 2 3 4 5 | cleanup : killall mtest -v -9 || true rm -rf *.log *.bak NB* logs/* .meta .db |
Modified ulex.scm from [39353b5283] to [419292ee51].
︙ | ︙ | |||
15 16 17 18 19 20 21 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit ulex)) | < | 15 16 17 18 19 20 21 22 23 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit ulex)) (include "ulex/ulex.scm") |
Deleted ulex/ulex-prev-orig.scm version [42b648b50c].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Modified ulex/ulex.scm from [88c5ce4192] to [92f3edc6d9].
︙ | ︙ | |||
22 23 24 25 26 27 28 | ;; See README in the distribution at https://www.kiatoa.com/fossils/ulex ;; NOTES: ;; Why sql-de-lite and not say, dbi? - performance mostly, then simplicity. ;; ;;====================================================================== (module ulex | > | > > > > > > > > > > > > > > > > > > > > > | 22 23 24 25 26 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 54 55 56 57 58 | ;; See README in the distribution at https://www.kiatoa.com/fossils/ulex ;; NOTES: ;; Why sql-de-lite and not say, dbi? - performance mostly, then simplicity. ;; ;;====================================================================== (module ulex ( run-listener ;; (run-listener handler-proc [port]) => uconn ;; NOTE: handler-proc params; ;; (handler-proc rem-host-port qrykey cmd params) send-receive ;; (send-receive uconn host-port cmd data) ;; NOTE: cmd can be any plain text symbol except for these; ;; 'ping 'ack 'goodbye 'response set-work-handler ;; (set-work-handler proc) wait-and-close ;; (wait-and-close uconn) ;; needed to get the interface:port that was automatically found udat-port udat-host-port ;; for testing only ;; pp-uconn ) (import scheme chicken.base chicken.file chicken.time chicken.condition chicken.string |
︙ | ︙ | |||
64 65 66 67 68 69 70 71 72 | (peers (make-hash-table)) ;; host:port->peer ;; work handling (work-queue (make-queue)) (work-proc #f) ;; set by user (cnum 0) ;; cookie number (mboxes (make-hash-table)) (avail-cmboxes '()) ;; list of (<cookie> . <mbox>) for re-use ) | > > > | | | | | < | > | | | | | | | < > | 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 | (peers (make-hash-table)) ;; host:port->peer ;; work handling (work-queue (make-queue)) (work-proc #f) ;; set by user (cnum 0) ;; cookie number (mboxes (make-hash-table)) (avail-cmboxes '()) ;; list of (<cookie> . <mbox>) for re-use ;; threads (cmd-thread #f) (work-queue-thread #f) ) ;; ;; struct for keeping track of others we are talking to ;; ;; ;; (defstruct pdat ;; (host-port #f) ;; (conns '()) ;; list of pcon structs, pop one off when calling the peer ;; ) ;; ;; ;; struct for peer connections, keep track of expiration etc. ;; ;; ;; (defstruct pcon ;; (inp #f) ;; (oup #f) ;; (exp (+ (current-seconds) 59)) ;; expires at this time, set to (+ (current-seconds) 59) ;; (lifetime (+ (current-seconds) 600)) ;; throw away and create new after five minutes ;; ) ;;====================================================================== ;; listener ;;====================================================================== ;; create a tcp listener and return a populated udat struct with ;; my port, address, hostname, pid etc. ;; return #f if fail to find a port to allocate. |
︙ | ︙ | |||
109 110 111 112 113 114 115 116 117 118 119 120 121 122 | ;; sockaddr-address, sockaddr-port, sockaddr->string (let* ((tlsn (tcp-listen port 1000 #f)) ;; (tcp-listen TCPPORT [BACKLOG [HOST]]) (addr (get-my-best-address))) ;; (hostinfo-addresses (host-information (current-hostname))) (udat-port-set! uconn port) (udat-host-port-set! uconn (conc addr":"port)) (udat-socket-set! uconn tlsn) uconn)) ;;====================================================================== ;; peers and connections ;;====================================================================== ;; send structured data to recipient ;; | > > > > > > > > > > > > > > > > > > > > > | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 | ;; sockaddr-address, sockaddr-port, sockaddr->string (let* ((tlsn (tcp-listen port 1000 #f)) ;; (tcp-listen TCPPORT [BACKLOG [HOST]]) (addr (get-my-best-address))) ;; (hostinfo-addresses (host-information (current-hostname))) (udat-port-set! uconn port) (udat-host-port-set! uconn (conc addr":"port)) (udat-socket-set! uconn tlsn) uconn)) ;; run-listener does all the work of starting a listener in a thread ;; it then returns control ;; (define (run-listener handler-proc #!optional (port-suggestion #f)) (let* ((uconn (make-udat))) (udat-work-proc-set! uconn handler-proc) (if (setup-listener uconn port-suggestion) (let* ((th1 (make-thread (lambda ()(ulex-cmd-loop uconn)) "Ulex command loop")) (th2 (make-thread (lambda ()(process-work-queue uconn)) "Ulex work queue processor"))) (thread-start! th1) (thread-start! th2) (udat-cmd-thread-set! uconn th1) (udat-work-queue-thread-set! uconn th2) (print "cmd loop and process workers started") uconn) (assert #f "ERROR: run-listener called without proper setup.")))) (define (wait-and-close uconn) (thread-join! (udat-cmd-thread uconn)) (tcp-close (udat-socket uconn))) ;;====================================================================== ;; peers and connections ;;====================================================================== ;; send structured data to recipient ;; |
︙ | ︙ | |||
227 228 229 230 231 232 233 | ;; add a proc to the cmd list, these are done symetrically (i.e. in all instances) ;; so that the proc can be dereferenced remotely ;; (define (set-work-handler uconn proc) (udat-work-proc-set! uconn proc)) | < < < < < < < < < < < < < < < < < | 273 274 275 276 277 278 279 280 281 282 283 284 285 286 | ;; add a proc to the cmd list, these are done symetrically (i.e. in all instances) ;; so that the proc can be dereferenced remotely ;; (define (set-work-handler uconn proc) (udat-work-proc-set! uconn proc)) ;;====================================================================== ;; work queues - this is all happening on the listener side ;;====================================================================== ;; rdata is (rem-host-port qrykey cmd params) (define (add-to-work-queue uconn rdata) |
︙ | ︙ | |||
372 373 374 375 376 377 378 | (define (get-all-ips) (map address-info-host (filter (lambda (x) (equal? (address-info-type x) "tcp")) (address-infos (get-host-name))))) | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 401 402 403 404 405 406 407 408 | (define (get-all-ips) (map address-info-host (filter (lambda (x) (equal? (address-info-type x) "tcp")) (address-infos (get-host-name))))) ) |