Artifact
5e80ce2ed910e43956d4ac53395b0dd701e745c7:
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 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 30 36 2d 32 30 31 33 2c right 2006-2013,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 69 73 20 70 ..;; .;; This p
0080: 72 6f 67 72 61 6d 20 69 73 20 6d 61 64 65 20 61 rogram is made a
0090: 76 61 69 6c 61 62 6c 65 20 75 6e 64 65 72 20 74 vailable under t
00a0: 68 65 20 47 4e 55 20 47 50 4c 20 76 65 72 73 69 he GNU GPL versi
00b0: 6f 6e 20 32 2e 30 20 6f 72 0a 3b 3b 20 20 67 72 on 2.0 or.;; gr
00c0: 65 61 74 65 72 2e 20 53 65 65 20 74 68 65 20 61 eater. See the a
00d0: 63 63 6f 6d 70 61 6e 79 69 6e 67 20 66 69 6c 65 ccompanying file
00e0: 20 43 4f 50 59 49 4e 47 20 66 6f 72 20 64 65 74 COPYING for det
00f0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 ails..;; .;; Th
0100: 69 73 20 70 72 6f 67 72 61 6d 20 69 73 20 64 69 is program is di
0110: 73 74 72 69 62 75 74 65 64 20 57 49 54 48 4f 55 stributed WITHOU
0120: 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 3b 20 T ANY WARRANTY;
0130: 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 68 65 without even the
0140: 0a 3b 3b 20 20 69 6d 70 6c 69 65 64 20 77 61 72 .;; implied war
0150: 72 61 6e 74 79 20 6f 66 20 4d 45 52 43 48 41 4e ranty of MERCHAN
0160: 54 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e TABILITY or FITN
0170: 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 ESS FOR A PARTIC
0180: 55 4c 41 52 0a 3b 3b 20 20 50 55 52 50 4f 53 45 ULAR.;; PURPOSE
0190: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
01a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 63 ==========..(dec
01e0: 6c 61 72 65 20 28 75 6e 69 74 20 61 70 69 29 29 lare (unit api))
01f0: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0200: 72 6d 74 29 29 0a 28 64 65 63 6c 61 72 65 20 28 rmt)).(declare (
0210: 75 73 65 73 20 64 62 29 29 0a 0a 3b 3b 20 61 6c uses db))..;; al
0220: 6c 6f 77 20 74 68 65 73 65 20 71 75 65 72 69 65 low these querie
0230: 73 20 74 68 72 6f 75 67 68 20 77 69 74 68 6f 75 s through withou
0240: 74 20 73 74 61 72 74 69 6e 67 20 61 20 73 65 72 t starting a ser
0250: 76 65 72 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 61 ver.;;.(define a
0260: 70 69 3a 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 pi:read-only-que
0270: 72 69 65 73 0a 20 20 27 28 67 65 74 2d 6b 65 79 ries. '(get-key
0280: 2d 76 61 6c 2d 70 61 69 72 73 0a 20 20 20 20 67 -val-pairs. g
0290: 65 74 2d 6b 65 79 73 0a 20 20 20 20 74 65 73 74 et-keys. test
02a0: 2d 74 6f 70 6c 65 76 65 6c 2d 6e 75 6d 2d 69 74 -toplevel-num-it
02b0: 65 6d 73 0a 20 20 20 20 67 65 74 2d 74 65 73 74 ems. get-test
02c0: 2d 69 6e 66 6f 2d 62 79 2d 69 64 0a 20 20 20 20 -info-by-id.
02d0: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 2d test-get-rundir-
02e0: 66 72 6f 6d 2d 74 65 73 74 2d 69 64 0a 20 20 20 from-test-id.
02f0: 20 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 get-count-tests
0300: 2d 72 75 6e 6e 69 6e 67 0a 20 20 20 20 67 65 74 -running. get
0310: 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e -count-tests-run
0320: 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 ning-in-jobgroup
0330: 0a 20 20 20 20 67 65 74 2d 70 72 65 76 69 6f 75 . get-previou
0340: 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 s-test-run-recor
0350: 64 0a 20 20 20 20 67 65 74 2d 6d 61 74 63 68 69 d. get-matchi
0360: 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 ng-previous-test
0370: 2d 72 75 6e 2d 72 65 63 6f 72 64 73 0a 20 20 20 -run-records.
0380: 20 74 65 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c test-get-logfil
0390: 65 2d 69 6e 66 6f 0a 20 20 20 20 74 65 73 74 2d e-info. test-
03a0: 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d get-records-for-
03b0: 69 6e 64 65 78 2d 66 69 6c 65 0a 20 20 20 20 67 index-file. g
03c0: 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 et-testinfo-stat
03d0: 65 2d 73 74 61 74 75 73 0a 20 20 20 20 74 65 73 e-status. tes
03e0: 74 2d 67 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 t-get-top-proces
03f0: 73 2d 70 69 64 0a 20 20 20 20 74 65 73 74 2d 67 s-pid. test-g
0400: 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 68 69 6e et-paths-matchin
0410: 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 72 67 65 g-keynames-targe
0420: 74 2d 6e 65 77 0a 20 20 20 20 67 65 74 2d 70 72 t-new. get-pr
0430: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 0a 20 20 ereqs-not-met.
0440: 20 20 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 get-count-test
0450: 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 72 75 s-running-for-ru
0460: 6e 2d 69 64 0a 20 20 20 20 67 65 74 2d 72 75 6e n-id. get-run
0470: 2d 69 6e 66 6f 0a 20 20 20 20 67 65 74 2d 72 75 -info. get-ru
0480: 6e 2d 73 74 61 74 75 73 0a 20 20 20 20 72 65 67 n-status. reg
0490: 69 73 74 65 72 2d 72 75 6e 0a 20 20 20 20 67 65 ister-run. ge
04a0: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 0a t-tests-for-run.
04b0: 20 20 20 20 67 65 74 2d 74 65 73 74 2d 69 64 0a get-test-id.
04c0: 20 20 20 20 67 65 74 2d 74 65 73 74 73 2d 66 6f get-tests-fo
04d0: 72 2d 72 75 6e 73 2d 6d 69 6e 64 61 74 61 0a 20 r-runs-mindata.
04e0: 20 20 20 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d get-run-name-
04f0: 66 72 6f 6d 2d 69 64 0a 20 20 20 20 67 65 74 2d from-id. get-
0500: 72 75 6e 73 0a 20 20 20 20 67 65 74 2d 61 6c 6c runs. get-all
0510: 2d 72 75 6e 2d 69 64 73 0a 20 20 20 20 67 65 74 -run-ids. get
0520: 2d 70 72 65 76 2d 72 75 6e 2d 69 64 73 0a 20 20 -prev-run-ids.
0530: 20 20 67 65 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 get-run-ids-ma
0540: 74 63 68 69 6e 67 2d 74 61 72 67 65 74 0a 20 20 tching-target.
0550: 20 20 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 get-runs-by-pa
0560: 74 74 0a 20 20 20 20 67 65 74 2d 73 74 65 70 73 tt. get-steps
0570: 2d 64 61 74 61 0a 20 20 20 20 6c 6f 67 69 6e 0a -data. login.
0580: 20 20 20 20 74 65 73 74 6d 65 74 61 2d 67 65 74 testmeta-get
0590: 2d 72 65 63 6f 72 64 29 29 0a 0a 3b 3b 20 54 68 -record))..;; Th
05a0: 65 73 65 20 61 72 65 20 63 61 6c 6c 65 64 20 62 ese are called b
05b0: 79 20 74 68 65 20 73 65 72 76 65 72 20 6f 6e 20 y the server on
05c0: 72 65 63 69 70 74 20 6f 66 20 2f 61 70 69 20 63 recipt of /api c
05d0: 61 6c 6c 73 0a 3b 3b 20 20 20 20 2d 20 6b 65 65 alls.;; - kee
05e0: 70 20 69 74 20 73 69 6d 70 6c 65 2c 20 6f 6e 6c p it simple, onl
05f0: 79 20 72 65 74 75 72 6e 20 74 68 65 20 61 63 74 y return the act
0600: 75 61 6c 20 72 65 73 75 6c 74 20 6f 66 20 74 68 ual result of th
0610: 65 20 63 61 6c 6c 2c 20 69 2e 65 2e 20 6e 6f 20 e call, i.e. no
0620: 6d 65 74 61 20 69 6e 66 6f 20 68 65 72 65 0a 3b meta info here.;
0630: 3b 0a 28 64 65 66 69 6e 65 20 28 61 70 69 3a 65 ;.(define (api:e
0640: 78 65 63 75 74 65 2d 72 65 71 75 65 73 74 73 20 xecute-requests
0650: 64 62 73 74 72 75 63 74 20 63 6d 64 20 70 61 72 dbstruct cmd par
0660: 61 6d 73 29 0a 20 20 28 63 61 73 65 20 28 73 74 ams). (case (st
0670: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 63 6d 64 ring->symbol cmd
0680: 29 0a 20 20 20 20 3b 3b 20 53 45 52 56 45 52 53 ). ;; SERVERS
0690: 0a 20 20 20 20 28 28 73 74 61 72 74 2d 73 65 72 . ((start-ser
06a0: 76 65 72 29 20 20 20 20 20 20 20 20 20 20 20 20 ver)
06b0: 20 20 20 20 20 28 61 70 70 6c 79 20 73 65 72 76 (apply serv
06c0: 65 72 3a 6b 69 6e 64 2d 72 75 6e 20 70 61 72 61 er:kind-run para
06d0: 6d 73 29 29 0a 20 20 20 20 28 28 6b 69 6c 6c 2d ms)). ((kill-
06e0: 73 65 72 76 65 72 29 20 20 20 20 20 20 20 20 20 server)
06f0: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 2a (set! *
0700: 73 65 72 76 65 72 2d 72 75 6e 2a 20 23 66 29 29 server-run* #f))
0710: 0a 0a 20 20 20 20 3b 3b 20 4b 45 59 53 0a 20 20 .. ;; KEYS.
0720: 20 20 28 28 67 65 74 2d 6b 65 79 2d 76 61 6c 2d ((get-key-val-
0730: 70 61 69 72 73 29 20 20 20 20 20 20 20 20 20 20 pairs)
0740: 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d (apply db:get-
0750: 6b 65 79 2d 76 61 6c 2d 70 61 69 72 73 20 64 62 key-val-pairs db
0760: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
0770: 20 20 20 20 28 28 67 65 74 2d 6b 65 79 73 29 20 ((get-keys)
0780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0790: 20 20 20 20 28 64 62 3a 67 65 74 2d 6b 65 79 73 (db:get-keys
07a0: 20 64 62 73 74 72 75 63 74 29 29 0a 0a 20 20 20 dbstruct))..
07b0: 20 3b 3b 20 54 45 53 54 53 0a 20 20 20 20 28 28 ;; TESTS. ((
07c0: 74 65 73 74 2d 74 6f 70 6c 65 76 65 6c 2d 6e 75 test-toplevel-nu
07d0: 6d 2d 69 74 65 6d 73 29 20 20 20 20 20 20 20 20 m-items)
07e0: 20 28 61 70 70 6c 79 20 64 62 3a 74 65 73 74 2d (apply db:test-
07f0: 74 6f 70 6c 65 76 65 6c 2d 6e 75 6d 2d 69 74 65 toplevel-num-ite
0800: 6d 73 20 64 62 73 74 72 75 63 74 20 70 61 72 61 ms dbstruct para
0810: 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 2d 74 ms)). ((get-t
0820: 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 29 09 est-info-by-id).
0830: 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 (apply db
0840: 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 :get-test-info-b
0850: 79 2d 69 64 20 64 62 73 74 72 75 63 74 20 70 61 y-id dbstruct pa
0860: 72 61 6d 73 29 29 0a 20 20 20 20 28 28 74 65 73 rams)). ((tes
0870: 74 2d 67 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f t-get-rundir-fro
0880: 6d 2d 74 65 73 74 2d 69 64 29 20 20 20 20 28 61 m-test-id) (a
0890: 70 70 6c 79 20 64 62 3a 74 65 73 74 2d 67 65 74 pply db:test-get
08a0: 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 65 73 -rundir-from-tes
08b0: 74 2d 69 64 20 64 62 73 74 72 75 63 74 20 70 61 t-id dbstruct pa
08c0: 72 61 6d 73 29 29 0a 20 20 20 20 28 28 74 65 73 rams)). ((tes
08d0: 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 t-set-state-stat
08e0: 75 73 2d 62 79 2d 69 64 29 20 20 20 20 20 28 61 us-by-id) (a
08f0: 70 70 6c 79 20 64 62 3a 74 65 73 74 2d 73 65 74 pply db:test-set
0900: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 -state-status-by
0910: 2d 69 64 20 64 62 73 74 72 75 63 74 20 70 61 72 -id dbstruct par
0920: 61 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 2d ams)). ((get-
0930: 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e count-tests-runn
0940: 69 6e 67 29 20 20 20 20 20 20 20 20 20 28 61 70 ing) (ap
0950: 70 6c 79 20 64 62 3a 67 65 74 2d 63 6f 75 6e 74 ply db:get-count
0960: 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 64 -tests-running d
0970: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
0980: 0a 20 20 20 20 28 28 67 65 74 2d 63 6f 75 6e 74 . ((get-count
0990: 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 -tests-running-i
09a0: 6e 2d 6a 6f 62 67 72 6f 75 70 29 20 28 61 70 70 n-jobgroup) (app
09b0: 6c 79 20 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d ly db:get-count-
09c0: 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e tests-running-in
09d0: 2d 6a 6f 62 67 72 6f 75 70 20 64 62 73 74 72 75 -jobgroup dbstru
09e0: 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ct params)).
09f0: 28 28 64 65 6c 65 74 65 2d 74 65 73 74 2d 72 65 ((delete-test-re
0a00: 63 6f 72 64 73 29 20 20 20 20 20 20 20 20 20 20 cords)
0a10: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 64 65 6c (apply db:del
0a20: 65 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 ete-test-records
0a30: 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 dbstruct params
0a40: 29 29 0a 20 20 20 20 3b 3b 20 28 28 64 65 6c 65 )). ;; ((dele
0a50: 74 65 2d 74 65 73 74 2d 73 74 65 70 2d 72 65 63 te-test-step-rec
0a60: 6f 72 64 73 29 20 20 20 20 20 20 20 20 28 61 70 ords) (ap
0a70: 70 6c 79 20 64 62 3a 64 65 6c 65 74 65 2d 74 65 ply db:delete-te
0a80: 73 74 2d 73 74 65 70 2d 72 65 63 6f 72 64 73 20 st-step-records
0a90: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
0aa0: 29 0a 20 20 20 20 28 28 64 65 6c 65 74 65 2d 6f ). ((delete-o
0ab0: 6c 64 2d 64 65 6c 65 74 65 64 2d 74 65 73 74 2d ld-deleted-test-
0ac0: 72 65 63 6f 72 64 73 29 20 28 61 70 70 6c 79 20 records) (apply
0ad0: 64 62 3a 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 db:delete-old-de
0ae0: 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 63 6f 72 leted-test-recor
0af0: 64 73 20 64 62 73 74 72 75 63 74 20 70 61 72 61 ds dbstruct para
0b00: 6d 73 29 29 0a 20 20 20 20 28 28 74 65 73 74 2d ms)). ((test-
0b10: 73 65 74 2d 73 74 61 74 75 73 2d 73 74 61 74 65 set-status-state
0b20: 29 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 ) (app
0b30: 6c 79 20 64 62 3a 74 65 73 74 2d 73 65 74 2d 73 ly db:test-set-s
0b40: 74 61 74 75 73 2d 73 74 61 74 65 20 64 62 73 74 tatus-state dbst
0b50: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
0b60: 20 20 28 28 67 65 74 2d 70 72 65 76 69 6f 75 73 ((get-previous
0b70: 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
0b80: 29 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 ) (apply db:g
0b90: 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 et-previous-test
0ba0: 2d 72 75 6e 2d 72 65 63 6f 72 64 20 64 62 73 74 -run-record dbst
0bb0: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
0bc0: 20 20 28 28 67 65 74 2d 6d 61 74 63 68 69 6e 67 ((get-matching
0bd0: 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 -previous-test-r
0be0: 75 6e 2d 72 65 63 6f 72 64 73 29 28 61 70 70 6c un-records)(appl
0bf0: 79 20 64 62 3a 67 65 74 2d 6d 61 74 63 68 69 6e y db:get-matchin
0c00: 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d g-previous-test-
0c10: 72 75 6e 2d 72 65 63 6f 72 64 73 20 64 62 73 74 run-records dbst
0c20: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
0c30: 20 20 28 28 74 65 73 74 2d 67 65 74 2d 6c 6f 67 ((test-get-log
0c40: 66 69 6c 65 2d 69 6e 66 6f 29 20 20 20 20 20 20 file-info)
0c50: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 74 (apply db:t
0c60: 65 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 2d est-get-logfile-
0c70: 69 6e 66 6f 20 64 62 73 74 72 75 63 74 20 70 61 info dbstruct pa
0c80: 72 61 6d 73 29 29 0a 20 20 20 20 28 28 74 65 73 rams)). ((tes
0c90: 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f t-get-records-fo
0ca0: 72 2d 69 6e 64 65 78 2d 66 69 6c 65 29 20 20 28 r-index-file) (
0cb0: 61 70 70 6c 79 20 64 62 3a 74 65 73 74 2d 67 65 apply db:test-ge
0cc0: 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d 69 6e t-records-for-in
0cd0: 64 65 78 2d 66 69 6c 65 20 64 62 73 74 72 75 63 dex-file dbstruc
0ce0: 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 t params)). (
0cf0: 28 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 (get-testinfo-st
0d00: 61 74 65 2d 73 74 61 74 75 73 29 20 20 20 20 20 ate-status)
0d10: 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d (apply db:get-
0d20: 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 testinfo-state-s
0d30: 74 61 74 75 73 20 64 62 73 74 72 75 63 74 20 70 tatus dbstruct p
0d40: 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 74 65 arams)). ((te
0d50: 73 74 2d 73 65 74 2d 74 6f 70 2d 70 72 6f 63 65 st-set-top-proce
0d60: 73 73 2d 70 69 64 29 20 20 20 20 20 20 20 20 28 ss-pid) (
0d70: 61 70 70 6c 79 20 64 62 3a 74 65 73 74 2d 73 65 apply db:test-se
0d80: 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 t-top-process-pi
0d90: 64 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d d dbstruct param
0da0: 73 29 29 0a 20 20 20 20 28 28 74 65 73 74 2d 67 s)). ((test-g
0db0: 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 et-top-process-p
0dc0: 69 64 29 20 20 20 20 20 20 20 20 28 61 70 70 6c id) (appl
0dd0: 79 20 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 6f y db:test-get-to
0de0: 70 2d 70 72 6f 63 65 73 73 2d 70 69 64 20 64 62 p-process-pid db
0df0: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
0e00: 20 20 20 20 28 28 74 65 73 74 2d 67 65 74 2d 70 ((test-get-p
0e10: 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 2d 6b 65 aths-matching-ke
0e20: 79 6e 61 6d 65 73 2d 74 61 72 67 65 74 2d 6e 65 ynames-target-ne
0e30: 77 29 20 28 61 70 70 6c 79 20 64 62 3a 74 65 73 w) (apply db:tes
0e40: 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 t-get-paths-matc
0e50: 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 hing-keynames-ta
0e60: 72 67 65 74 2d 6e 65 77 20 64 62 73 74 72 75 63 rget-new dbstruc
0e70: 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 t params)). (
0e80: 28 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 (get-prereqs-not
0e90: 2d 6d 65 74 29 20 20 20 20 20 20 20 20 20 20 20 -met)
0ea0: 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d (apply db:get-
0eb0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 prereqs-not-met
0ec0: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
0ed0: 29 0a 20 20 20 20 28 28 72 6f 6c 6c 2d 75 70 2d ). ((roll-up-
0ee0: 70 61 73 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 pass-fail-counts
0ef0: 29 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 ) (apply
0f00: 64 62 3a 72 6f 6c 6c 2d 75 70 2d 70 61 73 73 2d db:roll-up-pass-
0f10: 66 61 69 6c 2d 63 6f 75 6e 74 73 20 64 62 73 74 fail-counts dbst
0f20: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
0f30: 20 20 28 28 75 70 64 61 74 65 2d 66 61 69 6c 2d ((update-fail-
0f40: 70 61 73 73 2d 63 6f 75 6e 74 73 29 20 20 20 20 pass-counts)
0f50: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 (apply db:g
0f60: 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 64 62 73 74 eneral-call dbst
0f70: 72 75 63 74 20 27 75 70 64 61 74 65 2d 70 61 73 ruct 'update-pas
0f80: 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 70 61 s-fail-counts pa
0f90: 72 61 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 rams)). ((get
0fa0: 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e -count-tests-run
0fb0: 6e 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d 69 64 29 ning-for-run-id)
0fc0: 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 63 (apply db:get-c
0fd0: 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 ount-tests-runni
0fe0: 6e 67 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 64 62 ng-for-run-id db
0ff0: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
1000: 0a 20 20 20 20 3b 3b 20 52 55 4e 53 0a 20 20 20 . ;; RUNS.
1010: 20 28 28 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 29 ((get-run-info)
1020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1030: 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 72 (apply db:get-r
1040: 75 6e 2d 69 6e 66 6f 20 64 62 73 74 72 75 63 74 un-info dbstruct
1050: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 params)). ((
1060: 67 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 29 20 get-run-status)
1070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
1080: 70 70 6c 79 20 64 62 3a 67 65 74 2d 72 75 6e 2d pply db:get-run-
1090: 73 74 61 74 75 73 20 64 62 73 74 72 75 63 74 20 status dbstruct
10a0: 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 73 params)). ((s
10b0: 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 29 20 20 et-run-status)
10c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 (ap
10d0: 70 6c 79 20 64 62 3a 73 65 74 2d 72 75 6e 2d 73 ply db:set-run-s
10e0: 74 61 74 75 73 20 64 62 73 74 72 75 63 74 20 70 tatus dbstruct p
10f0: 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 72 65 arams)). ((re
1100: 67 69 73 74 65 72 2d 72 75 6e 29 20 20 20 20 20 gister-run)
1110: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 (app
1120: 6c 79 20 64 62 3a 72 65 67 69 73 74 65 72 2d 72 ly db:register-r
1130: 75 6e 20 64 62 73 74 72 75 63 74 20 70 61 72 61 un dbstruct para
1140: 6d 73 29 29 0a 20 20 20 20 28 28 73 65 74 2d 74 ms)). ((set-t
1150: 65 73 74 73 2d 73 74 61 74 65 2d 73 74 61 74 75 ests-state-statu
1160: 73 29 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 s) (apply
1170: 64 62 3a 73 65 74 2d 74 65 73 74 73 2d 73 74 61 db:set-tests-sta
1180: 74 65 2d 73 74 61 74 75 73 20 64 62 73 74 72 75 te-status dbstru
1190: 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ct params)).
11a0: 28 28 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d ((get-tests-for-
11b0: 72 75 6e 29 20 20 20 20 20 20 20 20 20 20 20 20 run)
11c0: 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 74 65 (apply db:get-te
11d0: 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 73 74 sts-for-run dbst
11e0: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
11f0: 20 20 28 28 67 65 74 2d 74 65 73 74 2d 69 64 29 ((get-test-id)
1200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1210: 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d (apply db:get-
1220: 74 65 73 74 2d 69 64 20 64 62 73 74 72 75 63 74 test-id dbstruct
1230: 20 70 61 72 61 6d 73 29 29 0a 09 20 20 20 20 28 params)).. (
1240: 28 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 (get-tests-for-r
1250: 75 6e 2d 6d 69 6e 64 61 74 61 29 20 20 20 20 28 un-mindata) (
1260: 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 74 65 73 apply db:get-tes
1270: 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 ts-for-run-minda
1280: 74 61 20 64 62 73 74 72 75 63 74 20 70 61 72 61 ta dbstruct para
1290: 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 2d 72 ms)). ((get-r
12a0: 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 29 un-name-from-id)
12b0: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply
12c0: 64 62 3a 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d db:get-run-name-
12d0: 66 72 6f 6d 2d 69 64 20 64 62 73 74 72 75 63 74 from-id dbstruct
12e0: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 params)). ((
12f0: 64 65 6c 65 74 65 2d 72 75 6e 29 20 20 20 20 20 delete-run)
1300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
1310: 70 70 6c 79 20 64 62 3a 64 65 6c 65 74 65 2d 72 pply db:delete-r
1320: 75 6e 20 64 62 73 74 72 75 63 74 20 70 61 72 61 un dbstruct para
1330: 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 2d 72 ms)). ((get-r
1340: 75 6e 73 29 20 20 20 20 20 20 20 20 20 20 20 20 uns)
1350: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply
1360: 64 62 3a 67 65 74 2d 72 75 6e 73 20 64 62 73 74 db:get-runs dbst
1370: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
1380: 20 20 28 28 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d ((get-all-run-
1390: 69 64 73 29 20 20 20 20 20 20 20 20 20 20 20 20 ids)
13a0: 20 20 28 64 62 3a 67 65 74 2d 61 6c 6c 2d 72 75 (db:get-all-ru
13b0: 6e 2d 69 64 73 20 64 62 73 74 72 75 63 74 29 29 n-ids dbstruct))
13c0: 0a 20 20 20 20 28 28 67 65 74 2d 70 72 65 76 2d . ((get-prev-
13d0: 72 75 6e 2d 69 64 73 29 20 20 20 20 20 20 20 20 run-ids)
13e0: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 (apply db:g
13f0: 65 74 2d 70 72 65 76 2d 72 75 6e 2d 69 64 73 20 et-prev-run-ids
1400: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
1410: 29 0a 20 20 20 20 28 28 67 65 74 2d 72 75 6e 2d ). ((get-run-
1420: 69 64 73 2d 6d 61 74 63 68 69 6e 67 2d 74 61 72 ids-matching-tar
1430: 67 65 74 29 20 20 28 61 70 70 6c 79 20 64 62 3a get) (apply db:
1440: 67 65 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 74 63 get-run-ids-matc
1450: 68 69 6e 67 2d 74 61 72 67 65 74 20 64 62 73 74 hing-target dbst
1460: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
1470: 20 20 28 28 67 65 74 2d 72 75 6e 73 2d 62 79 2d ((get-runs-by-
1480: 70 61 74 74 29 20 20 20 20 20 20 20 20 20 20 20 patt)
1490: 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d (apply db:get-
14a0: 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 73 runs-by-patt dbs
14b0: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 truct params)).
14c0: 20 20 20 28 28 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b ((lock/unlock
14d0: 2d 72 75 6e 29 20 20 20 20 20 20 20 20 20 20 20 -run)
14e0: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 6c 6f 63 (apply db:loc
14f0: 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 64 62 73 k/unlock-run dbs
1500: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 truct params)).
1510: 20 20 20 28 28 75 70 64 61 74 65 2d 72 75 6e 2d ((update-run-
1520: 65 76 65 6e 74 5f 74 69 6d 65 29 20 20 20 20 20 event_time)
1530: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 75 70 64 (apply db:upd
1540: 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 69 ate-run-event_ti
1550: 6d 65 20 64 62 73 74 72 75 63 74 20 70 61 72 61 me dbstruct para
1560: 6d 73 29 29 0a 20 20 20 20 28 28 66 69 6e 64 2d ms)). ((find-
1570: 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c and-mark-incompl
1580: 65 74 65 29 20 20 20 20 20 28 61 70 70 6c 79 20 ete) (apply
1590: 64 62 3a 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b db:find-and-mark
15a0: 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 64 62 73 74 -incomplete dbst
15b0: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 0a 20 ruct params))..
15c0: 20 20 20 3b 3b 20 53 54 45 50 53 0a 20 20 20 20 ;; STEPS.
15d0: 28 28 74 65 73 74 73 74 65 70 2d 73 65 74 2d 73 ((teststep-set-s
15e0: 74 61 74 75 73 21 29 20 20 20 20 20 20 20 20 20 tatus!)
15f0: 28 61 70 70 6c 79 20 64 62 3a 74 65 73 74 73 74 (apply db:testst
1600: 65 70 2d 73 65 74 2d 73 74 61 74 75 73 21 20 64 ep-set-status! d
1610: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
1620: 0a 0a 20 20 20 20 3b 3b 20 54 45 53 54 20 44 41 .. ;; TEST DA
1630: 54 41 0a 20 20 20 20 28 28 74 65 73 74 2d 64 61 TA. ((test-da
1640: 74 61 2d 72 6f 6c 6c 75 70 29 20 20 20 20 20 20 ta-rollup)
1650: 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 (apply db
1660: 3a 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 :test-data-rollu
1670: 70 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d p dbstruct param
1680: 73 29 29 0a 20 20 20 20 28 28 63 73 76 2d 3e 74 s)). ((csv->t
1690: 65 73 74 2d 64 61 74 61 29 20 20 20 20 20 20 20 est-data)
16a0: 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 (apply d
16b0: 62 3a 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 b:csv->test-data
16c0: 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 dbstruct params
16d0: 29 29 0a 20 20 20 20 28 28 67 65 74 2d 73 74 65 )). ((get-ste
16e0: 70 73 2d 64 61 74 61 29 20 20 20 20 20 20 20 20 ps-data)
16f0: 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 (apply db
1700: 3a 67 65 74 2d 73 74 65 70 73 2d 64 61 74 61 20 :get-steps-data
1710: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
1720: 29 0a 0a 20 20 20 20 3b 3b 20 4d 49 53 43 0a 20 ).. ;; MISC.
1730: 20 20 20 28 28 6c 6f 67 69 6e 29 20 20 20 20 20 ((login)
1740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1750: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 6c 6f 67 (apply db:log
1760: 69 6e 20 64 62 73 74 72 75 63 74 20 70 61 72 61 in dbstruct para
1770: 6d 73 29 29 0a 20 20 20 20 28 28 67 65 6e 65 72 ms)). ((gener
1780: 61 6c 2d 63 61 6c 6c 29 20 20 20 20 20 20 20 20 al-call)
1790: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let ((
17a0: 73 74 6d 74 6e 61 6d 65 20 20 20 28 63 61 72 20 stmtname (car
17b0: 70 61 72 61 6d 73 29 29 0a 09 09 09 09 09 20 20 params))......
17c0: 28 72 75 6e 2d 69 64 20 20 20 20 20 28 63 61 64 (run-id (cad
17d0: 72 20 70 61 72 61 6d 73 29 29 0a 09 09 09 09 09 r params))......
17e0: 20 20 28 72 65 61 6c 70 61 72 61 6d 73 20 28 63 (realparams (c
17f0: 64 64 72 20 70 61 72 61 6d 73 29 29 29 0a 09 09 ddr params)))...
1800: 09 09 20 20 20 20 20 20 28 64 62 3a 77 69 74 68 .. (db:with
1810: 2d 64 62 20 64 62 73 74 72 75 63 74 20 72 75 6e -db dbstruct run
1820: 2d 69 64 20 23 74 20 3b 3b 20 74 68 65 73 65 20 -id #t ;; these
1830: 61 72 65 20 61 6c 6c 20 66 6f 72 20 6d 6f 64 69 are all for modi
1840: 66 79 69 6e 67 20 74 68 65 20 64 62 0a 09 09 09 fying the db....
1850: 09 09 09 20 20 28 6c 61 6d 62 64 61 20 28 64 62 ... (lambda (db
1860: 29 0a 09 09 09 09 09 09 20 20 20 20 28 64 62 3a )....... (db:
1870: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 64 62 20 general-call db
1880: 73 74 6d 74 6e 61 6d 65 20 72 65 61 6c 70 61 72 stmtname realpar
1890: 61 6d 73 29 29 29 29 29 0a 20 20 20 20 28 28 73 ams))))). ((s
18a0: 79 6e 63 2d 69 6e 6d 65 6d 2d 3e 64 62 29 20 20 ync-inmem->db)
18b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 (db
18c0: 3a 73 79 6e 63 2d 74 6f 75 63 68 65 64 20 64 62 :sync-touched db
18d0: 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 66 6f struct run-id fo
18e0: 72 63 65 2d 73 79 6e 63 3a 20 23 74 29 29 0a 20 rce-sync: #t)).
18f0: 20 20 20 28 28 73 64 62 2d 71 72 79 29 20 20 20 ((sdb-qry)
1900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1910: 20 20 20 28 61 70 70 6c 79 20 73 64 62 3a 71 72 (apply sdb:qr
1920: 79 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 y params))..
1930: 3b 3b 20 54 45 53 54 4d 45 54 41 0a 20 20 20 20 ;; TESTMETA.
1940: 28 28 74 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 ((testmeta-get-r
1950: 65 63 6f 72 64 29 20 20 20 20 20 20 20 28 61 70 ecord) (ap
1960: 70 6c 79 20 64 62 3a 74 65 73 74 6d 65 74 61 2d ply db:testmeta-
1970: 67 65 74 2d 72 65 63 6f 72 64 20 64 62 73 74 72 get-record dbstr
1980: 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 uct params)).
1990: 20 28 28 74 65 73 74 6d 65 74 61 2d 61 64 64 2d ((testmeta-add-
19a0: 72 65 63 6f 72 64 29 20 20 20 20 20 20 20 28 61 record) (a
19b0: 70 70 6c 79 20 64 62 3a 74 65 73 74 6d 65 74 61 pply db:testmeta
19c0: 2d 61 64 64 2d 72 65 63 6f 72 64 20 64 62 73 74 -add-record dbst
19d0: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
19e0: 20 20 28 28 74 65 73 74 6d 65 74 61 2d 75 70 64 ((testmeta-upd
19f0: 61 74 65 2d 66 69 65 6c 64 29 20 20 20 20 20 28 ate-field) (
1a00: 61 70 70 6c 79 20 64 62 3a 74 65 73 74 6d 65 74 apply db:testmet
1a10: 61 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 20 64 a-update-field d
1a20: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
1a30: 0a 0a 20 20 20 20 3b 3b 20 54 41 53 4b 53 20 0a .. ;; TASKS .
1a40: 20 20 20 20 28 28 66 69 6e 64 2d 74 61 73 6b 2d ((find-task-
1a50: 71 75 65 75 65 2d 72 65 63 6f 72 64 73 29 20 20 queue-records)
1a60: 20 28 61 70 70 6c 79 20 74 61 73 6b 73 3a 66 69 (apply tasks:fi
1a70: 6e 64 2d 74 61 73 6b 2d 71 75 65 75 65 2d 72 65 nd-task-queue-re
1a80: 63 6f 72 64 73 20 64 62 73 74 72 75 63 74 20 70 cords dbstruct p
1a90: 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 74 61 arams)). ((ta
1aa0: 73 6b 73 2d 61 64 64 29 20 20 20 20 20 20 20 20 sks-add)
1ab0: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply
1ac0: 74 61 73 6b 73 3a 61 64 64 20 64 62 73 74 72 75 tasks:add dbstru
1ad0: 63 74 20 70 61 72 61 6d 73 29 29 20 20 20 0a 20 ct params)) .
1ae0: 20 20 20 28 28 74 61 73 6b 73 2d 73 65 74 2d 73 ((tasks-set-s
1af0: 74 61 74 65 2d 67 69 76 65 6e 2d 70 61 72 61 6d tate-given-param
1b00: 2d 6b 65 79 29 20 28 61 70 70 6c 79 20 74 61 73 -key) (apply tas
1b10: 6b 73 3a 73 65 74 2d 73 74 61 74 65 2d 67 69 76 ks:set-state-giv
1b20: 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 64 62 73 en-param-key dbs
1b30: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 0a truct params))..
1b40: 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 28 (else. (
1b50: 6c 69 73 74 20 22 45 52 52 4f 52 22 20 30 29 29 list "ERROR" 0))
1b60: 29 29 0a 0a 3b 3b 20 68 74 74 70 2d 73 65 72 76 ))..;; http-serv
1b70: 65 72 20 20 73 65 6e 64 2d 72 65 73 70 6f 6e 73 er send-respons
1b80: 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 e.;;
1b90: 20 20 20 20 20 61 70 69 3a 70 72 6f 63 65 73 73 api:process
1ba0: 2d 72 65 71 75 65 73 74 0a 3b 3b 20 20 20 20 20 -request.;;
1bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 64 d
1bc0: 62 3a 2a 0a 3b 3b 0a 3b 3b 20 4e 42 2f 2f 20 52 b:*.;;.;; NB// R
1bd0: 75 6e 73 20 6f 6e 20 74 68 65 20 73 65 72 76 65 uns on the serve
1be0: 72 20 61 73 20 70 61 72 74 20 6f 66 20 74 68 65 r as part of the
1bf0: 20 73 65 72 76 65 72 20 6c 6f 6f 70 0a 3b 3b 0a server loop.;;.
1c00: 28 64 65 66 69 6e 65 20 28 61 70 69 3a 70 72 6f (define (api:pro
1c10: 63 65 73 73 2d 72 65 71 75 65 73 74 20 64 62 73 cess-request dbs
1c20: 74 72 75 63 74 20 24 29 20 3b 3b 20 74 68 65 20 truct $) ;; the
1c30: 24 20 69 73 20 74 68 65 20 72 65 71 75 65 73 74 $ is the request
1c40: 20 76 61 72 73 20 70 72 6f 63 0a 20 20 28 6c 65 vars proc. (le
1c50: 74 2a 20 28 28 63 6d 64 20 20 20 20 20 28 24 20 t* ((cmd ($
1c60: 27 63 6d 64 29 29 0a 09 20 28 70 61 72 61 6d 73 'cmd)).. (params
1c70: 6a 20 28 24 20 27 70 61 72 61 6d 73 29 29 0a 09 j ($ 'params))..
1c80: 20 28 70 61 72 61 6d 73 20 20 28 64 62 3a 73 74 (params (db:st
1c90: 72 69 6e 67 2d 3e 6f 62 6a 20 70 61 72 61 6d 73 ring->obj params
1ca0: 6a 29 29 20 3b 3b 20 28 72 6d 74 3a 6a 73 6f 6e j)) ;; (rmt:json
1cb0: 2d 73 74 72 2d 3e 64 61 74 20 70 61 72 61 6d 73 -str->dat params
1cc0: 6a 29 29 0a 09 20 28 72 65 73 20 20 20 20 20 28 j)).. (res (
1cd0: 61 70 69 3a 65 78 65 63 75 74 65 2d 72 65 71 75 api:execute-requ
1ce0: 65 73 74 73 20 64 62 73 74 72 75 63 74 20 63 6d ests dbstruct cm
1cf0: 64 20 70 61 72 61 6d 73 29 29 29 0a 0a 20 20 20 d params)))..
1d00: 20 3b 3b 20 54 68 69 73 20 63 61 6e 20 62 65 20 ;; This can be
1d10: 68 65 72 65 20 62 75 74 20 6e 65 65 64 73 20 63 here but needs c
1d20: 6f 6e 74 72 6f 6c 73 20 74 6f 20 65 6e 73 75 72 ontrols to ensur
1d30: 65 20 69 74 20 64 6f 65 73 6e 27 74 20 72 75 6e e it doesn't run
1d40: 20 6d 6f 72 65 20 74 68 61 6e 20 65 76 65 72 79 more than every
1d50: 20 34 20 73 65 63 6f 6e 64 73 0a 20 20 20 20 3b 4 seconds. ;
1d60: 3b 20 28 72 6d 74 3a 64 61 74 2d 3e 6a 73 6f 6e ; (rmt:dat->json
1d70: 2d 73 74 72 0a 20 20 20 20 3b 3b 20 20 28 69 66 -str. ;; (if
1d80: 20 28 6f 72 20 28 73 74 72 69 6e 67 3f 20 72 65 (or (string? re
1d90: 73 29 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 s). ;;
1da0: 20 20 20 28 6c 69 73 74 3f 20 20 20 72 65 73 29 (list? res)
1db0: 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 . ;;
1dc0: 20 28 6e 75 6d 62 65 72 3f 20 72 65 73 29 0a 20 (number? res).
1dd0: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 28 ;; (
1de0: 62 6f 6f 6c 65 61 6e 3f 20 72 65 73 29 29 0a 20 boolean? res)).
1df0: 20 20 20 3b 3b 20 20 20 20 20 20 72 65 73 20 0a ;; res .
1e00: 20 20 20 20 3b 3b 20 20 20 20 20 20 28 6c 69 73 ;; (lis
1e10: 74 20 22 45 52 52 4f 52 2c 20 6e 6f 74 20 73 74 t "ERROR, not st
1e20: 72 69 6e 67 2c 20 6c 69 73 74 2c 20 6e 75 6d 62 ring, list, numb
1e30: 65 72 20 6f 72 20 62 6f 6f 6c 65 61 6e 22 20 31 er or boolean" 1
1e40: 20 63 6d 64 20 70 61 72 61 6d 73 20 72 65 73 29 cmd params res)
1e50: 29 29 29 29 0a 20 20 20 20 28 64 62 3a 6f 62 6a )))). (db:obj
1e60: 2d 3e 73 74 72 69 6e 67 20 72 65 73 29 29 29 0a ->string res))).
1e70: 0a .