Overview
Comment: | wip - does not compile |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.80-tcp-inmem |
Files: | files | file ages | folders |
SHA1: |
ab238c7c301013fe9117488eef434a4c |
User & Date: | matt on 2023-02-15 08:22:59 |
Other Links: | branch diff | manifest | tags |
Context
2023-02-15
| ||
14:17 | wip check-in: e0ef4cda9d user: matt tags: v1.80-tcp-inmem | |
08:22 | wip - does not compile check-in: ab238c7c30 user: matt tags: v1.80-tcp-inmem | |
2023-02-12
| ||
20:21 | wip check-in: 278a10af86 user: matt tags: v1.80-tcp-inmem | |
Changes
Modified commonmod.scm from [e15f774ed4] to [35092db3d2].
︙ | ︙ | |||
516 517 518 519 520 521 522 523 524 | ;;====================================================================== ;; misc stuff ;;====================================================================== (define (common:get-signature str) (message-digest-string (md5-primitive) str)) ) | > > > > > > > > > > > > > > > > > | 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 | ;;====================================================================== ;; misc stuff ;;====================================================================== (define (common:get-signature str) (message-digest-string (md5-primitive) str)) ;;====================================================================== ;; hash of hashs ;;====================================================================== (define (db:hoh-set! dat key1 key2 val) (let* ((subhash (hash-table-ref/default dat key1 #f))) (if subhash (hash-table-set! subhash key2 val) (begin (hash-table-set! dat key1 (make-hash-table)) (db:hoh-set! dat key1 key2 val))))) (define (db:hoh-get dat key1 key2) (let* ((subhash (hash-table-ref/default dat key1 #f))) (and subhash (hash-table-ref/default subhash key2 #f)))) ) |
Modified db.scm from [9c05d0ba74] to [42d13b3d83].
︙ | ︙ | |||
581 582 583 584 585 586 587 | ;; Sync all changed db's ;; (define (db:tmp->megatest.db-sync dbstruct run-id last-update) (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))) (res '())) (for-each (lambda (subdb) | < | | 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 | ;; Sync all changed db's ;; (define (db:tmp->megatest.db-sync dbstruct run-id last-update) (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))) (res '())) (for-each (lambda (subdb) (let* ((mtdb (dbr:subdb-mtdb subdb)) (tmpdb (db:get-subdb dbstruct run-id)) (refndb (dbr:subdb-refndb subdb)) (newres (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) last-update tmpdb refndb mtdb))) ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb) ;; BUG: verify this is really needed (dbfile:add-dbdat dbstruct run-id tmpdb) (set! res (cons newres res)))) |
︙ | ︙ |
Modified dbfile.scm from [e35890c342] to [575621e170].
︙ | ︙ | |||
54 55 56 57 58 59 60 61 62 63 64 65 66 67 | ;; (defstruct dbr:dbstruct (areapath #f) (homehost #f) (tmppath #f) (read-only #f) (subdbs (make-hash-table)) ) ;; NOTE: Need one dbr:subdb per main.db, 1.db ... ;; (defstruct dbr:subdb (dbname #f) ;; .megatest/1.db (mtdbfile #f) ;; mtrah/.megatest/1.db | > > > > > | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | ;; (defstruct dbr:dbstruct (areapath #f) (homehost #f) (tmppath #f) (read-only #f) (subdbs (make-hash-table)) ;; for the inmem approach (see dbmod.scm) ;; this is one db per server (inmem #f) ;; handle for the in memory copy (dbfile #f) ;; path to the db file on disk (ondiskdb #f) ;; handle for the on-disk file ) ;; NOTE: Need one dbr:subdb per main.db, 1.db ... ;; (defstruct dbr:subdb (dbname #f) ;; .megatest/1.db (mtdbfile #f) ;; mtrah/.megatest/1.db |
︙ | ︙ |
Modified dbmod.scm from [043beb90c3] to [75595b50f0].
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 | ;; ;; 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 dbmod)) (module dbmod * | > > > | > > > > | > | > | > | > > | > > | | | > > > > > < > > > > > > | > > > > > > > > > | | > > > > > > > > > > > | < | > | | > > | < | < > > | 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 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 | ;; ;; 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 dbmod)) (declare (uses dbfile)) (declare (uses commonmod)) (declare (uses debugprint)) (module dbmod * (import scheme chicken data-structures extras (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 commonmod dbfile debugprint ) ;; NOTE: This returns only the name "1.db", "main.db", not the path ;; (define (dbmod:run-id->dbfname run-id) (conc (dbfile:run-id->dbnum run-id)".db")) (define (dbmod:get-dbdir dbstruct run-id) (let* ((areapath (dbr:dbstruct-areapath dbstruct))) (conc areapath"/.megatest"))) (define (dbmod:run-id->full-dbfname dbstruct run-id) (conc (dbmod:get-dbdir dbstruct run-id)"/"(dbmod:run-id->dbfname run-id))) ;;====================================================================== ;; The inmem one-db file per server method goes in here ;;====================================================================== (define (dbmod:open-inmem-db initproc) (let* ((db (sqlite3:open-database ":memory:")) (handler (sqlite3:make-busy-timeout 3600))) (sqlite3:set-busy-handler! db handler) (initproc db) db)) ;; Open the inmem db and the on-disk db ;; populate the inmem db with data ;; ;; Updates fields in dbstruct ;; Returns dbstruct ;; ;; This routine creates the db if not found ;; (define (db:open-dbmoddb dbstruct run-id init-proc) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbfname (dbmod:run-id->dbfname run-id)) (dbpath (dbmod:get-dbdir dbstruct run-id)) ;; directory where all the .db files are kept (dbfullname (dbmod:run-id->full-dbfname dbstruct run-id)) (dbexists (file-exists? dbfullname)) (inmem (dbmod:open-inmem-db init-proc)) (write-access (file-write-access? dbpath)) (db (dbfile:with-simple-file-lock (conc dbfullname".lock") (lambda () (let* ((db (sqlite3:open-database dbfullname)) (handler (sqlite3:make-busy-timeout 136000))) (sqlite3:set-busy-handler! db handler) (if write-access (init-proc db)) db))))) (dbr:dbstruct-inmem-set! dbstruct inmem) (dbr:dbstruct-ondiskdb-set! dbstruct db) (dbr:dbstruct-dbfile-set! dbstruct dbfullname) dbstruct)) (define (dbmod:close-db dbstruct) ;; do final sync to disk file ;; (do-sync ...) (sqlite3:finalize! (dbr:dbstruct-ondiskdb dbstruct))) ) |
Modified megatest.scm from [d06abcb0ca] to [44c5a97a42].
︙ | ︙ | |||
78 79 80 81 82 83 84 85 86 87 88 89 90 91 | (use sparse-vectors) (require-library mutils) (define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file (dbfile:db-init-proc db:initialize-main-db) ;; 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))) | > > | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | (use sparse-vectors) (require-library mutils) (define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file ;; 'http or 'tcp (rmt:transport-mode 'tcp) (dbfile:db-init-proc db:initialize-main-db) ;; 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 tcp-transportmod.scm from [3021f407ce] to [735951d904].
︙ | ︙ | |||
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 59 60 61 62 | (module tcp-transportmod * (import scheme (prefix sqlite3 sqlite3:) chicken data-structures directory-utils extras files hostinfo matchable md5 message-digest ports posix srfi-1 srfi-18 srfi-4 srfi-69 stack typed-records commonmod debugprint ) ;;====================================================================== ;; client ;;====================================================================== ;; (define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic (defstruct tt ;; all (areapath #f) ;; client related (conns (make-hash-table)) ;; dbfname -> conn | > > > > > > > < < > > > > > > > > > > > | 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 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 | (module tcp-transportmod * (import scheme (prefix sqlite3 sqlite3:) chicken data-structures ;; address-info directory-utils extras files hostinfo matchable md5 message-digest ports posix regex regex-case srfi-1 srfi-18 srfi-4 srfi-69 stack typed-records tcp6 commonmod debugprint ) ;;====================================================================== ;; client ;;====================================================================== ;; (define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic ;; the client side struct ;; (defstruct tt ;; all (areapath #f) ;; client related (conns (make-hash-table)) ;; dbfname -> conn ) (defstruct tt-conn host port dbfname ) (defstruct tt-srv ;; server related (host #f) (port #f) (conn #f) (cleanup-proc #f) socket thread host-port ) (define (tt:make-remote areapath) (make-tt area: areapath)) (define (tt:client-connect-to-server ttdat) #f) |
︙ | ︙ | |||
114 115 116 117 118 119 120 | ;;====================================================================== (define (tt:sync-dbs ttdat) #f) ;; start the listener and start responding to requests ;; | | > > > > > > > > > > > > > > > > > > | 130 131 132 133 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 169 170 | ;;====================================================================== (define (tt:sync-dbs ttdat) #f) ;; start the listener and start responding to requests ;; (define (tt:start-server ttdat dbfname) ;; is there already a server for this dbfile? Then exit. (let* ((servers (tt:find-server ttdat dbfname))) (if (not (null? servers)) (begin (debug:print 0 *default-log-port* "INFO: found server(s) already running for db "dbfname", "(string-intersperse servers ",")" Exiting.") (exit)) (begin (tt:start-tcp-server ttdat) (tt:keep-running ttdat dbfname))))) (define (tt:start-tcp-server ttdat) #f) (define (tt:keep-running ttdat dbfile) #f) (define (tt:shutdown-server ttdat) (let* ((cleanproc (tt-cleanup-proc ttdat))) (if cleanproc (cleanproc)) ;; close up ports here #f)) (define (wait-and-close uconn) (thread-join! (tt-srv-cmd-thread uconn)) (tcp-close (tt-srv-socket uconn))) ;; return servid ;; side-effects: ;; ttdat-cleanup-proc is populated with function to remove the serverinfo file (define (tt:create-server-registration-file ttdat dbfname) (let* ((areapath (tt-areapath ttdat)) (servdir (tt:get-servinfo-dir areapath)) (conn (hash-table-ref/default (tt-conns ttdat) dbfname #f))) |
︙ | ︙ | |||
173 174 175 176 177 178 179 180 181 182 183 184 185 186 | ))) ;; (conc " >> " logfile " 2>&1 &"))))) ;; we want the remote server to start in *toppath* so push there (push-directory areapath) (debug:print 0 *default-log-port* "INFO: Trying to start server in tcp mode (" cmdln ") ...") (debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time)) (system (conc "nbfake " cmdln)) (pop-directory))) ;;====================================================================== ;; utils ;;====================================================================== ;; Generate a unique signature for this server (define (tt:mk-signature areapath) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ))) ;; (conc " >> " logfile " 2>&1 &"))))) ;; we want the remote server to start in *toppath* so push there (push-directory areapath) (debug:print 0 *default-log-port* "INFO: Trying to start server in tcp mode (" cmdln ") ...") (debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time)) (system (conc "nbfake " cmdln)) (pop-directory))) ;;====================================================================== ;; tcp connection stuff ;;====================================================================== ;; 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. ;; ;; if udata-in is #f create the record ;; if there is already a serv-listener return the udata ;; (define (setup-listener uconn #!optional (port 4242)) (handle-exceptions exn (if (< port 65535) (setup-listener uconn (+ port 1)) #f) (connect-listener uconn port))) (define (connect-listener uconn port) ;; (tcp-listener-socket LISTENER)(socket-name so) ;; 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))) (tt-srv-port-set! uconn port) (tt-srv-host-port-set! uconn (conc addr":"port)) (tt-srv-socket-set! uconn tlsn) uconn)) ;;====================================================================== ;; utils ;;====================================================================== ;; Generate a unique signature for this server (define (tt:mk-signature areapath) |
︙ | ︙ | |||
206 207 208 209 210 211 212 213 | (if res res (hostname->ip hostname)))) "."))) (define (tt:get-servinfo-dir areapath) (let* ((spath (conc areapath"/.servinfo"))) (if (not (file-exists? spath)) (create-directory spath #t)) spath)) | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | (if res res (hostname->ip hostname)))) "."))) (define (tt:get-servinfo-dir areapath) (let* ((spath (conc areapath"/.servinfo"))) (if (not (file-exists? spath)) (create-directory spath #t)) spath)) ;;====================================================================== ;; network utilities ;;====================================================================== ;; NOTE: Look at address-info egg as alternative to some of this (define (rate-ip ipaddr) (regex-case ipaddr ( "^127\\..*" _ 0 ) ( "^(10\\.0|192\\.168)\\..*" _ 1 ) ( else 2 ) )) ;; Change this to bias for addresses with a reasonable broadcast value? ;; (define (ip-pref-less? a b) (> (rate-ip a) (rate-ip b))) (define (get-my-best-address) (let ((all-my-addresses (get-all-ips))) (cond ((null? all-my-addresses) (get-host-name)) ;; no interfaces? ((eq? (length all-my-addresses) 1) (car all-my-addresses)) ;; only one to choose from, just go with it (else (car (sort all-my-addresses ip-pref-less?)))))) (define (get-all-ips-sorted) (sort (get-all-ips) ip-pref-less?)) (define (get-all-ips) (map address-info-host (filter (lambda (x) (equal? (address-info-type x) "tcp")) (address-infos (get-host-name))))) ) |