Changes In Branch v2.001 Through [58cfc286d8] Excluding Merge-Ins
This is equivalent to a diff from 3ebb15bd95 to 58cfc286d8
2021-12-21
| ||
17:47 | all-rmt unit tests pass check-in: 9f85a4b1dd user: matt tags: v2.001 | |
12:46 | wip check-in: 58cfc286d8 user: matt tags: v2.001 | |
2021-12-20
| ||
18:48 | wip check-in: a9fa8512c8 user: matt tags: v2.001 | |
2021-12-01
| ||
19:25 | Start of v2.0 (again) check-in: 35ec63886f user: matt tags: v2.001 | |
2021-11-29
| ||
18:41 | Corrected - but not quite - the calls to get-inmem Leaf check-in: 3ebb15bd95 user: matt tags: v1.6584-nanomsg | |
09:38 | wip check-in: 31c178ba40 user: matt tags: v1.6584-nanomsg | |
Modified TODO from [426bdbbbe8] to [1f8790aebc].
︙ | ︙ | |||
14 15 16 17 18 19 20 | # # You should have received a copy of the GNU General Public License # along with Megatest. If not, see <http://www.gnu.org/licenses/>. TODO ==== | > > | > > > | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | # # You should have received a copy of the GNU General Public License # along with Megatest. If not, see <http://www.gnu.org/licenses/>. TODO ==== Loose ends ---------- . -list-servers not correct . move *remotedat* into bigdata . add back server stats on exit (look in rmt:run in rmtmod.scm) WW15 . fill newview matrix with data, filter pipeline gui elements . improve [script], especially indent handling WW16 . split db into megatest.db (runs etc.) db/<something>.db |
︙ | ︙ |
Modified apimod.scm from [e18f34d37e] to [f47a08f057].
︙ | ︙ | |||
37 38 39 40 41 42 43 44 45 46 47 48 49 50 | (import scheme chicken.base chicken.process-context.posix chicken.string chicken.time chicken.condition chicken.process chicken.random chicken.file ;; (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 | > | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | (import scheme chicken.base chicken.process-context.posix chicken.string chicken.time chicken.condition chicken.process chicken.pathname chicken.random chicken.file ;; (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 |
︙ | ︙ | |||
164 165 166 167 168 169 170 | ;; TASKS tasks-add tasks-set-state-given-param-key )) (define (api:run-server-process apath dbname) | > > > > > > > > | | < < < | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 | ;; TASKS tasks-add tasks-set-state-given-param-key )) (define (api:run-server-process apath dbname) (let* ((cleandbname (pathname-strip-directory dbname)) ;; (string-translate dbname "./" "--")) (logd (conc apath "/logs")) (logf (conc logd "/server-launch-";;(current-process-id) (seconds->year-work-week/day-time-fname (current-seconds)) "-"cleandbname".log")) (logf2 (conc logd "/server-" (seconds->year-work-week/day-time-fname (current-seconds)) "-"cleandbname"-")) (cmd (conc "nbfake megatest -server - -area "apath " -db "dbname" -autolog "logf2))) (if (not (directory-exists? logd)) (create-directory logd #t)) (system (conc "NBFAKE_LOG="logf" "cmd)))) ;; special function to get server ;; look up in db ;; if found -> return it |
︙ | ︙ | |||
201 202 203 204 205 206 207 | ;;=============================================== ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl ;; SERVERS ;; ((start-server) (apply server:kind-run params)) ((kill-server) (set! *server-run* #f)) | | > | | 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 | ;;=============================================== ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl ;; SERVERS ;; ((start-server) (apply server:kind-run params)) ((kill-server) (set! *server-run* #f)) ((start-server get-server) (api:start-server dbstruct params)) ((get-server-info) (apply db:get-server-info dbstruct params)) ((register-server) (apply db:register-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath) ((deregister-server) (apply db:deregister-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath) ((get-count-servers) (apply db:get-count-servers dbstruct params)) ((get-servers-info) (apply db:get-servers-info dbstruct params)) ;; TESTS ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. ((test-set-state-status-by-id) ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) |
︙ | ︙ | |||
341 342 343 344 345 346 347 348 349 350 351 352 353 354 | ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt dbstruct params)) ((get-all-run-ids) (db:get-all-run-ids dbstruct)) ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) ((get-var) (apply db:get-var dbstruct params)) ((get-run-stats) (apply db:get-run-stats dbstruct params)) ((get-run-times) (apply db:get-run-times dbstruct params)) ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) | > | 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 | ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt dbstruct params)) ((get-all-run-ids) (db:get-all-run-ids dbstruct)) ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) ((log-to-main) (apply debug:print 0 *default-log-port* params)) ((get-var) (apply db:get-var dbstruct params)) ((get-run-stats) (apply db:get-run-stats dbstruct params)) ((get-run-times) (apply db:get-run-times dbstruct params)) ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) |
︙ | ︙ |
Added build-assist/README version [d108fc0f5b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Here is how I like to install chicken for building Megatest. This guide assumes you have the Megatest fossil and are in the build-assist directory and that you have the opensrc fossil with uv synced: fossil clone https://www.kiatoa.com/fossils/megatest fossil clone https://www.kiatoa.com/fossils/opensrc;cd opensrc;fossil uv sync Make a build directory and go to it: mkdir build;cd build Make a destination directory and set PREFIX export PREFIX=/opt/chicken/5.3.0; mkdir -p $PREFIX Get chicken: wget https://code.call-cc.org/releases/5.3.0/chicken-5.3.0.tar.gz Extract, build, and install chicken: tar xf chicken-5.3.0.tar.gz; cd chicken-5.3.0; make PLATFORM=linux PREFIX=$PREFIX install; cd .. Install all needed eggs. for egg in $(cat ../ck5-egg.list);do echo $egg;ck5 chicken-install $egg;done Now run the script ../iup-compile.sh for remaining instructions |
Modified build-assist/ck5 from [a0370c68ea] to [e0bdd3a902].
1 | #!/bin/bash | > > > | > > | > > | | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | #!/bin/bash # /opt/chicken/5.3.0 # WHICHCKVER=5.1.0_WW45 WHICHCKVER=5.3.0 BASEDIR=/opt/chicken/$WHICHCKVER export PATH="$BASEDIR/bin:$PATH" NEW_LD_LIBRARY_PATH="$BASEDIR/lib:$BASEDIR/lib64" if [[ -z "$LD_LIBRARY_PATH" ]];then export LD_LIBRARY_PATH=$NEW_LD_LIBRARY_PATH else export LD_LIBRARY_PATH="$NEW_LD_LIBRARY_PATH:$LD_LIBRARY_PATH" fi exec "$@" |
Modified build-assist/ck5-eggs.list from [4ccb4f5090] to [6d7e206485].
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | address-info ansi-escape-sequences apropos base64 crypt csv-abnf directory-utils filepath fmt format http-client itemsmod json linenoise | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | csm address-info ansi-escape-sequences apropos base64 crypt csv-abnf directory-utils dot-locking filepath fmt format http-client itemsmod json linenoise |
︙ | ︙ |
Added build-assist/installing-nng version [9ef49d4af4].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | wget https://github.com/nanomsg/nng/archive/refs/tags/v1.5.2.tar.gz tar xf v1.5.2.tar.gz cd nng-1.5.2 mkdir build cd build make sudo make install vi CMakeCache.txt Change OFF to ON for shared libraries: //Build shared library BUILD_SHARED_LIBS:BOOL=ON make sudo make install sudo ldconfig chicken-install nng -or- git clone https://gitlab.com/ariSun/chicken-nng.git cd chicken-ngg;chicken-install |
Modified build-assist/iup-compile.sh from [a1231c7291] to [f2fe37f920].
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | if [[ -z $PREFIX ]];then echo "PREFIX required" exit fi echo "Put iup, im and cd .a and .so files in PREFIX/lib" echo " 1. get opensrc fossil from https://www.kiatoa.com/fossils/opensrc" echo " 2. list the unversioned files and export the cd, im and iup lib for your kernel (try uname -a for the kernel number) 4.15 ==> 415_64" echo " 3. untar iup, im and cp tars into a clean working dir and then copy:" 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 -feature disable-iup-matrixex" echo "else:" | > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | if [[ -z $PREFIX ]];then echo "PREFIX required" exit fi echo "Put iup, im and cd .a and .so files in PREFIX/lib" echo " 1. get opensrc fossil from https://www.kiatoa.com/fossils/opensrc" echo " 2. list the unversioned files and export the cd, im and iup lib for your kernel (try uname -a for the kernel number) 4.15 ==> 415_64" echo ' for x in $(fossil uv list | grep 415| awk ''{print $6}'');do targ=$(echo $x|cut -d/ -f3); fossil uv export $x $targ; done' echo " 3. untar iup, im and cp tars into a clean working dir and then copy:" echo " find . -name \*.a -print -exec cp {} $PREFIX/lib \;" echo " find . -name \*.so -print -exec cp {} $PREFIX/lib \;" 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 -feature disable-iup-matrixex" echo "else:" |
︙ | ︙ |
Modified commonmod.scm from [3bc09277ff] to [787a13f0a3].
︙ | ︙ | |||
273 274 275 276 277 278 279 | common:get-normalized-cpu-load-raw common:unix-ping launch:is-test-alive common:get-num-cpus common:wait-for-normalized-load common:wait-for-cpuload tasks:kill-server | | | | | | | | 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 | common:get-normalized-cpu-load-raw common:unix-ping launch:is-test-alive common:get-num-cpus common:wait-for-normalized-load common:wait-for-cpuload tasks:kill-server ;; server:get-logs-list ;; server:get-list ;; server:get-num-alive ;; server:get-best ;; server:get-first-best ;; server:get-rand-best server:record->id server:get-num-servers server:logf-get-start-info get-uname realpath common:real-path common:get-disk-space-used |
︙ | ︙ | |||
312 313 314 315 316 317 318 319 320 321 322 323 324 325 | common:hms-string->seconds seconds->hr-min-sec seconds->time-string seconds->work-week/day-time seconds->work-week/day seconds->year-work-week/day seconds->year-work-week/day-time seconds->year-week/day-time seconds->quarter common:date-time->seconds common:find-start-mark-and-mark-delta common:expand-cron-slash common:cron-expand common:cron-event | > | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 | common:hms-string->seconds seconds->hr-min-sec seconds->time-string seconds->work-week/day-time seconds->work-week/day seconds->year-work-week/day seconds->year-work-week/day-time seconds->year-work-week/day-time-fname seconds->year-week/day-time seconds->quarter common:date-time->seconds common:find-start-mark-and-mark-delta common:expand-cron-slash common:cron-expand common:cron-event |
︙ | ︙ | |||
2823 2824 2825 2826 2827 2828 2829 | (thread-sleep! 0.5) (if (file-exists? gzfile) (delete-file gzfile)) (system (conc "gzip " logfile)) (unset-environment-variable! "TARGETHOST_LOGF") (unset-environment-variable! "TARGETHOST")))) | | | | 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 | (thread-sleep! 0.5) (if (file-exists? gzfile) (delete-file gzfile)) (system (conc "gzip " logfile)) (unset-environment-variable! "TARGETHOST_LOGF") (unset-environment-variable! "TARGETHOST")))) #;(define (server:get-logs-list area-path) (let* (;; (server-logs-cmd (conc "grep -iL exiting " area-path "/logs/server-*-*.log")) ;; (server-logs (string-split (string-chomp (with-input-from-pipe server-logs-cmd read-string)))) (server-logs (glob (conc area-path"/logs/server-*-*.log"))) ) server-logs)) ;; get a list of servers with all relevant data ;; ( mod-time host port start-time pid ) ;; #;(define (server:get-list areapath #!key (limit #f)) (let ((fname-rx (regexp "^(|.*/)server-(\\d+)-(\\S+).log$")) (day-seconds (* 24 60 60))) ;; if the directory exists continue to get the list ;; otherwise attempt to create the logs dir and then ;; continue (if (if (directory-exists? (conc areapath "/logs")) '() |
︙ | ︙ | |||
2885 2886 2887 2888 2889 2890 2891 | (if (null? tal) (if (and limit (> (length new-res) limit)) new-res ;; (take new-res limit) <= need intelligent sorting before this will work new-res) (loop (string-chomp (car tal)) (cdr tal) new-res))))))))) | | | 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 | (if (null? tal) (if (and limit (> (length new-res) limit)) new-res ;; (take new-res limit) <= need intelligent sorting before this will work new-res) (loop (string-chomp (car tal)) (cdr tal) new-res))))))))) #;(define (server:get-num-alive srvlst) (let ((num-alive 0)) (for-each (lambda (server) (handle-exceptions exn (begin (debug:print-info 0 *default-log-port* "Unable to get server start-time and/or mod-time from " server ", exn=" exn)) |
︙ | ︙ | |||
2912 2913 2914 2915 2916 2917 2918 | ;; active (i.e. mod-time < 10 seconds ;; ;; mod-time host port start-time pid ;; ;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off ;; and servers should stick around for about two hours or so. ;; | | | 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 | ;; active (i.e. mod-time < 10 seconds ;; ;; mod-time host port start-time pid ;; ;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off ;; and servers should stick around for about two hours or so. ;; #;(define (server:get-best srvlst) (let* ((nums (server:get-num-servers)) (now (current-seconds)) (slst (sort (filter (lambda (rec) (if (and (list? rec) (> (length rec) 2)) (let ((start-time (list-ref rec 3)) |
︙ | ︙ | |||
2940 2941 2942 2943 2944 2945 2946 | (lambda (a b) (< (list-ref a 3) (list-ref b 3)))))) (if (> (length slst) nums) (take slst nums) slst))) | | | | 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 | (lambda (a b) (< (list-ref a 3) (list-ref b 3)))))) (if (> (length slst) nums) (take slst nums) slst))) #;(define (server:get-first-best areapath) (let ((srvrs (server:get-best (server:get-list areapath)))) (if (and srvrs (not (null? srvrs))) (car srvrs) #f))) #;(define (server:get-rand-best areapath) (let ((srvrs (server:get-best (server:get-list areapath)))) (if (and (list? srvrs) (not (null? srvrs))) (let* ((len (length srvrs)) (idx (pseudo-random-integer len))) (list-ref srvrs idx)) #f))) |
︙ | ︙ | |||
3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 | (define (seconds->work-week/day sec) (time->string (seconds->local-time sec) "ww%V.%u")) (define (seconds->year-work-week/day sec) (time->string (seconds->local-time sec) "%yww%V.%w")) (define (seconds->year-work-week/day-time sec) (time->string (seconds->local-time sec) "%Yww%V.%w %H:%M")) (define (seconds->year-week/day-time sec) (time->string | > > > > | 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 | (define (seconds->work-week/day sec) (time->string (seconds->local-time sec) "ww%V.%u")) (define (seconds->year-work-week/day sec) (time->string (seconds->local-time sec) "%yww%V.%w")) (define (seconds->year-work-week/day-time-fname sec) (time->string (seconds->local-time sec) "%yww%V.%w.%H%M%S")) (define (seconds->year-work-week/day-time sec) (time->string (seconds->local-time sec) "%Yww%V.%w %H:%M")) (define (seconds->year-week/day-time sec) (time->string |
︙ | ︙ |
Modified configfmod.scm from [0f89b247bb] to [b4853bf0ef].
︙ | ︙ | |||
84 85 86 87 88 89 90 91 92 93 94 95 96 97 | keysmod (prefix base64 base64:) (prefix dbi dbi:) (prefix sqlite3 sqlite3:) (srfi 18) directory-utils format matchable md5 message-digest regex regex-case sparse-vectors | > | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | keysmod (prefix base64 base64:) (prefix dbi dbi:) (prefix sqlite3 sqlite3:) (srfi 18) directory-utils dot-locking format matchable md5 message-digest regex regex-case sparse-vectors |
︙ | ︙ | |||
110 111 112 113 114 115 116 117 118 119 120 121 122 123 | ;;====================================================================== ;; parameters ;;====================================================================== ;; while targets are Megatest specific they are a useful concept (define mytarget (make-parameter #f)) ;;====================================================================== ;; move debug stuff to separate module then put these back where they belong ;;====================================================================== ;;====================================================================== ;; lookup routines - replicated from configf ;;====================================================================== | > > > > > | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | ;;====================================================================== ;; parameters ;;====================================================================== ;; while targets are Megatest specific they are a useful concept (define mytarget (make-parameter #f)) ;; locking is optional, many environments don't care (e.g. running on one machine) ;; NOTE: the locker must follow the same syntax as with-dot-lock* ;; (define my-with-lock (make-parameter with-dot-lock*)) ;;====================================================================== ;; move debug stuff to separate module then put these back where they belong ;;====================================================================== ;;====================================================================== ;; lookup routines - replicated from configf ;;====================================================================== |
︙ | ︙ | |||
1184 1185 1186 1187 1188 1189 1190 | ;;====================================================================== ;; DO THE LOCKING AROUND THE CALL ;;====================================================================== ;; (define (configf:write-alist cdat fname) ;; (if (not (common:faux-lock fname)) | | > > > | | | | | | | | | | | | | | | | | | | < | | 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 | ;;====================================================================== ;; DO THE LOCKING AROUND THE CALL ;;====================================================================== ;; (define (configf:write-alist cdat fname) ;; (if (not (common:faux-lock fname)) ;; (debug:print 0 *default-log-port* "INFO: NEED LOCKING ADDED HERE " fname) ((my-with-lock) fname (lambda () (let* ((dat (configf:config->alist cdat)) (res (begin (with-output-to-file fname ;; first write out the file (lambda () (pp dat))) ;; I don't like this. It makes write-alist opaque and complicated. -mrw- (if (file-exists? fname) ;; now verify it is readable (if (configf:read-alist fname) #t ;; data is good. (begin (handle-exceptions exn (begin (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn) #f) (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.") (delete-file fname)) #f)) #f)))) res)))) (define (common:get-fields cfgdat) (let ((fields (hash-table-ref/default cfgdat "fields" '()))) (map car fields))) ) |
Modified dashboard.scm from [733ea55f33] to [feba132a9c].
︙ | ︙ | |||
40 41 42 43 44 45 46 47 48 49 50 51 52 53 | (declare (uses runsmod)) (declare (uses rmtmod)) (declare (uses subrunmod)) (declare (uses tree)) (declare (uses vgmod)) (declare (uses testsmod)) (declare (uses tasksmod)) ;; needed for configf scripts, scheme etc. ;; (declare (uses apimod.import)) ;; (declare (uses debugprint.import)) ;; (declare (uses mtargs.import)) ;; (declare (uses commonmod.import)) ;; (declare (uses configfmod.import)) | > | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | (declare (uses runsmod)) (declare (uses rmtmod)) (declare (uses subrunmod)) (declare (uses tree)) (declare (uses vgmod)) (declare (uses testsmod)) (declare (uses tasksmod)) (declare (uses dbi)) ;; needed for configf scripts, scheme etc. ;; (declare (uses apimod.import)) ;; (declare (uses debugprint.import)) ;; (declare (uses mtargs.import)) ;; (declare (uses commonmod.import)) ;; (declare (uses configfmod.import)) |
︙ | ︙ | |||
87 88 89 90 91 92 93 94 95 96 97 98 99 100 | chicken.time chicken.time.posix (prefix iup iup:) canvas-draw canvas-draw-iup (prefix sqlite3 sqlite3:) srfi-1 regex regex-case srfi-69 typed-records sparse-vectors format srfi-4 srfi-14 | > | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | chicken.time chicken.time.posix (prefix iup iup:) canvas-draw canvas-draw-iup (prefix sqlite3 sqlite3:) (prefix dbi dbi:) srfi-1 regex regex-case srfi-69 typed-records sparse-vectors format srfi-4 srfi-14 |
︙ | ︙ | |||
236 237 238 239 240 241 242 243 244 245 246 247 248 249 | ;; RA => Might require revert for filters ;; create a watch dog to move changes from lt/.db/*.db to megatest.db ;; ;;;(if (file-write-access? (conc *toppath* "/megatest.db")) ;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn") (thread-start! (make-thread common:watchdog "Watchdog thread")) ;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn") ;; (if (not (args:get-arg "-use-db-cache")) ;; (begin ;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") ;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;) ;;) | > | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 | ;; RA => Might require revert for filters ;; create a watch dog to move changes from lt/.db/*.db to megatest.db ;; ;;;(if (file-write-access? (conc *toppath* "/megatest.db")) ;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn") (thread-start! (make-thread common:watchdog "Watchdog thread")) ;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn") ;; (if (not (args:get-arg "-use-db-cache")) ;; (begin ;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") ;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;) ;;) |
︙ | ︙ | |||
2840 2841 2842 2843 2844 2845 2846 | (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)) (dashboard:runs-horizontal-slider runs-dat)))) controls )) (views-cfgdat (common:load-views-config)) (additional-tabnames '()) | | | 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 | (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)) (dashboard:runs-horizontal-slider runs-dat)))) controls )) (views-cfgdat (common:load-views-config)) (additional-tabnames '()) (tab-start-num 6) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW ;; (data (dboard:tabdat-init (make-d:data))) (additional-views ;; process views-dat (let ((tab-num tab-start-num) (result '())) (for-each (lambda (view-name) (debug:print 0 *default-log-port* "Adding view " view-name) |
︙ | ︙ | |||
2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 | "tabchangepos")) (dashboard:summary commondat stats-dat tab-num: 0) runs-view ;; (make-runs-view commondat runs2-dat 2) (dashboard:runs-summary commondat onerun-dat tab-num: 2) (dashboard:run-controls commondat runcontrols-dat tab-num: 3) (dashboard:run-times commondat runtimes-dat tab-num: 4) additional-views))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Summary") (iup:attribute-set! tabs "TABTITLE1" "Runs") ;; (iup:attribute-set! tabs "TABTITLE2" "Runs2") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") (iup:attribute-set! tabs "TABTITLE3" "Run Control") (iup:attribute-set! tabs "TABTITLE4" "Run Times") ;; (iup:attribute-set! tabs "TABTITLE3" "New View") ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") ;; set the tab names for user added tabs (for-each (lambda (tab-info) (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info))) | > > > | 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 | "tabchangepos")) (dashboard:summary commondat stats-dat tab-num: 0) runs-view ;; (make-runs-view commondat runs2-dat 2) (dashboard:runs-summary commondat onerun-dat tab-num: 2) (dashboard:run-controls commondat runcontrols-dat tab-num: 3) (dashboard:run-times commondat runtimes-dat tab-num: 4) (iup:vbox (iup:button "Pushme")) ;; tab 5 additional-views))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Summary") (iup:attribute-set! tabs "TABTITLE1" "Runs") ;; (iup:attribute-set! tabs "TABTITLE2" "Runs2") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") (iup:attribute-set! tabs "TABTITLE3" "Run Control") (iup:attribute-set! tabs "TABTITLE4" "Run Times") (iup:attribute-set! tabs "TABTITLE5" "Sys Status") ;; (iup:attribute-set! tabs "TABTITLE3" "New View") ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") ;; set the tab names for user added tabs (for-each (lambda (tab-info) (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info))) |
︙ | ︙ | |||
3662 3663 3664 3665 3666 3667 3668 | "dashboard:runs-tab-updater")) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== (define (dashboard-main) | | | 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 | "dashboard:runs-tab-updater")) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== (define (dashboard-main) (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; not used for now, update for .db area and use for write access detection #;(if (and (common:file-exists? mtdb-path) (file-writable? mtdb-path)) (if (not (args:get-arg "-skip-version-check")) (common:exit-on-version-changed))) (let* ((commondat (dboard:commondat-make))) ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... (cond |
︙ | ︙ |
Modified dbi.scm from [3f996117f2] to [b3324417ec].
︙ | ︙ | |||
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 dbi)) (include "dbi/dbi.scm") | > | 15 16 17 18 19 20 21 22 23 24 | ;; ;; 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 dbi)) (declare (uses autoload)) (include "dbi/dbi.scm") |
Modified dbmod.scm from [7cd57dd118] to [1af1007e9d].
︙ | ︙ | |||
42 43 44 45 46 47 48 | db:get-dbdat db:get-inmem db:get-ddb db:open-dbdat db:open-run-db db:open-inmem-db db:setup | | > | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | db:get-dbdat db:get-inmem db:get-ddb db:open-dbdat db:open-run-db db:open-inmem-db db:setup ;; db:get-main-lock db:with-lock-db db:get-iam-server-lock db:get-locker db:take-lock db:steal-lock-db db:release-lock db:general-sqlite-error-dump db:first-result-default db:generic-error-printout db:with-db db:set-sync db:get-last-update-time |
︙ | ︙ | |||
224 225 226 227 228 229 230 231 232 233 234 235 236 237 | db:hoh-set! db:hoh-get db:get-cache-stmth db:register-server db:deregister-server db:get-server-info db:get-count-servers db:get-steps-info-by-id make-dbr:dbdat dbr:dbdat-db dbr:dbdat-inmem dbr:dbdat-last-sync dbr:dbdat-last-write | > | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 | db:hoh-set! db:hoh-get db:get-cache-stmth db:register-server db:deregister-server db:get-server-info db:get-count-servers db:get-servers-info db:get-steps-info-by-id make-dbr:dbdat dbr:dbdat-db dbr:dbdat-inmem dbr:dbdat-last-sync dbr:dbdat-last-write |
︙ | ︙ | |||
509 510 511 512 513 514 515 | ;; NOTE: ;; These operate directly on the disk file, NOT on the inmemory db ;; The lockname is the filename (can have many to one, run-id to fname ;;====================================================================== ;; only use for main.db - need to re-write some of this :( ;; | | | < > | | | | > > > > > | 511 512 513 514 515 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 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 | ;; NOTE: ;; These operate directly on the disk file, NOT on the inmemory db ;; The lockname is the filename (can have many to one, run-id to fname ;;====================================================================== ;; only use for main.db - need to re-write some of this :( ;; #;(define (db:get-main-lock dbfile) (db:with-lock-db dbfile (lambda (dbh dbfile) (db:get-iam-server-lock dbh dbfile)))) (define (db:with-lock-db dbfile proc) (let* ((dbh (db:open-run-db dbfile db:initialize-db)) (res (proc dbh dbfile))) ;; (sqlite3:finalize! dbh) res)) ;; called before db is open? ;; (define (db:get-iam-server-lock dbh dbfname port) (sqlite3:with-transaction dbh (lambda () (let* ((locker (db:get-locker dbh dbfname))) (if locker locker (db:take-lock dbh dbfname port)))))) ;; (exn sqlite3) (define (db:get-locker dbh dbfname) (condition-case (sqlite3:first-row dbh "SELECT owner_pid,owner_host,owner_port,event_time FROM locks WHERE lockname=?;" dbfname) (exn (sqlite3) #f))) ;; should never fail because it is run in a transaction with a test for the lock ;; (define (db:take-lock dbh dbfname port) ;; (condition-case ;; (begin (sqlite3:execute dbh "INSERT INTO locks (lockname,owner_pid,owner_host,owner_port) VALUES (?,?,?,?);" dbfname (current-process-id) (get-host-name) port) ;; #t) ;; (exn (sqlite3) #f))) #t) (define (db:steal-lock-db dbh dbfname port) (sqlite3:execute dbh "DELETE FROM locks WHERE lockname=?;" dbfname) (sqlite3:execute dbh "INSERT INTO locks (lockname,owner_pid,owner_host,owner_port) VALUES (?,?,?,?);" dbfname (current-process-id) (get-host-name) port) #t) (define (db:release-lock dbh dbfname) (sqlite3:execute dbh "DELETE FROM locks WHERE lockname=?;" dbfname)) ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== |
︙ | ︙ | |||
1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 | db (lambda () (sqlite3:execute db "CREATE TABLE IF NOT EXISTS locks (id INTEGER PRIMARY KEY, lockname TEXT, owner_pid INTEGER, owner_host TEXT, event_time TIMESTAMP DEFAULT (strftime('%s','now')), CONSTRAINT lock_constraint UNIQUE (lockname));") ;; maps to *srvpktspec* from http-transportmod (sqlite3:execute db "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY, host TEXT, | > | 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 | db (lambda () (sqlite3:execute db "CREATE TABLE IF NOT EXISTS locks (id INTEGER PRIMARY KEY, lockname TEXT, owner_pid INTEGER, owner_host TEXT, owner_port TEXT, event_time TIMESTAMP DEFAULT (strftime('%s','now')), CONSTRAINT lock_constraint UNIQUE (lockname));") ;; maps to *srvpktspec* from http-transportmod (sqlite3:execute db "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY, host TEXT, |
︙ | ︙ | |||
5853 5854 5855 5856 5857 5858 5859 | (begin (debug:print-info 0 *default-log-port* "Server already removed for "apath", "dbname) ;; at "sinfo ", while trying to register server " host":"port) #f) ;; server already deregistered (begin (sqlite3:execute db "DELETE FROM servers WHERE apath=? AND dbname=?;" ;; (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);" ;; host port servkey pid ipaddr apath dbname) | | > | 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 | (begin (debug:print-info 0 *default-log-port* "Server already removed for "apath", "dbname) ;; at "sinfo ", while trying to register server " host":"port) #f) ;; server already deregistered (begin (sqlite3:execute db "DELETE FROM servers WHERE apath=? AND dbname=?;" ;; (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);" ;; host port servkey pid ipaddr apath dbname) #;(db:get-server-info dbstruct apath dbname) 'done)))))))) (define (db:get-server-info dbstruct apath dbname) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:fold-row |
︙ | ︙ | |||
5880 5881 5882 5883 5884 5885 5886 5887 | (sqlite3:fold-row (lambda (res count) (max res count)) 0 db "SELECT count(*) FROM servers WHERE apath=?;" apath)))) | > > > > > > > > > > > > | > | 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 | (sqlite3:fold-row (lambda (res count) (max res count)) 0 db "SELECT count(*) FROM servers WHERE apath=?;" apath)))) (define (db:get-servers-info dbstruct apath) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:fold-row (lambda (res . row) (cons row res)) '() db "SELECT * FROM servers WHERE apath=?;" apath)))) ) |
Modified dcommon.scm from [dedc418b9b] to [217250003b].
︙ | ︙ | |||
900 901 902 903 904 905 906 | (let* ((colnum 0) (rownum 0) (servers-matrix (iup:matrix #:expand "YES" #:numcol 7 #:numcol-visible 7 #:numlin-visible 5 )) | | | | | | | | | < < | | < | 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 | (let* ((colnum 0) (rownum 0) (servers-matrix (iup:matrix #:expand "YES" #:numcol 7 #:numcol-visible 7 #:numlin-visible 5 )) (colnames (list "Id" "MTver" "Pid" "Host" "Interface:port" "Runtime" "State" "Db")) (updater (lambda () (if (dashboard:monitor-changed? commondat tabdat) (let ((servers (rmt:get-servers-info *toppath*)#;(server:get-list *toppath* limit: 10))) (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) ;; (set! colnum 0) ;; (for-each (lambda (colname) ;; ;; (print "colnum: " colnum " colname: " colname) ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) ;; (set! colnum (+ 1 colnum))) ;; colnames) (set! rownum 1) (for-each (lambda (server) (set! colnum 0) ;; id host port servkey pid ipaddr apath dbname event_time (match-let (((id host port server-id pid ipaddr apath dbname start-time) ;; (mod-time host port start-time server-id pid) server)) (let* ((uptime (- (current-seconds) start-time)) #;(runtime (if start-time (- mod-time start-time) 0)) (vals (list server-id ;; (vector-ref server 0) ;; Id "-" ;; (vector-ref server 9) ;; MT-Ver pid ;; (vector-ref server 1) ;; Pid host ;; (vector-ref server 2) ;; Hostname (conc host ":" port) ;; (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port (seconds->hr-min-sec uptime) ;; Runtime "Running" ;; State - Do some kind of ping here dbname ;; Db ))) (for-each (lambda (val) (let* ((row-col (conc rownum ":" colnum)) (curr-val (iup:attribute servers-matrix row-col))) (if (not (equal? (conc val) curr-val)) (begin (iup:attribute-set! servers-matrix row-col val) |
︙ | ︙ |
Modified debugprint.scm from [4552843dbc] to [2f3aa7f0ad].
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 | (declare (unit debugprint)) (declare (uses mtargs)) (module debugprint * ;;(import scheme chicken data-structures extras files ports) (import scheme chicken.base chicken.string chicken.port chicken.process-context (prefix mtargs args:) srfi-1 ) ;;====================================================================== ;; debug stuff ;;====================================================================== (define verbosity (make-parameter '())) (define *default-log-port* (current-error-port)) (define (debug:setup) (let ((debugstr (or (args:get-arg "-debug") (args:get-arg "-debug-noprop") (get-environment-variable "MT_DEBUG_MODE")))) (verbosity (debug:calc-verbosity debugstr 'q)) (debug:check-verbosity (verbosity) debugstr) | > > > > | 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 | (declare (unit debugprint)) (declare (uses mtargs)) (module debugprint * ;;(import scheme chicken data-structures extras files ports) (import scheme chicken.base chicken.string chicken.port chicken.process-context chicken.process-context.posix (prefix mtargs args:) srfi-1 system-information ) ;;====================================================================== ;; debug stuff ;;====================================================================== (define verbosity (make-parameter '())) (define *default-log-port* (current-error-port)) (define debug:print-logger (make-parameter #f)) ;; se to a proc to call on every logging print (define (debug:setup) (let ((debugstr (or (args:get-arg "-debug") (args:get-arg "-debug-noprop") (get-environment-variable "MT_DEBUG_MODE")))) (verbosity (debug:calc-verbosity debugstr 'q)) (debug:check-verbosity (verbosity) debugstr) |
︙ | ︙ | |||
97 98 99 100 101 102 103 104 105 106 107 108 109 110 | (list? n)) (not (null? (lset-intersection! eq? vb n)))) ((and (number? vb) (list? n)) (member vb n)) (else #f)))) (define (debug:print n e . params) (if (debug:debug-mode n) (with-output-to-port (or e (current-error-port)) (lambda () ;; (if *logging* ;; (db:log-event (apply conc params)) (apply print params) | > > > > > > > | > > > > > > > > > > > | 101 102 103 104 105 106 107 108 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 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 | (list? n)) (not (null? (lset-intersection! eq? vb n)))) ((and (number? vb) (list? n)) (member vb n)) (else #f)))) (define (debug:handle-remote-logging params) (if (debug:print-logger) ;; NOTE: turn params into string to keep things simple for now ((debug:print-logger)(conc "REMOTE ("(get-host-name)", pid="(current-process-id)") " (string-intersperse (map conc params) " ") "; " (string-intersperse (command-line-arguments) " "))))) (define (debug:print n e . params) (if (debug:debug-mode n) (with-output-to-port (or e (current-error-port)) (lambda () ;; (if *logging* ;; (db:log-event (apply conc params)) (apply print params) (debug:handle-remote-logging params) ))) #t ;; only here to make remote stuff happy. It'd be nice to fix that ... ) (define (debug:print-error n e . params) ;; normal print (if (debug:debug-mode n) (with-output-to-port (if (port? e) e (current-error-port)) (lambda () (apply print "ERROR: " params) (debug:handle-remote-logging (cons "ERROR: " params)) ))) ;; pass important messages to stderr (if (and (eq? n 0)(not (eq? e (current-error-port)))) (with-output-to-port (current-error-port) (lambda () (apply print "ERROR: " params) )))) (define (debug:print-info n e . params) (if (debug:debug-mode n) (with-output-to-port (if (port? e) e (current-error-port)) (lambda () (apply print "INFO: (" n ") " params) ;; res) (debug:handle-remote-logging (cons "INFO: " params)) )))) (define (debug:print-warn n e . params) (if (debug:debug-mode n) (with-output-to-port (if (port? e) e (current-error-port)) (lambda () (apply print "WARN: (" n ") " params) ;; res) (debug:handle-remote-logging (cons "WARN: " params)) )))) ) |
Modified megatest.scm from [ca9d861939] to [c1c08ee586].
︙ | ︙ | |||
435 436 437 438 439 440 441 442 443 444 445 446 447 448 | overwritten by values set in config files. -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname -adjutant C,M : start the server/adjutant with allocated cores C and Mem M (Gig), use 0,0 to auto use full machine -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 -ping run-id|host:port : ping server, exit with 0 if found -debug N|N,M,O... : enable debug 0-N or N and M and O ... | > | 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 | overwritten by values set in config files. -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname -adjutant C,M : start the server/adjutant with allocated cores C and Mem M (Gig), use 0,0 to auto use full machine -transport http|rpc : use http or rpc for transport (default is http) -log logfile : send stdout and stderr to logfile -autolog logfilebase : appends pid and host to logfilebase for 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 -ping run-id|host:port : ping server, exit with 0 if found -debug N|N,M,O... : enable debug 0-N or N and M and O ... |
︙ | ︙ | |||
628 629 630 631 632 633 634 635 636 637 638 639 640 641 | "-var" "-dumpmode" "-run-id" "-ping" "-refdb2dat" "-o" "-log" "-sync-log" "-since" "-fields" "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state "-sort" "-target-db" "-source-db" | > | 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 | "-var" "-dumpmode" "-run-id" "-ping" "-refdb2dat" "-o" "-log" "-autolog" "-sync-log" "-since" "-fields" "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state "-sort" "-target-db" "-source-db" |
︙ | ︙ | |||
782 783 784 785 786 787 788 | ;; (list? n)) ;; (member *verbosity* n)))) ;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not ;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation ;; where (launch:setup) returns #f? ;; | | > > > | | > | | | 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 | ;; (list? n)) ;; (member *verbosity* n)))) ;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not ;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation ;; where (launch:setup) returns #f? ;; (if (or (args:get-arg "-log") ;;(args:get-arg "-server") ;; redirect the log always when a server (args:get-arg "-autolog")) (handle-exceptions exn (begin (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) ) (let* ((tl (or (args:get-arg "-log") (args:get-arg "-autolog") ;; autolog provides the basename .../logs/something- for the logfile (launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name (conc tl (current-process-id)"-"(get-host-name)".log") (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log"))) (oup (open-logfile logf))) (if (not (args:get-arg "-log")) (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log (debug:print-info 0 *default-log-port* "Sending log output to " logf) (set! *default-log-port* oup)))) (if (or (args:get-arg "-h") (args:get-arg "-help") |
︙ | ︙ | |||
1133 1134 1135 1136 1137 1138 1139 | (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 | | > > > > > > > > > | | | < < < < < > | | | < | > | < | > | | < < < | 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 | (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 (rmt:get-servers-info *toppath*)) (fmtstr "~8a~22a~20a~20a~8a\n")) ;; id INTEGER PRIMARY KEY, ;; host TEXT, ;; port INTEGER, ;; servkey TEXT, ;; pid TEXT, ;; ipaddr TEXT, ;; apath TEXT, ;; dbname TEXT, ;; event_time (format #t fmtstr "pid" "Interface:port" "State" "dbname" "apath") (format #t fmtstr "===" "==============" "=====" "======" "=====") (for-each ;; ( mod-time host port start-time pid ) (lambda (server) (match-let (((id host port servkey pid ipaddr apath dbname event_time) server)) (format #t fmtstr pid (conc host":"port) (if (server-ready? host port servkey) "Running" "Dead") dbname ;; (seconds->hr-min-sec mod) apath ) (if (args:get-arg "-kill-servers") (begin (debug:print-info 0 *default-log-port* "Attempting to kill server with pid " pid " !!needs completion!!") #;(server:kill server))))) servers) ;; (debug:print-info 1 *default-log-port* "Done with listservers") (set! *didsomething* #t) (exit)) (exit)))) ;; must do, would have to add checks to many/all calls below ;;====================================================================== |
︙ | ︙ |
Modified rmtmod.scm from [db7ecb31bf] to [4d23f52ced].
︙ | ︙ | |||
131 132 133 134 135 136 137 | (status 'starting) (trynum 0) ;; count the number of ports we've tried ) (define (servdat->url sdat) (conc (servdat-host sdat)":"(servdat-port sdat))) | < | | | > | | | | | | | > > > > | > > | > > > > > > > | | | < > > > | > | > | | | > | | | | | | < < < < | | | | | > | | | | | | | > | < < | | > | > > | > > > > > | | | | | | | | | > | | < | | > | | > > | | | | | | | | | > > | | | | | | > > | | | | | 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 171 172 173 174 175 176 177 178 179 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 265 266 267 268 269 270 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 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 | (status 'starting) (trynum 0) ;; count the number of ports we've tried ) (define (servdat->url sdat) (conc (servdat-host sdat)":"(servdat-port sdat))) ;; generate entries for ~/.megatestrc with the following ;; ;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u (defstruct remotedat (conns (make-hash-table)) ;; apath/dbname => conndat ) (defstruct conndat (apath #f) (dbname #f) (fullname #f) (hostport #f) (ipaddr #f) (port #f) (socket #f) (srvpkt #f) (srvkey #f) (lastmsg 0) (expires 0) (inport #f) (outport #f)) (define *srvpktspec* `((server (host . h) (port . p) (servkey . k) (pid . i) (ipaddr . a) (dbpath . d)))) ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== ;; replaces *runremote* (define *remotedat* (make-remotedat)) ;; -> 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)) (api-proc api:process-request) ;; 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 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 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 (if (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 ;; Below we will find or create and connect to main (let* ((dbname (db:run-id->dbname #f)) (the-srv (rmt:find-main-server 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))) (mutex-unlock! *connstart-mutex*) (rmt:open-main-connection remdat apath) ;; TODO: Add limit to number of tries ))) (if (not the-srv) ;; have server, try connecting to it (start-main-srv) (let* ((srv-addr (server-address the-srv)) ;; need serv (ipaddr (alist-ref 'ipaddr the-srv)) (port (alist-ref 'port the-srv)) (srvkey (alist-ref 'servkey the-srv)) (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) 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 ))) (hash-table-set! conns fullpath new-the-srv))) #t)))) ;; NB// remdat is a remotedat struct ;; (define (rmt:general-open-connection remdat apath dbname #!key (num-tries 5)) (assert (not (equal? dbname ".db/main.db")) "ERROR: general-open-connection should never be called with main as the db") (let* ((mdbname (db:run-id->dbname #f)) (fullname (db:dbname->path apath dbname)) (conns (remotedat-conns remdat)) (mconn (rmt:get-conn remdat apath mdbname))) (if (and mconn (not (debug:print-logger))) (begin (debug:print-info 0 *default-log-port* "Turning on logging to main, look in logs dir for main log.") (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 (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) (if (> num-tries 0) (begin (thread-sleep! 2) (rmt:general-open-connection remdat apath dbname num-tries: (- num-tries 1))) (begin (debug:print-error 0 *default-log-port* "Failed to start servers needed or open channel to "apath", "dbname) (exit 1)))) (else (if (list? res) ;; server has been registered and the info was returned. pass it on. (begin ;; ("192.168.0.9" 53817 ;; "5e34239f48e8973b3813221e54701a01" "24310" ;; "192.168.0.9" ;; "/home/matt/data/megatest/tests/simplerun" ;; ".db/1.db") (match res ((host port servkey pid ipaddr apath dbname) (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)) 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))) res) (begin (debug:print-info 0 *default-log-port* "Unexpected result: " res) res))))))) #t)) ;;====================================================================== ;; FOR DEBUGGING SET TO #t ;; (define *localmode* #t) (define *localmode* #f) (define *dbstruct* (make-dbr:dbstruct)) ;; Defaults to current area ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; (if (not *remotedat*)(set! *remotedat* (make-remotedat))) (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: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))))) #;(define (rmt:send-receive-setup conn) (if (not (conndat-inport conn)) (let-values (((i o) (tcp-connect (conndat-ipaddr conn) (conndat-port conn)))) (conndat-inport-set! conn i) (conndat-outport-set! conn o)))) ;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed ;; sometime in the future ;; (define (rmt:send-receive-real remdat apath dbname cmd params) (let* ((conn (rmt:get-conn remdat apath dbname))) (assert conn "FATAL: rmt:send-receive-real called without the needed channels opened") (assert (conndat-socket conn) "FATAL: rmt:send-receive-real called without the channel socket opened.") (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-nn soc ;; (open-send-receive-nn (conc host":"port) (sexpr->string 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. ;; ;; Purpose - call the main.db server and request a server be started ;; for the given area path and dbname ;; ;; (define (rmt:send-receive-server-start remdat apath dbname) ;; (let* ((conn (rmt:get-conn remdat apath dbname))) ;; (assert conn "FATAL: Unable to connect to db "apath"/"dbname) ;; #;(let* ((res (with-input-from-request ;; (conndat->uri conn "api") ;; `((params . (,apath ,dbname))) ;; read-string))) ;; (string->sexpr res)))) (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, "(seconds->year-week/day-time (current-seconds))"\n=====================") |
︙ | ︙ | |||
404 405 406 407 408 409 410 | ;;====================================================================== ;;====================================================================== ;; S E R V E R ;;====================================================================== (define (rmt:kill-server run-id) | | | > > > | 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 | ;;====================================================================== ;;====================================================================== ;; S E R V E R ;;====================================================================== (define (rmt:kill-server run-id) (rmt:send-receive 'kill-server #f (list run-id))) (define (rmt:start-server run-id) (rmt:send-receive 'start-server #f (list run-id))) (define (rmt:get-server-info apath dbname) (rmt:send-receive 'get-server-info #f (list apath dbname))) ;;====================================================================== ;; M I S C ;;====================================================================== (define (rmt:login run-id) (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-signature*))) |
︙ | ︙ | |||
762 763 764 765 766 767 768 769 770 771 772 773 774 775 | ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime)) (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime)) ) ;; ) (define (rmt:get-main-run-stats run-id) (rmt:send-receive 'get-main-run-stats #f (list run-id))) (define (rmt:get-var run-id varname) (rmt:send-receive 'get-var run-id (list run-id varname))) (define (rmt:del-var run-id varname) (rmt:send-receive 'del-var run-id (list run-id varname))) (define (rmt:set-var run-id varname value) | > > > | 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 | ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime)) (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime)) ) ;; ) (define (rmt:get-main-run-stats run-id) (rmt:send-receive 'get-main-run-stats #f (list run-id))) (define (rmt:log-to-main . params) (rmt:send-receive 'log-to-main #f params)) (define (rmt:get-var run-id varname) (rmt:send-receive 'get-var run-id (list run-id varname))) (define (rmt:del-var run-id varname) (rmt:send-receive 'del-var run-id (list run-id varname))) (define (rmt:set-var run-id varname value) |
︙ | ︙ | |||
1476 1477 1478 1479 1480 1481 1482 | (define (rmt:server-shutdown) (let ((dbfile (servdat-dbfile *server-info*))) (debug:print-info 0 *default-log-port* "dbfile is "dbfile) (if dbfile (let* ((am-server (args:get-arg "-server")) (dbfile (args:get-arg "-db")) (apath *toppath*) | > > | | | | | | | | | > | > > | > | > | > | < | < < < < < < | < | 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 | (define (rmt:server-shutdown) (let ((dbfile (servdat-dbfile *server-info*))) (debug:print-info 0 *default-log-port* "dbfile is "dbfile) (if dbfile (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)) ) ;; 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) (sqlite3:finalize! db) (debug:print-info 0 *default-log-port* "in rmt:server-shutdown, db is not a database, not finalizing...")) (if (sqlite3:database? inmem) (sqlite3:finalize! inmem) (debug:print-info 0 *default-log-port* "in rmt:server-shutdown, inmem is not a database, not finalizing...")) (debug:print-info 0 *default-log-port* "Finalizing db and inmem complete")) (debug:print-info 0 *default-log-port* "Db was never opened, no cleanup to do.")) (if (not am-server) (debug:print-info 0 *default-log-port* "I am not a server, should NOT get here!") (if (string-match ".*/main.db$" dbfile) (let ((pkt-file (conc (get-pkts-dir *toppath*) "/" (servdat-uuid *server-info*) ".pkt"))) (debug:print-info 0 *default-log-port* "removing pkt "pkt-file) (delete-file* pkt-file) (debug:print-info 0 *default-log-port* "Releasing lock for "dbfile) (db:with-lock-db (servdat-dbfile *server-info*) (lambda (dbh dbfile) (db:release-lock dbh dbfile)))) (let* ((sdat *server-info*) ;; we have a run-id server (host (servdat-host sdat)) (port (servdat-port sdat)) (uuid (servdat-uuid sdat)) (res (rmt:deregister-server remdat *toppath* host port uuid dbfile))) (debug:print-info 0 *default-log-port* "deregistered-server, res="res) (debug:print-info 0 *default-log-port* "deregistering server "host":"port" with uuid "uuid) ))))))) (define (std-exit-procedure) ;;(common:telemetry-log-close) (on-exit (lambda () 0)) ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*) |
︙ | ︙ | |||
1579 1580 1581 1582 1583 1584 1585 | (args:get-arg "-server")) ;; 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. ;; | > > | > > > | > | | | 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 | (args:get-arg "-server")) ;; 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. ;; ;; 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-nn 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) ;; ;; 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 ...") (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") (server:get-best-guess-address hostname) #f))) (if ipstr ipstr hostn))) ;; hostname))) (port (portlogger:open-run-close portlogger:find-port)) ;; (link-tree-path (common:get-linktree)) ;; (tmp-area (common:get-db-tmp-area)) #;(start-file (conc tmp-area "/.server-start"))) (debug:print-info 0 *default-log-port* "portlogger recommended port: " port) (if *server-info* (begin (servdat-host-set! *server-info* ipaddrstr) (servdat-port-set! *server-info* port) |
︙ | ︙ | |||
1674 1675 1676 1677 1678 1679 1680 | (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1))) (set! *server-info* (make-servdat host: ipaddrstr port: portnum))) (debug:print-info 0 *default-log-port* "rmt:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum) | < < < < < < < < < | < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 | (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1))) (set! *server-info* (make-servdat host: ipaddrstr port: portnum))) (debug:print-info 0 *default-log-port* "rmt:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum) (assert (servdat? *server-info*) "FATAL: Must always have *server-info* properly set up by here.") (servdat-status-set! *server-info* 'starting) (servdat-port-set! *server-info* portnum) (if (not (servdat-rep *server-info*)) (let ((rep (make-rep-socket))) (servdat-rep-set! *server-info* rep) (socket-set! rep 'nng/recvtimeo 2000))) (let* ((rep (servdat-rep *server-info*))) (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum) (handle-exceptions exn (begin (print-error-message exn) (if (< portnum 64000) (begin (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...") (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 5 *default-log-port* "exn=" (condition->list exn)) (portlogger:open-run-close portlogger:set-failed portnum) (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port") ;; (thread-sleep! 0.1) (rmt:try-start-server ipaddrstr (portlogger:open-run-close portlogger:find-port))) (begin (print "ERROR: Tried and tried but could not start the server, stopping at port "portnum)))) (nng-listen rep (conc "tcp://*:" portnum)) rep))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;;====================================================================== ;; C L I E N T S ;;====================================================================== (define (rmt:get-time-to-cleanup) (let ((res #f)) (mutex-lock! *http-mutex*) (set! res (> (current-seconds) *http-connections-next-cleanup*)) (mutex-unlock! *http-mutex*) res)) (define (rmt:inc-requests-count) (mutex-lock! *http-mutex*) (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)) ;; Use this opportunity to slow things down iff there are too many requests in flight (if (> *http-requests-in-progress* 5) (begin (debug:print-info 0 *default-log-port* "Whoa there buddy, ease up...") (thread-sleep! 1))) (mutex-unlock! *http-mutex*)) (define (rmt:dec-requests-count proc) (mutex-lock! *http-mutex*) (proc) (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) (mutex-unlock! *http-mutex*)) (define (rmt:dec-requests-count-and-close-all-connections) (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds (if (> *http-requests-in-progress* 0) (if (> etime (current-seconds)) (begin (thread-sleep! 0.052) (loop etime)) (debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) #;(close-idle-connections!))) (set! *http-connections-next-cleanup* (+ (current-seconds) 10)) (mutex-unlock! *http-mutex*)) (define (rmt:inc-requests-and-prep-to-close-all-connections) (mutex-lock! *http-mutex*) (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))) ;; careful closing of connections stored in *runremote* ;; (define (rmt:close-connections #!key (area-dat #f)) (debug:print-info 0 *default-log-port* "rmt:close-connections doesn't do anything now!")) ;; (let* ((runremote (or area-dat *runremote*)) ;; (server-dat (if runremote ;; (remote-conndat runremote) ;; #f))) ;; (hash-table-ref/default *runremote* run-id #f))) ;; (if (vector? server-dat) ;; (let ((api-dat (http-transport:server-dat-get-api-uri server-dat))) ;; (handle-exceptions |
︙ | ︙ | |||
1814 1815 1816 1817 1818 1819 1820 | ;;====================================================================== ;; NEW SERVER METHOD ;;====================================================================== ;; only use for main.db - need to re-write some of this :( ;; | | | | > > > > > > > > > > > > | 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 | ;;====================================================================== ;; NEW SERVER METHOD ;;====================================================================== ;; only use for main.db - need to re-write some of this :( ;; (define (get-lock-db sdat dbfile port) (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 port))) ;; 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? owner_host owner_port "abc") #f (begin (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) res)) (define (register-server pkts-dir pkt-spec host port servkey ipaddr dbpath) (let* ((pkt-dat `((host . ,host) (port . ,port) |
︙ | ︙ | |||
1865 1866 1867 1868 1869 1870 1871 | all-pkt-files))) (define (server-address srv-pkt) (conc (alist-ref 'host srv-pkt) ":" (alist-ref 'port srv-pkt))) (define (server-ready? host port key) ;; server-address is host:port | < < < < < | 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 | all-pkt-files))) (define (server-address srv-pkt) (conc (alist-ref 'host srv-pkt) ":" (alist-ref 'port srv-pkt))) (define (server-ready? host port key) ;; server-address is host:port (let* ((data (sexpr->string `((cmd . ping) (key . ,key) (params . ())))) (res (open-send-receive-nn (conc host ":" port) data))) (string->sexpr res))) ;; (let ((res (with-input-from-port i |
︙ | ︙ | |||
1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 | (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)))))) ;; from viable servers get one that is alive and ready ;; (define (get-the-server apath serv-pkts) (let loop ((tail serv-pkts)) (if (null? tail) #f | > > > > > > > > > > > > > > > > > > > | 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 1980 1981 1982 1983 1984 | (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 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 (handle-exceptions exn #f (server-ready? 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 apath serv-pkts) (let loop ((tail serv-pkts)) (if (null? tail) #f |
︙ | ︙ | |||
1969 1970 1971 1972 1973 1974 1975 | ;;====================================================================== ;; END NEW SERVER METHOD ;;====================================================================== ;; if .db/main.db check the pkts ;; | | | 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 | ;;====================================================================== ;; END NEW SERVER METHOD ;;====================================================================== ;; if .db/main.db check the pkts ;; (define (rmt:wait-for-server pkts-dir db-file server-key) (let* ((sdat *server-info*)) (let loop ((start-time (current-seconds)) (changed #t) (last-sdat "not this")) (begin ;; let ((sdat #f)) (thread-sleep! 0.01) (debug:print-info 0 *default-log-port* "Waiting for server alive signature") |
︙ | ︙ | |||
2003 2004 2005 2006 2007 2008 2009 | (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)) | > | | > > > > > > > | | | | | > | | < < | > | | | > | | | | > > | > | | | | | | 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 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 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 | (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 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"))) (debug:print-info 0 *default-log-port* "Attempting to remove bogus pkt file "pktfile) (delete-file* pktfile))))) ;; remove immediately instead of waiting for on-exit (debug:print 0 *default-log-port* "best-srv-key: "best-srv-key", server-key: "server-key", i-am-srv: "i-am-srv) ;; am I the best-srv, compare server-keys to know (if i-am-srv (if (get-lock-db sdat db-file (servdat-port sdat)) ;; (db:get-iam-server-lock *dbstruct-db* *toppath* run-id) (begin (debug:print-info 0 *default-log-port* "I'm the server!") (servdat-dbfile-set! sdat db-file) (servdat-status-set! sdat 'db-locked)) (begin (debug:print-info 0 *default-log-port* "I'm not the server, exiting.") (bdat-time-to-exit-set! *bdat* #t) (delete-pkt) (thread-sleep! 0.2) (exit))) (begin (debug:print-info 0 *default-log-port* "Keys do not match "best-srv-key", "server-key", exiting.") (bdat-time-to-exit-set! *bdat* #t) (delete-pkt) (thread-sleep! 0.2) (exit))) sdat)) (begin ;; sdat not yet contains server info (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat) (sleep 4) (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes (begin (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server") (exit)) (loop start-time (equal? sdat last-sdat) sdat)))))))) (define (rmt:register-server remdat apath iface port server-key dbname) (remotedat-conns remdat) ;; just checking types (rmt:open-main-connection remdat apath) ;; we need a channel to main.db (rmt:send-receive-real remdat apath ;; params: host port servkey pid ipaddr dbpath (db:run-id->dbname #f) 'register-server `(,iface ,port ,server-key ,(current-process-id) ,iface ,apath ,dbname))) (define (rmt:get-count-servers remdat apath) (remotedat-conns remdat) ;; just checking types (rmt:open-main-connection remdat apath) ;; we need a channel to main.db (rmt:send-receive-real remdat apath ;; params: host port servkey pid ipaddr dbpath (db:run-id->dbname #f) 'get-count-servers `(,apath))) (define (rmt:get-servers-info apath) (rmt:send-receive 'get-servers-info #f `(,apath))) (define (rmt:deregister-server remdat apath iface port server-key dbname) (remotedat-conns remdat) ;; just checking types (rmt:open-main-connection remdat apath) ;; we need a channel to main.db (rmt:send-receive-real remdat apath ;; params: host port servkey pid ipaddr dbpath (db:run-id->dbname #f) 'deregister-server `(,iface ,port ,server-key ,(current-process-id) ,iface ,apath ,dbname))) (define (rmt:wait-for-stable-interface #!optional (num-tries-allowed 100)) ;; wait until *server-info* stops changing (let* ((stime (current-seconds))) (let loop ((last-host #f) (last-port #f) (tries 0)) (let* ((curr-host (and *server-info* (servdat-host *server-info*))) (curr-port (and *server-info* (servdat-port *server-info*)))) ;; first we verify port and interface, update *server-info* in need be. (cond ((> tries num-tries-allowed) (debug:print 0 *default-log-port* "rmt:keep-running, giving up after trying for several minutes.") (exit 1)) ((not *server-info*) (thread-sleep! 0.25) (loop curr-host curr-port (+ tries 1))) ((or (not last-host)(not last-port)) (debug:print 0 *default-log-port* "rmt:keep-running, still no interface, tries="tries) (thread-sleep! 0.25) (loop curr-host curr-port (+ tries 1))) ((or (not (equal? last-host curr-host)) (not (equal? last-port curr-port))) (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info") (thread-sleep! 0.25) (loop curr-host curr-port (+ tries 1))) |
︙ | ︙ | |||
2109 2110 2111 2112 2113 2114 2115 | "SERVER STARTED: " curr-host ":" curr-port " AT " (current-seconds) " server signature: " *my-signature* " with "(servdat-trynum *server-info*)" port changes") (flush-output *default-log-port*) #t)))))) | | > | | > > > > > > > > > > | | < | > > > > | > > > > | | | 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 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 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 | "SERVER STARTED: " curr-host ":" curr-port " AT " (current-seconds) " server signature: " *my-signature* " with "(servdat-trynum *server-info*)" port changes") (flush-output *default-log-port*) #t)))))) ;; run rmt:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; (define (rmt:keep-running dbname) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server") (let* ((remdat *remotedat*) (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 (port) (set! *unclean-shutdown* #f) (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id)) (rmt:server-shutdown) (portlogger:open-run-close portlogger:set-port port "released") (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*))) (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) (let* ((serv-info (rmt:get-server-info *toppath* dbname))) (match serv-info ((host port servkey pid ipaddr apath dbpath) (if (not (server-ready? 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) (exit))))))) (debug:print 0 *default-log-port* "SERVER: running, db "dbname" opened, megatest version: " (common:get-full-version)) ;; start the watchdog ;; is this really needed? |
︙ | ︙ | |||
2201 2202 2203 2204 2205 2206 2207 2208 | (if (common:low-noise-print 60 "dbstats") (begin (debug:print 0 *default-log-port* "Server stats:") (db:print-current-query-stats))) (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600))) (cond ((and *server-run* | > > > > > > | < | | | < | < < | 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 | (if (common:low-noise-print 60 "dbstats") (begin (debug:print 0 *default-log-port* "Server stats:") (db:print-current-query-stats))) (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600))) (cond ((not *server-run*) (debug:print-info 0 *default-log-port* "*server-run* set to #f. Shutting down.") (shutdown-server-sequence port)) ((timed-out?) (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) (shutdown-server-sequence port)) ((and *server-run* (or (not (timed-out?)) (if is-main ;; do not exit if there are other servers (keep main open until all others gone) (> (rmt:get-count-servers remdat *toppath*) 1) #f))) (if (common:low-noise-print 120 "server continuing") (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))) (loop 0 bad-sync-count (current-milliseconds))) (else (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 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 ;; |
︙ | ︙ | |||
2290 2291 2292 2293 2294 2295 2296 | ret)) ;;start a server, returns the connection ;; (define (start-nn-server portnum ) (let ((rep (make-rep-socket))) ;; (nn-socket 'rep))) (socket-set! rep 'nng/recvtimeo 2000) | | | < < | | | < < < > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | < > | | | | | | | | | | | | < < < < < < < | | 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 | ret)) ;;start a server, returns the connection ;; (define (start-nn-server portnum ) (let ((rep (make-rep-socket))) ;; (nn-socket 'rep))) (socket-set! rep 'nng/recvtimeo 2000) (handle-exceptions ;; why have exception handler here? exn (let ((emsg ((condition-property-accessor 'exn 'message) exn))) (print "ERROR: Failed to start server \"" emsg "\"") (exit 1)) (nng-dial #;nn-bind rep (conc "tcp://*:" portnum))) rep)) (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)) ;; (res #f) ;; ;; (contacts (alist-ref 'contact attrib)) ;; ;; (mode (alist-ref 'mode attrib)) ;; ) ;; (socket-set! req 'nng/recvtimeo 2000) ;; (handle-exceptions ;; exn ;; (let ((emsg ((condition-property-accessor 'exn 'message) exn))) ;; ;; Send notification ;; (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" ) ;; #f) ;; (nng-dial req uri) ;; ;; (print "Connected to the server " ) ;; (nng-send req msg) ;; ;; (print "Request Sent") ;; (let* ((th1 (make-thread (lambda () ;; (let ((resp (nng-recv req))) ;; (nng-close! req) ;; (set! res (if (equal? resp "ok") ;; #t ;; #f)))) ;; "recv thread")) ;; (th2 (make-thread (lambda () ;; (thread-sleep! timeout) ;; (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 (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\", exn=" exn) #f) (nng-dial req uri) (nng-send req msg) (let* ((th1 (make-thread (lambda () (let ((resp (nng-recv req))) (nng-close! req) ;; (print resp) (set! res resp))) "recv thread")) (th2 (make-thread (lambda () (thread-sleep! timeout) (thread-terminate! th1)) "timer thread"))) (thread-start! th1) |
︙ | ︙ | |||
2455 2456 2457 2458 2459 2460 2461 | ;; headers: '((content-type text/plain)))) ;; ((equal? (uri-path (request-uri (current-request))) ;; '(/ "loop-test")) ;; (send-response body: (alist-ref 'data ($)) ;; headers: '((content-type text/plain)))) ;; ((equal? (uri-path (request-uri (current-request))) ;; '(/ "")) | | | | | | | | 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 | ;; headers: '((content-type text/plain)))) ;; ((equal? (uri-path (request-uri (current-request))) ;; '(/ "loop-test")) ;; (send-response body: (alist-ref 'data ($)) ;; headers: '((content-type text/plain)))) ;; ((equal? (uri-path (request-uri (current-request))) ;; '(/ "")) ;; (send-response body: ((http-get-function 'rmt:main-page)))) ;; ((equal? (uri-path (request-uri (current-request))) ;; '(/ "json_api")) ;; (send-response body: ((http-get-function 'rmt:main-page)))) ;; ((equal? (uri-path (request-uri (current-request))) ;; '(/ "runs")) ;; (send-response body: ((http-get-function 'rmt:main-page)))) ;; ((equal? (uri-path (request-uri (current-request))) ;; '(/ any)) ;; (send-response body: "hey there!\n" ;; headers: '((content-type text/plain)))) ;; ((equal? (uri-path (request-uri (current-request))) ;; '(/ "hey")) ;; (send-response body: "hey there!\n" ;; headers: '((content-type text/plain)))) ;; ((equal? (uri-path (request-uri (current-request))) ;; '(/ "jquery3.1.0.js")) ;; (send-response body: ((http-get-function 'rmt:show-jquery)) ;; headers: '((content-type application/javascript)))) ;; ((equal? (uri-path (request-uri (current-request))) ;; '(/ "test_log")) ;; (send-response body: ((http-get-function 'rmt:html-test-log) $) ;; headers: '((content-type text/HTML)))) ;; ((equal? (uri-path (request-uri (current-request))) ;; '(/ "dashboard")) ;; (send-response body: ((http-get-function 'rmt:html-dboard) $) ;; headers: '((content-type text/HTML)))) ;; (else (continue)))))))) |
Modified stml2.scm from [6f0ee137b2] to [c7394e5219].
︙ | ︙ | |||
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 stml2)) (declare (uses cookie)) (include "stml2/stml2.scm") | > > | 16 17 18 19 20 21 22 23 24 25 26 27 | ;; 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 stml2)) (declare (uses cookie)) (declare (uses dbi)) (declare (uses autoload)) (include "stml2/stml2.scm") |
Modified stml2/formdat.scm from [f4b16c20f8] to [0f3102ec8c].
︙ | ︙ | |||
8 9 10 11 12 13 14 | ;; PURPOSE. ;; (declare (unit formdat)) (module formdat * | | < | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 | ;; PURPOSE. ;; (declare (unit formdat)) (module formdat * (import chicken scheme data-structures extras srfi-13 ports html-filter) (import regex) (import srfi-69) ) |
Modified stml2/html-filter.scm from [55ec64cff2] to [a2ae004691].
︙ | ︙ | |||
9 10 11 12 13 14 15 | ;; (declare (unit html-filter)) (module html-filter * (import chicken scheme data-structures extras srfi-13 ports ) | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 | ;; (declare (unit html-filter)) (module html-filter * (import chicken scheme data-structures extras srfi-13 ports ) (import misc-stml) (import regex) ;; ) |
Modified stml2/misc-stml.scm from [30ba5d90bf] to [8660d67355].
︙ | ︙ | |||
14 15 16 17 18 19 20 | ;; (declare (unit misc-stml)) (module misc-stml * (import chicken scheme data-structures extras srfi-13 ports posix) | | | < | 14 15 16 17 18 19 20 21 22 23 | ;; (declare (unit misc-stml)) (module misc-stml * (import chicken scheme data-structures extras srfi-13 ports posix) (import regex (prefix dbi dbi:)) (import (prefix crypt c:)) ) |
Modified stml2/rollup-pages.scm from [b24bc2e231] to [37b97898ac].
|
| | | 1 2 3 4 5 6 7 8 | (import regex posix srfi-69 srfi-1) (define extract-rx (regexp "pages\\/(.*)_(view|ctrl).scm")) (define (print-page-wrapper lookup page) (print "(define (pages:" page " session db shared)") (if (hash-table-ref/default lookup (conc page "_ctrl") #f) (print "(include \"pages/" page "_ctrl.scm\")")) |
︙ | ︙ |
Modified stml2/session.scm from [300e7014a0] to [32b68ce58f].
︙ | ︙ | |||
9 10 11 12 13 14 15 | ;; (declare (unit session)) (module session * (import chicken scheme data-structures extras srfi-13 ports posix files srfi-1) | | < | | 9 10 11 12 13 14 15 16 17 18 19 | ;; (declare (unit session)) (module session * (import chicken scheme data-structures extras srfi-13 ports posix files srfi-1) (import (prefix dbi dbi:) srfi-69 regex) (import cookie stmlcommon) ;; (declare (uses cookie)) ) |
Modified stml2/setup.scm from [27fec5f813] to [6248624979].
1 2 3 4 5 6 7 8 9 10 11 12 13 | ;; Copyright 2007-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (module setup * (import chicken scheme data-structures extras srfi-13 ports posix) | | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | ;; Copyright 2007-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (module setup * (import chicken scheme data-structures extras srfi-13 ports posix) (import session misc-stml) ;; (declare (unit setup))se ;; (declare (uses session)) (import srfi-69 regex) ) |
Modified stml2/spiffyserver.scm from [0953505b2d] to [36a130548d].
1 2 | ;; This doesn't work yet ;; | | | 1 2 3 4 5 6 7 8 9 10 | ;; This doesn't work yet ;; (import spiffy cgi-handler) (spiffy-debug-mode #t) (spiffy-file-ext-handlers `(("drcdb" . ,(cgi-handler* "/path/to/drcdb")))) (spiffy-root-path "/path/to/web") |
︙ | ︙ |
Modified stml2/sqlite3.scm from [935dbe7787] to [b0bb736749].
1 2 3 4 5 6 7 8 9 10 11 12 13 | ;; Copyright 2007-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; ;; I used this to get a simple interactive sqlite editor on the nokia n800 ;; since I couldn't get sqlite3 to install (for reasons I can't remember). | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | ;; Copyright 2007-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; ;; I used this to get a simple interactive sqlite editor on the nokia n800 ;; since I couldn't get sqlite3 to install (for reasons I can't remember). (import sqlite3) (define args (argv)) (define num-args (length args)) (define dbname #f) (define cmd #f) |
︙ | ︙ |
Modified stml2/stmlcommon.scm from [d0639f2742] to [ba756fc30d].
︙ | ︙ | |||
11 12 13 14 15 16 17 | ;; (declare (run-time-macros)) (module stmlcommon * (import chicken scheme data-structures extras srfi-13 ports posix) | | | 11 12 13 14 15 16 17 18 19 20 | ;; (declare (run-time-macros)) (module stmlcommon * (import chicken scheme data-structures extras srfi-13 ports posix) (import (prefix dbi dbi:) regex (prefix crypt c:) srfi-69) ) |
Modified stml2/stmlrun.scm from [a5be661fee] to [4939b15c7b].
︙ | ︙ | |||
9 10 11 12 13 14 15 | ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; (require-extension syntax-case) ;; (declare (run-time-macros)) ;; (include "stmlcommon.scm") | | | 9 10 11 12 13 14 15 16 17 18 19 | ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; (require-extension syntax-case) ;; (declare (run-time-macros)) ;; (include "stmlcommon.scm") (import stml) (stml:main #f) |
Modified stml2/test.scm from [62a996e095] to [6d65a60d4d].
|
| | < | 1 2 3 4 5 6 7 8 9 | (import test md5) (import (prefix sqlite3 sqlite3:)) (require-library dbi) ;; (declare (uses stml)) (include "requirements.scm") |
︙ | ︙ |
Added tests/simplerun/Makefile version [38acf6b450].
> > > | 1 2 3 | cleanup : killall mtest -v -9;rm -rf .meta .db |
Modified tests/simplerun/megatest.config from [373cc8c0cf] to [3e9fa2e5ac].
︙ | ︙ | |||
34 35 36 37 38 39 40 | # Valid values for state and status for steps, NB// It is not recommended you use this [validvalues] state start end completed # Job tools are more advanced ways to control how your jobs are launched [jobtools] useshell yes | | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | # Valid values for state and status for steps, NB// It is not recommended you use this [validvalues] state start end completed # Job tools are more advanced ways to control how your jobs are launched [jobtools] useshell yes launcher nbfake # You can override environment variables for all your tests here [env-override] EXAMPLE_VAR example value # As you run more tests you may need to add additional disks, the names are arbitrary but must be unique [disks] |
︙ | ︙ |
Modified tests/tests.scm from [2fa2f9d268] to [7467445dd0].
︙ | ︙ | |||
13 14 15 16 17 18 19 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') | | > > > > > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (import srfi-18 test chicken.string chicken.process-context chicken.file chicken.pretty-print commonmod ) (define test-work-dir (current-directory)) ;; given list of lists ;; ( ( msg expected param1 param2 ...) ;; ( ... ) ) ;; apply test to all |
︙ | ︙ |
Modified tests/unittests/basicserver.scm from [928bc7546a] to [0bda564ab1].
︙ | ︙ | |||
19 20 21 22 23 24 25 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; Run like this: ;; ;; ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) (import rmtmod trace http-client apimod dbmod | | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; Run like this: ;; ;; ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) (import rmtmod trace http-client apimod dbmod launchmod srfi-69) (trace-call-sites #t) (trace ;; db:get-dbdat ;; rmt:find-main-server ;; rmt:send-receive-real ;; rmt:send-receive |
︙ | ︙ | |||
43 44 45 46 47 48 49 | ;; get-viable-servers ;; get-best-candidate ;; api:run-server-process ;; rmt:run ;; rmt:try-start-server ) | | | | | | | | | | | 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 | ;; get-viable-servers ;; get-best-candidate ;; api:run-server-process ;; rmt:run ;; rmt:try-start-server ) (test #f #t (remotedat? (let ((r (make-remotedat))) (set! *remotedat* r) r))) (test #f #f (rmt:get-conn *remotedat* *toppath* ".db/main.db")) (test #f #f (rmt:find-main-server *toppath* ".db/main.db")) (test #f #t (rmt:open-main-connection *remotedat* *toppath*)) (pp (hash-table->alist (remotedat-conns *remotedat*))) (test #f #t (conndat? (rmt:get-conn *remotedat* *toppath* ".db/main.db"))) (define *main* (rmt:get-conn *remotedat* *toppath* ".db/main.db")) ;; (for-each (lambda (tdat) ;; (test #f tdat (loop-test (rmt:conn-ipaddr *main*) ;; (rmt:conn-port *main*) tdat))) ;; (list 'a ;; '(a "b" 123 1.23 ))) (test #f #t (rmt:send-receive 'ping #f 'hello)) (define *db* (db:setup ".db/main.db")) ;; these let me cut and paste from source easily (define apath *toppath*) (define dbname ".db/2.db") (define remote *remotedat*) (define keyvals '(("SYSTEM" "a")("RELEASE" "b"))) (test #f '() (string->sexpr "()")) (test #f 'server-started (api:execute-requests *db* 'get-server (list *toppath* ".db/2.db"))) (set! *dbstruct-db* #f) (exit) |
Modified tests/unittests/server.scm from [288618866d] to [7bdfa0e7f2].
︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 | ;; ;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) (import rmtmod trace http-client apimod dbmod launchmod) (trace-call-sites #t) (trace ;; db:get-dbdat ;; rmt:find-main-server | > | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | ;; ;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) (import rmtmod trace http-client apimod dbmod launchmod) (trace-call-sites #t) (trace ;; db:get-dbdat ;; rmt:find-main-server ;; rmt:send-receive-real ;; rmt:send-receive ;; sexpr->string ;; server-ready? ;; rmt:register-server ;; rmt:deregister-server ;; rmt:open-main-connection ;; rmt:general-open-connection ;; rmt:get-conn |
︙ | ︙ | |||
50 51 52 53 54 55 56 | ) (define *db* (db:setup ".db/main.db")) ;; these let me cut and paste from source easily (define apath *toppath*) (define dbname ".db/2.db") | | | | | > | > | | | > | < > > | 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 | ) (define *db* (db:setup ".db/main.db")) ;; these let me cut and paste from source easily (define apath *toppath*) (define dbname ".db/2.db") (define remote *remotedat*) (define keyvals '(("SYSTEM" "a")("RELEASE" "b"))) (test #f #t (rmt:open-main-connection remote apath)) (test #f #t (conndat? (rmt:get-conn *remotedat* *toppath* ".db/main.db"))) (test #f #t (conndat? (rmt:get-conn *remotedat* *toppath* ".db/main.db"))) (test #f ".db/2.db" (list-ref (rmt:send-receive-real *remotedat* *toppath* ".db/main.db" 'get-server `(,apath ,dbname)) 6)) (thread-sleep! 2) (test #f #t (rmt:general-open-connection *remotedat* *toppath* ".db/2.db")) (test #f #t (list? (rmt:get-servers-info *toppath*))) (test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) (test #f 1 (rmt:send-receive 'register-run #f (list keyvals "run1" "new" "n/a" "justme" #f))) ;; (print "Got here.") (test #f 1 (rmt:send-receive 'register-run 1 (list keyvals "run1" "new" "n/a" "justme" #f))) (test #f 2 (rmt:register-run keyvals "run2" "new" "n/a" "justme" #f)) ;; (test #f 2 (rmt:deregister-server *remotedat* *toppath* iface port server-key dbname (test #f 2 (rmt:get-count-servers *remotedat* *toppath*)) (test #f "run2" (rmt:get-run-name-from-id 2)) (test #f #f (rmt:send-receive 'get-test-info-by-id 2 '(2 1))) (test #f #t (rmt:general-call 'update-cpuload-diskfree 2 1.5 1e6 1)) (exit) |
Modified testsmod.scm from [13d6172d0b] to [1d551a945a].
︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 | (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses itemsmod)) (declare (uses rmtmod)) (declare (uses stml2)) (declare (uses dbmod)) (declare (uses tasksmod)) (module testsmod * (import scheme chicken.base | > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses itemsmod)) (declare (uses rmtmod)) (declare (uses stml2)) (declare (uses dbmod)) (declare (uses tasksmod)) (declare (uses dbi)) (module testsmod * (import scheme chicken.base |
︙ | ︙ |