Overview
Comment: | Cleaned up some junk from the patch forward. |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | v1.65-adjutant-patched-forward-defunct |
Files: | files | file ages | folders |
SHA1: |
5ec348be6dbd0a90aec35e15e6c5ea08 |
User & Date: | matt on 2024-08-15 19:14:52 |
Other Links: | branch diff | manifest | tags |
Context
2024-08-15
| ||
19:14 | Cleaned up some junk from the patch forward. Closed-Leaf check-in: 5ec348be6d user: matt tags: v1.65-adjutant-patched-forward-defunct | |
18:16 | Patched forward adjutant code check-in: 15a47376a6 user: matt tags: v1.65-adjutant-patched-forward-defunct | |
Changes
Modified Makefile from [e5c890e93c] to [cb404ea48e].
︙ | ︙ | |||
91 92 93 94 95 96 97 | dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut | | < | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut # include makefile.inc TCMTOBJS = \ api.o \ archive.o \ cgisetup/models/pgdb.o \ client.o \ common.o \ |
︙ | ︙ |
Modified api.scm from [6784eb775b] to [210c6387b8].
︙ | ︙ | |||
157 158 159 160 161 162 163 | ((not (vector? dat)) ;; it is an error to not receive a vector (vector #f (vector #f "remote must be called with a vector"))) ((> *api-process-request-count* 20) ;; 20) (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.") (set! *server-overloaded* #t) (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor! (else | | | | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 | ((not (vector? dat)) ;; it is an error to not receive a vector (vector #f (vector #f "remote must be called with a vector"))) ((> *api-process-request-count* 20) ;; 20) (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.") (set! *server-overloaded* #t) (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor! (else (let* ((cmd-in (vector-ref dat 0)) (cmd (if (symbol? cmd-in) cmd-in (string->symbol cmd-in))) (params (vector-ref dat 1)) (start-t (current-milliseconds)) (readonly-mode (dbr:dbstruct-read-only dbstruct)) (readonly-command (member cmd api:read-only-queries)) (writecmd-in-readonly-mode (and readonly-mode (not readonly-command))) #;(foo (begin #;(common:telemetry-log (conc "api-in:"(->string cmd)) payload: `((params . ,params))) |
︙ | ︙ | |||
265 266 267 268 269 270 271 | ((no-sync-job-records-clean) (apply db:no-sync-job-records-clean *no-sync-db* params)) ;; ARCHIVES ;; ((archive-get-allocations) ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) ;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) | | | 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 | ((no-sync-job-records-clean) (apply db:no-sync-job-records-clean *no-sync-db* params)) ;; ARCHIVES ;; ((archive-get-allocations) ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) ;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) ;;====================================================================== ;; READ ONLY QUERIES ;;====================================================================== ;; KEYS ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) ((get-keys) (db:get-keys dbstruct)) |
︙ | ︙ | |||
389 390 391 392 393 394 395 | ;; (define (api:process-request dbstruct $) ;; the $ is the request vars proc (debug:print 4 *default-log-port* "server-id:" *server-id*) (let* ((cmd ($ 'cmd)) (paramsj ($ 'params)) (key ($ 'key)) (params (db:string->obj paramsj transport: 'http))) ;; incoming data from the POST (or is it a GET?) | < < | 389 390 391 392 393 394 395 396 397 398 399 400 401 402 | ;; (define (api:process-request dbstruct $) ;; the $ is the request vars proc (debug:print 4 *default-log-port* "server-id:" *server-id*) (let* ((cmd ($ 'cmd)) (paramsj ($ 'params)) (key ($ 'key)) (params (db:string->obj paramsj transport: 'http))) ;; incoming data from the POST (or is it a GET?) (debug:print 4 *default-log-port* "cmd:" cmd " with params " params "key " key) (if (equal? key *server-id*) (begin (set! *api-process-request-count* (+ *api-process-request-count* 1)) (let* ((resdat (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result ) (success (vector-ref resdat 0)) (res (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?) |
︙ | ︙ | |||
415 416 417 418 419 420 421 | ;; (number? res) ;; (boolean? res)) ;; res ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res))))) (db:obj->string res transport: 'http))) (begin (debug:print 0 *default-log-port* "Server refused to process request. Sever id mismatch. recived " key " expected: " *server-id* ".\nOther arguments recived: cmd=" cmd " params = " params) | | < < | 413 414 415 416 417 418 419 420 421 | ;; (number? res) ;; (boolean? res)) ;; res ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res))))) (db:obj->string res transport: 'http))) (begin (debug:print 0 *default-log-port* "Server refused to process request. Sever id mismatch. recived " key " expected: " *server-id* ".\nOther arguments recived: cmd=" cmd " params = " params) (db:obj->string (conc "Server refused to process request server-id mismatch: " key ", " *server-id*) transport: 'http))))) |
Modified common.scm from [4f78a11800] to [f260cd5572].
︙ | ︙ | |||
1053 1054 1055 1056 1057 1058 1059 | (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct) (cond ((dbr:dbstruct-read-only dbstruct) (debug:print-info 13 *default-log-port* "loading read-only watchdog") (common:readonly-watchdog dbstruct)) (else (debug:print-info 13 *default-log-port* "loading writable-watchdog.") | | | 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 | (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct) (cond ((dbr:dbstruct-read-only dbstruct) (debug:print-info 13 *default-log-port* "loading read-only watchdog") (common:readonly-watchdog dbstruct)) (else (debug:print-info 13 *default-log-port* "loading writable-watchdog.") (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "brute-force-sync"))) (cond ((equal? syncer "brute-force-sync") (server:writable-watchdog-bruteforce dbstruct)) ((equal? syncer "delta-sync") (server:writable-watchdog-deltasync dbstruct)) (else (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are brute-force-sync and delta-sync.") |
︙ | ︙ |
Modified dashboard.scm from [be8f9ca9ab] to [8bdd431aae].
︙ | ︙ | |||
1948 1949 1950 1951 1952 1953 1954 | ;; userdata: (conc "run-id: " run-id)))) (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids))) (define (dashboard:tests-ht->tests-dat tests-ht) | > > > > > > > > > > > > > > > > > | | 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 1974 1975 1976 1977 1978 1979 | ;; userdata: (conc "run-id: " run-id)))) (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids))) (define (dashboard:tests-ht->tests-dat tests-ht) (reverse (sort (hash-table-values tests-ht) (lambda (a b) (let ((a-test-name (db:test-get-testname a)) (a-item-path (db:test-get-item-path a)) (b-test-name (db:test-get-testname b)) (b-item-path (db:test-get-item-path b)) (a-event-time (db:test-get-event_time a)) (b-event-time (db:test-get-event_time b))) (if (not (equal? a-test-name b-test-name)) (> a-event-time b-event-time) (cond ((< 0 (string-compare3 a-test-name b-test-name)) #t) ((> 0 (string-compare3 a-test-name b-test-name)) #f) ((< 0 (string-compare3 a-item-path b-item-path)) #t) (else #f)))))))) #;(let ((oldest-item (make-hash-table))) ;; ;; populate the oldest-item table (for-each (lambda (tdat) (let ((tname (db:test-get-testname tdat)) (etime (db:test-get-event_time tdat))) (if (hash-table-exists? oldest-item tname) (if (< (hash-table-ref oldest-item tname) etime) |
︙ | ︙ | |||
1972 1973 1974 1975 1976 1977 1978 | (b-test-name (db:test-get-testname b)) (b-item-path (db:test-get-item-path b)) (a-event-time (db:test-get-event_time a)) (b-event-time (db:test-get-event_time b))) (if (equal? a-test-name b-test-name) (> a-event-time b-event-time) (> (hash-table-ref oldest-item a-test-name) | | < | 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 | (b-test-name (db:test-get-testname b)) (b-item-path (db:test-get-item-path b)) (a-event-time (db:test-get-event_time a)) (b-event-time (db:test-get-event_time b))) (if (equal? a-test-name b-test-name) (> a-event-time b-event-time) (> (hash-table-ref oldest-item a-test-name) (hash-table-ref oldest-item b-test-name)))))))) ;; (if (not (equal? a-test-name b-test-name)) ;; (> a-event-time b-event-time) ;; (cond ;; ((< 0 (string-compare3 a-test-name b-test-name)) #t) ;; ((> 0 (string-compare3 a-test-name b-test-name)) #f) ;; ((< 0 (string-compare3 a-item-path b-item-path)) #t) ;; (else #f))))))))) (define (dashboard:run-id->tests-mindat run-id tabdat runs-hash) (let* ((run (hash-table-ref/default runs-hash run-id #f)) (key-vals (rmt:get-key-vals run-id)) (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) (tests-dat (dashboard:tests-ht->tests-dat tests-ht)) |
︙ | ︙ | |||
2127 2128 2129 2130 2131 2132 2133 | (for-each (lambda (ind) (let* ((name (car ind)) (num (cadr ind)) (key (conc "0:" num))) (if (not (equal? (iup:attribute run-matrix key) name)) (begin (set! changed #t) | | | | 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 | (for-each (lambda (ind) (let* ((name (car ind)) (num (cadr ind)) (key (conc "0:" num))) (if (not (equal? (iup:attribute run-matrix key) name)) (begin (set! changed #t) (iup:attribute-set! run-matrix key name) (if (<= num max-col) (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))) col-indices) (if (and (eq? pass-num 0) changed) (loop 1 #t)) ;; force second pass due to column labels changing ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num) |
︙ | ︙ |
Modified db.scm from [ea90a41ed4] to [1f27416f7b].
︙ | ︙ | |||
2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 | (let* ((dbpath (db:dbfile-path)) (dbname (conc dbpath "/no-sync.db")) (db-exists (common:file-exists? dbname)) (db (sqlite3:open-database dbname))) (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) (if (not db-exists) (begin (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));") (sqlite3:execute db "PRAGMA journal_mode=WAL;"))) ;; MOVE THIS TABLE CREATION TO THE (begin above in about six months (it is Sep 2020 right now). (sqlite3:execute db "CREATE TABLE IF NOT EXISTS jobs_queue (id INTEGER PRIMARY KEY, host_type TEXT, cores INTEGER, memory TEXT, vars TEXT, exekey TEXT, cmdline TEXT, state TEXT, event_time INTEGER, last_update INTEGER);") ;; not sure I'll use this next one. I prefer if tests simply append to a file: ;; last-update-seconds cpuload tmpspace rundirspace (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_extra_data (id INTEGER PRIMARY KEY, run_id INTEGER, test_id INTEGER, last_seen_running INTEGER);") | > | 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 | (let* ((dbpath (db:dbfile-path)) (dbname (conc dbpath "/no-sync.db")) (db-exists (common:file-exists? dbname)) (db (sqlite3:open-database dbname))) (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) (if (not db-exists) (begin (sqlite3:execute db "PRAGMA synchronous = 0;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));") (sqlite3:execute db "PRAGMA journal_mode=WAL;"))) ;; MOVE THIS TABLE CREATION TO THE (begin above in about six months (it is Sep 2020 right now). (sqlite3:execute db "CREATE TABLE IF NOT EXISTS jobs_queue (id INTEGER PRIMARY KEY, host_type TEXT, cores INTEGER, memory TEXT, vars TEXT, exekey TEXT, cmdline TEXT, state TEXT, event_time INTEGER, last_update INTEGER);") ;; not sure I'll use this next one. I prefer if tests simply append to a file: ;; last-update-seconds cpuload tmpspace rundirspace (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_extra_data (id INTEGER PRIMARY KEY, run_id INTEGER, test_id INTEGER, last_seen_running INTEGER);") |
︙ | ︙ |
Modified megatest.scm from [dab1c0eb1d] to [1072b43c10].
︙ | ︙ | |||
208 209 210 211 212 213 214 | -sync-to dest : sync to new postgresql central style database -update-meta : update the tests metadata for all tests -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname -adjutant host-type : start the server/adjutant with given host-type | < | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 | -sync-to dest : sync to new postgresql central style database -update-meta : update the tests metadata for all tests -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname -adjutant host-type : start the server/adjutant with given host-type -transport http|rpc : use http or rpc for transport (default is http) -log logfile : send stdout and stderr to logfile -list-servers : list the servers -kill-servers : kill all servers -repl : start a repl (useful for extending megatest) -load file.scm : load and run file.scm -mark-incompletes : find and mark incomplete tests |
︙ | ︙ |
Modified rmt.scm from [d89d68077a] to [9ad535ae91].
︙ | ︙ | |||
405 406 407 408 409 410 411 | (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy (if (and (vector? v) (> (vector-length v) 1)) (let ((newvec (vector (vector-ref v 0)(vector-ref v 1)))) newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record (vector #t '())))) ;; we could also check that the returned types are valid (vector #t '()))) | | | | 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 | (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy (if (and (vector? v) (> (vector-length v) 1)) (let ((newvec (vector (vector-ref v 0)(vector-ref v 1)))) newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record (vector #t '())))) ;; we could also check that the returned types are valid (vector #t '()))) (success (vector-ref resdat 0)) (res (vector-ref resdat 1)) (duration (- (current-milliseconds) start))) (if (and read-only qry-is-write) (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd)) (if (not success) (if (> remretries 0) (begin (debug:print-error 0 *default-log-port* "local query failed. Trying again.") |
︙ | ︙ |
Modified server.scm from [cc03b241e1] to [99d72bd3eb].
︙ | ︙ | |||
376 377 378 379 380 381 382 | ;; if it then has the wrong server key, wait <idle time> + 1 and call this function recursively. ;; (define (server:wait-for-server-start-last-flag areapath) (let* ((start-flag (conc areapath "/logs/server-start-last")) ;;; THIS INTERACTS WITH [server] timeout. Suggest using 0.1 or above for timeout (6 seconds) (idletime (configf:lookup-number *configdat* "server" "idletime" default: 4)) (server-key (conc (get-host-name) "-" (current-process-id)))) | < | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 | ;; if it then has the wrong server key, wait <idle time> + 1 and call this function recursively. ;; (define (server:wait-for-server-start-last-flag areapath) (let* ((start-flag (conc areapath "/logs/server-start-last")) ;;; THIS INTERACTS WITH [server] timeout. Suggest using 0.1 or above for timeout (6 seconds) (idletime (configf:lookup-number *configdat* "server" "idletime" default: 4)) (server-key (conc (get-host-name) "-" (current-process-id)))) (if (file-exists? start-flag) (let* ((fmodtime (file-modification-time start-flag)) (delta (- (current-seconds) fmodtime)) (old-enough (> delta idletime)) (new-server-key "") ) |
︙ | ︙ |