Artifact
67b7c04b6367e9cd4222504aa6e399bb8529fd92:
0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 ========.;; S E
0050: 52 20 56 20 45 20 52 0a 3b 3b 3d 3d 3d 3d 3d 3d R V E R.;;======
0060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
00a0: 0a 3b 3b 20 20 43 6f 70 79 72 69 67 68 74 20 32 .;; Copyright 2
00b0: 30 30 36 2d 32 30 31 37 2c 20 4d 61 74 74 68 65 006-2017, Matthe
00c0: 77 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b w Welland..;; .;
00d0: 3b 20 54 68 69 73 20 66 69 6c 65 20 69 73 20 70 ; This file is p
00e0: 61 72 74 20 6f 66 20 4d 65 67 61 74 65 73 74 2e art of Megatest.
00f0: 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 .;; .;; Mega
0100: 74 65 73 74 20 69 73 20 66 72 65 65 20 73 6f 66 test is free sof
0110: 74 77 61 72 65 3a 20 79 6f 75 20 63 61 6e 20 72 tware: you can r
0120: 65 64 69 73 74 72 69 62 75 74 65 20 69 74 20 61 edistribute it a
0130: 6e 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b 3b 20 nd/or modify.;;
0140: 20 20 20 20 69 74 20 75 6e 64 65 72 20 74 68 65 it under the
0150: 20 74 65 72 6d 73 20 6f 66 20 74 68 65 20 47 4e terms of the GN
0160: 55 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 U General Public
0170: 20 4c 69 63 65 6e 73 65 20 61 73 20 70 75 62 6c License as publ
0180: 69 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 20 20 ished by.;;
0190: 74 68 65 20 46 72 65 65 20 53 6f 66 74 77 61 72 the Free Softwar
01a0: 65 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 65 69 e Foundation, ei
01b0: 74 68 65 72 20 76 65 72 73 69 6f 6e 20 33 20 6f ther version 3 o
01c0: 66 20 74 68 65 20 4c 69 63 65 6e 73 65 2c 20 6f f the License, o
01d0: 72 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 6f 75 r.;; (at you
01e0: 72 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 6c 61 r option) any la
01f0: 74 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b 3b 20 ter version..;;
0200: 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 73 74 .;; Megatest
0210: 20 69 73 20 64 69 73 74 72 69 62 75 74 65 64 20 is distributed
0220: 69 6e 20 74 68 65 20 68 6f 70 65 20 74 68 61 74 in the hope that
0230: 20 69 74 20 77 69 6c 6c 20 62 65 20 75 73 65 66 it will be usef
0240: 75 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 20 57 ul,.;; but W
0250: 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 52 41 ITHOUT ANY WARRA
0260: 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 76 65 NTY; without eve
0270: 6e 20 74 68 65 20 69 6d 70 6c 69 65 64 20 77 61 n the implied wa
0280: 72 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 20 20 rranty of.;;
0290: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
02a0: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
02b0: 41 20 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 A PARTICULAR PUR
02c0: 50 4f 53 45 2e 20 20 53 65 65 20 74 68 65 0a 3b POSE. See the.;
02d0: 3b 20 20 20 20 20 47 4e 55 20 47 65 6e 65 72 61 ; GNU Genera
02e0: 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 l Public License
02f0: 20 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 69 6c for more detail
0300: 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 59 6f s..;; .;; Yo
0310: 75 20 73 68 6f 75 6c 64 20 68 61 76 65 20 72 65 u should have re
0320: 63 65 69 76 65 64 20 61 20 63 6f 70 79 20 6f 66 ceived a copy of
0330: 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c the GNU General
0340: 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 0a Public License.
0350: 3b 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 69 74 ;; along wit
0360: 68 20 4d 65 67 61 74 65 73 74 2e 20 20 49 66 20 h Megatest. If
0370: 6e 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 3a 2f not, see <http:/
0380: 2f 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c 69 63 /www.gnu.org/lic
0390: 65 6e 73 65 73 2f 3e 2e 0a 0a 3b 3b 20 52 75 6e enses/>...;; Run
03a0: 20 6c 69 6b 65 20 74 68 69 73 3a 0a 3b 3b 0a 3b like this:.;;.;
03b0: 3b 20 20 2e 2f 72 75 6e 75 6e 69 74 74 65 73 74 ; ./rununittest
03c0: 2e 73 68 20 73 65 72 76 65 72 20 31 3b 28 63 64 .sh server 1;(cd
03d0: 20 73 69 6d 70 6c 65 72 75 6e 3b 6d 65 67 61 74 simplerun;megat
03e0: 65 73 74 20 2d 73 74 6f 70 2d 73 65 72 76 65 72 est -stop-server
03f0: 20 30 29 0a 0a 28 69 6d 70 6f 72 74 20 72 6d 74 0)..(import rmt
0400: 6d 6f 64 20 74 72 61 63 65 20 68 74 74 70 2d 63 mod trace http-c
0410: 6c 69 65 6e 74 20 61 70 69 6d 6f 64 20 64 62 6d lient apimod dbm
0420: 6f 64 0a 09 6c 61 75 6e 63 68 6d 6f 64 29 0a 28 od..launchmod).(
0430: 74 72 61 63 65 2d 63 61 6c 6c 2d 73 69 74 65 73 trace-call-sites
0440: 20 23 74 29 0a 28 74 72 61 63 65 0a 20 3b 3b 20 #t).(trace. ;;
0450: 64 62 3a 67 65 74 2d 64 62 64 61 74 0a 20 3b 3b db:get-dbdat. ;;
0460: 20 72 6d 74 3a 66 69 6e 64 2d 6d 61 69 6e 2d 73 rmt:find-main-s
0470: 65 72 76 65 72 0a 20 3b 3b 20 72 6d 74 3a 73 65 erver. ;; rmt:se
0480: 6e 64 2d 72 65 63 65 69 76 65 2d 72 65 61 6c 0a nd-receive-real.
0490: 20 3b 3b 20 72 6d 74 3a 73 65 6e 64 2d 72 65 63 ;; rmt:send-rec
04a0: 65 69 76 65 0a 20 3b 3b 20 73 65 78 70 72 2d 3e eive. ;; sexpr->
04b0: 73 74 72 69 6e 67 0a 20 3b 3b 20 73 65 72 76 65 string. ;; serve
04c0: 72 2d 72 65 61 64 79 3f 0a 20 3b 3b 20 72 6d 74 r-ready?. ;; rmt
04d0: 3a 72 65 67 69 73 74 65 72 2d 73 65 72 76 65 72 :register-server
04e0: 0a 20 3b 3b 20 72 6d 74 3a 6f 70 65 6e 2d 6d 61 . ;; rmt:open-ma
04f0: 69 6e 2d 63 6f 6e 6e 65 63 74 69 6f 6e 0a 20 3b in-connection. ;
0500: 3b 20 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 6f 70 ; rmt:general-op
0510: 65 6e 2d 63 6f 6e 6e 65 63 74 69 6f 6e 0a 20 3b en-connection. ;
0520: 3b 20 72 6d 74 3a 67 65 74 2d 63 6f 6e 6e 79 0a ; rmt:get-conny.
0530: 20 3b 3b 20 63 6f 6d 6d 6f 6e 3a 77 61 74 63 68 ;; common:watch
0540: 64 6f 67 0a 20 3b 3b 20 72 6d 74 3a 66 69 6e 64 dog. ;; rmt:find
0550: 2d 6d 61 69 6e 2d 73 65 72 76 65 72 0a 20 3b 3b -main-server. ;;
0560: 20 67 65 74 2d 61 6c 6c 2d 73 65 72 76 65 72 2d get-all-server-
0570: 70 6b 74 73 0a 20 3b 3b 20 67 65 74 2d 76 69 61 pkts. ;; get-via
0580: 62 6c 65 2d 73 65 72 76 65 72 73 0a 20 3b 3b 20 ble-servers. ;;
0590: 67 65 74 2d 62 65 73 74 2d 63 61 6e 64 69 64 61 get-best-candida
05a0: 74 65 0a 20 3b 3b 20 61 70 69 3a 72 75 6e 2d 73 te. ;; api:run-s
05b0: 65 72 76 65 72 2d 70 72 6f 63 65 73 73 0a 20 29 erver-process. )
05c0: 0a 0a 28 74 65 73 74 20 23 66 20 23 74 20 28 72 ..(test #f #t (r
05d0: 6d 74 3a 72 65 6d 6f 74 65 3f 20 28 6c 65 74 20 mt:remote? (let
05e0: 28 28 72 20 28 6d 61 6b 65 2d 72 6d 74 3a 72 65 ((r (make-rmt:re
05f0: 6d 6f 74 65 29 29 29 0a 09 09 09 20 20 20 28 73 mote))).... (s
0600: 65 74 21 20 2a 72 6d 74 3a 72 65 6d 6f 74 65 2a et! *rmt:remote*
0610: 20 72 29 0a 09 09 09 20 20 20 72 29 29 29 0a 28 r).... r))).(
0620: 74 65 73 74 20 23 66 20 23 66 20 28 72 6d 74 3a test #f #f (rmt:
0630: 67 65 74 2d 63 6f 6e 6e 20 2a 72 6d 74 3a 72 65 get-conn *rmt:re
0640: 6d 6f 74 65 2a 20 2a 74 6f 70 70 61 74 68 2a 20 mote* *toppath*
0650: 22 2e 64 62 2f 6d 61 69 6e 2e 64 62 22 29 29 0a ".db/main.db")).
0660: 28 74 65 73 74 20 23 66 20 23 66 20 28 72 6d 74 (test #f #f (rmt
0670: 3a 66 69 6e 64 2d 6d 61 69 6e 2d 73 65 72 76 65 :find-main-serve
0680: 72 20 2a 74 6f 70 70 61 74 68 2a 20 22 2e 64 62 r *toppath* ".db
0690: 2f 6d 61 69 6e 2e 64 62 22 29 29 0a 28 74 65 73 /main.db")).(tes
06a0: 74 20 23 66 20 23 74 20 28 72 6d 74 3a 6f 70 65 t #f #t (rmt:ope
06b0: 6e 2d 6d 61 69 6e 2d 63 6f 6e 6e 65 63 74 69 6f n-main-connectio
06c0: 6e 20 2a 72 6d 74 3a 72 65 6d 6f 74 65 2a 20 2a n *rmt:remote* *
06d0: 74 6f 70 70 61 74 68 2a 29 29 0a 28 70 70 20 28 toppath*)).(pp (
06e0: 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 hash-table->alis
06f0: 74 20 28 72 6d 74 3a 72 65 6d 6f 74 65 2d 63 6f t (rmt:remote-co
0700: 6e 6e 73 20 2a 72 6d 74 3a 72 65 6d 6f 74 65 2a nns *rmt:remote*
0710: 29 29 29 0a 28 74 65 73 74 20 23 66 20 23 74 20 ))).(test #f #t
0720: 28 72 6d 74 3a 63 6f 6e 6e 3f 20 28 72 6d 74 3a (rmt:conn? (rmt:
0730: 67 65 74 2d 63 6f 6e 6e 20 2a 72 6d 74 3a 72 65 get-conn *rmt:re
0740: 6d 6f 74 65 2a 20 2a 74 6f 70 70 61 74 68 2a 20 mote* *toppath*
0750: 22 2e 64 62 2f 6d 61 69 6e 2e 64 62 22 29 29 29 ".db/main.db")))
0760: 0a 0a 28 64 65 66 69 6e 65 20 2a 6d 61 69 6e 2a ..(define *main*
0770: 20 20 28 72 6d 74 3a 67 65 74 2d 63 6f 6e 6e 20 (rmt:get-conn
0780: 2a 72 6d 74 3a 72 65 6d 6f 74 65 2a 20 2a 74 6f *rmt:remote* *to
0790: 70 70 61 74 68 2a 20 22 2e 64 62 2f 6d 61 69 6e ppath* ".db/main
07a0: 2e 64 62 22 29 29 0a 0a 28 66 6f 72 2d 65 61 63 .db"))..(for-eac
07b0: 68 20 28 6c 61 6d 62 64 61 20 28 74 64 61 74 29 h (lambda (tdat)
07c0: 0a 09 20 20 20 20 28 74 65 73 74 20 23 66 20 74 .. (test #f t
07d0: 64 61 74 20 28 6c 6f 6f 70 2d 74 65 73 74 20 28 dat (loop-test (
07e0: 72 6d 74 3a 63 6f 6e 6e 2d 69 70 61 64 64 72 20 rmt:conn-ipaddr
07f0: 2a 6d 61 69 6e 2a 29 0a 09 09 09 09 20 20 20 20 *main*).....
0800: 20 28 72 6d 74 3a 63 6f 6e 6e 2d 70 6f 72 74 20 (rmt:conn-port
0810: 2a 6d 61 69 6e 2a 29 20 74 64 61 74 29 29 29 0a *main*) tdat))).
0820: 09 20 20 28 6c 69 73 74 20 27 61 0a 09 09 27 28 . (list 'a...'(
0830: 61 20 22 62 22 20 31 32 33 20 31 2e 32 33 20 29 a "b" 123 1.23 )
0840: 29 29 0a 28 74 65 73 74 20 23 66 20 23 74 20 28 )).(test #f #t (
0850: 6e 75 6d 62 65 72 3f 20 28 72 6d 74 3a 73 65 6e number? (rmt:sen
0860: 64 2d 72 65 63 65 69 76 65 20 27 70 69 6e 67 20 d-receive 'ping
0870: 23 66 20 27 68 65 6c 6c 6f 29 29 29 0a 0a 28 64 #f 'hello)))..(d
0880: 65 66 69 6e 65 20 2a 64 62 2a 20 28 64 62 3a 73 efine *db* (db:s
0890: 65 74 75 70 20 23 66 29 29 0a 0a 3b 3b 20 74 68 etup #f))..;; th
08a0: 65 73 65 20 6c 65 74 20 6d 65 20 63 75 74 20 61 ese let me cut a
08b0: 6e 64 20 70 61 73 74 65 20 66 72 6f 6d 20 73 6f nd paste from so
08c0: 75 72 63 65 20 65 61 73 69 6c 79 0a 28 64 65 66 urce easily.(def
08d0: 69 6e 65 20 61 70 61 74 68 20 2a 74 6f 70 70 61 ine apath *toppa
08e0: 74 68 2a 29 0a 28 64 65 66 69 6e 65 20 64 62 6e th*).(define dbn
08f0: 61 6d 65 20 22 2e 64 62 2f 32 2e 64 62 22 29 0a ame ".db/2.db").
0900: 28 64 65 66 69 6e 65 20 72 65 6d 6f 74 65 20 2a (define remote *
0910: 72 6d 74 3a 72 65 6d 6f 74 65 2a 29 0a 28 64 65 rmt:remote*).(de
0920: 66 69 6e 65 20 6b 65 79 76 61 6c 73 20 20 27 28 fine keyvals '(
0930: 28 22 53 59 53 54 45 4d 22 20 22 61 22 29 28 22 ("SYSTEM" "a")("
0940: 52 45 4c 45 41 53 45 22 20 22 62 22 29 29 29 0a RELEASE" "b"))).
0950: 0a 28 74 65 73 74 20 23 66 20 27 73 65 72 76 65 .(test #f 'serve
0960: 72 2d 73 74 61 72 74 65 64 20 28 61 70 69 3a 65 r-started (api:e
0970: 78 65 63 75 74 65 2d 72 65 71 75 65 73 74 73 20 xecute-requests
0980: 2a 64 62 2a 20 27 67 65 74 2d 73 65 72 76 65 72 *db* 'get-server
0990: 20 28 6c 69 73 74 20 2a 74 6f 70 70 61 74 68 2a (list *toppath*
09a0: 20 22 2e 64 62 2f 32 2e 64 62 22 29 29 29 0a 28 ".db/2.db"))).(
09b0: 73 65 74 21 20 2a 64 62 73 74 72 75 63 74 2d 64 set! *dbstruct-d
09c0: 62 2a 20 23 66 29 0a 28 74 65 73 74 20 23 66 20 b* #f).(test #f
09d0: 23 74 20 28 72 6d 74 3a 6f 70 65 6e 2d 6d 61 69 #t (rmt:open-mai
09e0: 6e 2d 63 6f 6e 6e 65 63 74 69 6f 6e 20 72 65 6d n-connection rem
09f0: 6f 74 65 20 61 70 61 74 68 29 29 0a 28 74 65 73 ote apath)).(tes
0a00: 74 20 23 66 20 23 74 20 28 72 6d 74 3a 63 6f 6e t #f #t (rmt:con
0a10: 6e 3f 20 28 72 6d 74 3a 67 65 74 2d 63 6f 6e 6e n? (rmt:get-conn
0a20: 20 2a 72 6d 74 3a 72 65 6d 6f 74 65 2a 20 2a 74 *rmt:remote* *t
0a30: 6f 70 70 61 74 68 2a 20 22 2e 64 62 2f 6d 61 69 oppath* ".db/mai
0a40: 6e 2e 64 62 22 29 29 29 0a 28 74 65 73 74 20 23 n.db"))).(test #
0a50: 66 20 27 73 65 72 76 65 72 2d 73 74 61 72 74 65 f 'server-starte
0a60: 64 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 d (rmt:send-rece
0a70: 69 76 65 2d 72 65 61 6c 20 2a 72 6d 74 3a 72 65 ive-real *rmt:re
0a80: 6d 6f 74 65 2a 20 2a 74 6f 70 70 61 74 68 2a 20 mote* *toppath*
0a90: 22 2e 64 62 2f 6d 61 69 6e 2e 64 62 22 20 27 67 ".db/main.db" 'g
0aa0: 65 74 2d 73 65 72 76 65 72 20 60 28 2c 61 70 61 et-server `(,apa
0ab0: 74 68 20 2c 64 62 6e 61 6d 65 29 29 29 0a 0a 28 th ,dbname)))..(
0ac0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 thread-sleep! 2)
0ad0: 0a 28 74 65 73 74 20 23 66 20 23 74 20 28 6c 69 .(test #f #t (li
0ae0: 73 74 3f 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c st? (rmt:general
0af0: 2d 6f 70 65 6e 2d 63 6f 6e 6e 65 63 74 69 6f 6e -open-connection
0b00: 20 2a 72 6d 74 3a 72 65 6d 6f 74 65 2a 20 2a 74 *rmt:remote* *t
0b10: 6f 70 70 61 74 68 2a 20 22 2e 64 62 2f 32 2e 64 oppath* ".db/2.d
0b20: 62 22 29 29 29 0a 0a 28 74 65 73 74 20 23 66 20 b")))..(test #f
0b30: 27 28 22 53 59 53 54 45 4d 22 20 22 52 45 4c 45 '("SYSTEM" "RELE
0b40: 41 53 45 22 29 20 28 72 6d 74 3a 67 65 74 2d 6b ASE") (rmt:get-k
0b50: 65 79 73 29 29 0a 28 74 65 73 74 20 23 66 20 31 eys)).(test #f 1
0b60: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
0b70: 76 65 20 27 72 65 67 69 73 74 65 72 2d 72 75 6e ve 'register-run
0b80: 20 23 66 20 28 6c 69 73 74 20 6b 65 79 76 61 6c #f (list keyval
0b90: 73 20 22 72 75 6e 31 22 20 22 6e 65 77 22 20 22 s "run1" "new" "
0ba0: 6e 2f 61 22 20 22 6a 75 73 74 6d 65 22 20 23 66 n/a" "justme" #f
0bb0: 29 29 29 0a 28 74 65 73 74 20 23 74 20 31 20 28 ))).(test #t 1 (
0bc0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
0bd0: 20 27 72 65 67 69 73 74 65 72 2d 72 75 6e 20 72 'register-run r
0be0: 75 6e 2d 69 64 20 28 6c 69 73 74 20 6b 65 79 76 un-id (list keyv
0bf0: 61 6c 73 20 22 72 75 6e 31 22 20 22 6e 65 77 22 als "run1" "new"
0c00: 20 22 6e 2f 61 22 20 22 6a 75 73 74 6d 65 22 20 "n/a" "justme"
0c10: 23 66 29 29 29 0a 0a 28 74 65 73 74 20 23 66 20 #f)))..(test #f
0c20: 31 20 28 72 6d 74 3a 72 65 67 69 73 74 65 72 2d 1 (rmt:register-
0c30: 72 75 6e 20 6b 65 79 76 61 6c 73 20 22 72 75 6e run keyvals "run
0c40: 32 22 20 22 6e 65 77 22 20 22 6e 2f 61 22 20 22 2" "new" "n/a" "
0c50: 6a 75 73 74 6d 65 22 20 23 66 29 29 0a 0a 3b 3b justme" #f))..;;
0c60: 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 22 (delete-file* "
0c70: 6c 6f 67 73 2f 31 2e 6c 6f 67 22 29 0a 3b 3b 20 logs/1.log").;;
0c80: 28 64 65 66 69 6e 65 20 72 75 6e 2d 69 64 20 31 (define run-id 1
0c90: 29 0a 0a 3b 3b 20 28 74 65 73 74 20 22 73 65 74 )..;; (test "set
0ca0: 75 70 20 66 6f 72 20 72 75 6e 22 20 23 74 20 28 up for run" #t (
0cb0: 62 65 67 69 6e 20 28 6c 61 75 6e 63 68 3a 73 65 begin (launch:se
0cc0: 74 75 70 29 0a 3b 3b 20 20 09 09 09 09 28 73 74 tup).;; ....(st
0cd0: 72 69 6e 67 3f 20 28 67 65 74 65 6e 76 20 22 4d ring? (getenv "M
0ce0: 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 T_RUN_AREA_HOME"
0cf0: 29 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 74 65 73 )))).;; .;; (tes
0d00: 74 20 23 66 20 23 74 20 28 61 6e 64 20 28 73 65 t #f #t (and (se
0d10: 72 76 65 72 3a 6b 69 6e 64 2d 72 75 6e 20 2a 74 rver:kind-run *t
0d20: 6f 70 70 61 74 68 2a 29 20 23 74 29 29 0a 3b 3b oppath*) #t)).;;
0d30: 20 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 6e 65 .;; .;; (define
0d40: 20 75 73 65 72 20 20 20 20 28 63 75 72 72 65 6e user (curren
0d50: 74 2d 75 73 65 72 2d 6e 61 6d 65 29 29 0a 3b 3b t-user-name)).;;
0d60: 20 28 64 65 66 69 6e 65 20 72 75 6e 6e 61 6d 65 (define runname
0d70: 20 22 6d 79 74 65 73 74 72 75 6e 22 29 0a 3b 3b "mytestrun").;;
0d80: 20 28 64 65 66 69 6e 65 20 6b 65 79 73 20 20 20 (define keys
0d90: 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 (rmt:get-keys))
0da0: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 72 75 6e 69 .;; (define runi
0db0: 6e 66 6f 20 23 66 29 0a 3b 3b 20 28 64 65 66 69 nfo #f).;; (defi
0dc0: 6e 65 20 6b 65 79 76 61 6c 73 20 27 28 28 22 53 ne keyvals '(("S
0dd0: 59 53 54 45 4d 22 20 22 61 62 63 22 29 28 22 52 YSTEM" "abc")("R
0de0: 45 4c 45 41 53 45 22 20 22 64 65 66 22 29 29 29 ELEASE" "def")))
0df0: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 68 65 61 64 .;; (define head
0e00: 65 72 20 20 28 6c 69 73 74 20 22 53 59 53 54 45 er (list "SYSTE
0e10: 4d 22 20 22 52 45 4c 45 41 53 45 22 20 22 69 64 M" "RELEASE" "id
0e20: 22 20 22 72 75 6e 6e 61 6d 65 22 20 22 73 74 61 " "runname" "sta
0e30: 74 65 22 20 22 73 74 61 74 75 73 22 20 22 6f 77 te" "status" "ow
0e40: 6e 65 72 22 20 22 65 76 65 6e 74 5f 74 69 6d 65 ner" "event_time
0e50: 22 29 29 0a 3b 3b 20 0a 3b 3b 20 3b 3b 20 53 65 ")).;; .;; ;; Se
0e60: 74 75 70 0a 3b 3b 20 3b 3b 0a 3b 3b 20 3b 3b 20 tup.;; ;;.;; ;;
0e70: 28 74 65 73 74 20 23 66 20 23 66 20 20 28 6e 6f (test #f #f (no
0e80: 74 20 28 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 t (client:setup
0e90: 72 75 6e 2d 69 64 29 29 29 0a 3b 3b 20 3b 3b 20 run-id))).;; ;;
0ea0: 28 74 65 73 74 20 23 66 20 23 66 20 20 28 6e 6f (test #f #f (no
0eb0: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
0ec0: 66 2f 64 65 66 61 75 6c 74 20 2a 72 75 6e 72 65 f/default *runre
0ed0: 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 23 66 29 mote* run-id #f)
0ee0: 29 29 0a 3b 3b 20 0a 3b 3b 20 3b 3b 20 4c 6f 67 )).;; .;; ;; Log
0ef0: 69 6e 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 74 65 73 in.;; ;;.;; (tes
0f00: 74 20 23 66 27 28 23 74 20 22 73 75 63 63 65 73 t #f'(#t "succes
0f10: 73 66 75 6c 20 6c 6f 67 69 6e 22 29 0a 3b 3b 20 sful login").;;
0f20: 20 20 20 20 20 20 28 72 6d 74 3a 6c 6f 67 69 6e (rmt:login
0f30: 20 72 75 6e 2d 69 64 29 29 0a 3b 3b 20 0a 3b 3b run-id)).;; .;;
0f40: 20 3b 3b 20 4b 65 79 73 0a 3b 3b 20 3b 3b 0a 3b ;; Keys.;; ;;.;
0f50: 3b 20 28 74 65 73 74 20 23 66 20 27 28 22 53 59 ; (test #f '("SY
0f60: 53 54 45 4d 22 20 22 52 45 4c 45 41 53 45 22 29 STEM" "RELEASE")
0f70: 20 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 (rmt:get-keys)
0f80: 29 0a 3b 3b 20 0a 3b 3b 20 3b 3b 20 4e 6f 20 64 ).;; .;; ;; No d
0f90: 61 74 61 20 69 6e 20 64 62 0a 3b 3b 20 3b 3b 0a ata in db.;; ;;.
0fa0: 3b 3b 20 28 74 65 73 74 20 23 66 20 27 28 29 20 ;; (test #f '()
0fb0: 28 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e (rmt:get-all-run
0fc0: 2d 69 64 73 29 29 0a 3b 3b 20 28 74 65 73 74 20 -ids)).;; (test
0fd0: 23 66 20 23 66 20 20 28 72 6d 74 3a 67 65 74 2d #f #f (rmt:get-
0fe0: 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 run-name-from-id
0ff0: 20 72 75 6e 2d 69 64 29 29 0a 3b 3b 20 28 74 65 run-id)).;; (te
1000: 73 74 20 23 66 20 0a 3b 3b 20 20 20 20 20 20 20 st #f .;;
1010: 28 76 65 63 74 6f 72 0a 3b 3b 20 20 20 20 20 20 (vector.;;
1020: 20 20 68 65 61 64 65 72 0a 3b 3b 20 20 20 20 20 header.;;
1030: 20 20 20 28 76 65 63 74 6f 72 20 23 66 20 23 66 (vector #f #f
1040: 20 23 66 20 23 66 29 29 0a 3b 3b 20 20 20 20 20 #f #f)).;;
1050: 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 (rmt:get-run-i
1060: 6e 66 6f 20 72 75 6e 2d 69 64 29 29 0a 3b 3b 20 nfo run-id)).;;
1070: 0a 3b 3b 20 3b 3b 20 49 6e 73 65 72 74 20 64 61 .;; ;; Insert da
1080: 74 61 20 69 6e 74 6f 20 64 62 0a 3b 3b 20 3b 3b ta into db.;; ;;
1090: 0a 3b 3b 20 28 74 65 73 74 20 23 66 20 31 20 28 .;; (test #f 1 (
10a0: 72 6d 74 3a 72 65 67 69 73 74 65 72 2d 72 75 6e rmt:register-run
10b0: 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 keyvals runname
10c0: 20 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 73 65 "new" "n/a" use
10d0: 72 29 29 0a 3b 3b 20 3b 3b 20 28 74 65 73 74 20 r)).;; ;; (test
10e0: 23 66 20 23 66 20 28 72 6d 74 3a 67 65 74 2d 72 #f #f (rmt:get-r
10f0: 75 6e 73 2d 62 79 2d 70 61 74 74 20 6b 65 79 73 uns-by-patt keys
1100: 20 72 75 6e 6e 61 6d 65 29 29 0a 3b 3b 20 28 74 runname)).;; (t
1110: 65 73 74 20 23 66 20 23 74 20 28 72 6d 74 3a 67 est #f #t (rmt:g
1120: 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 72 65 67 eneral-call 'reg
1130: 69 73 74 65 72 2d 74 65 73 74 20 72 75 6e 2d 69 ister-test run-i
1140: 64 20 72 75 6e 2d 69 64 20 22 74 65 73 74 2d 6f d run-id "test-o
1150: 6e 65 22 20 22 22 29 29 0a 3b 3b 20 28 64 65 66 ne" "")).;; (def
1160: 69 6e 65 20 74 65 73 74 2d 6f 6e 65 2d 69 64 20 ine test-one-id
1170: 23 66 29 0a 3b 3b 20 28 74 65 73 74 20 23 66 20 #f).;; (test #f
1180: 31 20 20 28 6c 65 74 20 28 28 74 65 73 74 2d 69 1 (let ((test-i
1190: 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d d (rmt:get-test-
11a0: 69 64 20 72 75 6e 2d 69 64 20 22 74 65 73 74 2d id run-id "test-
11b0: 6f 6e 65 22 20 22 22 29 29 29 0a 3b 3b 20 09 20 one" ""))).;; .
11c0: 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 2d (set! test-
11d0: 6f 6e 65 2d 69 64 20 74 65 73 74 2d 69 64 29 0a one-id test-id).
11e0: 3b 3b 20 09 20 20 20 20 20 20 74 65 73 74 2d 69 ;; . test-i
11f0: 64 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 74 d)).;; (define t
1200: 65 73 74 2d 6f 6e 65 2d 72 65 63 20 23 66 29 0a est-one-rec #f).
1210: 3b 3b 20 28 74 65 73 74 20 23 66 20 22 74 65 73 ;; (test #f "tes
1220: 74 2d 6f 6e 65 22 20 28 6c 65 74 20 28 28 74 65 t-one" (let ((te
1230: 73 74 2d 72 65 63 20 28 72 6d 74 3a 67 65 74 2d st-rec (rmt:get-
1240: 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 test-info-by-id
1250: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6f 6e 65 2d run-id test-one-
1260: 69 64 29 29 29 0a 3b 3b 20 09 09 20 20 20 20 20 id))).;; ..
1270: 20 28 73 65 74 21 20 74 65 73 74 2d 6f 6e 65 2d (set! test-one-
1280: 72 65 63 20 74 65 73 74 2d 72 65 63 29 0a 3b 3b rec test-rec).;;
1290: 20 09 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 .. (vector
12a0: 2d 72 65 66 20 74 65 73 74 2d 72 65 63 20 32 29 -ref test-rec 2)
12b0: 29 29 0a 3b 3b 20 0a 3b 3b 20 3b 3b 20 57 69 74 )).;; .;; ;; Wit
12c0: 68 20 64 61 74 61 20 69 6e 20 64 62 0a 3b 3b 20 h data in db.;;
12d0: 3b 3b 0a 3b 3b 20 28 70 72 69 6e 74 20 22 55 73 ;;.;; (print "Us
12e0: 69 6e 67 20 72 75 6e 61 6d 65 3d 22 20 72 75 6e ing runame=" run
12f0: 6e 61 6d 65 29 0a 3b 3b 20 28 74 65 73 74 20 23 name).;; (test #
1300: 66 20 27 28 31 29 20 20 20 20 28 72 6d 74 3a 67 f '(1) (rmt:g
1310: 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 29 et-all-run-ids))
1320: 0a 3b 3b 20 28 74 65 73 74 20 23 66 20 72 75 6e .;; (test #f run
1330: 6e 61 6d 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 name (rmt:get-ru
1340: 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 72 n-name-from-id r
1350: 75 6e 2d 69 64 29 29 0a 3b 3b 20 28 74 65 73 74 un-id)).;; (test
1360: 20 23 66 20 0a 3b 3b 20 20 20 20 20 20 20 72 75 #f .;; ru
1370: 6e 6e 61 6d 65 0a 3b 3b 20 20 20 20 20 20 20 28 nname.;; (
1380: 6c 65 74 20 28 28 72 75 6e 2d 69 6e 66 6f 20 28 let ((run-info (
1390: 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 6e 66 6f rmt:get-run-info
13a0: 20 72 75 6e 2d 69 64 29 29 29 0a 3b 3b 20 09 28 run-id))).;; .(
13b0: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
13c0: 68 65 61 64 65 72 20 28 64 62 3a 67 65 74 2d 72 header (db:get-r
13d0: 6f 77 73 20 72 75 6e 2d 69 6e 66 6f 29 0a 3b 3b ows run-info).;;
13e0: 20 09 09 09 09 28 64 62 3a 67 65 74 2d 68 65 61 ....(db:get-hea
13f0: 64 65 72 20 72 75 6e 2d 69 6e 66 6f 29 0a 3b 3b der run-info).;;
1400: 20 09 09 09 09 22 72 75 6e 6e 61 6d 65 22 29 29 ...."runname"))
1410: 29 0a 3b 3b 20 0a 3b 3b 20 3b 3b 20 74 65 73 74 ).;; .;; ;; test
1420: 20 6b 69 6c 6c 69 6e 67 20 73 65 72 76 65 72 0a killing server.
1430: 3b 3b 20 3b 3b 0a 3b 3b 20 28 66 6f 72 2d 65 61 ;; ;;.;; (for-ea
1440: 63 68 0a 3b 3b 20 20 28 6c 61 6d 62 64 61 20 28 ch.;; (lambda (
1450: 72 75 6e 2d 69 64 29 0a 3b 3b 20 20 20 20 28 74 run-id).;; (t
1460: 65 73 74 20 23 66 20 23 74 20 28 61 6e 64 20 28 est #f #t (and (
1470: 74 61 73 6b 73 3a 6b 69 6c 6c 2d 73 65 72 76 65 tasks:kill-serve
1480: 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 29 r-run-id run-id)
1490: 20 23 74 29 29 0a 3b 3b 20 20 20 20 28 74 65 73 #t)).;; (tes
14a0: 74 20 23 66 20 23 66 20 28 74 61 73 6b 73 3a 73 t #f #f (tasks:s
14b0: 65 72 76 65 72 2d 72 75 6e 6e 69 6e 67 2d 6f 72 erver-running-or
14c0: 2d 73 74 61 72 74 69 6e 67 3f 20 28 64 62 3a 64 -starting? (db:d
14d0: 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 28 74 61 elay-if-busy (ta
14e0: 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 20 72 75 sks:open-db)) ru
14f0: 6e 2d 69 64 29 29 29 0a 3b 3b 20 20 28 6c 69 73 n-id))).;; (lis
1500: 74 20 30 20 31 29 29 0a 3b 3b 20 0a 3b 3b 20 3b t 0 1)).;; .;; ;
1510: 3b 20 54 65 73 74 73 20 74 6f 20 61 73 73 65 73 ; Tests to asses
1520: 73 20 72 65 61 64 69 6e 67 2f 77 72 69 74 69 6e s reading/writin
1530: 67 20 77 68 69 6c 65 20 73 65 72 76 65 72 73 20 g while servers
1540: 61 72 65 20 73 74 61 72 74 69 6e 67 2f 73 74 6f are starting/sto
1550: 70 70 69 6e 67 0a 3b 3b 20 3b 3b 20 4e 4f 20 4c pping.;; ;; NO L
1560: 4f 4e 47 45 52 20 41 50 50 4c 49 43 41 42 4c 45 ONGER APPLICABLE
1570: 0a 3b 3b 20 0a 3b 3b 20 3b 3b 20 53 65 72 76 65 .;; .;; ;; Serve
1580: 72 20 74 65 73 74 73 20 67 6f 20 68 65 72 65 0a r tests go here.
1590: 3b 3b 20 28 64 65 66 69 6e 65 20 28 73 65 72 76 ;; (define (serv
15a0: 65 72 2d 74 65 73 74 73 2d 64 6f 6e 74 2d 72 75 er-tests-dont-ru
15b0: 6e 2d 72 69 67 68 74 2d 6e 6f 77 29 0a 3b 3b 20 n-right-now).;;
15c0: 28 66 6f 72 2d 65 61 63 68 0a 3b 3b 20 20 28 6c (for-each.;; (l
15d0: 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 29 0a 3b ambda (run-id).;
15e0: 3b 20 20 20 20 28 74 65 73 74 20 23 66 20 23 66 ; (test #f #f
15f0: 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 72 (tasks:server-r
1600: 75 6e 6e 69 6e 67 2d 6f 72 2d 73 74 61 72 74 69 unning-or-starti
1610: 6e 67 3f 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 ng? (db:delay-if
1620: 2d 62 75 73 79 20 28 74 61 73 6b 73 3a 6f 70 65 -busy (tasks:ope
1630: 6e 2d 64 62 29 29 20 72 75 6e 2d 69 64 29 29 0a n-db)) run-id)).
1640: 3b 3b 20 20 20 20 28 73 65 72 76 65 72 3a 6b 69 ;; (server:ki
1650: 6e 64 2d 72 75 6e 20 72 75 6e 2d 69 64 29 0a 3b nd-run run-id).;
1660: 3b 20 20 20 20 28 74 65 73 74 20 22 64 69 64 20 ; (test "did
1670: 73 65 72 76 65 72 20 73 74 61 72 74 20 77 69 74 server start wit
1680: 68 69 6e 20 32 30 20 73 65 63 6f 6e 64 73 3f 22 hin 20 seconds?"
1690: 0a 3b 3b 20 09 20 23 74 0a 3b 3b 20 09 20 28 6c .;; . #t.;; . (l
16a0: 65 74 20 6c 6f 6f 70 20 28 28 72 65 6d 74 72 69 et loop ((remtri
16b0: 65 73 20 32 30 29 0a 3b 3b 20 09 09 20 20 20 20 es 20).;; ..
16c0: 28 72 75 6e 6e 69 6e 67 20 28 74 61 73 6b 73 3a (running (tasks:
16d0: 73 65 72 76 65 72 2d 72 75 6e 6e 69 6e 67 2d 6f server-running-o
16e0: 72 2d 73 74 61 72 74 69 6e 67 3f 20 28 64 62 3a r-starting? (db:
16f0: 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 0a 3b 3b delay-if-busy.;;
1700: 20 09 09 09 09 09 09 09 09 20 28 74 61 73 6b 73 ........ (tasks
1710: 3a 6f 70 65 6e 2d 64 62 29 29 0a 3b 3b 20 09 09 :open-db)).;; ..
1720: 09 09 09 09 09 09 72 75 6e 2d 69 64 29 29 29 0a ......run-id))).
1730: 3b 3b 20 09 20 20 20 28 69 66 20 72 75 6e 6e 69 ;; . (if runni
1740: 6e 67 20 0a 3b 3b 20 09 20 20 20 20 20 20 20 28 ng .;; . (
1750: 3e 20 72 75 6e 6e 69 6e 67 20 30 29 0a 3b 3b 20 > running 0).;;
1760: 09 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 72 . (if (> r
1770: 65 6d 74 72 69 65 73 20 30 29 0a 3b 3b 20 09 09 emtries 0).;; ..
1780: 20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 09 09 20 (begin.;; ..
1790: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
17a0: 70 21 20 31 29 0a 3b 3b 20 09 09 20 20 20 20 20 p! 1).;; ..
17b0: 28 6c 6f 6f 70 20 28 2d 20 72 65 6d 74 72 69 65 (loop (- remtrie
17c0: 73 20 31 29 0a 3b 3b 20 09 09 09 20 20 20 28 74 s 1).;; ... (t
17d0: 61 73 6b 73 3a 73 65 72 76 65 72 2d 72 75 6e 6e asks:server-runn
17e0: 69 6e 67 2d 6f 72 2d 73 74 61 72 74 69 6e 67 3f ing-or-starting?
17f0: 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 (db:delay-if-bu
1800: 73 79 0a 3b 3b 20 09 09 09 09 09 09 09 20 20 20 sy.;; .......
1810: 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d (tasks:open-
1820: 64 62 29 29 0a 3b 3b 20 09 09 09 09 09 09 09 20 db)).;; .......
1830: 20 20 20 20 20 72 75 6e 2d 69 64 29 29 29 29 29 run-id)))))
1840: 29 29 0a 3b 3b 20 20 20 20 0a 3b 3b 20 20 20 20 )).;; .;;
1850: 28 74 65 73 74 20 22 64 69 64 20 73 65 72 76 65 (test "did serve
1860: 72 20 62 65 63 6f 6d 65 20 61 76 61 69 6c 61 62 r become availab
1870: 6c 65 22 20 23 74 0a 3b 3b 20 09 20 28 6c 65 74 le" #t.;; . (let
1880: 20 6c 6f 6f 70 20 28 28 72 65 6d 74 72 69 65 73 loop ((remtries
1890: 20 31 30 29 0a 3b 3b 20 09 09 20 20 20 20 28 72 10).;; .. (r
18a0: 65 73 20 20 20 20 20 20 28 74 61 73 6b 73 3a 67 es (tasks:g
18b0: 65 74 2d 73 65 72 76 65 72 20 28 64 62 3a 64 65 et-server (db:de
18c0: 6c 61 79 2d 69 66 2d 62 75 73 79 20 28 74 61 73 lay-if-busy (tas
18d0: 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 20 72 75 6e ks:open-db)) run
18e0: 2d 69 64 29 29 29 0a 3b 3b 20 09 20 20 20 28 69 -id))).;; . (i
18f0: 66 20 72 65 73 0a 3b 3b 20 09 20 20 20 20 20 20 f res.;; .
1900: 20 28 76 65 63 74 6f 72 3f 20 72 65 73 29 0a 3b (vector? res).;
1910: 3b 20 09 20 20 20 20 20 20 20 28 62 65 67 69 6e ; . (begin
1920: 0a 3b 3b 20 09 09 20 28 69 66 20 28 3e 20 72 65 .;; .. (if (> re
1930: 6d 74 72 69 65 73 20 30 29 0a 3b 3b 20 09 09 20 mtries 0).;; ..
1940: 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 09 09 (begin.;; ..
1950: 20 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 (thread-s
1960: 6c 65 65 70 21 20 31 2e 31 29 0a 3b 3b 20 09 09 leep! 1.1).;; ..
1970: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 2d 20 (loop (-
1980: 72 65 6d 74 72 69 65 73 20 31 29 28 74 61 73 6b remtries 1)(task
1990: 73 3a 67 65 74 2d 73 65 72 76 65 72 20 28 64 62 s:get-server (db
19a0: 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 28 :delay-if-busy (
19b0: 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 20 tasks:open-db))
19c0: 72 75 6e 2d 69 64 29 29 29 0a 3b 3b 20 09 09 20 run-id))).;; ..
19d0: 20 20 20 20 72 65 73 29 29 29 29 29 0a 3b 3b 20 res))))).;;
19e0: 20 20 20 29 0a 3b 3b 20 20 28 6c 69 73 74 20 30 ).;; (list 0
19f0: 20 31 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 1))).;; .;; (de
1a00: 66 69 6e 65 20 73 74 61 72 74 2d 74 69 6d 65 20 fine start-time
1a10: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
1a20: 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 72 )).;; (define (r
1a30: 65 61 64 69 6e 67 2d 77 72 69 74 69 6e 67 2d 77 eading-writing-w
1a40: 68 69 6c 65 2d 73 65 72 76 65 72 2d 73 74 61 72 hile-server-star
1a50: 74 69 6e 67 2d 73 74 6f 70 70 69 6e 67 2d 64 6f ting-stopping-do
1a60: 6e 74 2d 72 75 6e 2d 6e 6f 77 29 0a 3b 3b 20 28 nt-run-now).;; (
1a70: 6c 65 74 20 6c 6f 6f 70 20 28 28 74 65 73 74 2d let loop ((test-
1a80: 73 74 61 74 65 20 27 73 74 61 72 74 29 29 0a 3b state 'start)).;
1a90: 3b 20 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 ; (let* ((serv
1aa0: 65 72 2d 64 61 74 73 20 28 74 61 73 6b 73 3a 67 er-dats (tasks:g
1ab0: 65 74 2d 73 65 72 76 65 72 2d 72 65 63 6f 72 64 et-server-record
1ac0: 73 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 s (db:delay-if-b
1ad0: 75 73 79 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d usy (tasks:open-
1ae0: 64 62 29 29 20 72 75 6e 2d 69 64 29 29 0a 3b 3b db)) run-id)).;;
1af0: 20 09 20 28 66 69 72 73 74 2d 64 61 74 20 20 20 . (first-dat
1b00: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
1b10: 73 65 72 76 65 72 2d 64 61 74 73 29 29 0a 3b 3b server-dats)).;;
1b20: 20 09 09 09 20 20 28 63 61 72 20 73 65 72 76 65 ... (car serve
1b30: 72 2d 64 61 74 73 29 0a 3b 3b 20 09 09 09 20 20 r-dats).;; ...
1b40: 23 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 6d 61 #f))).;; (ma
1b50: 70 20 28 6c 61 6d 62 64 61 20 28 64 61 74 29 0a p (lambda (dat).
1b60: 3b 3b 20 09 20 20 20 28 61 70 70 6c 79 20 70 72 ;; . (apply pr
1b70: 69 6e 74 20 28 69 6e 74 65 72 73 70 65 72 73 65 int (intersperse
1b80: 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 64 (vector->list d
1b90: 61 74 29 20 22 2c 20 22 29 29 29 0a 3b 3b 20 09 at) ", "))).;; .
1ba0: 20 73 65 72 76 65 72 2d 64 61 74 73 29 0a 3b 3b server-dats).;;
1bb0: 20 20 20 20 20 28 74 65 73 74 20 23 66 20 74 65 (test #f te
1bc0: 73 74 2d 6f 6e 65 2d 72 65 63 20 28 72 6d 74 3a st-one-rec (rmt:
1bd0: 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 get-test-info-by
1be0: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
1bf0: 6f 6e 65 2d 69 64 29 29 0a 3b 3b 20 20 20 20 20 one-id)).;;
1c00: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 (thread-sleep! 1
1c10: 29 0a 3b 3b 20 20 20 20 20 28 63 61 73 65 20 74 ).;; (case t
1c20: 65 73 74 2d 73 74 61 74 65 0a 3b 3b 20 20 20 20 est-state.;;
1c30: 20 20 20 28 28 73 74 61 72 74 29 0a 3b 3b 20 20 ((start).;;
1c40: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 54 72 (print "Tr
1c50: 79 69 6e 67 20 74 6f 20 73 74 61 72 74 20 73 65 ying to start se
1c60: 72 76 65 72 22 29 0a 3b 3b 20 20 20 20 20 20 20 rver").;;
1c70: 20 28 73 65 72 76 65 72 3a 6b 69 6e 64 2d 72 75 (server:kind-ru
1c80: 6e 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 20 20 20 n run-id).;;
1c90: 20 20 20 20 28 6c 6f 6f 70 20 27 73 65 72 76 65 (loop 'serve
1ca0: 72 2d 73 74 61 72 74 65 64 29 29 0a 3b 3b 20 20 r-started)).;;
1cb0: 20 20 20 20 20 28 28 73 65 72 76 65 72 2d 73 74 ((server-st
1cc0: 61 72 74 65 64 29 0a 3b 3b 20 20 20 20 20 20 20 arted).;;
1cd0: 20 28 63 61 73 65 20 28 69 66 20 66 69 72 73 74 (case (if first
1ce0: 2d 64 61 74 20 28 76 65 63 74 6f 72 2d 72 65 66 -dat (vector-ref
1cf0: 20 66 69 72 73 74 2d 64 61 74 20 30 29 20 27 62 first-dat 0) 'b
1d00: 6c 61 68 29 0a 3b 3b 20 09 20 28 28 72 75 6e 6e lah).;; . ((runn
1d10: 69 6e 67 29 0a 3b 3b 20 09 20 20 28 70 72 69 6e ing).;; . (prin
1d20: 74 20 22 53 65 72 76 65 72 20 61 70 70 65 61 72 t "Server appear
1d30: 73 20 74 6f 20 62 65 20 72 75 6e 6e 69 6e 67 2e s to be running.
1d40: 20 4e 6f 77 20 61 73 6b 20 69 74 20 74 6f 20 73 Now ask it to s
1d50: 68 75 74 64 6f 77 6e 22 29 0a 3b 3b 20 09 20 20 hutdown").;; .
1d60: 28 72 6d 74 3a 6b 69 6c 6c 2d 73 65 72 76 65 72 (rmt:kill-server
1d70: 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 09 20 20 28 run-id).;; . (
1d80: 6c 6f 6f 70 20 27 73 65 72 76 65 72 2d 73 68 75 loop 'server-shu
1d90: 74 64 6f 77 6e 29 29 0a 3b 3b 20 09 20 28 28 73 tdown)).;; . ((s
1da0: 68 75 74 74 69 6e 67 2d 64 6f 77 6e 29 0a 3b 3b hutting-down).;;
1db0: 20 09 20 20 28 6c 6f 6f 70 20 74 65 73 74 2d 73 . (loop test-s
1dc0: 74 61 74 65 29 29 0a 3b 3b 20 09 20 28 65 6c 73 tate)).;; . (els
1dd0: 65 20 28 70 72 69 6e 74 20 22 44 6f 6e 27 74 20 e (print "Don't
1de0: 6b 6e 6f 77 20 77 68 61 74 20 74 6f 20 64 6f 20 know what to do
1df0: 69 66 20 67 65 74 20 68 65 72 65 22 29 29 29 29 if get here"))))
1e00: 0a 3b 3b 20 20 20 20 20 20 20 28 28 73 65 72 76 .;; ((serv
1e10: 65 72 2d 73 68 75 74 64 6f 77 6e 29 0a 3b 3b 20 er-shutdown).;;
1e20: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 74 65 73 (loop tes
1e30: 74 2d 73 74 61 74 65 29 29 29 29 29 0a 3b 3b 20 t-state))))).;;
1e40: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
1e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 ===========.;; E
1e90: 4e 44 20 4f 46 20 54 45 53 54 53 0a 3b 3b 3d 3d ND OF TESTS.;;==
1ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ee0: 3d 3d 3d 3d 0a 0a 0a 3b 3b 20 28 74 65 73 74 20 ====...;; (test
1ef0: 23 66 20 23 66 20 28 63 6c 69 65 6e 74 3a 73 65 #f #f (client:se
1f00: 74 75 70 20 72 75 6e 2d 69 64 29 29 0a 0a 3b 3b tup run-id))..;;
1f10: 20 28 73 65 74 21 20 2a 74 72 61 6e 73 70 6f 72 (set! *transpor
1f20: 74 2d 74 79 70 65 2a 20 27 68 74 74 70 29 0a 3b t-type* 'http).;
1f30: 3b 20 0a 3b 3b 20 28 74 65 73 74 20 22 73 65 74 ; .;; (test "set
1f40: 75 70 20 66 6f 72 20 72 75 6e 22 20 23 74 20 28 up for run" #t (
1f50: 62 65 67 69 6e 20 28 6c 61 75 6e 63 68 3a 73 65 begin (launch:se
1f60: 74 75 70 2d 66 6f 72 2d 72 75 6e 29 0a 3b 3b 20 tup-for-run).;;
1f70: 09 09 09 09 28 73 74 72 69 6e 67 3f 20 28 67 65 ....(string? (ge
1f80: 74 65 6e 76 20 22 4d 54 5f 52 55 4e 5f 41 52 45 tenv "MT_RUN_ARE
1f90: 41 5f 48 4f 4d 45 22 29 29 29 29 0a 3b 3b 20 0a A_HOME")))).;; .
1fa0: 3b 3b 20 28 74 65 73 74 20 22 73 65 72 76 65 72 ;; (test "server
1fb0: 2d 72 65 67 69 73 74 65 72 2c 20 67 65 74 2d 62 -register, get-b
1fc0: 65 73 74 2d 73 65 72 76 65 72 22 20 23 74 20 28 est-server" #t (
1fd0: 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 0a 3b let ((res #f)).;
1fe0: 3b 20 09 09 09 09 09 20 20 20 20 20 20 28 6f 70 ; ..... (op
1ff0: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 en-run-close tas
2000: 6b 73 3a 73 65 72 76 65 72 2d 72 65 67 69 73 74 ks:server-regist
2010: 65 72 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 er tasks:open-db
2020: 20 31 20 22 62 6f 62 22 20 31 32 33 34 20 31 30 1 "bob" 1234 10
2030: 30 20 27 6c 69 76 65 20 27 68 74 74 70 29 0a 3b 0 'live 'http).;
2040: 3b 20 09 09 09 09 09 20 20 20 20 20 20 28 73 65 ; ..... (se
2050: 74 21 20 72 65 73 20 28 6f 70 65 6e 2d 72 75 6e t! res (open-run
2060: 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 67 65 74 -close tasks:get
2070: 2d 62 65 73 74 2d 73 65 72 76 65 72 20 74 61 73 -best-server tas
2080: 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 0a 3b 3b 20 ks:open-db)).;;
2090: 09 09 09 09 09 20 20 20 20 20 20 28 6e 75 6d 62 ..... (numb
20a0: 65 72 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 er? (vector-ref
20b0: 72 65 73 20 33 29 29 29 29 0a 3b 3b 20 0a 3b 3b res 3)))).;; .;;
20c0: 20 28 74 65 73 74 20 22 64 65 2d 72 65 67 69 73 (test "de-regis
20d0: 74 65 72 20 73 65 72 76 65 72 22 20 23 66 20 28 ter server" #f (
20e0: 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 0a 3b let ((res #f)).;
20f0: 3b 20 09 09 09 09 28 6f 70 65 6e 2d 72 75 6e 2d ; ....(open-run-
2100: 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 76 close tasks:serv
2110: 65 72 2d 64 65 72 65 67 69 73 74 65 72 20 74 61 er-deregister ta
2120: 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 22 62 6f 62 sks:open-db "bob
2130: 22 20 70 6f 72 74 3a 20 31 32 33 34 29 0a 3b 3b " port: 1234).;;
2140: 20 09 09 09 09 28 76 65 63 74 6f 72 3f 20 28 6f ....(vector? (o
2150: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 pen-run-close ta
2160: 73 6b 73 3a 67 65 74 2d 62 65 73 74 2d 73 65 72 sks:get-best-ser
2170: 76 65 72 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 ver tasks:open-d
2180: 62 29 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 b)))).;; .;; (de
2190: 66 69 6e 65 20 73 65 72 76 65 72 2d 70 69 64 20 fine server-pid
21a0: 23 66 29 0a 3b 3b 20 0a 3b 3b 20 3b 3b 20 4e 6f #f).;; .;; ;; No
21b0: 74 20 73 75 72 65 20 68 6f 77 20 74 68 65 20 66 t sure how the f
21c0: 6f 6c 6c 6f 77 69 6e 67 20 73 68 6f 75 6c 64 20 ollowing should
21d0: 77 6f 72 6b 2c 20 72 65 70 6c 61 63 69 6e 67 20 work, replacing
21e0: 69 74 20 77 69 74 68 20 73 79 73 74 65 6d 20 6f it with system o
21f0: 66 20 6d 65 67 61 74 65 73 74 20 2d 73 65 72 76 f megatest -serv
2200: 65 72 0a 3b 3b 20 3b 3b 20 28 74 65 73 74 20 22 er.;; ;; (test "
2210: 6c 61 75 6e 63 68 20 73 65 72 76 65 72 22 20 23 launch server" #
2220: 74 20 28 6c 65 74 20 28 28 70 69 64 20 28 70 72 t (let ((pid (pr
2230: 6f 63 65 73 73 2d 66 6f 72 6b 20 28 6c 61 6d 62 ocess-fork (lamb
2240: 64 61 20 28 29 0a 3b 3b 20 3b 3b 20 09 09 09 09 da ().;; ;; ....
2250: 09 09 20 20 20 20 3b 3b 20 28 64 61 65 6d 6f 6e .. ;; (daemon
2260: 3a 69 7a 65 29 0a 3b 3b 20 3b 3b 20 09 09 09 09 :ize).;; ;; ....
2270: 09 09 20 20 20 20 28 73 65 72 76 65 72 3a 6c 61 .. (server:la
2280: 75 6e 63 68 20 27 68 74 74 70 29 29 29 29 29 0a unch 'http))))).
2290: 3b 3b 20 3b 3b 20 09 09 09 20 20 20 28 73 65 74 ;; ;; ... (set
22a0: 21 20 73 65 72 76 65 72 2d 70 69 64 20 70 69 64 ! server-pid pid
22b0: 29 0a 3b 3b 20 3b 3b 20 09 09 09 20 20 20 28 6e ).;; ;; ... (n
22c0: 75 6d 62 65 72 3f 20 70 69 64 29 29 29 0a 3b 3b umber? pid))).;;
22d0: 20 28 73 79 73 74 65 6d 20 22 2e 2e 2f 2e 2e 2f (system "../../
22e0: 62 69 6e 2f 6d 65 67 61 74 65 73 74 20 2d 73 65 bin/megatest -se
22f0: 72 76 65 72 20 2d 20 2d 64 65 62 75 67 62 63 6f rver - -debugbco
2300: 6d 20 32 32 20 3e 20 73 65 72 76 65 72 2e 6c 6f m 22 > server.lo
2310: 67 20 32 3e 20 73 65 72 76 65 72 2e 6c 6f 67 20 g 2> server.log
2320: 26 22 29 0a 3b 3b 20 0a 3b 3b 20 28 6c 65 74 20 &").;; .;; (let
2330: 6c 6f 6f 70 20 28 28 6e 20 31 30 29 29 0a 3b 3b loop ((n 10)).;;
2340: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
2350: 21 20 31 29 20 3b 3b 20 6e 65 65 64 20 74 6f 20 ! 1) ;; need to
2360: 77 61 69 74 20 66 6f 72 20 73 65 72 76 65 72 20 wait for server
2370: 74 6f 20 73 74 61 72 74 2e 0a 3b 3b 20 20 20 28 to start..;; (
2380: 6c 65 74 20 28 28 72 65 73 20 28 6f 70 65 6e 2d let ((res (open-
2390: 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a run-close tasks:
23a0: 67 65 74 2d 62 65 73 74 2d 73 65 72 76 65 72 20 get-best-server
23b0: 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 29 tasks:open-db)))
23c0: 0a 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 20 22 .;; (print "
23d0: 74 61 73 6b 73 3a 67 65 74 2d 62 65 73 74 2d 73 tasks:get-best-s
23e0: 65 72 76 65 72 20 72 65 74 75 72 6e 65 64 20 22 erver returned "
23f0: 20 72 65 73 29 0a 3b 3b 20 20 20 20 20 28 69 66 res).;; (if
2400: 20 28 61 6e 64 20 28 6e 6f 74 20 72 65 73 29 0a (and (not res).
2410: 3b 3b 20 09 20 20 20 20 20 28 3e 20 6e 20 30 29 ;; . (> n 0)
2420: 29 0a 3b 3b 20 09 28 6c 6f 6f 70 20 28 2d 20 6e ).;; .(loop (- n
2430: 20 31 29 29 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 1))))).;; .;; (
2440: 74 65 73 74 20 22 67 65 74 2d 62 65 73 74 2d 73 test "get-best-s
2450: 65 72 76 65 72 22 20 23 74 20 28 62 65 67 69 6e erver" #t (begin
2460: 20 0a 3b 3b 20 09 09 09 20 20 20 20 20 28 63 6c .;; ... (cl
2470: 69 65 6e 74 3a 6c 61 75 6e 63 68 29 0a 3b 3b 20 ient:launch).;;
2480: 09 09 09 20 20 20 20 20 28 6c 65 74 20 28 28 64 ... (let ((d
2490: 61 74 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f at (open-run-clo
24a0: 73 65 20 74 61 73 6b 73 3a 67 65 74 2d 62 65 73 se tasks:get-bes
24b0: 74 2d 73 65 72 76 65 72 20 74 61 73 6b 73 3a 6f t-server tasks:o
24c0: 70 65 6e 2d 64 62 29 29 29 0a 3b 3b 20 09 09 09 pen-db))).;; ...
24d0: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 3f 20 (vector?
24e0: 64 61 74 29 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 dat)))).;; .;; (
24f0: 64 65 66 69 6e 65 20 2a 6b 65 79 73 2a 20 20 20 define *keys*
2500: 20 20 20 20 20 20 20 20 20 20 20 20 28 6b 65 79 (key
2510: 73 3a 63 6f 6e 66 69 67 2d 67 65 74 2d 66 69 65 s:config-get-fie
2520: 6c 64 73 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 lds *configdat*)
2530: 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 2a 6b 65 ).;; (define *ke
2540: 79 76 61 6c 73 2a 20 20 20 20 20 20 20 20 20 20 yvals*
2550: 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e (keys:target->
2560: 6b 65 79 76 61 6c 20 2a 6b 65 79 73 2a 20 22 61 keyval *keys* "a
2570: 2f 62 2f 63 22 29 29 0a 3b 3b 20 0a 3b 3b 20 28 /b/c")).;; .;; (
2580: 74 65 73 74 20 23 66 20 23 74 20 20 20 20 20 20 test #f #t
2590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
25a0: 20 28 73 74 72 69 6e 67 3f 20 28 63 61 72 20 2a (string? (car *
25b0: 72 75 6e 72 65 6d 6f 74 65 2a 29 29 29 0a 3b 3b runremote*))).;;
25c0: 20 28 74 65 73 74 20 23 66 20 27 28 23 74 20 22 (test #f '(#t "
25d0: 73 75 63 63 65 73 73 66 75 6c 20 6c 6f 67 69 6e successful login
25e0: 22 29 20 28 72 6d 74 3a 6c 6f 67 69 6e 29 29 20 ") (rmt:login))
25f0: 3b 3b 20 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 ;; *runremote*
2600: 2a 74 6f 70 70 61 74 68 2a 20 2a 6d 79 2d 63 6c *toppath* *my-cl
2610: 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 29 ient-signature*)
2620: 29 29 0a 3b 3b 20 0a 3b 3b 20 28 74 65 73 74 20 )).;; .;; (test
2630: 23 66 20 23 66 20 20 20 20 20 20 20 20 20 20 20 #f #f
2640: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 6d 74 (rmt
2650: 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 :get-test-info-b
2660: 79 2d 69 64 20 39 39 29 29 20 3b 3b 20 67 65 74 y-id 99)) ;; get
2670: 20 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 non-existant te
2680: 73 74 0a 3b 3b 20 0a 3b 3b 20 3b 3b 20 52 55 4e st.;; .;; ;; RUN
2690: 53 0a 3b 3b 20 28 74 65 73 74 20 23 66 20 31 20 S.;; (test #f 1
26a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
26b0: 20 20 20 20 20 20 20 28 72 6d 74 3a 72 65 67 69 (rmt:regi
26c0: 73 74 65 72 2d 72 75 6e 20 20 2a 6b 65 79 76 61 ster-run *keyva
26d0: 6c 73 2a 20 22 66 69 72 73 74 72 75 6e 22 20 22 ls* "firstrun" "
26e0: 6e 65 77 22 20 22 6e 2f 61 22 20 28 63 75 72 72 new" "n/a" (curr
26f0: 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 29 29 ent-user-name)))
2700: 0a 3b 3b 20 28 74 65 73 74 20 22 67 65 74 20 72 .;; (test "get r
2710: 75 6e 20 69 6e 66 6f 22 20 20 22 66 69 72 73 74 un info" "first
2720: 72 75 6e 22 20 20 28 6c 65 74 20 28 28 72 69 6e run" (let ((rin
2730: 66 6f 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d fo (rmt:get-run-
2740: 69 6e 66 6f 20 31 29 29 29 0a 3b 3b 20 09 09 09 info 1))).;; ...
2750: 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 . (vector-ref
2760: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 69 6e (vector-ref rin
2770: 66 6f 20 31 29 20 33 29 29 29 0a 3b 3b 20 28 74 fo 1) 3))).;; (t
2780: 65 73 74 20 22 67 65 74 20 72 75 6e 6e 61 6d 65 est "get runname
2790: 20 66 72 6f 6d 20 69 64 22 20 22 66 69 72 73 74 from id" "first
27a0: 72 75 6e 22 20 28 72 6d 74 3a 67 65 74 2d 72 75 run" (rmt:get-ru
27b0: 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 31 n-name-from-id 1
27c0: 29 29 0a 3b 3b 20 0a 3b 3b 20 3b 3b 20 54 45 53 )).;; .;; ;; TES
27d0: 54 53 0a 3b 3b 20 28 74 65 73 74 20 22 67 65 74 TS.;; (test "get
27e0: 20 74 65 73 74 73 20 28 6e 6f 20 64 61 74 61 29 tests (no data)
27f0: 22 20 27 28 29 20 20 20 28 72 6d 74 3a 67 65 74 " '() (rmt:get
2800: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 31 -tests-for-run 1
2810: 20 22 25 22 20 27 28 29 20 27 28 29 20 23 66 20 "%" '() '() #f
2820: 23 66 20 23 66 20 23 66 20 23 66 20 23 66 29 29 #f #f #f #f #f))
2830: 0a 3b 3b 20 28 74 65 73 74 20 22 72 65 67 69 73 .;; (test "regis
2840: 74 65 72 20 74 65 73 74 22 20 20 20 20 20 20 20 ter test"
2850: 23 74 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 72 #t (rmt:gener
2860: 61 6c 2d 63 61 6c 6c 20 27 72 65 67 69 73 74 65 al-call 'registe
2870: 72 2d 74 65 73 74 20 31 20 22 74 65 73 74 31 22 r-test 1 "test1"
2880: 20 22 22 29 29 0a 3b 3b 20 28 74 65 73 74 20 22 "")).;; (test "
2890: 67 65 74 20 74 65 73 74 73 20 28 73 6f 6d 65 20 get tests (some
28a0: 64 61 74 61 29 22 20 20 31 20 20 28 6c 65 6e 67 data)" 1 (leng
28b0: 74 68 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 th (rmt:get-test
28c0: 73 2d 66 6f 72 2d 72 75 6e 20 31 20 22 25 22 20 s-for-run 1 "%"
28d0: 27 28 29 20 27 28 29 20 23 66 20 23 66 20 23 66 '() '() #f #f #f
28e0: 20 23 66 20 23 66 20 23 66 29 29 29 0a 3b 3b 20 #f #f #f))).;;
28f0: 28 74 65 73 74 20 22 67 65 74 20 74 65 73 74 20 (test "get test
2900: 69 64 22 20 20 20 20 20 20 20 20 20 20 20 20 31 id" 1
2910: 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d (rmt:get-test-
2920: 69 64 20 31 20 22 74 65 73 74 31 22 20 22 22 29 id 1 "test1" "")
2930: 29 0a 3b 3b 20 28 74 65 73 74 20 22 73 79 6e 63 ).;; (test "sync
2940: 20 62 61 63 6b 22 20 20 20 20 20 20 20 20 20 20 back"
2950: 20 20 20 20 23 74 20 28 3e 20 28 72 6d 74 3a 73 #t (> (rmt:s
2960: 79 6e 63 2d 69 6e 6d 65 6d 2d 3e 64 62 29 20 30 ync-inmem->db) 0
2970: 29 29 0a 3b 3b 20 28 74 65 73 74 20 22 67 65 74 )).;; (test "get
2980: 20 74 65 73 74 20 69 64 20 66 72 6f 6d 20 6d 61 test id from ma
2990: 69 6e 22 20 20 31 20 20 28 64 62 3a 67 65 74 2d in" 1 (db:get-
29a0: 74 65 73 74 2d 69 64 20 2a 64 62 2a 20 31 20 22 test-id *db* 1 "
29b0: 74 65 73 74 31 22 20 22 22 29 29 0a 3b 3b 20 28 test1" "")).;; (
29c0: 74 65 73 74 20 22 67 65 74 20 6b 65 79 73 22 20 test "get keys"
29d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 74 #t
29e0: 20 28 6c 69 73 74 3f 20 28 72 6d 74 3a 67 65 74 (list? (rmt:get
29f0: 2d 6b 65 79 73 29 29 29 0a 3b 3b 20 28 74 65 73 -keys))).;; (tes
2a00: 74 20 22 73 65 74 20 63 6f 6d 6d 65 6e 74 22 20 t "set comment"
2a10: 20 20 20 20 20 20 20 20 20 20 20 23 74 20 28 62 #t (b
2a20: 65 67 69 6e 20 28 72 6d 74 3a 67 65 6e 65 72 61 egin (rmt:genera
2a30: 6c 2d 63 61 6c 6c 20 27 73 65 74 2d 74 65 73 74 l-call 'set-test
2a40: 2d 63 6f 6d 6d 65 6e 74 20 22 74 68 69 73 20 69 -comment "this i
2a50: 73 20 61 20 63 6f 6d 6d 65 6e 74 22 20 31 29 20 s a comment" 1)
2a60: 23 74 29 29 0a 3b 3b 20 28 74 65 73 74 20 22 67 #t)).;; (test "g
2a70: 65 74 20 63 6f 6d 6d 65 6e 74 22 20 22 74 68 69 et comment" "thi
2a80: 73 20 69 73 20 61 20 63 6f 6d 6d 65 6e 74 22 20 s is a comment"
2a90: 28 6c 65 74 20 28 28 74 72 65 63 20 28 72 6d 74 (let ((trec (rmt
2aa0: 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 :get-test-info-b
2ab0: 79 2d 69 64 20 31 29 29 29 0a 3b 3b 20 09 09 09 y-id 1))).;; ...
2ac0: 09 09 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 .. (db:test-get
2ad0: 2d 63 6f 6d 6d 65 6e 74 20 74 72 65 63 29 29 29 -comment trec)))
2ae0: 0a 3b 3b 20 0a 3b 3b 20 3b 3b 20 4d 4f 52 45 20 .;; .;; ;; MORE
2af0: 52 55 4e 53 0a 3b 3b 20 28 74 65 73 74 20 22 67 RUNS.;; (test "g
2b00: 65 74 20 72 75 6e 73 22 20 20 23 74 20 28 6c 65 et runs" #t (le
2b10: 74 2a 20 28 28 72 75 6e 73 20 20 20 28 72 6d 74 t* ((runs (rmt
2b20: 3a 67 65 74 2d 72 75 6e 73 20 22 25 22 20 23 66 :get-runs "%" #f
2b30: 20 23 66 20 27 28 29 29 29 0a 3b 3b 20 09 09 09 #f '())).;; ...
2b40: 20 20 20 20 28 68 65 61 64 65 72 20 28 76 65 63 (header (vec
2b50: 74 6f 72 2d 72 65 66 20 72 75 6e 73 20 30 29 29 tor-ref runs 0))
2b60: 0a 3b 3b 20 09 09 09 20 20 20 20 28 64 61 74 61 .;; ... (data
2b70: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 (vector-ref r
2b80: 75 6e 73 20 31 29 29 29 0a 3b 3b 20 09 09 20 20 uns 1))).;; ..
2b90: 20 20 20 20 20 28 61 6e 64 20 28 6c 69 73 74 3f (and (list?
2ba0: 20 20 20 68 65 61 64 65 72 29 0a 3b 3b 20 09 09 header).;; ..
2bb0: 09 20 20 20 20 28 6c 69 73 74 3f 20 20 20 64 61 . (list? da
2bc0: 74 61 29 0a 3b 3b 20 09 09 09 20 20 20 20 28 76 ta).;; ... (v
2bd0: 65 63 74 6f 72 3f 20 28 63 61 72 20 64 61 74 61 ector? (car data
2be0: 29 29 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 74 65 ))))).;; .;; (te
2bf0: 73 74 20 22 67 65 74 20 6c 6f 63 61 6c 20 74 65 st "get local te
2c00: 73 74 69 6e 66 6f 22 20 22 74 65 73 74 31 22 20 stinfo" "test1"
2c10: 28 76 65 63 74 6f 72 2d 72 65 66 20 28 64 62 3a (vector-ref (db:
2c20: 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 get-testinfo-sta
2c30: 74 65 2d 73 74 61 74 75 73 20 2a 64 62 2a 20 31 te-status *db* 1
2c40: 29 20 32 29 29 0a 3b 3b 20 28 74 65 73 74 20 22 ) 2)).;; (test "
2c50: 67 65 74 20 74 65 73 74 69 6e 66 6f 22 20 20 20 get testinfo"
2c60: 20 20 20 20 22 74 65 73 74 31 22 20 28 76 65 63 "test1" (vec
2c70: 74 6f 72 2d 72 65 66 20 28 72 6d 74 3a 67 65 74 tor-ref (rmt:get
2c80: 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d -testinfo-state-
2c90: 73 74 61 74 75 73 20 31 29 20 32 29 29 0a 3b 3b status 1) 2)).;;
2ca0: 20 0a 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d .;; ;;=========
2cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
2cf0: 20 3b 3b 20 44 20 42 0a 3b 3b 20 3b 3b 3d 3d 3d ;; D B.;; ;;===
2d00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d40: 3d 3d 3d 0a 3b 3b 20 0a 3b 3b 20 28 74 65 73 74 ===.;; .;; (test
2d50: 20 22 70 61 73 73 20 66 61 69 6c 20 63 6f 75 6e "pass fail coun
2d60: 74 73 22 20 23 74 20 28 72 6d 74 3a 67 65 6e 65 ts" #t (rmt:gene
2d70: 72 61 6c 2d 63 61 6c 6c 20 27 70 61 73 73 2d 66 ral-call 'pass-f
2d80: 61 69 6c 2d 63 6f 75 6e 74 73 20 31 30 20 39 20 ail-counts 10 9
2d90: 31 29 29 0a 3b 3b 20 28 74 65 73 74 20 22 67 65 1)).;; (test "ge
2da0: 74 20 70 61 73 73 20 66 61 69 6c 20 63 6f 75 6e t pass fail coun
2db0: 74 73 22 20 31 39 20 28 6c 65 74 20 28 28 64 61 ts" 19 (let ((da
2dc0: 74 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d t (rmt:get-test-
2dd0: 69 6e 66 6f 2d 62 79 2d 69 64 20 31 29 29 29 0a info-by-id 1))).
2de0: 3b 3b 20 09 09 09 09 20 20 28 2b 20 28 64 62 3a ;; .... (+ (db:
2df0: 74 65 73 74 2d 67 65 74 2d 70 61 73 73 5f 63 6f test-get-pass_co
2e00: 75 6e 74 20 64 61 74 29 0a 3b 3b 20 09 09 09 09 unt dat).;; ....
2e10: 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
2e20: 74 2d 66 61 69 6c 5f 63 6f 75 6e 74 20 64 61 74 t-fail_count dat
2e30: 29 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 )))).;; .;; (def
2e40: 69 6e 65 20 74 65 73 74 72 65 67 69 73 74 72 79 ine testregistry
2e50: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
2e60: 65 29 29 0a 3b 3b 20 28 66 6f 72 2d 65 61 63 68 e)).;; (for-each
2e70: 0a 3b 3b 20 20 28 6c 61 6d 62 64 61 20 28 74 6e .;; (lambda (tn
2e80: 61 6d 65 29 0a 3b 3b 20 20 20 20 28 66 6f 72 2d ame).;; (for-
2e90: 65 61 63 68 0a 3b 3b 20 20 20 20 20 28 6c 61 6d each.;; (lam
2ea0: 62 64 61 20 28 69 74 65 6d 70 61 74 68 29 0a 3b bda (itempath).;
2eb0: 3b 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 74 ; (let ((t
2ec0: 6b 65 79 20 20 28 63 6f 6e 63 20 74 6e 61 6d 65 key (conc tname
2ed0: 20 22 2f 22 20 69 74 65 6d 70 61 74 68 29 29 0a "/" itempath)).
2ee0: 3b 3b 20 09 20 20 20 20 28 72 70 61 73 73 20 28 ;; . (rpass (
2ef0: 72 61 6e 64 6f 6d 20 31 30 29 29 0a 3b 3b 20 09 random 10)).;; .
2f00: 20 20 20 20 28 72 66 61 69 6c 20 28 72 61 6e 64 (rfail (rand
2f10: 6f 6d 20 31 30 29 29 29 0a 3b 3b 20 09 28 68 61 om 10))).;; .(ha
2f20: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 sh-table-set! te
2f30: 73 74 72 65 67 69 73 74 72 79 20 74 6b 65 79 20 stregistry tkey
2f40: 28 6c 69 73 74 20 74 6e 61 6d 65 20 69 74 65 6d (list tname item
2f50: 70 61 74 68 29 29 0a 3b 3b 20 09 28 72 6d 74 3a path)).;; .(rmt:
2f60: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 72 65 general-call 're
2f70: 67 69 73 74 65 72 2d 74 65 73 74 20 31 20 74 6e gister-test 1 tn
2f80: 61 6d 65 20 69 74 65 6d 70 61 74 68 29 0a 3b 3b ame itempath).;;
2f90: 20 09 28 6c 65 74 2a 20 28 28 74 69 64 20 20 28 .(let* ((tid (
2fa0: 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 rmt:get-test-id
2fb0: 31 20 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 1 tname itempath
2fc0: 29 29 0a 3b 3b 20 09 20 20 20 20 20 20 20 28 74 )).;; . (t
2fd0: 64 61 74 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 dat (rmt:get-tes
2fe0: 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 74 69 64 t-info-by-id tid
2ff0: 29 29 29 0a 3b 3b 20 09 20 20 28 72 6d 74 3a 67 ))).;; . (rmt:g
3000: 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 70 61 73 eneral-call 'pas
3010: 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 70 s-fail-counts rp
3020: 61 73 73 20 72 66 61 69 6c 20 28 64 62 3a 74 65 ass rfail (db:te
3030: 73 74 2d 67 65 74 2d 69 64 20 74 64 61 74 29 29 st-get-id tdat))
3040: 0a 3b 3b 20 09 20 20 28 6c 65 74 2a 20 28 28 72 .;; . (let* ((r
3050: 65 73 64 61 74 20 28 72 6d 74 3a 67 65 74 2d 74 esdat (rmt:get-t
3060: 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 74 est-info-by-id t
3070: 69 64 29 29 29 0a 3b 3b 20 09 20 20 20 20 28 74 id))).;; . (t
3080: 65 73 74 20 22 73 65 74 2f 67 65 74 20 70 61 73 est "set/get pas
3090: 73 20 66 61 69 6c 20 63 6f 75 6e 74 73 22 20 28 s fail counts" (
30a0: 6c 69 73 74 20 72 70 61 73 73 20 72 66 61 69 6c list rpass rfail
30b0: 29 0a 3b 3b 20 09 09 20 20 28 6c 69 73 74 20 28 ).;; .. (list (
30c0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 70 61 73 73 db:test-get-pass
30d0: 5f 63 6f 75 6e 74 20 72 65 73 64 61 74 29 0a 3b _count resdat).;
30e0: 3b 20 09 09 09 28 64 62 3a 74 65 73 74 2d 67 65 ; ...(db:test-ge
30f0: 74 2d 66 61 69 6c 5f 63 6f 75 6e 74 20 72 65 73 t-fail_count res
3100: 64 61 74 29 29 29 29 29 29 29 0a 3b 3b 20 20 20 dat))))))).;;
3110: 20 20 28 6c 69 73 74 20 22 22 20 22 61 22 20 22 (list "" "a" "
3120: 62 22 20 22 63 22 20 22 64 22 20 22 65 22 20 22 b" "c" "d" "e" "
3130: 66 22 20 22 67 22 20 22 68 22 20 22 69 22 20 22 f" "g" "h" "i" "
3140: 6a 22 29 29 29 0a 3b 3b 20 20 28 6c 69 73 74 20 j"))).;; (list
3150: 22 74 65 73 74 31 22 20 22 74 65 73 74 32 22 20 "test1" "test2"
3160: 22 74 65 73 74 33 22 20 22 74 65 73 74 34 22 20 "test3" "test4"
3170: 22 74 65 73 74 35 22 29 29 0a 3b 3b 20 0a 3b 3b "test5")).;; .;;
3180: 20 0a 3b 3b 20 28 74 65 73 74 20 23 66 20 27 28 .;; (test #f '(
3190: 23 74 20 22 65 78 69 74 20 70 72 6f 63 65 73 73 #t "exit process
31a0: 20 73 74 61 72 74 65 64 22 29 20 28 72 6d 74 3a started") (rmt:
31b0: 6b 69 6c 6c 2d 73 65 72 76 65 72 29 29 20 3b 3b kill-server)) ;;
31c0: 20 2a 74 6f 70 70 61 74 68 2a 20 2a 6d 79 2d 63 *toppath* *my-c
31d0: 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a lient-signature*
31e0: 20 23 66 29 29 29 0a 3b 3b 20 0a 0a 28 65 78 69 #f))).;; ..(exi
31f0: 74 29 0a t).