Overview
Comment: | all effed |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.6584-tcp6 |
Files: | files | file ages | folders |
SHA1: |
58eed43d634f267097b948b1b9f18eb1 |
User & Date: | matt on 2021-06-06 23:58:20 |
Other Links: | branch diff | manifest | tags |
Context
2021-06-07
| ||
06:26 | try nanomsg check-in: 14a50c3c87 user: matt tags: v1.6584-nanomsg | |
2021-06-06
| ||
23:58 | all effed Leaf check-in: 58eed43d63 user: matt tags: v1.6584-tcp6 | |
22:07 | Got all PASS on current tests check-in: f1e43b7b99 user: matt tags: v1.6584-tcp6 | |
Changes
Modified fullrununit.sh from [e6c2056159] to [b363702396].
1 2 | #!/bin/bash | > | | | | > > | 1 2 3 4 5 6 7 8 9 | #!/bin/bash for x in basicserver server;do (killall mtest -v;sleep 1;killall mtest -v -9;rm -f tests/simplerun/.db/* tests/simplerun/logs/* tests/$x.log) & ck5 make -j install && wait && script -c "cd tests;ck5 make $x.log" full-$x.log done |
Modified rmtmod.scm from [348d9df954] to [cd536fb107].
︙ | ︙ | |||
213 214 215 216 217 218 219 | ;; srv not ready, delay a little and try again (api:run-server-process apath dbname) (thread-sleep! 4) (rmt:open-main-connection remote apath) ;; TODO: Add limit to number of tries ))) (if the-srv ;; yes, we have a server, now try connecting to it (let* ((srv-addr (server-address the-srv)) | | | | | | 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 | ;; srv not ready, delay a little and try again (api:run-server-process apath dbname) (thread-sleep! 4) (rmt:open-main-connection remote apath) ;; TODO: Add limit to number of tries ))) (if the-srv ;; yes, we have a server, now try connecting to it (let* ((srv-addr (server-address the-srv)) (ipaddr (alist-ref 'ipaddr the-srv)) (port (alist-ref 'port the-srv)) (srvkey (alist-ref 'servkey the-srv)) (fullpath (db:dbname->path apath dbname)) (srvready (server-ready? ipaddr port srvkey))) (if srvready (begin (hash-table-set! (rmt:remote-conns remote) dbname ;; fullpath ;; yes, I'd prefer it to be fullpath - FIXME later (make-rmt:conn apath: apath dbname: dbname fullname: fullpath hostport: 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 )) #t) (start-main-srv))) (start-main-srv)))) |
︙ | ︙ | |||
278 279 280 281 282 283 284 | (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote))) (let* ((apath *toppath*) (conns *rmt:remote*) (dbname (db:run-id->dbname rid))) (rmt:general-open-connection conns apath dbname) (rmt:send-receive-real conns apath dbname cmd params))) | | > | > > | | | | | | | | | > > | | 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 | (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote))) (let* ((apath *toppath*) (conns *rmt:remote*) (dbname (db:run-id->dbname rid))) (rmt:general-open-connection conns apath dbname) (rmt:send-receive-real conns apath dbname cmd params))) #;(define (rmt:send-receive-setup conn) (if (not (rmt:conn-inport conn)) (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn) (rmt:conn-port conn)))) (rmt:conn-inport-set! conn i) (rmt:conn-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 remote apath dbname cmd params) (let* ((conn (rmt:get-conn remote apath dbname))) (assert conn "FATAL: rmt:send-receive-real called without the needed channels opened") (pp (rmt:conn->alist conn)) ;; (rmt:send-receive-setup conn) (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn) (rmt:conn-port conn)))) (let* ((key #f) (payload `((cmd . ,cmd) (key . ,(rmt:conn-srvkey conn)) (params . ,params))) (res (begin (write payload o) ;; (rmt:conn-outport conn)) (with-input-from-port i ;; (rmt:conn-inport conn) read)))) (close-input-port i) (close-output-port o) res)))) ;; (if (string? res) ;; (string->sexpr res) ;; res)))) ;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed |
︙ | ︙ | |||
1584 1585 1586 1587 1588 1589 1590 | (if *server-info* (begin (servdat-host-set! *server-info* ipaddrstr) (servdat-port-set! *server-info* port) (servdat-status-set! *server-info* 'trying-port) (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1))) (set! *server-info* (make-servdat host: ipaddrstr port: port))) | | < | | 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 | (if *server-info* (begin (servdat-host-set! *server-info* ipaddrstr) (servdat-port-set! *server-info* port) (servdat-status-set! *server-info* 'trying-port) (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1))) (set! *server-info* (make-servdat host: ipaddrstr port: port))) (let* ((l (rmt:try-start-server ipaddrstr port))) (let oloop () (let-values (((i o) (tcp-accept l))) ;; (write-line "Hello!" o) (let loop ((indat (read i))) (if (eof-object? indat) (begin (close-input-port i) (close-output-port o) (oloop)) (let* ((res (api:process-request *dbstruct-db* indat))) (set! *db-last-access* (current-seconds)) (write res o) (loop (read i)))))))) (let* ((portnum (servdat-port *server-info*))) (portlogger:open-run-close portlogger:set-port portnum "released") (debug:print 1 *default-log-port* "INFO: server has been stopped")))) |
︙ | ︙ | |||
1922 1923 1924 1925 1926 1927 1928 | ;; (servdat-uuid-set! sdat (register-server pkts-dir *srvpktspec* (get-host-name) (servdat-port sdat) server-key (servdat-host sdat) db-file)) | | < > > > | 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 | ;; (servdat-uuid-set! sdat (register-server pkts-dir *srvpktspec* (get-host-name) (servdat-port sdat) server-key (servdat-host sdat) db-file)) ;; (set! *my-signature* (servdat-uuid sdat)) ;; replace with Z, no, stick with proper key ;; now read pkts and see if we are a contender (let* ((all-pkts (get-all-server-pkts pkts-dir *srvpktspec*)) (viables (get-viable-servers all-pkts db-file)) (best-srv (get-best-candidate viables db-file)) (best-srv-key (if best-srv (alist-ref 'servkey best-srv) #f))) (debug:print 0 *default-log-port* "best-srv-key: "best-srv-key", server-key: "server-key) ;; am I the best-srv, compare server-keys to know (if (equal? best-srv-key server-key) (if (get-lock-db sdat db-file) ;; (db:get-iam-server-lock *dbstruct-db* *toppath* run-id) (begin (debug:print 0 *default-log-port* "I'm the server!") (servdat-dbfile-set! sdat db-file) (servdat-status-set! sdat 'db-locked)) (begin (debug:print 0 *default-log-port* "I'm not the server, exiting.") (bdat-time-to-exit-set! *bdat* #t) (thread-sleep! 0.2) (exit))) (begin (debug:print 0 *default-log-port* "Keys do not match "best-srv-key", "server-key", exiting.") (bdat-time-to-exit-set! *bdat* #t) (delete-file* (conc (get-pkts-dir *toppath*) "/" (servdat-uuid *server-info*) ".pkt")) ;; remove immediately instead of waiting for on-exit (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 |
︙ | ︙ | |||
2000 2001 2002 2003 2004 2005 2006 | (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))) ((< (- (current-seconds) stime) 1) ;; keep up the looping until at least 3 seconds have passed (thread-sleep! 0.5) (loop curr-host curr-port (+ tries 1))) (else | | | < | 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 | (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))) ((< (- (current-seconds) stime) 1) ;; keep up the looping until at least 3 seconds have passed (thread-sleep! 0.5) (loop curr-host curr-port (+ tries 1))) (else (rmt:get-signature) ;; sets *my-signature* as side effect (servdat-status-set! *server-info* 'interface-stable) (debug:print 0 *default-log-port* "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 http-transport: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* ((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))) ;; main and run db servers have both got wait logic (could/should merge it) (if is-main (http-transport:wait-for-server pkts-dir dbname server-key) (http-transport:wait-for-stable-interface)) ;; this is our forever loop (let* ((iface (servdat-host *server-info*)) (port (servdat-port *server-info*))) (let loop ((count 0) |
︙ | ︙ |
Modified tests/Makefile from [f693c2a7e2] to [ee95d53fd2].
︙ | ︙ | |||
38 39 40 41 42 43 44 | # The NEWTARGET causes some tests to fail. Do not use until this is fixed. NEWTARGET = "$(OS)/$(FS)/$(VER)" TARGET = "ubuntu/nfs/none" all : build unit test4 # test1 test2 test3 test4 test5 test6 test7 test8 test9 | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | # The NEWTARGET causes some tests to fail. Do not use until this is fixed. NEWTARGET = "$(OS)/$(FS)/$(VER)" TARGET = "ubuntu/nfs/none" all : build unit test4 # test1 test2 test3 test4 test5 test6 test7 test8 test9 unit : basicserver.log server.log # all-rmt.log all-api.log # runs.log misc.log tests.log # inter dependencies on the unit tests, I wish these could be "suggestions" all-rmt.log : all-api.log rel : |
︙ | ︙ |
Modified tests/unittests/basicserver.scm from [d1fb7365d1] to [1303cd104d].
︙ | ︙ | |||
74 75 76 77 78 79 80 | (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) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 74 75 76 77 78 79 80 | (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 [a6d42b3a64] to [245ccd4190].
︙ | ︙ | |||
18 19 20 21 22 23 24 25 26 27 28 29 30 31 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; Run like this: ;; ;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) (delete-file* "logs/1.log") (define run-id 1) (test "setup for run" #t (begin (launch:setup-for-run) (string? (getenv "MT_RUN_AREA_HOME")))) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 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 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 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; Run like this: ;; ;; (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:open-main-connection ;; rmt:general-open-connection ;; rmt:get-conny ;; common:watchdog ;; rmt:find-main-server ;; get-all-server-pkts ;; get-viable-servers ;; get-best-candidate ;; api:run-server-process ;; rmt:run ;; rmt:try-start-server ) (define *db* (db:setup #f)) ;; these let me cut and paste from source easily (define apath *toppath*) (define dbname ".db/2.db") (define remote *rmt:remote*) (define keyvals '(("SYSTEM" "a")("RELEASE" "b"))) (test #f #t (rmt:open-main-connection remote apath)) (test #f #t (rmt:conn? (rmt:get-conn *rmt:remote* *toppath* ".db/main.db"))) (test #f 'server-started (rmt:send-receive-real *rmt:remote* *toppath* ".db/main.db" 'get-server `(,apath ,dbname))) (thread-sleep! 2) (test #f #t (list? (rmt:general-open-connection *rmt:remote* *toppath* ".db/2.db"))) (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 #t 1 (rmt:send-receive 'register-run 1 (list keyvals "run2" "new" "n/a" "justme" #f))) (test #f 1 (rmt:register-run keyvals "run2" "new" "n/a" "justme" #f)) ;; (delete-file* "logs/1.log") ;; (define run-id 1) ;; (test "setup for run" #t (begin (launch:setup) ;; (string? (getenv "MT_RUN_AREA_HOME")))) ;; ;; (test #f #t (and (server:kind-run *toppath*) #t)) ;; ;; ;; (define user (current-user-name)) ;; (define runname "mytestrun") ;; (define keys (rmt:get-keys)) ;; (define runinfo #f) ;; (define keyvals '(("SYSTEM" "abc")("RELEASE" "def"))) ;; (define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time")) ;; ;; ;; Setup ;; ;; ;; ;; (test #f #f (not (client:setup run-id))) ;; ;; (test #f #f (not (hash-table-ref/default *runremote* run-id #f))) ;; ;; ;; Login ;; ;; ;; (test #f'(#t "successful login") ;; (rmt:login run-id)) ;; ;; ;; Keys ;; ;; ;; (test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) ;; ;; ;; No data in db ;; ;; ;; (test #f '() (rmt:get-all-run-ids)) ;; (test #f #f (rmt:get-run-name-from-id run-id)) ;; (test #f ;; (vector ;; header ;; (vector #f #f #f #f)) ;; (rmt:get-run-info run-id)) ;; ;; ;; Insert data into db ;; ;; ;; (test #f 1 (rmt:register-run keyvals runname "new" "n/a" user)) ;; ;; (test #f #f (rmt:get-runs-by-patt keys runname)) ;; (test #f #t (rmt:general-call 'register-test run-id run-id "test-one" "")) ;; (define test-one-id #f) ;; (test #f 1 (let ((test-id (rmt:get-test-id run-id "test-one" ""))) ;; (set! test-one-id test-id) ;; test-id)) ;; (define test-one-rec #f) ;; (test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id))) ;; (set! test-one-rec test-rec) ;; (vector-ref test-rec 2))) ;; ;; ;; With data in db ;; ;; ;; (print "Using runame=" runname) ;; (test #f '(1) (rmt:get-all-run-ids)) ;; (test #f runname (rmt:get-run-name-from-id run-id)) ;; (test #f ;; runname ;; (let ((run-info (rmt:get-run-info run-id))) ;; (db:get-value-by-header (db:get-rows run-info) ;; (db:get-header run-info) ;; "runname"))) ;; ;; ;; test killing server ;; ;; ;; (for-each ;; (lambda (run-id) ;; (test #f #t (and (tasks:kill-server-run-id run-id) #t)) ;; (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))) ;; (list 0 1)) ;; ;; ;; Tests to assess reading/writing while servers are starting/stopping ;; ;; NO LONGER APPLICABLE ;; ;; ;; Server tests go here ;; (define (server-tests-dont-run-right-now) ;; (for-each ;; (lambda (run-id) ;; (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)) ;; (server:kind-run run-id) ;; (test "did server start within 20 seconds?" ;; #t ;; (let loop ((remtries 20) ;; (running (tasks:server-running-or-starting? (db:delay-if-busy ;; (tasks:open-db)) ;; run-id))) ;; (if running ;; (> running 0) ;; (if (> remtries 0) ;; (begin ;; (thread-sleep! 1) ;; (loop (- remtries 1) ;; (tasks:server-running-or-starting? (db:delay-if-busy ;; (tasks:open-db)) ;; run-id))))))) ;; ;; (test "did server become available" #t ;; (let loop ((remtries 10) ;; (res (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) ;; (if res ;; (vector? res) ;; (begin ;; (if (> remtries 0) ;; (begin ;; (thread-sleep! 1.1) ;; (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) ;; res))))) ;; ) ;; (list 0 1))) ;; ;; (define start-time (current-seconds)) ;; (define (reading-writing-while-server-starting-stopping-dont-run-now) ;; (let loop ((test-state 'start)) ;; (let* ((server-dats (tasks:get-server-records (db:delay-if-busy (tasks:open-db)) run-id)) ;; (first-dat (if (not (null? server-dats)) ;; (car server-dats) ;; #f))) ;; (map (lambda (dat) ;; (apply print (intersperse (vector->list dat) ", "))) ;; server-dats) ;; (test #f test-one-rec (rmt:get-test-info-by-id run-id test-one-id)) ;; (thread-sleep! 1) ;; (case test-state ;; ((start) ;; (print "Trying to start server") ;; (server:kind-run run-id) ;; (loop 'server-started)) ;; ((server-started) ;; (case (if first-dat (vector-ref first-dat 0) 'blah) ;; ((running) ;; (print "Server appears to be running. Now ask it to shutdown") ;; (rmt:kill-server run-id) ;; (loop 'server-shutdown)) ;; ((shutting-down) ;; (loop test-state)) ;; (else (print "Don't know what to do if get here")))) ;; ((server-shutdown) ;; (loop test-state))))) ;; ) ;;====================================================================== ;; END OF TESTS ;;====================================================================== ;; (test #f #f (client:setup run-id)) ;; (set! *transport-type* 'http) ;; ;; (test "setup for run" #t (begin (launch:setup-for-run) ;; (string? (getenv "MT_RUN_AREA_HOME")))) ;; ;; (test "server-register, get-best-server" #t (let ((res #f)) ;; (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) ;; (set! res (open-run-close tasks:get-best-server tasks:open-db)) ;; (number? (vector-ref res 3)))) ;; ;; (test "de-register server" #f (let ((res #f)) ;; (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) ;; (vector? (open-run-close tasks:get-best-server tasks:open-db)))) ;; ;; (define server-pid #f) ;; ;; ;; Not sure how the following should work, replacing it with system of megatest -server ;; ;; (test "launch server" #t (let ((pid (process-fork (lambda () ;; ;; ;; (daemon:ize) ;; ;; (server:launch 'http))))) ;; ;; (set! server-pid pid) ;; ;; (number? pid))) ;; (system "../../bin/megatest -server - -debugbcom 22 > server.log 2> server.log &") ;; ;; (let loop ((n 10)) ;; (thread-sleep! 1) ;; need to wait for server to start. ;; (let ((res (open-run-close tasks:get-best-server tasks:open-db))) ;; (print "tasks:get-best-server returned " res) ;; (if (and (not res) ;; (> n 0)) ;; (loop (- n 1))))) ;; ;; (test "get-best-server" #t (begin ;; (client:launch) ;; (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) ;; (vector? dat)))) ;; ;; (define *keys* (keys:config-get-fields *configdat*)) ;; (define *keyvals* (keys:target->keyval *keys* "a/b/c")) ;; ;; (test #f #t (string? (car *runremote*))) ;; (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) ;; ;; (test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test ;; ;; ;; RUNS ;; (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) ;; (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) ;; (vector-ref (vector-ref rinfo 1) 3))) ;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) ;; ;; ;; TESTS ;; (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) ;; (test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) ;; (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) ;; (test "get test id" 1 (rmt:get-test-id 1 "test1" "")) ;; (test "sync back" #t (> (rmt:sync-inmem->db) 0)) ;; (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) ;; (test "get keys" #t (list? (rmt:get-keys))) ;; (test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) ;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) ;; (db:test-get-comment trec))) ;; ;; ;; MORE RUNS ;; (test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) ;; (header (vector-ref runs 0)) ;; (data (vector-ref runs 1))) ;; (and (list? header) ;; (list? data) ;; (vector? (car data))))) ;; ;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2)) ;; (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2)) ;; ;; ;;====================================================================== ;; ;; D B ;; ;;====================================================================== ;; ;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) ;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) ;; (+ (db:test-get-pass_count dat) ;; (db:test-get-fail_count dat)))) ;; ;; (define testregistry (make-hash-table)) ;; (for-each ;; (lambda (tname) ;; (for-each ;; (lambda (itempath) ;; (let ((tkey (conc tname "/" itempath)) ;; (rpass (random 10)) ;; (rfail (random 10))) ;; (hash-table-set! testregistry tkey (list tname itempath)) ;; (rmt:general-call 'register-test 1 tname itempath) ;; (let* ((tid (rmt:get-test-id 1 tname itempath)) ;; (tdat (rmt:get-test-info-by-id tid))) ;; (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) ;; (let* ((resdat (rmt:get-test-info-by-id tid))) ;; (test "set/get pass fail counts" (list rpass rfail) ;; (list (db:test-get-pass_count resdat) ;; (db:test-get-fail_count resdat))))))) ;; (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) ;; (list "test1" "test2" "test3" "test4" "test5")) ;; ;; ;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) ;; ;; (exit) ;; all old stuff below (delete-file* "logs/1.log") (define run-id 1) (test "setup for run" #t (begin (launch:setup-for-run) (string? (getenv "MT_RUN_AREA_HOME")))) |
︙ | ︙ |