Artifact
befb5033e9e40ea14d99b3249dedc2935a14ea25:
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 54 68 69 73 20 66 69 ..;; .;; This fi
0080: 6c 65 20 69 73 20 70 61 72 74 20 6f 66 20 4d 65 le is part of Me
0090: 67 61 74 65 73 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 gatest..;; .;;
00a0: 20 20 20 4d 65 67 61 74 65 73 74 20 69 73 20 66 Megatest is f
00b0: 72 65 65 20 73 6f 66 74 77 61 72 65 3a 20 79 6f ree software: yo
00c0: 75 20 63 61 6e 20 72 65 64 69 73 74 72 69 62 75 u can redistribu
00d0: 74 65 20 69 74 20 61 6e 64 2f 6f 72 20 6d 6f 64 te it and/or mod
00e0: 69 66 79 0a 3b 3b 20 20 20 20 20 69 74 20 75 6e ify.;; it un
00f0: 64 65 72 20 74 68 65 20 74 65 72 6d 73 20 6f 66 der the terms of
0100: 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c the GNU General
0110: 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 Public License
0120: 61 73 20 70 75 62 6c 69 73 68 65 64 20 62 79 0a as published by.
0130: 3b 3b 20 20 20 20 20 74 68 65 20 46 72 65 65 20 ;; the Free
0140: 53 6f 66 74 77 61 72 65 20 46 6f 75 6e 64 61 74 Software Foundat
0150: 69 6f 6e 2c 20 65 69 74 68 65 72 20 76 65 72 73 ion, either vers
0160: 69 6f 6e 20 33 20 6f 66 20 74 68 65 20 4c 69 63 ion 3 of the Lic
0170: 65 6e 73 65 2c 20 6f 72 0a 3b 3b 20 20 20 20 20 ense, or.;;
0180: 28 61 74 20 79 6f 75 72 20 6f 70 74 69 6f 6e 29 (at your option)
0190: 20 61 6e 79 20 6c 61 74 65 72 20 76 65 72 73 69 any later versi
01a0: 6f 6e 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d on..;; .;; M
01b0: 65 67 61 74 65 73 74 20 69 73 20 64 69 73 74 72 egatest is distr
01c0: 69 62 75 74 65 64 20 69 6e 20 74 68 65 20 68 6f ibuted in the ho
01d0: 70 65 20 74 68 61 74 20 69 74 20 77 69 6c 6c 20 pe that it will
01e0: 62 65 20 75 73 65 66 75 6c 2c 0a 3b 3b 20 20 20 be useful,.;;
01f0: 20 20 62 75 74 20 57 49 54 48 4f 55 54 20 41 4e but WITHOUT AN
0200: 59 20 57 41 52 52 41 4e 54 59 3b 20 77 69 74 68 Y WARRANTY; with
0210: 6f 75 74 20 65 76 65 6e 20 74 68 65 20 69 6d 70 out even the imp
0220: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0230: 0a 3b 3b 20 20 20 20 20 4d 45 52 43 48 41 4e 54 .;; MERCHANT
0240: 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e 45 ABILITY or FITNE
0250: 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 55 SS FOR A PARTICU
0260: 4c 41 52 20 50 55 52 50 4f 53 45 2e 20 20 53 65 LAR PURPOSE. Se
0270: 65 20 74 68 65 0a 3b 3b 20 20 20 20 20 47 4e 55 e the.;; GNU
0280: 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 General Public
0290: 4c 69 63 65 6e 73 65 20 66 6f 72 20 6d 6f 72 65 License for more
02a0: 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b details..;; .;;
02b0: 20 20 20 20 20 59 6f 75 20 73 68 6f 75 6c 64 20 You should
02c0: 68 61 76 65 20 72 65 63 65 69 76 65 64 20 61 20 have received a
02d0: 63 6f 70 79 20 6f 66 20 74 68 65 20 47 4e 55 20 copy of the GNU
02e0: 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 4c General Public L
02f0: 69 63 65 6e 73 65 0a 3b 3b 20 20 20 20 20 61 6c icense.;; al
0300: 6f 6e 67 20 77 69 74 68 20 4d 65 67 61 74 65 73 ong with Megates
0310: 74 2e 20 20 49 66 20 6e 6f 74 2c 20 73 65 65 20 t. If not, see
0320: 3c 68 74 74 70 3a 2f 2f 77 77 77 2e 67 6e 75 2e <http://www.gnu.
0330: 6f 72 67 2f 6c 69 63 65 6e 73 65 73 2f 3e 2e 0a org/licenses/>..
0340: 3b 3b 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;.;;===========
0350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
0390: 63 6c 61 72 65 20 28 75 6e 69 74 20 61 70 69 29 clare (unit api)
03a0: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
03b0: 20 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 db)).(declare (
03c0: 75 73 65 73 20 64 65 62 75 67 70 72 69 6e 74 29 uses debugprint)
03d0: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
03e0: 20 63 6f 6d 6d 6f 6e 6d 6f 64 29 29 0a 28 64 65 commonmod)).(de
03f0: 63 6c 61 72 65 20 28 75 73 65 73 20 64 62 6d 6f clare (uses dbmo
0400: 64 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 d)).(declare (us
0410: 65 73 20 64 62 66 69 6c 65 29 29 0a 28 64 65 63 es dbfile)).(dec
0420: 6c 61 72 65 20 28 75 73 65 73 20 74 61 73 6b 73 lare (uses tasks
0430: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0440: 73 20 74 63 70 2d 74 72 61 6e 73 70 6f 72 74 6d s tcp-transportm
0450: 6f 64 29 29 0a 0a 28 69 6d 70 6f 72 74 20 63 6f od))..(import co
0460: 6d 6d 6f 6e 6d 6f 64 29 0a 28 69 6d 70 6f 72 74 mmonmod).(import
0470: 20 64 62 6d 6f 64 29 0a 28 69 6d 70 6f 72 74 20 dbmod).(import
0480: 64 62 66 69 6c 65 29 0a 28 69 6d 70 6f 72 74 20 dbfile).(import
0490: 64 65 62 75 67 70 72 69 6e 74 29 0a 28 69 6d 70 debugprint).(imp
04a0: 6f 72 74 20 74 63 70 2d 74 72 61 6e 73 70 6f 72 ort tcp-transpor
04b0: 74 6d 6f 64 29 0a 0a 28 75 73 65 20 73 72 66 69 tmod)..(use srfi
04c0: 2d 36 39 0a 20 20 20 20 20 73 72 66 69 2d 31 38 -69. srfi-18
04d0: 0a 20 20 20 20 20 70 6f 73 69 78 0a 20 20 20 20 . posix.
04e0: 20 6d 61 74 63 68 61 62 6c 65 0a 20 20 20 20 20 matchable.
04f0: 73 31 31 6e 29 0a 0a 3b 3b 20 61 6c 6c 6f 77 20 s11n)..;; allow
0500: 74 68 65 73 65 20 71 75 65 72 69 65 73 20 74 68 these queries th
0510: 72 6f 75 67 68 20 77 69 74 68 6f 75 74 20 73 74 rough without st
0520: 61 72 74 69 6e 67 20 61 20 73 65 72 76 65 72 0a arting a server.
0530: 3b 3b 0a 28 64 65 66 69 6e 65 20 61 70 69 3a 72 ;;.(define api:r
0540: 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 ead-only-queries
0550: 0a 20 20 27 28 67 65 74 2d 6b 65 79 2d 76 61 6c . '(get-key-val
0560: 2d 70 61 69 72 73 0a 20 20 20 20 67 65 74 2d 76 -pairs. get-v
0570: 61 72 0a 20 20 20 20 67 65 74 2d 6b 65 79 73 0a ar. get-keys.
0580: 20 20 20 20 67 65 74 2d 6b 65 79 2d 76 61 6c 73 get-key-vals
0590: 0a 20 20 20 20 74 65 73 74 2d 74 6f 70 6c 65 76 . test-toplev
05a0: 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 0a 20 20 20 el-num-items.
05b0: 20 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 get-test-info-b
05c0: 79 2d 69 64 0a 20 20 20 20 67 65 74 2d 74 65 73 y-id. get-tes
05d0: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 t-state-status-b
05e0: 79 2d 69 64 0a 20 20 20 20 67 65 74 2d 73 74 65 y-id. get-ste
05f0: 70 73 2d 69 6e 66 6f 2d 62 79 2d 69 64 0a 20 20 ps-info-by-id.
0600: 20 20 67 65 74 2d 64 61 74 61 2d 69 6e 66 6f 2d get-data-info-
0610: 62 79 2d 69 64 0a 20 20 20 20 74 65 73 74 2d 67 by-id. test-g
0620: 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 et-rundir-from-t
0630: 65 73 74 2d 69 64 0a 20 20 20 20 67 65 74 2d 63 est-id. get-c
0640: 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 ount-tests-runni
0650: 6e 67 2d 66 6f 72 2d 74 65 73 74 6e 61 6d 65 0a ng-for-testname.
0660: 20 20 20 20 67 65 74 2d 63 6f 75 6e 74 2d 74 65 get-count-te
0670: 73 74 73 2d 72 75 6e 6e 69 6e 67 0a 20 20 20 20 sts-running.
0680: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
0690: 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 running-in-jobgr
06a0: 6f 75 70 0a 20 20 20 20 67 65 74 2d 70 72 65 76 oup. get-prev
06b0: 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 ious-test-run-re
06c0: 63 6f 72 64 0a 20 20 20 20 67 65 74 2d 6d 61 74 cord. get-mat
06d0: 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 ching-previous-t
06e0: 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 73 0a est-run-records.
06f0: 20 20 20 20 74 65 73 74 2d 67 65 74 2d 6c 6f 67 test-get-log
0700: 66 69 6c 65 2d 69 6e 66 6f 0a 20 20 20 20 74 65 file-info. te
0710: 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 st-get-records-f
0720: 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 0a 20 20 or-index-file.
0730: 20 20 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 get-testinfo-s
0740: 74 61 74 65 2d 73 74 61 74 75 73 0a 20 20 20 20 tate-status.
0750: 74 65 73 74 2d 67 65 74 2d 74 6f 70 2d 70 72 6f test-get-top-pro
0760: 63 65 73 73 2d 70 69 64 0a 20 20 20 20 74 65 73 cess-pid. tes
0770: 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 t-get-paths-matc
0780: 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 hing-keynames-ta
0790: 72 67 65 74 2d 6e 65 77 0a 20 20 20 20 67 65 74 rget-new. get
07a0: 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 -prereqs-not-met
07b0: 0a 20 20 20 20 67 65 74 2d 63 6f 75 6e 74 2d 74 . get-count-t
07c0: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 ests-running-for
07d0: 2d 72 75 6e 2d 69 64 0a 20 20 20 20 67 65 74 2d -run-id. get-
07e0: 72 75 6e 2d 69 6e 66 6f 0a 20 20 20 20 67 65 74 run-info. get
07f0: 2d 72 75 6e 2d 73 74 61 74 75 73 0a 20 20 20 20 -run-status.
0800: 67 65 74 2d 72 75 6e 2d 73 74 61 74 65 0a 20 20 get-run-state.
0810: 20 20 67 65 74 2d 72 75 6e 2d 73 74 61 74 73 0a get-run-stats.
0820: 20 20 20 20 67 65 74 2d 72 75 6e 2d 74 69 6d 65 get-run-time
0830: 73 0a 20 20 20 20 67 65 74 2d 74 61 72 67 65 74 s. get-target
0840: 0a 20 20 20 20 67 65 74 2d 74 61 72 67 65 74 73 . get-targets
0850: 0a 20 20 20 20 3b 3b 20 72 65 67 69 73 74 65 72 . ;; register
0860: 2d 72 75 6e 0a 20 20 20 20 67 65 74 2d 74 65 73 -run. get-tes
0870: 74 73 2d 74 61 67 73 0a 20 20 20 20 67 65 74 2d ts-tags. get-
0880: 74 65 73 74 2d 74 69 6d 65 73 0a 20 20 20 20 67 test-times. g
0890: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
08a0: 0a 20 20 20 20 67 65 74 2d 74 65 73 74 73 2d 66 . get-tests-f
08b0: 6f 72 2d 72 75 6e 2d 73 74 61 74 65 2d 73 74 61 or-run-state-sta
08c0: 74 75 73 0a 20 20 20 20 67 65 74 2d 74 65 73 74 tus. get-test
08d0: 2d 69 64 0a 20 20 20 20 67 65 74 2d 74 65 73 74 -id. get-test
08e0: 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 6e 64 61 s-for-runs-minda
08f0: 74 61 0a 20 20 20 20 67 65 74 2d 74 65 73 74 73 ta. get-tests
0900: 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 -for-run-mindata
0910: 0a 20 20 20 20 67 65 74 2d 72 75 6e 2d 6e 61 6d . get-run-nam
0920: 65 2d 66 72 6f 6d 2d 69 64 0a 20 20 20 20 67 65 e-from-id. ge
0930: 74 2d 72 75 6e 73 0a 20 20 20 20 73 69 6d 70 6c t-runs. simpl
0940: 65 2d 67 65 74 2d 72 75 6e 73 0a 20 20 20 20 67 e-get-runs. g
0950: 65 74 2d 6e 75 6d 2d 72 75 6e 73 0a 20 20 20 20 et-num-runs.
0960: 67 65 74 2d 72 75 6e 73 2d 63 6e 74 2d 62 79 2d get-runs-cnt-by-
0970: 70 61 74 74 0a 20 20 20 20 67 65 74 2d 61 6c 6c patt. get-all
0980: 2d 72 75 6e 2d 69 64 73 0a 20 20 20 20 67 65 74 -run-ids. get
0990: 2d 70 72 65 76 2d 72 75 6e 2d 69 64 73 0a 20 20 -prev-run-ids.
09a0: 20 20 67 65 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 get-run-ids-ma
09b0: 74 63 68 69 6e 67 2d 74 61 72 67 65 74 0a 20 20 tching-target.
09c0: 20 20 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 get-runs-by-pa
09d0: 74 74 0a 20 20 20 20 67 65 74 2d 73 74 65 70 73 tt. get-steps
09e0: 2d 64 61 74 61 0a 20 20 20 20 67 65 74 2d 73 74 -data. get-st
09f0: 65 70 73 2d 66 6f 72 2d 74 65 73 74 0a 20 20 20 eps-for-test.
0a00: 20 72 65 61 64 2d 74 65 73 74 2d 64 61 74 61 0a read-test-data.
0a10: 20 20 20 20 72 65 61 64 2d 74 65 73 74 2d 64 61 read-test-da
0a20: 74 61 2d 76 61 72 70 61 74 74 0a 20 20 20 20 6c ta-varpatt. l
0a30: 6f 67 69 6e 0a 20 20 20 20 74 61 73 6b 73 2d 67 ogin. tasks-g
0a40: 65 74 2d 6c 61 73 74 0a 20 20 20 20 74 65 73 74 et-last. test
0a50: 6d 65 74 61 2d 67 65 74 2d 72 65 63 6f 72 64 0a meta-get-record.
0a60: 20 20 20 20 68 61 76 65 2d 69 6e 63 6f 6d 70 6c have-incompl
0a70: 65 74 65 73 3f 0a 20 20 20 20 67 65 74 2d 63 68 etes?. get-ch
0a80: 61 6e 67 65 64 2d 72 65 63 6f 72 64 2d 69 64 73 anged-record-ids
0a90: 0a 20 20 20 20 67 65 74 2d 72 75 6e 2d 72 65 63 . get-run-rec
0aa0: 6f 72 64 2d 69 64 73 20 0a 20 20 20 20 67 65 74 ord-ids . get
0ab0: 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 2d 63 -not-completed-c
0ac0: 6e 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 61 70 nt))..(define ap
0ad0: 69 3a 77 72 69 74 65 2d 71 75 65 72 69 65 73 0a i:write-queries.
0ae0: 20 20 27 28 0a 20 20 20 20 67 65 74 2d 6b 65 79 '(. get-key
0af0: 73 2d 77 72 69 74 65 20 3b 3b 20 64 75 6d 6d 79 s-write ;; dummy
0b00: 20 22 77 72 69 74 65 22 20 71 75 65 72 79 20 74 "write" query t
0b10: 6f 20 66 6f 72 63 65 20 73 65 72 76 65 72 20 73 o force server s
0b20: 74 61 72 74 0a 0a 20 20 20 20 3b 3b 20 53 45 52 tart.. ;; SER
0b30: 56 45 52 53 0a 20 20 20 20 3b 3b 20 73 74 61 72 VERS. ;; star
0b40: 74 2d 73 65 72 76 65 72 0a 20 20 20 20 3b 3b 20 t-server. ;;
0b50: 6b 69 6c 6c 2d 73 65 72 76 65 72 0a 0a 20 20 20 kill-server..
0b60: 20 3b 3b 20 54 45 53 54 53 0a 20 20 20 20 74 65 ;; TESTS. te
0b70: 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 st-set-state-sta
0b80: 74 75 73 2d 62 79 2d 69 64 0a 20 20 20 20 64 65 tus-by-id. de
0b90: 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 lete-test-record
0ba0: 73 0a 20 20 20 20 64 65 6c 65 74 65 2d 6f 6c 64 s. delete-old
0bb0: 2d 64 65 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 -deleted-test-re
0bc0: 63 6f 72 64 73 0a 20 20 20 20 74 65 73 74 2d 73 cords. test-s
0bd0: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 0a et-state-status.
0be0: 20 20 20 20 74 65 73 74 2d 73 65 74 2d 74 6f 70 test-set-top
0bf0: 2d 70 72 6f 63 65 73 73 2d 70 69 64 0a 20 20 20 -process-pid.
0c00: 20 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 set-state-statu
0c10: 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 s-and-roll-up-it
0c20: 65 6d 73 0a 20 20 20 20 0a 20 20 20 20 75 70 64 ems. . upd
0c30: 61 74 65 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f ate-pass-fail-co
0c40: 75 6e 74 73 0a 20 20 20 20 74 6f 70 2d 74 65 73 unts. top-tes
0c50: 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 6f 75 t-set-per-pf-cou
0c60: 6e 74 73 20 3b 3b 20 28 64 62 3a 74 6f 70 2d 74 nts ;; (db:top-t
0c70: 65 73 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 est-set-per-pf-c
0c80: 6f 75 6e 74 73 20 28 64 62 3a 67 65 74 2d 64 62 ounts (db:get-db
0c90: 20 2a 64 62 2a 20 35 29 20 35 20 22 72 75 6e 66 *db* 5) 5 "runf
0ca0: 69 72 73 74 22 29 0a 0a 20 20 20 20 3b 3b 20 52 irst").. ;; R
0cb0: 55 4e 53 0a 20 20 20 20 72 65 67 69 73 74 65 72 UNS. register
0cc0: 2d 72 75 6e 0a 20 20 20 20 73 65 74 2d 74 65 73 -run. set-tes
0cd0: 74 73 2d 73 74 61 74 65 2d 73 74 61 74 75 73 0a ts-state-status.
0ce0: 20 20 20 20 64 65 6c 65 74 65 2d 72 75 6e 0a 20 delete-run.
0cf0: 20 20 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 lock/unlock-r
0d00: 75 6e 0a 20 20 20 20 75 70 64 61 74 65 2d 72 75 un. update-ru
0d10: 6e 2d 65 76 65 6e 74 5f 74 69 6d 65 0a 20 20 20 n-event_time.
0d20: 20 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 mark-incomplete
0d30: 0a 20 20 20 20 73 65 74 2d 73 74 61 74 65 2d 73 . set-state-s
0d40: 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 tatus-and-roll-u
0d50: 70 2d 72 75 6e 0a 20 20 20 20 3b 3b 20 53 54 45 p-run. ;; STE
0d60: 50 53 0a 20 20 20 20 74 65 73 74 73 74 65 70 2d PS. teststep-
0d70: 73 65 74 2d 73 74 61 74 75 73 21 0a 20 20 20 20 set-status!.
0d80: 64 65 6c 65 74 65 2d 73 74 65 70 73 2d 66 6f 72 delete-steps-for
0d90: 2d 74 65 73 74 0a 20 20 20 20 3b 3b 20 54 45 53 -test. ;; TES
0da0: 54 20 44 41 54 41 0a 20 20 20 20 74 65 73 74 2d T DATA. test-
0db0: 64 61 74 61 2d 72 6f 6c 6c 75 70 0a 20 20 20 20 data-rollup.
0dc0: 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 0a 0a csv->test-data..
0dd0: 20 20 20 20 3b 3b 20 4d 49 53 43 0a 20 20 20 20 ;; MISC.
0de0: 73 79 6e 63 2d 69 6e 6d 65 6d 2d 3e 64 62 0a 20 sync-inmem->db.
0df0: 20 20 20 64 72 6f 70 2d 61 6c 6c 2d 74 72 69 67 drop-all-trig
0e00: 67 65 72 73 0a 20 20 20 20 63 72 65 61 74 65 2d gers. create-
0e10: 61 6c 6c 2d 74 72 69 67 67 65 72 73 0a 20 20 20 all-triggers.
0e20: 20 75 70 64 61 74 65 2d 74 65 73 64 61 74 61 2d update-tesdata-
0e30: 6f 6e 2d 72 65 70 69 6c 63 61 74 65 2d 64 62 20 on-repilcate-db
0e40: 0a 0a 20 20 20 20 3b 3b 20 54 45 53 54 4d 45 54 .. ;; TESTMET
0e50: 41 0a 20 20 20 20 74 65 73 74 6d 65 74 61 2d 61 A. testmeta-a
0e60: 64 64 2d 72 65 63 6f 72 64 0a 20 20 20 20 74 65 dd-record. te
0e70: 73 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 69 stmeta-update-fi
0e80: 65 6c 64 0a 0a 20 20 20 20 3b 3b 20 54 41 53 4b eld.. ;; TASK
0e90: 53 0a 20 20 20 20 74 61 73 6b 73 2d 61 64 64 0a S. tasks-add.
0ea0: 20 20 20 20 74 61 73 6b 73 2d 73 65 74 2d 73 74 tasks-set-st
0eb0: 61 74 65 2d 67 69 76 65 6e 2d 70 61 72 61 6d 2d ate-given-param-
0ec0: 6b 65 79 0a 20 20 20 20 29 29 0a 0a 28 64 65 66 key. ))..(def
0ed0: 69 6e 65 20 2a 64 62 2d 77 72 69 74 65 2d 6d 75 ine *db-write-mu
0ee0: 74 65 78 65 73 2a 20 28 6d 61 6b 65 2d 68 61 73 texes* (make-has
0ef0: 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 69 6e h-table)).(defin
0f00: 65 20 2a 73 65 72 76 65 72 2d 73 69 67 6e 61 74 e *server-signat
0f10: 75 72 65 2a 20 23 66 29 0a 3b 3b 20 3b 3b 20 54 ure* #f).;; ;; T
0f20: 68 65 73 65 20 61 72 65 20 63 61 6c 6c 65 64 20 hese are called
0f30: 62 79 20 74 68 65 20 73 65 72 76 65 72 20 6f 6e by the server on
0f40: 20 72 65 63 69 70 74 20 6f 66 20 2f 61 70 69 20 recipt of /api
0f50: 63 61 6c 6c 73 0a 3b 3b 20 3b 3b 20 20 20 20 2d calls.;; ;; -
0f60: 20 6b 65 65 70 20 69 74 20 73 69 6d 70 6c 65 2c keep it simple,
0f70: 20 6f 6e 6c 79 20 72 65 74 75 72 6e 20 74 68 65 only return the
0f80: 20 61 63 74 75 61 6c 20 72 65 73 75 6c 74 20 6f actual result o
0f90: 66 20 74 68 65 20 63 61 6c 6c 2c 20 69 2e 65 2e f the call, i.e.
0fa0: 20 6e 6f 20 6d 65 74 61 20 69 6e 66 6f 20 68 65 no meta info he
0fb0: 72 65 0a 3b 3b 20 3b 3b 0a 3b 3b 20 3b 3b 20 20 re.;; ;;.;; ;;
0fc0: 20 20 2d 20 72 65 74 75 72 6e 73 20 23 28 20 66 - returns #( f
0fd0: 6c 61 67 20 72 65 73 75 6c 74 20 29 0a 3b 3b 20 lag result ).;;
0fe0: 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 61 ;;.;; (define (a
0ff0: 70 69 3a 65 78 65 63 75 74 65 2d 72 65 71 75 65 pi:execute-reque
1000: 73 74 73 20 64 62 73 74 72 75 63 74 20 64 61 74 sts dbstruct dat
1010: 29 0a 3b 3b 20 20 20 28 69 66 20 28 3e 20 2a 61 ).;; (if (> *a
1020: 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 pi-process-reque
1030: 73 74 2d 63 6f 75 6e 74 2a 20 35 30 29 0a 3b 3b st-count* 50).;;
1040: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b (begin.;;
1050: 20 09 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f .(if (common:lo
1060: 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 33 30 w-noise-print 30
1070: 20 22 74 6f 6f 20 6d 61 6e 79 20 74 68 72 65 61 "too many threa
1080: 64 73 22 29 0a 3b 3b 20 09 20 20 20 20 28 64 65 ds").;; . (de
1090: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
10a0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
10b0: 57 41 52 4e 49 4e 47 3a 20 22 2a 61 70 69 2d 70 WARNING: "*api-p
10c0: 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 2d 63 rocess-request-c
10d0: 6f 75 6e 74 2a 22 20 74 68 72 65 61 64 73 2c 20 ount*" threads,
10e0: 70 6f 74 65 6e 74 69 61 6c 20 6f 76 65 72 6c 6f potential overlo
10f0: 61 64 2c 20 61 64 64 69 6e 67 20 30 2e 35 20 73 ad, adding 0.5 s
1100: 65 63 20 64 65 6c 61 79 2e 22 29 29 0a 3b 3b 20 ec delay.")).;;
1110: 09 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .;; (thread-slee
1120: 70 21 20 30 2e 35 29 20 3b 3b 20 74 61 6b 65 20 p! 0.5) ;; take
1130: 61 20 6e 61 70 20 2d 20 6e 6f 2c 20 74 68 65 20 a nap - no, the
1140: 6e 61 70 70 69 6e 67 20 69 73 20 6d 6f 76 65 64 napping is moved
1150: 20 74 6f 20 74 68 65 20 63 6c 69 65 6e 74 73 20 to the clients
1160: 76 69 61 20 74 74 3a 62 61 63 6b 6f 66 66 2d 69 via tt:backoff-i
1170: 6e 63 72 0a 3b 3b 20 09 29 29 0a 3b 3b 20 20 20 ncr.;; .)).;;
1180: 28 63 6f 6e 64 0a 3b 3b 20 20 20 20 28 28 6e 6f (cond.;; ((no
1190: 74 20 28 76 65 63 74 6f 72 3f 20 64 61 74 29 29 t (vector? dat))
11a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11b0: 20 20 20 20 3b 3b 20 69 74 20 69 73 20 61 6e 20 ;; it is an
11c0: 65 72 72 6f 72 20 74 6f 20 6e 6f 74 20 72 65 63 error to not rec
11d0: 65 69 76 65 20 61 20 76 65 63 74 6f 72 0a 3b 3b eive a vector.;;
11e0: 20 20 20 20 20 28 76 65 63 74 6f 72 20 23 66 20 (vector #f
11f0: 28 76 65 63 74 6f 72 20 23 66 20 22 72 65 6d 6f (vector #f "remo
1200: 74 65 20 6d 75 73 74 20 62 65 20 63 61 6c 6c 65 te must be calle
1210: 64 20 77 69 74 68 20 61 20 76 65 63 74 6f 72 22 d with a vector"
1220: 29 29 29 0a 3b 3b 20 20 20 20 28 65 6c 73 65 20 ))).;; (else
1230: 20 0a 3b 3b 20 20 20 20 20 28 6c 65 74 2a 20 28 .;; (let* (
1240: 28 63 6d 64 2d 69 6e 20 20 20 20 20 20 20 20 20 (cmd-in
1250: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 64 (vector-ref d
1260: 61 74 20 30 29 29 0a 3b 3b 20 20 20 20 20 20 20 at 0)).;;
1270: 20 20 20 20 20 28 63 6d 64 20 20 20 20 20 20 20 (cmd
1280: 20 20 20 20 20 20 20 20 28 69 66 20 28 73 79 6d (if (sym
1290: 62 6f 6c 3f 20 63 6d 64 2d 69 6e 29 0a 3b 3b 20 bol? cmd-in).;;
12a0: 09 09 09 09 20 20 63 6d 64 2d 69 6e 0a 3b 3b 20 .... cmd-in.;;
12b0: 09 09 09 09 20 20 28 73 74 72 69 6e 67 2d 3e 73 .... (string->s
12c0: 79 6d 62 6f 6c 20 63 6d 64 2d 69 6e 29 29 29 0a ymbol cmd-in))).
12d0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 28 70 ;; (p
12e0: 61 72 61 6d 73 20 20 20 20 20 20 20 20 20 20 20 arams
12f0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 64 61 74 (vector-ref dat
1300: 20 31 29 29 0a 3b 3b 20 09 20 20 20 28 72 75 6e 1)).;; . (run
1310: 2d 69 64 20 20 20 20 20 20 20 20 20 20 20 20 28 -id (
1320: 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 if (null? params
1330: 29 0a 3b 3b 20 09 09 09 09 20 20 30 0a 3b 3b 20 ).;; .... 0.;;
1340: 09 09 09 09 20 20 28 63 61 72 20 70 61 72 61 6d .... (car param
1350: 73 29 29 29 0a 3b 3b 20 09 20 20 20 28 77 72 69 s))).;; . (wri
1360: 74 65 2d 6d 75 74 65 78 20 20 20 20 20 20 20 28 te-mutex (
1370: 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 65 if (hash-table-e
1380: 78 69 73 74 73 3f 20 2a 64 62 2d 77 72 69 74 65 xists? *db-write
1390: 2d 6d 75 74 65 78 65 73 2a 20 72 75 6e 2d 69 64 -mutexes* run-id
13a0: 29 0a 3b 3b 20 09 09 09 09 20 20 28 68 61 73 68 ).;; .... (hash
13b0: 2d 74 61 62 6c 65 2d 72 65 66 20 2a 64 62 2d 77 -table-ref *db-w
13c0: 72 69 74 65 2d 6d 75 74 65 78 65 73 2a 20 72 75 rite-mutexes* ru
13d0: 6e 2d 69 64 29 0a 3b 3b 20 09 09 09 09 20 20 28 n-id).;; .... (
13e0: 6c 65 74 2a 20 28 28 6e 65 77 6d 75 74 65 78 20 let* ((newmutex
13f0: 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 29 0a 3b (make-mutex))).;
1400: 3b 20 09 09 09 09 20 20 20 20 28 68 61 73 68 2d ; .... (hash-
1410: 74 61 62 6c 65 2d 73 65 74 21 20 2a 64 62 2d 77 table-set! *db-w
1420: 72 69 74 65 2d 6d 75 74 65 78 65 73 2a 20 72 75 rite-mutexes* ru
1430: 6e 2d 69 64 20 6e 65 77 6d 75 74 65 78 29 0a 3b n-id newmutex).;
1440: 3b 20 09 09 09 09 20 20 20 20 6e 65 77 6d 75 74 ; .... newmut
1450: 65 78 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 ex))).;;
1460: 20 20 20 20 28 73 74 61 72 74 2d 74 20 20 20 20 (start-t
1470: 20 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d (current-
1480: 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 3b milliseconds)).;
1490: 3b 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 ; (re
14a0: 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 20 20 20 20 adonly-mode
14b0: 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 72 65 (dbr:dbstruct-re
14c0: 61 64 2d 6f 6e 6c 79 20 64 62 73 74 72 75 63 74 ad-only dbstruct
14d0: 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 )).;;
14e0: 20 28 72 65 61 64 6f 6e 6c 79 2d 63 6f 6d 6d 61 (readonly-comma
14f0: 6e 64 20 20 28 6d 65 6d 62 65 72 20 63 6d 64 20 nd (member cmd
1500: 61 70 69 3a 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 api:read-only-qu
1510: 65 72 69 65 73 29 29 0a 3b 3b 20 20 20 20 20 20 eries)).;;
1520: 20 20 20 20 20 20 28 77 72 69 74 65 63 6d 64 2d (writecmd-
1530: 69 6e 2d 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 in-readonly-mode
1540: 20 28 61 6e 64 20 72 65 61 64 6f 6e 6c 79 2d 6d (and readonly-m
1550: 6f 64 65 20 28 6e 6f 74 20 72 65 61 64 6f 6e 6c ode (not readonl
1560: 79 2d 63 6f 6d 6d 61 6e 64 29 29 29 29 0a 3b 3b y-command)))).;;
1570: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
1580: 72 65 61 64 6f 6e 6c 79 2d 63 6f 6d 6d 61 6e 64 readonly-command
1590: 29 0a 3b 3b 20 09 20 20 28 6d 75 74 65 78 2d 6c ).;; . (mutex-l
15a0: 6f 63 6b 21 20 77 72 69 74 65 2d 6d 75 74 65 78 ock! write-mutex
15b0: 29 29 0a 3b 3b 20 20 20 20 20 20 20 28 6c 65 74 )).;; (let
15c0: 2a 20 28 28 74 6d 70 70 61 74 68 20 20 20 20 28 * ((tmppath (
15d0: 64 62 72 3a 64 62 73 74 72 75 63 74 2d 74 6d 70 dbr:dbstruct-tmp
15e0: 70 61 74 68 20 20 64 62 73 74 72 75 63 74 29 29 path dbstruct))
15f0: 0a 3b 3b 20 09 20 20 20 20 20 28 63 6c 65 61 6e .;; . (clean
1600: 2d 72 75 6e 2d 69 64 20 28 63 6f 6e 64 0a 3b 3b -run-id (cond.;;
1610: 20 09 09 09 20 20 20 20 28 28 6e 75 6d 62 65 72 ... ((number
1620: 3f 20 72 75 6e 2d 69 64 29 20 20 20 72 75 6e 2d ? run-id) run-
1630: 69 64 29 0a 3b 3b 20 09 09 09 20 20 20 20 28 28 id).;; ... ((
1640: 65 71 75 61 6c 3f 20 72 75 6e 2d 69 64 20 23 66 equal? run-id #f
1650: 29 20 22 6d 61 69 6e 22 29 0a 3b 3b 20 09 09 09 ) "main").;; ...
1660: 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 (else
1670: 20 20 20 20 20 20 20 20 22 6f 74 68 65 72 22 29 "other")
1680: 29 29 0a 3b 3b 20 09 20 20 20 20 20 28 63 72 75 )).;; . (cru
1690: 6d 62 66 69 6c 65 20 20 28 64 62 66 69 6c 65 3a mbfile (dbfile:
16a0: 77 61 69 74 2d 66 6f 72 2d 71 69 66 20 74 6d 70 wait-for-qif tmp
16b0: 70 61 74 68 20 63 6c 65 61 6e 2d 72 75 6e 2d 69 path clean-run-i
16c0: 64 20 28 63 6f 6e 73 20 63 6d 64 20 70 61 72 61 d (cons cmd para
16d0: 6d 73 29 29 29 0a 3b 3b 20 09 20 20 20 20 20 28 ms))).;; . (
16e0: 72 65 73 20 20 20 20 0a 3b 3b 20 20 20 20 20 20 res .;;
16f0: 20 20 20 20 20 20 20 20 20 28 69 66 20 77 72 69 (if wri
1700: 74 65 63 6d 64 2d 69 6e 2d 72 65 61 64 6f 6e 6c tecmd-in-readonl
1710: 79 2d 6d 6f 64 65 0a 3b 3b 20 20 20 20 20 20 20 y-mode.;;
1720: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
1730: 63 20 22 61 74 74 65 6d 70 74 20 74 6f 20 72 75 c "attempt to ru
1740: 6e 20 77 72 69 74 65 20 63 6f 6d 6d 61 6e 64 20 n write command
1750: 22 63 6d 64 22 20 6f 6e 20 61 20 72 65 61 64 2d "cmd" on a read-
1760: 6f 6e 6c 79 20 64 61 74 61 62 61 73 65 22 29 0a only database").
1770: 3b 3b 20 09 09 20 20 28 61 70 69 3a 64 69 73 70 ;; .. (api:disp
1780: 61 74 63 68 2d 72 65 71 75 65 73 74 20 64 62 73 atch-request dbs
1790: 74 72 75 63 74 20 63 6d 64 20 72 75 6e 2d 69 64 truct cmd run-id
17a0: 20 70 61 72 61 6d 73 29 29 29 29 0a 3b 3b 20 09 params)))).;; .
17b0: 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 63 72 (delete-file* cr
17c0: 75 6d 62 66 69 6c 65 29 0a 3b 3b 20 09 28 69 66 umbfile).;; .(if
17d0: 20 28 6e 6f 74 20 72 65 61 64 6f 6e 6c 79 2d 63 (not readonly-c
17e0: 6f 6d 6d 61 6e 64 29 0a 3b 3b 20 09 20 20 20 20 ommand).;; .
17f0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 77 (mutex-unlock! w
1800: 72 69 74 65 2d 6d 75 74 65 78 29 29 0a 3b 3b 20 rite-mutex)).;;
1810: 09 0a 3b 3b 20 09 3b 3b 20 73 61 76 65 20 61 6c ..;; .;; save al
1820: 6c 20 73 74 61 74 73 0a 3b 3b 20 09 28 6c 65 74 l stats.;; .(let
1830: 20 28 28 64 65 6c 74 61 2d 74 20 28 2d 20 28 63 ((delta-t (- (c
1840: 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f urrent-milliseco
1850: 6e 64 73 29 0a 3b 3b 20 09 09 09 20 20 73 74 61 nds).;; ... sta
1860: 72 74 2d 74 29 29 0a 3b 3b 20 09 20 20 20 20 20 rt-t)).;; .
1870: 20 28 6d 6f 64 69 66 69 65 64 2d 63 6d 64 20 28 (modified-cmd (
1880: 69 66 20 28 65 71 3f 20 63 6d 64 20 27 67 65 6e if (eq? cmd 'gen
1890: 65 72 61 6c 2d 63 61 6c 6c 29 0a 3b 3b 20 09 09 eral-call).;; ..
18a0: 09 09 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f ..(string->symbo
18b0: 6c 20 28 63 6f 6e 63 20 22 67 65 6e 65 72 61 6c l (conc "general
18c0: 2d 63 61 6c 6c 2d 22 20 28 63 61 72 20 70 61 72 -call-" (car par
18d0: 61 6d 73 29 29 29 0a 3b 3b 20 09 09 09 09 63 6d ams))).;; ....cm
18e0: 64 29 29 29 0a 3b 3b 20 09 20 20 28 68 61 73 68 d))).;; . (hash
18f0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 64 62 2d -table-set! *db-
1900: 61 70 69 2d 63 61 6c 6c 2d 74 69 6d 65 2a 20 6d api-call-time* m
1910: 6f 64 69 66 69 65 64 2d 63 6d 64 0a 3b 3b 20 09 odified-cmd.;; .
1920: 09 09 20 20 20 28 63 6f 6e 73 20 64 65 6c 74 61 .. (cons delta
1930: 2d 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 -t (hash-table-r
1940: 65 66 2f 64 65 66 61 75 6c 74 20 2a 64 62 2d 61 ef/default *db-a
1950: 70 69 2d 63 61 6c 6c 2d 74 69 6d 65 2a 20 6d 6f pi-call-time* mo
1960: 64 69 66 69 65 64 2d 63 6d 64 20 27 28 29 29 29 dified-cmd '()))
1970: 29 29 0a 3b 3b 20 09 28 69 66 20 77 72 69 74 65 )).;; .(if write
1980: 63 6d 64 2d 69 6e 2d 72 65 61 64 6f 6e 6c 79 2d cmd-in-readonly-
1990: 6d 6f 64 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 mode.;;
19a0: 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 20 20 (begin.;;
19b0: 20 20 20 20 20 20 20 20 20 20 20 20 23 3b 28 63 #;(c
19c0: 6f 6d 6d 6f 6e 3a 74 65 6c 65 6d 65 74 72 79 2d ommon:telemetry-
19d0: 6c 6f 67 20 28 63 6f 6e 63 20 22 61 70 69 2d 6f log (conc "api-o
19e0: 75 74 3a 22 28 2d 3e 73 74 72 69 6e 67 20 63 6d ut:"(->string cm
19f0: 64 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 d)).;;
1a00: 20 20 20 20 20 70 61 79 6c 6f 61 64 3a 20 60 28 payload: `(
1a10: 28 70 61 72 61 6d 73 20 2e 20 2c 70 61 72 61 6d (params . ,param
1a20: 73 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 s).;;
1a30: 20 20 20 20 28 6f 6b 2d 72 65 73 20 2e 20 23 74 (ok-res . #t
1a40: 29 29 29 0a 3b 3b 20 09 20 20 20 20 20 20 28 76 ))).;; . (v
1a50: 65 63 74 6f 72 20 23 66 20 72 65 73 29 29 0a 3b ector #f res)).;
1a60: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 ; (b
1a70: 65 67 69 6e 0a 3b 3b 20 20 20 20 20 20 20 20 20 egin.;;
1a80: 20 20 20 20 20 20 23 3b 28 63 6f 6d 6d 6f 6e 3a #;(common:
1a90: 74 65 6c 65 6d 65 74 72 79 2d 6c 6f 67 20 28 63 telemetry-log (c
1aa0: 6f 6e 63 20 22 61 70 69 2d 6f 75 74 3a 22 28 2d onc "api-out:"(-
1ab0: 3e 73 74 72 69 6e 67 20 63 6d 64 29 29 0a 3b 3b >string cmd)).;;
1ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 70 p
1ad0: 61 79 6c 6f 61 64 3a 20 60 28 28 70 61 72 61 6d ayload: `((param
1ae0: 73 20 2e 20 2c 70 61 72 61 6d 73 29 0a 3b 3b 20 s . ,params).;;
1af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6f (o
1b00: 6b 2d 72 65 73 20 2e 20 23 66 29 29 29 0a 3b 3b k-res . #f))).;;
1b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1b20: 76 65 63 74 6f 72 20 23 74 20 72 65 73 29 29 29 vector #t res)))
1b30: 29 29 29 29 29 0a 0a 3b 3b 20 69 6e 64 61 74 20 )))))..;; indat
1b40: 69 73 20 28 63 6d 64 20 72 75 6e 2d 69 64 20 70 is (cmd run-id p
1b50: 61 72 61 6d 73 20 6d 65 74 61 29 0a 3b 3b 0a 3b arams meta).;;.;
1b60: 3b 20 57 41 52 4e 49 4e 47 3a 20 44 6f 20 6e 6f ; WARNING: Do no
1b70: 74 20 70 72 69 6e 74 20 61 6e 79 74 68 69 6e 67 t print anything
1b80: 20 69 6e 20 74 68 65 20 6c 61 6d 62 64 61 20 6f in the lambda o
1b90: 66 20 74 68 69 73 20 66 75 6e 63 74 69 6f 6e 20 f this function
1ba0: 61 73 20 69 74 0a 3b 3b 20 20 20 20 20 20 20 20 as it.;;
1bb0: 20 20 72 65 61 64 73 2f 77 72 69 74 65 73 20 74 reads/writes t
1bc0: 6f 20 63 75 72 72 65 6e 74 20 69 6e 2f 6f 75 74 o current in/out
1bd0: 20 70 6f 72 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 port.;;.(define
1be0: 20 28 61 70 69 3a 74 63 70 2d 64 69 73 70 61 74 (api:tcp-dispat
1bf0: 63 68 2d 72 65 71 75 65 73 74 2d 6d 61 6b 65 2d ch-request-make-
1c00: 68 61 6e 64 6c 65 72 20 64 62 73 74 72 75 63 74 handler dbstruct
1c10: 29 20 3b 3b 20 63 6d 64 20 72 75 6e 2d 69 64 20 ) ;; cmd run-id
1c20: 70 61 72 61 6d 73 29 0a 20 20 28 61 73 73 65 72 params). (asser
1c30: 74 20 2a 74 6f 70 70 61 74 68 2a 20 22 46 41 54 t *toppath* "FAT
1c40: 41 4c 3a 20 61 70 69 3a 74 63 70 2d 64 69 73 70 AL: api:tcp-disp
1c50: 61 74 63 68 2d 72 65 71 75 65 73 74 2d 6d 61 6b atch-request-mak
1c60: 65 2d 68 61 6e 64 6c 65 72 20 63 61 6c 6c 65 64 e-handler called
1c70: 20 62 75 74 20 2a 74 6f 70 70 61 74 68 2a 20 6e but *toppath* n
1c80: 6f 74 20 73 65 74 2e 22 29 0a 20 20 28 69 66 20 ot set."). (if
1c90: 28 6e 6f 74 20 2a 73 65 72 76 65 72 2d 73 69 67 (not *server-sig
1ca0: 6e 61 74 75 72 65 2a 29 0a 20 20 20 20 20 20 28 nature*). (
1cb0: 73 65 74 21 20 2a 73 65 72 76 65 72 2d 73 69 67 set! *server-sig
1cc0: 6e 61 74 75 72 65 2a 20 28 74 74 3a 6d 6b 2d 73 nature* (tt:mk-s
1cd0: 69 67 6e 61 74 75 72 65 20 2a 74 6f 70 70 61 74 ignature *toppat
1ce0: 68 2a 29 29 29 0a 20 20 28 6c 61 6d 62 64 61 20 h*))). (lambda
1cf0: 28 69 6e 64 61 74 29 0a 20 20 20 20 28 6c 65 74 (indat). (let
1d00: 2a 20 28 3b 3b 20 28 69 6e 64 61 74 20 20 20 20 * (;; (indat
1d10: 20 20 28 64 65 73 65 72 69 61 6c 69 7a 65 29 29 (deserialize))
1d20: 0a 09 20 20 20 28 6e 65 77 63 6f 75 6e 74 20 20 .. (newcount
1d30: 20 28 2b 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 (+ *api-process
1d40: 2d 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a 20 -request-count*
1d50: 31 29 29 0a 09 20 20 20 28 64 65 6c 61 79 2d 77 1)).. (delay-w
1d60: 61 69 74 20 28 69 66 20 28 3e 20 6e 65 77 63 6f ait (if (> newco
1d70: 75 6e 74 20 31 30 29 0a 09 09 09 20 20 20 28 2d unt 10).... (-
1d80: 20 6e 65 77 63 6f 75 6e 74 20 31 30 29 0a 09 09 newcount 10)...
1d90: 09 20 20 20 30 29 29 0a 09 20 20 20 28 6e 6f 72 . 0)).. (nor
1da0: 6d 61 6c 2d 70 72 6f 63 20 28 6c 61 6d 62 64 61 mal-proc (lambda
1db0: 20 28 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 (cmd run-id par
1dc0: 61 6d 73 29 0a 09 09 09 20 20 28 63 61 73 65 20 ams).... (case
1dd0: 63 6d 64 0a 09 09 09 20 20 20 20 28 28 70 69 6e cmd.... ((pin
1de0: 67 29 20 2a 73 65 72 76 65 72 2d 73 69 67 6e 61 g) *server-signa
1df0: 74 75 72 65 2a 29 0a 09 09 09 20 20 20 20 28 65 ture*).... (e
1e00: 6c 73 65 0a 09 09 09 20 20 20 20 20 28 61 70 69 lse.... (api
1e10: 3a 64 69 73 70 61 74 63 68 2d 72 65 71 75 65 73 :dispatch-reques
1e20: 74 20 64 62 73 74 72 75 63 74 20 63 6d 64 20 72 t dbstruct cmd r
1e30: 75 6e 2d 69 64 20 70 61 72 61 6d 73 29 29 29 29 un-id params))))
1e40: 29 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 2a )). (set! *
1e50: 61 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 api-process-requ
1e60: 65 73 74 2d 63 6f 75 6e 74 2a 20 6e 65 77 63 6f est-count* newco
1e70: 75 6e 74 29 0a 20 20 20 20 20 20 28 73 65 74 21 unt). (set!
1e80: 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 *db-last-access
1e90: 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e * (current-secon
1ea0: 64 73 29 29 0a 20 20 20 20 20 20 28 6d 61 74 63 ds)). (matc
1eb0: 68 20 69 6e 64 61 74 0a 09 28 28 63 6d 64 20 72 h indat..((cmd r
1ec0: 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 6d 65 74 un-id params met
1ed0: 61 29 0a 09 20 28 6c 65 74 2a 20 28 28 64 62 2d a).. (let* ((db-
1ee0: 6f 6b 20 20 28 6c 65 74 2a 20 28 28 64 62 66 6e ok (let* ((dbfn
1ef0: 61 6d 65 20 28 64 62 6d 6f 64 3a 72 75 6e 2d 69 ame (dbmod:run-i
1f00: 64 2d 3e 64 62 66 6e 61 6d 65 20 72 75 6e 2d 69 d->dbfname run-i
1f10: 64 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 6f d)).... (o
1f20: 6b 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 64 k (equal? d
1f30: 62 66 6e 61 6d 65 20 28 64 62 72 3a 64 62 73 74 bfname (dbr:dbst
1f40: 72 75 63 74 2d 64 62 66 6e 61 6d 65 20 64 62 73 ruct-dbfname dbs
1f50: 74 72 75 63 74 29 29 29 29 0a 09 09 09 20 20 28 truct)))).... (
1f60: 63 61 73 65 20 63 6d 64 0a 09 09 09 20 20 20 20 case cmd....
1f70: 28 28 70 69 6e 67 29 20 23 74 29 20 3b 3b 20 77 ((ping) #t) ;; w
1f80: 65 20 61 72 65 20 66 69 6e 65 0a 09 09 09 20 20 e are fine....
1f90: 20 20 28 65 6c 73 65 0a 09 09 09 20 20 20 20 20 (else....
1fa0: 28 69 66 20 28 6e 6f 74 20 6f 6b 29 28 64 65 62 (if (not ok)(deb
1fb0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
1fc0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 ult-log-port* "E
1fd0: 52 52 4f 52 3a 20 22 63 6d 64 22 2c 20 72 75 6e RROR: "cmd", run
1fe0: 2d 69 64 20 22 72 75 6e 2d 69 64 22 2c 20 6e 6f -id "run-id", no
1ff0: 74 20 63 6f 72 72 65 63 74 20 66 6f 72 20 64 62 t correct for db
2000: 66 6e 61 6d 65 20 22 28 64 62 72 3a 64 62 73 74 fname "(dbr:dbst
2010: 72 75 63 74 2d 64 62 66 6e 61 6d 65 20 64 62 73 ruct-dbfname dbs
2020: 74 72 75 63 74 29 29 29 0a 09 09 09 20 20 20 20 truct)))....
2030: 20 28 61 73 73 65 72 74 20 6f 6b 20 22 46 41 54 (assert ok "FAT
2040: 41 4c 3a 20 64 61 74 61 62 61 73 65 20 66 69 6c AL: database fil
2050: 65 20 61 6e 64 20 72 75 6e 2d 69 64 20 6e 6f 74 e and run-id not
2060: 20 61 6c 69 67 6e 65 64 2e 22 29 29 29 29 29 0a aligned."))))).
2070: 09 09 28 74 74 64 61 74 20 20 20 2a 73 65 72 76 ..(ttdat *serv
2080: 65 72 2d 69 6e 66 6f 2a 29 0a 09 09 28 73 65 72 er-info*)...(ser
2090: 76 65 72 2d 73 74 61 74 65 20 28 74 74 2d 73 74 ver-state (tt-st
20a0: 61 74 65 20 74 74 64 61 74 29 29 0a 09 09 28 73 ate ttdat))...(s
20b0: 74 61 74 75 73 20 20 28 63 6f 6e 64 0a 09 09 09 tatus (cond....
20c0: 20 20 3b 3b 20 28 28 3e 20 6e 65 77 63 6f 75 6e ;; ((> newcoun
20d0: 74 20 36 30 30 29 20 27 62 75 73 79 29 0a 09 09 t 600) 'busy)...
20e0: 09 20 20 28 28 3e 20 6e 65 77 63 6f 75 6e 74 20 . ((> newcount
20f0: 35 29 20 27 6c 6f 61 64 65 64 29 20 3b 3b 20 74 5) 'loaded) ;; t
2100: 68 69 73 20 67 65 74 73 20 74 72 61 6e 73 6d 69 his gets transmi
2110: 74 74 65 64 20 74 6f 20 74 68 65 20 63 6c 69 65 tted to the clie
2120: 6e 74 20 77 68 69 63 68 20 63 61 6c 6c 73 20 74 nt which calls t
2130: 74 3a 62 61 63 6b 6f 66 66 2d 69 6e 63 72 20 74 t:backoff-incr t
2140: 6f 20 73 6c 6f 77 20 73 74 75 66 66 20 64 6f 77 o slow stuff dow
2150: 6e 2e 0a 09 09 09 20 20 28 65 6c 73 65 20 27 6f n..... (else 'o
2160: 6b 29 29 29 0a 09 09 28 65 72 72 6d 73 67 20 20 k)))...(errmsg
2170: 28 63 61 73 65 20 73 74 61 74 75 73 0a 09 09 09 (case status....
2180: 20 20 20 28 28 62 75 73 79 29 20 20 20 28 63 6f ((busy) (co
2190: 6e 63 20 22 53 65 72 76 65 72 20 6f 76 65 72 6c nc "Server overl
21a0: 6f 61 64 65 64 2c 20 22 6e 65 77 63 6f 75 6e 74 oaded, "newcount
21b0: 22 20 74 68 72 65 61 64 73 20 69 6e 20 66 6c 69 " threads in fli
21c0: 67 68 74 22 29 29 0a 09 09 09 20 20 20 28 28 6c ght")).... ((l
21d0: 6f 61 64 65 64 29 20 28 63 6f 6e 63 20 22 53 65 oaded) (conc "Se
21e0: 72 76 65 72 20 6c 6f 61 64 65 64 2c 20 22 6e 65 rver loaded, "ne
21f0: 77 63 6f 75 6e 74 22 20 74 68 72 65 61 64 73 20 wcount" threads
2200: 69 6e 20 66 6c 69 67 68 74 22 29 29 0a 09 09 09 in flight"))....
2210: 20 20 20 28 65 6c 73 65 20 20 20 20 20 23 66 29 (else #f)
2220: 29 29 0a 09 09 28 72 65 73 75 6c 74 20 20 28 63 ))...(result (c
2230: 61 73 65 20 73 74 61 74 75 73 0a 09 09 09 20 20 ase status....
2240: 20 28 28 62 75 73 79 29 20 20 28 2d 20 6e 65 77 ((busy) (- new
2250: 63 6f 75 6e 74 20 32 39 29 29 20 3b 3b 20 63 61 count 29)) ;; ca
2260: 6c 6c 20 62 61 63 6b 20 69 6e 20 61 73 20 6d 61 ll back in as ma
2270: 6e 79 20 73 65 63 6f 6e 64 73 0a 09 09 09 20 20 ny seconds....
2280: 20 28 28 6c 6f 61 64 65 64 29 0a 3b 3b 20 09 09 ((loaded).;; ..
2290: 09 20 20 20 20 28 69 66 20 28 65 71 3f 20 28 72 . (if (eq? (r
22a0: 6d 74 3a 74 72 61 6e 73 70 6f 72 74 2d 6d 6f 64 mt:transport-mod
22b0: 65 29 20 27 74 63 70 29 0a 3b 3b 20 09 09 09 09 e) 'tcp).;; ....
22c0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
22d0: 2e 35 29 29 0a 09 09 09 20 20 20 20 28 6e 6f 72 .5)).... (nor
22e0: 6d 61 6c 2d 70 72 6f 63 20 63 6d 64 20 72 75 6e mal-proc cmd run
22f0: 2d 69 64 20 70 61 72 61 6d 73 29 29 0a 09 09 09 -id params))....
2300: 20 20 20 28 65 6c 73 65 0a 09 09 09 20 20 20 20 (else....
2310: 28 6e 6f 72 6d 61 6c 2d 70 72 6f 63 20 63 6d 64 (normal-proc cmd
2320: 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 29 29 run-id params))
2330: 29 29 0a 09 09 28 6d 65 74 61 20 20 20 28 63 61 ))...(meta (ca
2340: 73 65 20 63 6d 64 0a 09 09 09 20 20 28 28 70 69 se cmd.... ((pi
2350: 6e 67 29 20 60 28 28 73 73 74 61 74 65 20 2e 20 ng) `((sstate .
2360: 2c 73 65 72 76 65 72 2d 73 74 61 74 65 29 29 29 ,server-state)))
2370: 0a 09 09 09 20 20 28 65 6c 73 65 20 20 20 60 28 .... (else `(
2380: 28 77 61 69 74 20 2e 20 2c 64 65 6c 61 79 2d 77 (wait . ,delay-w
2390: 61 69 74 29 29 29 29 29 0a 09 09 28 70 61 79 6c ait)))))...(payl
23a0: 6f 61 64 20 28 6c 69 73 74 20 73 74 61 74 75 73 oad (list status
23b0: 20 65 72 72 6d 73 67 20 72 65 73 75 6c 74 20 6d errmsg result m
23c0: 65 74 61 29 29 29 0a 09 20 20 20 28 73 65 74 21 eta))).. (set!
23d0: 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 *api-process-re
23e0: 71 75 65 73 74 2d 63 6f 75 6e 74 2a 20 28 2d 20 quest-count* (-
23f0: 2a 61 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 *api-process-req
2400: 75 65 73 74 2d 63 6f 75 6e 74 2a 20 31 29 29 0a uest-count* 1)).
2410: 09 20 20 20 3b 3b 20 28 73 65 72 69 61 6c 69 7a . ;; (serializ
2420: 65 20 70 61 79 6c 6f 61 64 29 0a 09 20 20 20 70 e payload).. p
2430: 61 79 6c 6f 61 64 29 29 0a 09 28 65 6c 73 65 0a ayload))..(else.
2440: 09 20 28 61 73 73 65 72 74 20 23 66 20 22 46 41 . (assert #f "FA
2450: 54 41 4c 3a 20 66 61 69 6c 65 64 20 74 6f 20 64 TAL: failed to d
2460: 65 73 65 72 69 61 6c 69 7a 65 20 69 6e 64 61 74 eserialize indat
2470: 20 22 69 6e 64 61 74 29 29 29 29 29 29 0a 20 20 "indat)))))).
2480: 20 20 20 20 20 0a 0a 28 64 65 66 69 6e 65 20 28 ..(define (
2490: 61 70 69 3a 64 69 73 70 61 74 63 68 2d 72 65 71 api:dispatch-req
24a0: 75 65 73 74 20 64 62 73 74 72 75 63 74 20 63 6d uest dbstruct cm
24b0: 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 29 d run-id params)
24c0: 0a 20 20 28 69 66 20 28 6e 6f 74 20 2a 6e 6f 2d . (if (not *no-
24d0: 73 79 6e 63 2d 64 62 2a 29 0a 20 20 20 20 20 20 sync-db*).
24e0: 28 64 62 3a 6f 70 65 6e 2d 6e 6f 2d 73 79 6e 63 (db:open-no-sync
24f0: 2d 64 62 29 29 0a 20 20 28 63 61 73 65 20 63 6d -db)). (case cm
2500: 64 0a 20 20 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d d. ;;========
2510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2530: 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 3b 3b 20 52 =======. ;; R
2540: 45 41 44 2f 57 52 49 54 45 20 51 55 45 52 49 45 EAD/WRITE QUERIE
2550: 53 0a 20 20 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d S. ;;========
2560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2580: 3d 3d 3d 3d 3d 3d 3d 0a 0a 20 20 20 20 28 28 67 =======.. ((g
2590: 65 74 2d 6b 65 79 73 2d 77 72 69 74 65 29 20 20 et-keys-write)
25a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
25b0: 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d 6b 65 (db:get-ke
25c0: 79 73 20 64 62 73 74 72 75 63 74 29 29 20 3b 3b ys dbstruct)) ;;
25d0: 20 66 6f 72 63 65 20 61 20 64 75 6d 6d 79 20 22 force a dummy "
25e0: 77 72 69 74 65 22 20 71 75 65 72 79 20 74 6f 20 write" query to
25f0: 66 6f 72 63 65 20 73 65 72 76 65 72 3b 20 66 6f force server; fo
2600: 72 20 64 65 62 75 67 20 69 6e 20 2d 72 65 70 6c r debug in -repl
2610: 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 53 45 52 . . ;; SER
2620: 56 45 52 53 0a 20 20 20 20 28 28 73 74 61 72 74 VERS. ((start
2630: 2d 73 65 72 76 65 72 29 20 20 20 20 20 20 20 20 -server)
2640: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 (app
2650: 6c 79 20 73 65 72 76 65 72 3a 6b 69 6e 64 2d 72 ly server:kind-r
2660: 75 6e 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 un params)).
2670: 28 28 6b 69 6c 6c 2d 73 65 72 76 65 72 29 20 20 ((kill-server)
2680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2690: 20 20 20 28 73 65 74 21 20 2a 73 65 72 76 65 72 (set! *server
26a0: 2d 72 75 6e 2a 20 23 66 29 29 0a 0a 20 20 20 20 -run* #f))..
26b0: 3b 3b 20 54 45 53 54 53 0a 0a 20 20 20 20 3b 3b ;; TESTS.. ;;
26c0: 28 28 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 ((test-set-state
26d0: 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 29 20 20 -status-by-id)
26e0: 20 20 20 28 61 70 70 6c 79 20 6d 74 3a 74 65 73 (apply mt:tes
26f0: 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 t-set-state-stat
2700: 75 73 2d 62 79 2d 69 64 20 64 62 73 74 72 75 63 us-by-id dbstruc
2710: 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 3b t params)). ;
2720: 3b 42 42 20 2d 20 63 6f 6d 6d 65 6e 74 65 64 20 ;BB - commented
2730: 6f 75 74 20 61 62 6f 76 65 20 62 65 63 61 75 73 out above becaus
2740: 65 20 69 74 20 77 61 73 20 63 61 6c 6c 69 6e 67 e it was calling
2750: 20 62 65 6c 6f 77 2c 20 65 76 65 6e 74 75 61 6c below, eventual
2760: 6c 79 2c 20 69 6e 63 6f 72 72 65 63 74 6c 79 20 ly, incorrectly
2770: 28 64 62 73 74 72 75 63 74 20 70 61 73 73 65 64 (dbstruct passed
2780: 20 74 6f 20 6d 74 3a 74 65 73 74 2d 73 65 74 2d to mt:test-set-
2790: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d state-status-by-
27a0: 69 64 2c 20 77 68 69 63 68 20 70 72 65 76 69 6f id, which previo
27b0: 73 6c 79 20 64 69 64 20 6d 6f 72 65 2c 20 62 75 sly did more, bu
27c0: 74 20 6e 6f 77 20 6f 6e 6c 79 20 70 61 73 73 65 t now only passe
27d0: 73 20 74 68 72 75 20 74 6f 20 64 62 3a 73 65 74 s thru to db:set
27e0: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e -state-status-an
27f0: 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 2e d-roll-up-items.
2800: 0a 20 20 20 20 28 28 74 65 73 74 2d 73 65 74 2d . ((test-set-
2810: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d state-status-by-
2820: 69 64 29 0a 0a 20 20 20 20 20 3b 3b 20 28 64 65 id).. ;; (de
2830: 66 69 6e 65 20 28 64 62 3a 73 65 74 2d 73 74 61 fine (db:set-sta
2840: 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f te-status-and-ro
2850: 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 64 62 73 74 ll-up-items dbst
2860: 72 75 63 74 20 72 75 6e 2d 69 64 20 74 65 73 74 ruct run-id test
2870: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 -name item-path
2880: 73 74 61 74 65 20 73 74 61 74 75 73 20 63 6f 6d state status com
2890: 6d 65 6e 74 29 0a 20 20 20 20 20 28 64 62 3a 73 ment). (db:s
28a0: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
28b0: 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d and-roll-up-item
28c0: 73 0a 20 20 20 20 20 20 64 62 73 74 72 75 63 74 s. dbstruct
28d0: 0a 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 . (list-ref
28e0: 20 70 61 72 61 6d 73 20 30 29 20 3b 20 72 75 6e params 0) ; run
28f0: 2d 69 64 0a 20 20 20 20 20 20 28 6c 69 73 74 2d -id. (list-
2900: 72 65 66 20 70 61 72 61 6d 73 20 31 29 20 3b 20 ref params 1) ;
2910: 74 65 73 74 2d 6e 61 6d 65 0a 20 20 20 20 20 20 test-name.
2920: 23 66 20 20 20 20 20 20 20 20 20 20 20 20 20 20 #f
2930: 20 20 20 20 3b 20 69 74 65 6d 2d 70 61 74 68 0a ; item-path.
2940: 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 (list-ref
2950: 70 61 72 61 6d 73 20 32 29 20 3b 20 73 74 61 74 params 2) ; stat
2960: 65 0a 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 e. (list-re
2970: 66 20 70 61 72 61 6d 73 20 33 29 20 3b 20 73 74 f params 3) ; st
2980: 61 74 75 73 0a 20 20 20 20 20 20 28 6c 69 73 74 atus. (list
2990: 2d 72 65 66 20 70 61 72 61 6d 73 20 34 29 20 3b -ref params 4) ;
29a0: 20 63 6f 6d 6d 65 6e 74 0a 20 20 20 20 20 20 29 comment. )
29b0: 29 0a 20 20 20 20 0a 20 20 20 20 28 28 64 65 6c ). . ((del
29c0: 65 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 ete-test-records
29d0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 ) (a
29e0: 70 70 6c 79 20 64 62 3a 64 65 6c 65 74 65 2d 74 pply db:delete-t
29f0: 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 73 74 est-records dbst
2a00: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
2a10: 20 20 28 28 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 ((delete-old-d
2a20: 65 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 63 6f eleted-test-reco
2a30: 72 64 73 29 20 28 61 70 70 6c 79 20 64 62 3a 64 rds) (apply db:d
2a40: 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 elete-old-delete
2a50: 64 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 d-test-records d
2a60: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
2a70: 0a 20 20 20 20 28 28 74 65 73 74 2d 73 65 74 2d . ((test-set-
2a80: 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 20 20 state-status)
2a90: 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 (apply d
2aa0: 62 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 b:test-set-state
2ab0: 2d 73 74 61 74 75 73 20 64 62 73 74 72 75 63 74 -status dbstruct
2ac0: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 params)). ((
2ad0: 74 65 73 74 2d 73 65 74 2d 74 6f 70 2d 70 72 6f test-set-top-pro
2ae0: 63 65 73 73 2d 70 69 64 29 20 20 20 20 20 20 20 cess-pid)
2af0: 20 28 61 70 70 6c 79 20 64 62 3a 74 65 73 74 2d (apply db:test-
2b00: 73 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d set-top-process-
2b10: 70 69 64 20 64 62 73 74 72 75 63 74 20 70 61 72 pid dbstruct par
2b20: 61 6d 73 29 29 0a 20 20 20 20 28 28 73 65 74 2d ams)). ((set-
2b30: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 state-status-and
2b40: 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 29 20 -roll-up-items)
2b50: 28 61 70 70 6c 79 20 64 62 3a 73 65 74 2d 73 74 (apply db:set-st
2b60: 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 ate-status-and-r
2b70: 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 64 62 73 oll-up-items dbs
2b80: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 truct params)).
2b90: 20 20 20 28 28 73 65 74 2d 73 74 61 74 65 2d 73 ((set-state-s
2ba0: 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 tatus-and-roll-u
2bb0: 70 2d 72 75 6e 29 20 28 61 70 70 6c 79 20 64 62 p-run) (apply db
2bc0: 3a 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 :set-state-statu
2bd0: 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 72 75 s-and-roll-up-ru
2be0: 6e 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d n dbstruct param
2bf0: 73 29 29 20 0a 20 20 20 20 28 28 74 6f 70 2d 74 s)) . ((top-t
2c00: 65 73 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 est-set-per-pf-c
2c10: 6f 75 6e 74 73 29 20 20 20 20 20 20 20 28 61 70 ounts) (ap
2c20: 70 6c 79 20 64 62 3a 74 6f 70 2d 74 65 73 74 2d ply db:top-test-
2c30: 73 65 74 2d 70 65 72 2d 70 66 2d 63 6f 75 6e 74 set-per-pf-count
2c40: 73 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d s dbstruct param
2c50: 73 29 29 0a 20 20 20 20 28 28 74 65 73 74 2d 73 s)). ((test-s
2c60: 65 74 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b et-archive-block
2c70: 2d 69 64 29 20 20 20 20 20 20 20 20 28 61 70 70 -id) (app
2c80: 6c 79 20 64 62 3a 74 65 73 74 2d 73 65 74 2d 61 ly db:test-set-a
2c90: 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 20 rchive-block-id
2ca0: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
2cb0: 29 0a 0a 20 20 20 20 28 28 69 6e 73 65 72 74 2d ).. ((insert-
2cc0: 74 65 73 74 29 20 20 20 20 20 20 20 20 20 20 20 test)
2cd0: 20 20 20 20 20 20 20 20 20 20 20 28 64 62 3a 69 (db:i
2ce0: 6e 73 65 72 74 2d 74 65 73 74 20 64 62 73 74 72 nsert-test dbstr
2cf0: 75 63 74 20 72 75 6e 2d 69 64 20 70 61 72 61 6d uct run-id param
2d00: 73 29 29 0a 0a 20 20 20 20 3b 3b 20 52 55 4e 53 s)).. ;; RUNS
2d10: 0a 20 20 20 20 28 28 72 65 67 69 73 74 65 72 2d . ((register-
2d20: 72 75 6e 29 20 20 20 20 20 20 20 20 20 20 20 20 run)
2d30: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 72 (apply db:r
2d40: 65 67 69 73 74 65 72 2d 72 75 6e 20 64 62 73 74 egister-run dbst
2d50: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
2d60: 20 20 28 28 73 65 74 2d 74 65 73 74 73 2d 73 74 ((set-tests-st
2d70: 61 74 65 2d 73 74 61 74 75 73 29 20 20 20 20 20 ate-status)
2d80: 20 20 28 61 70 70 6c 79 20 64 62 3a 73 65 74 2d (apply db:set-
2d90: 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 61 74 tests-state-stat
2da0: 75 73 20 64 62 73 74 72 75 63 74 20 70 61 72 61 us dbstruct para
2db0: 6d 73 29 29 0a 20 20 20 20 28 28 64 65 6c 65 74 ms)). ((delet
2dc0: 65 2d 72 75 6e 29 20 20 20 20 20 20 20 20 20 20 e-run)
2dd0: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply
2de0: 64 62 3a 64 65 6c 65 74 65 2d 72 75 6e 20 64 62 db:delete-run db
2df0: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
2e00: 20 20 20 20 28 28 6c 6f 63 6b 2f 75 6e 6c 6f 63 ((lock/unloc
2e10: 6b 2d 72 75 6e 29 20 20 20 20 20 20 20 20 20 20 k-run)
2e20: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 6c 6f (apply db:lo
2e30: 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 64 62 ck/unlock-run db
2e40: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
2e50: 20 20 20 20 28 28 75 70 64 61 74 65 2d 72 75 6e ((update-run
2e60: 2d 65 76 65 6e 74 5f 74 69 6d 65 29 20 20 20 20 -event_time)
2e70: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 75 70 (apply db:up
2e80: 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 date-run-event_t
2e90: 69 6d 65 20 64 62 73 74 72 75 63 74 20 70 61 72 ime dbstruct par
2ea0: 61 6d 73 29 29 0a 20 20 20 20 28 28 75 70 64 61 ams)). ((upda
2eb0: 74 65 2d 72 75 6e 2d 73 74 61 74 73 29 20 20 20 te-run-stats)
2ec0: 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 (apply
2ed0: 20 64 62 3a 75 70 64 61 74 65 2d 72 75 6e 2d 73 db:update-run-s
2ee0: 74 61 74 73 20 64 62 73 74 72 75 63 74 20 70 61 tats dbstruct pa
2ef0: 72 61 6d 73 29 29 0a 20 20 20 20 28 28 73 65 74 rams)). ((set
2f00: 2d 76 61 72 29 20 20 20 20 20 20 20 20 20 20 20 -var)
2f10: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c (appl
2f20: 79 20 64 62 3a 73 65 74 2d 76 61 72 20 64 62 73 y db:set-var dbs
2f30: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 truct params)).
2f40: 20 20 20 28 28 69 6e 63 2d 76 61 72 29 20 20 20 ((inc-var)
2f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f60: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 69 6e 63 (apply db:inc
2f70: 2d 76 61 72 20 64 62 73 74 72 75 63 74 20 70 61 -var dbstruct pa
2f80: 72 61 6d 73 29 29 0a 20 20 20 20 28 28 64 65 63 rams)). ((dec
2f90: 2d 76 61 72 29 20 20 20 20 20 20 20 20 20 20 20 -var)
2fa0: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c (appl
2fb0: 79 20 64 62 3a 64 65 63 2d 76 61 72 20 64 62 73 y db:dec-var dbs
2fc0: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 truct params)).
2fd0: 20 20 20 28 28 64 65 6c 2d 76 61 72 29 20 20 20 ((del-var)
2fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ff0: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 64 65 6c (apply db:del
3000: 2d 76 61 72 20 64 62 73 74 72 75 63 74 20 70 61 -var dbstruct pa
3010: 72 61 6d 73 29 29 0a 20 20 20 20 28 28 61 64 64 rams)). ((add
3020: 2d 76 61 72 29 20 20 20 20 20 20 20 20 20 20 20 -var)
3030: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c (appl
3040: 79 20 64 62 3a 61 64 64 2d 76 61 72 20 64 62 73 y db:add-var dbs
3050: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 0a truct params))..
3060: 20 20 20 20 28 28 69 6e 73 65 72 74 2d 72 75 6e ((insert-run
3070: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
3080: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 69 6e (apply db:in
3090: 73 65 72 74 2d 72 75 6e 20 64 62 73 74 72 75 63 sert-run dbstruc
30a0: 74 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 t params))..
30b0: 3b 3b 20 53 54 45 50 53 0a 20 20 20 20 28 28 74 ;; STEPS. ((t
30c0: 65 73 74 73 74 65 70 2d 73 65 74 2d 73 74 61 74 eststep-set-stat
30d0: 75 73 21 29 20 20 20 20 20 20 20 20 20 28 61 70 us!) (ap
30e0: 70 6c 79 20 64 62 3a 74 65 73 74 73 74 65 70 2d ply db:teststep-
30f0: 73 65 74 2d 73 74 61 74 75 73 21 20 64 62 73 74 set-status! dbst
3100: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
3110: 20 20 28 28 64 65 6c 65 74 65 2d 73 74 65 70 73 ((delete-steps
3120: 2d 66 6f 72 2d 74 65 73 74 21 29 20 20 20 20 20 -for-test!)
3130: 20 20 28 61 70 70 6c 79 20 64 62 3a 64 65 6c 65 (apply db:dele
3140: 74 65 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 te-steps-for-tes
3150: 74 21 20 64 62 73 74 72 75 63 74 20 70 61 72 61 t! dbstruct para
3160: 6d 73 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b ms)). . ;;
3170: 20 54 45 53 54 20 44 41 54 41 0a 20 20 20 20 28 TEST DATA. (
3180: 28 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 (test-data-rollu
3190: 70 29 20 20 20 20 20 20 20 20 20 20 20 20 20 28 p) (
31a0: 61 70 70 6c 79 20 64 62 3a 74 65 73 74 2d 64 61 apply db:test-da
31b0: 74 61 2d 72 6f 6c 6c 75 70 20 64 62 73 74 72 75 ta-rollup dbstru
31c0: 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ct params)).
31d0: 28 28 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 ((csv->test-data
31e0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
31f0: 28 61 70 70 6c 79 20 64 62 3a 63 73 76 2d 3e 74 (apply db:csv->t
3200: 65 73 74 2d 64 61 74 61 20 64 62 73 74 72 75 63 est-data dbstruc
3210: 74 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 t params))..
3220: 3b 3b 20 4d 49 53 43 0a 20 20 20 20 28 28 73 79 ;; MISC. ((sy
3230: 6e 63 2d 69 6e 6d 65 6d 2d 3e 64 62 29 20 20 20 nc-inmem->db)
3240: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
3250: 20 28 28 72 75 6e 2d 69 64 20 28 63 61 72 20 70 ((run-id (car p
3260: 61 72 61 6d 73 29 29 29 0a 20 20 20 20 20 20 20 arams))).
3270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3290: 64 62 3a 73 79 6e 63 2d 74 6f 75 63 68 65 64 20 db:sync-touched
32a0: 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 dbstruct run-id
32b0: 64 62 3a 69 6e 69 74 69 61 6c 69 7a 65 2d 6d 61 db:initialize-ma
32c0: 69 6e 2d 64 62 20 66 6f 72 63 65 2d 73 79 6e 63 in-db force-sync
32d0: 3a 20 23 74 29 29 29 0a 20 20 20 20 28 28 67 65 : #t))). ((ge
32e0: 74 2d 74 6f 70 6c 65 76 65 6c 73 2d 61 6e 64 2d t-toplevels-and-
32f0: 69 6e 63 6f 6d 70 6c 65 74 65 73 29 20 28 61 70 incompletes) (ap
3300: 70 6c 79 20 64 62 3a 67 65 74 2d 74 6f 70 6c 65 ply db:get-tople
3310: 76 65 6c 73 2d 61 6e 64 2d 69 6e 63 6f 6d 70 6c vels-and-incompl
3320: 65 74 65 73 20 64 62 73 74 72 75 63 74 20 70 61 etes dbstruct pa
3330: 72 61 6d 73 29 29 0a 20 20 20 20 28 28 6d 61 72 rams)). ((mar
3340: 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 29 20 20 20 k-incomplete)
3350: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 3b 3b #f);;
3360: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 28 (thread-start! (
3370: 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d make-thread (lam
3380: 62 64 61 20 28 29 20 3b 3b 20 6e 6f 20 6e 65 65 bda () ;; no nee
3390: 64 20 74 6f 20 62 6c 6f 63 6b 20 6f 6e 20 74 68 d to block on th
33a0: 69 73 20 6f 6e 65 0a 09 09 09 09 09 3b 3b 09 09 is one......;;..
33b0: 09 20 20 28 61 70 70 6c 79 20 64 62 3a 66 69 6e . (apply db:fin
33c0: 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d d-and-mark-incom
33d0: 70 6c 65 74 65 20 64 62 73 74 72 75 63 74 20 70 plete dbstruct p
33e0: 61 72 61 6d 73 29 0a 09 09 09 09 09 3b 3b 09 09 arams)......;;..
33f0: 09 20 20 23 74 29 29 29 29 20 0a 20 20 20 20 28 . #t)))) . (
3400: 28 63 72 65 61 74 65 2d 61 6c 6c 2d 74 72 69 67 (create-all-trig
3410: 67 65 72 73 29 20 20 20 20 20 20 20 20 20 20 28 gers) (
3420: 64 62 3a 63 72 65 61 74 65 2d 61 6c 6c 2d 74 72 db:create-all-tr
3430: 69 67 67 65 72 73 20 64 62 73 74 72 75 63 74 29 iggers dbstruct)
3440: 29 0a 20 20 20 20 28 28 64 72 6f 70 2d 61 6c 6c ). ((drop-all
3450: 2d 74 72 69 67 67 65 72 73 29 20 20 20 20 20 20 -triggers)
3460: 20 20 20 20 20 20 28 64 62 3a 64 72 6f 70 2d 61 (db:drop-a
3470: 6c 6c 2d 74 72 69 67 67 65 72 73 20 64 62 73 74 ll-triggers dbst
3480: 72 75 63 74 29 29 20 0a 0a 20 20 20 20 3b 3b 20 ruct)) .. ;;
3490: 54 45 53 54 4d 45 54 41 0a 20 20 20 20 28 28 74 TESTMETA. ((t
34a0: 65 73 74 6d 65 74 61 2d 61 64 64 2d 72 65 63 6f estmeta-add-reco
34b0: 72 64 29 20 20 20 20 20 20 20 28 61 70 70 6c 79 rd) (apply
34c0: 20 64 62 3a 74 65 73 74 6d 65 74 61 2d 61 64 64 db:testmeta-add
34d0: 2d 72 65 63 6f 72 64 20 64 62 73 74 72 75 63 74 -record dbstruct
34e0: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 params)). ((
34f0: 74 65 73 74 6d 65 74 61 2d 75 70 64 61 74 65 2d testmeta-update-
3500: 66 69 65 6c 64 29 20 20 20 20 20 28 61 70 70 6c field) (appl
3510: 79 20 64 62 3a 74 65 73 74 6d 65 74 61 2d 75 70 y db:testmeta-up
3520: 64 61 74 65 2d 66 69 65 6c 64 20 64 62 73 74 72 date-field dbstr
3530: 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 uct params)).
3540: 20 28 28 67 65 74 2d 74 65 73 74 73 2d 74 61 67 ((get-tests-tag
3550: 73 29 20 20 20 20 20 20 20 20 20 20 20 20 28 64 s) (d
3560: 62 3a 67 65 74 2d 74 65 73 74 73 2d 74 61 67 73 b:get-tests-tags
3570: 20 64 62 73 74 72 75 63 74 29 29 0a 0a 20 20 20 dbstruct))..
3580: 20 3b 3b 20 54 41 53 4b 53 0a 20 20 20 20 28 28 ;; TASKS. ((
3590: 74 61 73 6b 73 2d 61 64 64 29 20 20 20 20 20 20 tasks-add)
35a0: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c (appl
35b0: 79 20 74 61 73 6b 73 3a 61 64 64 20 64 62 73 74 y tasks:add dbst
35c0: 72 75 63 74 20 70 61 72 61 6d 73 29 29 20 20 20 ruct params))
35d0: 0a 20 20 20 20 28 28 74 61 73 6b 73 2d 73 65 74 . ((tasks-set
35e0: 2d 73 74 61 74 65 2d 67 69 76 65 6e 2d 70 61 72 -state-given-par
35f0: 61 6d 2d 6b 65 79 29 20 28 61 70 70 6c 79 20 74 am-key) (apply t
3600: 61 73 6b 73 3a 73 65 74 2d 73 74 61 74 65 2d 67 asks:set-state-g
3610: 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 64 iven-param-key d
3620: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
3630: 0a 20 20 20 20 28 28 74 61 73 6b 73 2d 67 65 74 . ((tasks-get
3640: 2d 6c 61 73 74 29 20 20 20 20 20 20 20 20 20 20 -last)
3650: 20 20 28 61 70 70 6c 79 20 74 61 73 6b 73 3a 67 (apply tasks:g
3660: 65 74 2d 6c 61 73 74 20 64 62 73 74 72 75 63 74 et-last dbstruct
3670: 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 3b params)).. ;
3680: 3b 20 4e 4f 20 53 59 4e 43 20 44 42 0a 20 20 20 ; NO SYNC DB.
3690: 20 28 28 6e 6f 2d 73 79 6e 63 2d 73 65 74 29 20 ((no-sync-set)
36a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
36b0: 70 70 6c 79 20 64 62 3a 6e 6f 2d 73 79 6e 63 2d pply db:no-sync-
36c0: 73 65 74 20 20 20 20 20 20 20 20 20 2a 6e 6f 2d set *no-
36d0: 73 79 6e 63 2d 64 62 2a 20 70 61 72 61 6d 73 29 sync-db* params)
36e0: 29 0a 20 20 20 20 28 28 6e 6f 2d 73 79 6e 63 2d ). ((no-sync-
36f0: 67 65 74 2f 64 65 66 61 75 6c 74 29 20 20 20 20 get/default)
3700: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 6e 6f 2d (apply db:no-
3710: 73 79 6e 63 2d 67 65 74 2f 64 65 66 61 75 6c 74 sync-get/default
3720: 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 2a 20 70 61 *no-sync-db* pa
3730: 72 61 6d 73 29 29 0a 20 20 20 20 28 28 6e 6f 2d rams)). ((no-
3740: 73 79 6e 63 2d 64 65 6c 21 29 20 20 20 20 20 20 sync-del!)
3750: 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 (apply d
3760: 62 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 20 20 b:no-sync-del!
3770: 20 20 20 20 20 20 2a 6e 6f 2d 73 79 6e 63 2d 64 *no-sync-d
3780: 62 2a 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 b* params)).
3790: 28 28 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f ((no-sync-get-lo
37a0: 63 6b 29 20 20 20 20 20 20 20 20 20 20 28 61 70 ck) (ap
37b0: 70 6c 79 20 64 62 3a 6e 6f 2d 73 79 6e 63 2d 67 ply db:no-sync-g
37c0: 65 74 2d 6c 6f 63 6b 20 20 20 20 2a 6e 6f 2d 73 et-lock *no-s
37d0: 79 6e 63 2d 64 62 2a 20 70 61 72 61 6d 73 29 29 ync-db* params))
37e0: 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 41 52 43 . . ;; ARC
37f0: 48 49 56 45 53 0a 20 20 20 20 3b 3b 20 28 28 61 HIVES. ;; ((a
3800: 72 63 68 69 76 65 2d 67 65 74 2d 61 6c 6c 6f 63 rchive-get-alloc
3810: 61 74 69 6f 6e 73 29 20 20 20 0a 20 20 20 20 28 ations) . (
3820: 28 61 72 63 68 69 76 65 2d 72 65 67 69 73 74 65 (archive-registe
3830: 72 2d 64 69 73 6b 29 20 20 20 20 20 28 61 70 70 r-disk) (app
3840: 6c 79 20 64 62 3a 61 72 63 68 69 76 65 2d 72 65 ly db:archive-re
3850: 67 69 73 74 65 72 2d 64 69 73 6b 20 64 62 73 74 gister-disk dbst
3860: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
3870: 20 20 28 28 61 72 63 68 69 76 65 2d 72 65 67 69 ((archive-regi
3880: 73 74 65 72 2d 62 6c 6f 63 6b 2d 6e 61 6d 65 29 ster-block-name)
3890: 28 61 70 70 6c 79 20 64 62 3a 61 72 63 68 69 76 (apply db:archiv
38a0: 65 2d 72 65 67 69 73 74 65 72 2d 62 6c 6f 63 6b e-register-block
38b0: 2d 6e 61 6d 65 20 64 62 73 74 72 75 63 74 20 70 -name dbstruct p
38c0: 61 72 61 6d 73 29 29 0a 20 20 20 20 3b 3b 20 28 arams)). ;; (
38d0: 28 61 72 63 68 69 76 65 2d 61 6c 6c 6f 63 61 74 (archive-allocat
38e0: 65 2d 74 65 73 74 73 75 69 74 65 2f 61 72 65 61 e-testsuite/area
38f0: 2d 74 6f 2d 62 6c 6f 63 6b 29 28 61 70 70 6c 79 -to-block)(apply
3900: 20 64 62 3a 61 72 63 68 69 76 65 2d 61 6c 6c 6f db:archive-allo
3910: 63 61 74 65 2d 74 65 73 74 73 75 69 74 65 2f 61 cate-testsuite/a
3920: 72 65 61 2d 74 6f 2d 62 6c 6f 63 6b 20 64 62 73 rea-to-block dbs
3930: 74 72 75 63 74 20 62 6c 6f 63 6b 2d 69 64 20 74 truct block-id t
3940: 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 20 61 72 estsuite-name ar
3950: 65 61 6b 65 79 29 29 0a 0a 20 20 20 20 3b 3b 3d eakey)).. ;;=
3960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39a0: 3d 3d 3d 3d 3d 0a 20 20 20 20 3b 3b 20 52 45 41 =====. ;; REA
39b0: 44 20 4f 4e 4c 59 20 51 55 45 52 49 45 53 0a 20 D ONLY QUERIES.
39c0: 20 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;===========
39d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 20 20 20 ===========..
3a10: 20 3b 3b 20 4b 45 59 53 0a 20 20 20 20 28 28 67 ;; KEYS. ((g
3a20: 65 74 2d 6b 65 79 2d 76 61 6c 2d 70 61 69 72 73 et-key-val-pairs
3a30: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
3a40: 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 6b 65 (apply db:get-ke
3a50: 79 2d 76 61 6c 2d 70 61 69 72 73 20 64 62 73 74 y-val-pairs dbst
3a60: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
3a70: 20 20 28 28 67 65 74 2d 6b 65 79 73 29 20 20 20 ((get-keys)
3a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a90: 20 20 20 20 20 28 64 62 3a 67 65 74 2d 6b 65 79 (db:get-key
3aa0: 73 20 64 62 73 74 72 75 63 74 29 29 0a 20 20 20 s dbstruct)).
3ab0: 20 28 28 67 65 74 2d 6b 65 79 2d 76 61 6c 73 29 ((get-key-vals)
3ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ad0: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 (apply db:ge
3ae0: 74 2d 6b 65 79 2d 76 61 6c 73 20 64 62 73 74 72 t-key-vals dbstr
3af0: 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 uct params)).
3b00: 20 28 28 67 65 74 2d 74 61 72 67 65 74 29 20 20 ((get-target)
3b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b20: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 (apply db:ge
3b30: 74 2d 74 61 72 67 65 74 20 64 62 73 74 72 75 63 t-target dbstruc
3b40: 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 t params)). (
3b50: 28 67 65 74 2d 74 61 72 67 65 74 73 29 20 20 20 (get-targets)
3b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b70: 20 20 28 64 62 3a 67 65 74 2d 74 61 72 67 65 74 (db:get-target
3b80: 73 20 64 62 73 74 72 75 63 74 29 29 0a 0a 20 20 s dbstruct))..
3b90: 20 20 3b 3b 20 41 52 43 48 49 56 45 53 0a 20 20 ;; ARCHIVES.
3ba0: 20 20 28 28 74 65 73 74 2d 67 65 74 2d 61 72 63 ((test-get-arc
3bb0: 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 6e 66 6f 29 hive-block-info)
3bc0: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 74 (apply db:t
3bd0: 65 73 74 2d 67 65 74 2d 61 72 63 68 69 76 65 2d est-get-archive-
3be0: 62 6c 6f 63 6b 2d 69 6e 66 6f 20 64 62 73 74 72 block-info dbstr
3bf0: 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 uct params)).
3c00: 20 0a 20 20 20 20 3b 3b 20 54 45 53 54 53 0a 20 . ;; TESTS.
3c10: 20 20 20 28 28 74 65 73 74 2d 74 6f 70 6c 65 76 ((test-toplev
3c20: 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 29 20 20 20 el-num-items)
3c30: 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a (apply db:
3c40: 74 65 73 74 2d 74 6f 70 6c 65 76 65 6c 2d 6e 75 test-toplevel-nu
3c50: 6d 2d 69 74 65 6d 73 20 64 62 73 74 72 75 63 74 m-items dbstruct
3c60: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 params)). ((
3c70: 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 get-test-info-by
3c80: 2d 69 64 29 09 20 20 20 20 20 20 20 28 61 70 70 -id). (app
3c90: 6c 79 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 ly db:get-test-i
3ca0: 6e 66 6f 2d 62 79 2d 69 64 20 64 62 73 74 72 75 nfo-by-id dbstru
3cb0: 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ct params)).
3cc0: 28 28 67 65 74 2d 74 65 73 74 2d 73 74 61 74 65 ((get-test-state
3cd0: 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 29 20 20 -status-by-id)
3ce0: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 (apply db:get
3cf0: 2d 74 65 73 74 2d 73 74 61 74 65 2d 73 74 61 74 -test-state-stat
3d00: 75 73 2d 62 79 2d 69 64 20 64 62 73 74 72 75 63 us-by-id dbstruc
3d10: 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 t params)). (
3d20: 28 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 (test-get-rundir
3d30: 2d 66 72 6f 6d 2d 74 65 73 74 2d 69 64 29 20 20 -from-test-id)
3d40: 20 20 28 61 70 70 6c 79 20 64 62 3a 74 65 73 74 (apply db:test
3d50: 2d 67 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d -get-rundir-from
3d60: 2d 74 65 73 74 2d 69 64 20 64 62 73 74 72 75 63 -test-id dbstruc
3d70: 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 t params)). (
3d80: 28 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 (get-count-tests
3d90: 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 74 65 73 -running-for-tes
3da0: 74 6e 61 6d 65 29 20 28 61 70 70 6c 79 20 64 62 tname) (apply db
3db0: 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 :get-count-tests
3dc0: 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 74 65 73 -running-for-tes
3dd0: 74 6e 61 6d 65 20 64 62 73 74 72 75 63 74 20 70 tname dbstruct p
3de0: 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 67 65 arams)). ((ge
3df0: 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 t-count-tests-ru
3e00: 6e 6e 69 6e 67 29 20 20 20 20 20 20 20 20 20 28 nning) (
3e10: 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 63 6f 75 apply db:get-cou
3e20: 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 nt-tests-running
3e30: 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 dbstruct params
3e40: 29 29 0a 20 20 20 20 28 28 67 65 74 2d 63 6f 75 )). ((get-cou
3e50: 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 nt-tests-running
3e60: 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 29 20 28 61 -in-jobgroup) (a
3e70: 70 70 6c 79 20 64 62 3a 67 65 74 2d 63 6f 75 6e pply db:get-coun
3e80: 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d t-tests-running-
3e90: 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 64 62 73 74 in-jobgroup dbst
3ea0: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
3eb0: 20 20 28 28 67 65 74 2d 61 6c 6c 2d 73 74 61 74 ((get-all-stat
3ec0: 65 2d 73 74 61 74 75 73 2d 63 6f 75 6e 74 73 2d e-status-counts-
3ed0: 66 6f 72 2d 74 65 73 74 29 20 28 61 70 70 6c 79 for-test) (apply
3ee0: 20 64 62 3a 67 65 74 2d 61 6c 6c 2d 73 74 61 74 db:get-all-stat
3ef0: 65 2d 73 74 61 74 75 73 2d 63 6f 75 6e 74 73 2d e-status-counts-
3f00: 66 6f 72 2d 74 65 73 74 20 64 62 73 74 72 75 63 for-test dbstruc
3f10: 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 3b t params)). ;
3f20: 3b 20 28 28 64 65 6c 65 74 65 2d 74 65 73 74 2d ; ((delete-test-
3f30: 73 74 65 70 2d 72 65 63 6f 72 64 73 29 20 20 20 step-records)
3f40: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 64 (apply db:d
3f50: 65 6c 65 74 65 2d 74 65 73 74 2d 73 74 65 70 2d elete-test-step-
3f60: 72 65 63 6f 72 64 73 20 64 62 73 74 72 75 63 74 records dbstruct
3f70: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 3b 3b params)). ;;
3f80: 20 28 28 67 65 74 2d 70 72 65 76 69 6f 75 73 2d ((get-previous-
3f90: 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 29 test-run-record)
3fa0: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 (apply db:ge
3fb0: 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d t-previous-test-
3fc0: 72 75 6e 2d 72 65 63 6f 72 64 20 64 62 73 74 72 run-record dbstr
3fd0: 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 uct params)).
3fe0: 20 28 28 67 65 74 2d 6d 61 74 63 68 69 6e 67 2d ((get-matching-
3ff0: 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 previous-test-ru
4000: 6e 2d 72 65 63 6f 72 64 73 29 28 61 70 70 6c 79 n-records)(apply
4010: 20 64 62 3a 67 65 74 2d 6d 61 74 63 68 69 6e 67 db:get-matching
4020: 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 -previous-test-r
4030: 75 6e 2d 72 65 63 6f 72 64 73 20 64 62 73 74 72 un-records dbstr
4040: 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 uct params)).
4050: 20 28 28 74 65 73 74 2d 67 65 74 2d 6c 6f 67 66 ((test-get-logf
4060: 69 6c 65 2d 69 6e 66 6f 29 20 20 20 20 20 20 20 ile-info)
4070: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 74 65 (apply db:te
4080: 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 2d 69 st-get-logfile-i
4090: 6e 66 6f 20 64 62 73 74 72 75 63 74 20 70 61 72 nfo dbstruct par
40a0: 61 6d 73 29 29 0a 20 20 20 20 28 28 74 65 73 74 ams)). ((test
40b0: 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 -get-records-for
40c0: 2d 69 6e 64 65 78 2d 66 69 6c 65 29 20 20 28 61 -index-file) (a
40d0: 70 70 6c 79 20 64 62 3a 74 65 73 74 2d 67 65 74 pply db:test-get
40e0: 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 -records-for-ind
40f0: 65 78 2d 66 69 6c 65 20 64 62 73 74 72 75 63 74 ex-file dbstruct
4100: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 params)). ((
4110: 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 get-testinfo-sta
4120: 74 65 2d 73 74 61 74 75 73 29 20 20 20 20 20 20 te-status)
4130: 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 74 (apply db:get-t
4140: 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 estinfo-state-st
4150: 61 74 75 73 20 64 62 73 74 72 75 63 74 20 70 61 atus dbstruct pa
4160: 72 61 6d 73 29 29 0a 20 20 20 20 28 28 74 65 73 rams)). ((tes
4170: 74 2d 67 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 t-get-top-proces
4180: 73 2d 70 69 64 29 20 20 20 20 20 20 20 20 28 61 s-pid) (a
4190: 70 70 6c 79 20 64 62 3a 74 65 73 74 2d 67 65 74 pply db:test-get
41a0: 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 64 -top-process-pid
41b0: 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 dbstruct params
41c0: 29 29 0a 20 20 20 20 28 28 74 65 73 74 2d 67 65 )). ((test-ge
41d0: 74 2d 70 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 t-paths-matching
41e0: 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 72 67 65 74 -keynames-target
41f0: 2d 6e 65 77 29 20 28 61 70 70 6c 79 20 64 62 3a -new) (apply db:
4200: 74 65 73 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d test-get-paths-m
4210: 61 74 63 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 atching-keynames
4220: 2d 74 61 72 67 65 74 2d 6e 65 77 20 64 62 73 74 -target-new dbst
4230: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
4240: 20 20 28 28 67 65 74 2d 70 72 65 72 65 71 73 2d ((get-prereqs-
4250: 6e 6f 74 2d 6d 65 74 29 20 20 20 20 20 20 20 20 not-met)
4260: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 (apply db:g
4270: 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d et-prereqs-not-m
4280: 65 74 20 64 62 73 74 72 75 63 74 20 70 61 72 61 et dbstruct para
4290: 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 2d 63 ms)). ((get-c
42a0: 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 ount-tests-runni
42b0: 6e 67 2d 66 6f 72 2d 72 75 6e 2d 69 64 29 20 28 ng-for-run-id) (
42c0: 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 63 6f 75 apply db:get-cou
42d0: 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 nt-tests-running
42e0: 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 64 62 73 74 -for-run-id dbst
42f0: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
4300: 20 20 28 28 67 65 74 2d 6e 6f 74 2d 63 6f 6d 70 ((get-not-comp
4310: 6c 65 74 65 64 2d 63 6e 74 29 20 20 20 20 20 20 leted-cnt)
4320: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 (apply db:g
4330: 65 74 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 et-not-completed
4340: 2d 63 6e 74 20 20 64 62 73 74 72 75 63 74 20 70 -cnt dbstruct p
4350: 61 72 61 6d 73 29 29 20 0a 20 20 20 20 28 28 67 arams)) . ((g
4360: 65 74 2d 72 61 77 2d 72 75 6e 2d 73 74 61 74 73 et-raw-run-stats
4370: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
4380: 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 72 61 (apply db:get-ra
4390: 77 2d 72 75 6e 2d 73 74 61 74 73 20 64 62 73 74 w-run-stats dbst
43a0: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
43b0: 20 20 28 28 67 65 74 2d 74 65 73 74 2d 74 69 6d ((get-test-tim
43c0: 65 73 29 20 20 20 20 20 20 20 20 20 20 20 20 20 es)
43d0: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 (apply db:g
43e0: 65 74 2d 74 65 73 74 2d 74 69 6d 65 73 20 64 62 et-test-times db
43f0: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
4400: 0a 20 20 20 20 3b 3b 20 52 55 4e 53 0a 20 20 20 . ;; RUNS.
4410: 20 28 28 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 29 ((get-run-info)
4420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4430: 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 72 (apply db:get-r
4440: 75 6e 2d 69 6e 66 6f 20 64 62 73 74 72 75 63 74 un-info dbstruct
4450: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 params)). ((
4460: 67 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 29 20 get-run-status)
4470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
4480: 70 70 6c 79 20 64 62 3a 67 65 74 2d 72 75 6e 2d pply db:get-run-
4490: 73 74 61 74 75 73 20 64 62 73 74 72 75 63 74 20 status dbstruct
44a0: 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 67 params)). ((g
44b0: 65 74 2d 72 75 6e 2d 73 74 61 74 65 29 20 20 20 et-run-state)
44c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 (ap
44d0: 70 6c 79 20 64 62 3a 67 65 74 2d 72 75 6e 2d 73 ply db:get-run-s
44e0: 74 61 74 65 20 64 62 73 74 72 75 63 74 20 70 61 tate dbstruct pa
44f0: 72 61 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 rams)). ((get
4500: 2d 72 75 6e 2d 73 74 61 74 65 2d 73 74 61 74 75 -run-state-statu
4510: 73 29 20 20 20 20 20 20 20 20 20 28 61 70 70 6c s) (appl
4520: 79 20 64 62 3a 67 65 74 2d 72 75 6e 2d 73 74 61 y db:get-run-sta
4530: 74 65 2d 73 74 61 74 75 73 20 64 62 73 74 72 75 te-status dbstru
4540: 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ct params)).
4550: 28 28 73 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 ((set-run-status
4560: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
4570: 28 61 70 70 6c 79 20 64 62 3a 73 65 74 2d 72 75 (apply db:set-ru
4580: 6e 2d 73 74 61 74 75 73 20 64 62 73 74 72 75 63 n-status dbstruc
4590: 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 t params)). (
45a0: 28 73 65 74 2d 72 75 6e 2d 73 74 61 74 65 2d 73 (set-run-state-s
45b0: 74 61 74 75 73 29 20 20 09 09 09 20 28 61 70 70 tatus) ... (app
45c0: 6c 79 20 64 62 3a 73 65 74 2d 72 75 6e 2d 73 74 ly db:set-run-st
45d0: 61 74 65 2d 73 74 61 74 75 73 20 64 62 73 74 72 ate-status dbstr
45e0: 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 uct params)).
45f0: 20 28 28 75 70 64 61 74 65 2d 74 65 73 64 61 74 ((update-tesdat
4600: 61 2d 6f 6e 2d 72 65 70 69 6c 63 61 74 65 2d 64 a-on-repilcate-d
4610: 62 29 20 28 61 70 70 6c 79 20 64 62 3a 75 70 64 b) (apply db:upd
4620: 61 74 65 2d 74 65 73 64 61 74 61 2d 6f 6e 2d 72 ate-tesdata-on-r
4630: 65 70 69 6c 63 61 74 65 2d 64 62 20 20 64 62 73 epilcate-db dbs
4640: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 20 0a truct params)) .
4650: 20 20 20 20 28 28 67 65 74 2d 74 65 73 74 73 2d ((get-tests-
4660: 66 6f 72 2d 72 75 6e 29 20 20 20 20 20 20 20 20 for-run)
4670: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 (apply db:ge
4680: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 t-tests-for-run
4690: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
46a0: 29 0a 20 20 20 20 28 28 67 65 74 2d 74 65 73 74 ). ((get-test
46b0: 73 2d 66 6f 72 2d 72 75 6e 2d 73 74 61 74 65 2d s-for-run-state-
46c0: 73 74 61 74 75 73 29 20 28 61 70 70 6c 79 20 64 status) (apply d
46d0: 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d b:get-tests-for-
46e0: 72 75 6e 2d 73 74 61 74 65 2d 73 74 61 74 75 73 run-state-status
46f0: 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 dbstruct params
4700: 29 29 0a 20 20 20 20 28 28 67 65 74 2d 74 65 73 )). ((get-tes
4710: 74 2d 69 64 29 20 20 20 20 20 20 20 20 20 20 20 t-id)
4720: 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 (apply db
4730: 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 64 62 73 :get-test-id dbs
4740: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 truct params)).
4750: 20 20 20 28 28 67 65 74 2d 74 65 73 74 73 2d 66 ((get-tests-f
4760: 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 29 20 or-run-mindata)
4770: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 (apply db:get
4780: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d -tests-for-run-m
4790: 69 6e 64 61 74 61 20 64 62 73 74 72 75 63 74 20 indata dbstruct
47a0: 70 61 72 61 6d 73 29 29 0a 20 20 20 20 3b 3b 20 params)). ;;
47b0: 28 28 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d ((get-tests-for-
47c0: 72 75 6e 73 2d 6d 69 6e 64 61 74 61 29 20 20 20 runs-mindata)
47d0: 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 74 65 (apply db:get-te
47e0: 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 6e sts-for-runs-min
47f0: 64 61 74 61 20 64 62 73 74 72 75 63 74 20 70 61 data dbstruct pa
4800: 72 61 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 rams)). ((get
4810: 2d 72 75 6e 73 29 20 20 20 20 20 20 20 20 20 20 -runs)
4820: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c (appl
4830: 79 20 64 62 3a 67 65 74 2d 72 75 6e 73 20 64 62 y db:get-runs db
4840: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
4850: 20 20 20 20 28 28 73 69 6d 70 6c 65 2d 67 65 74 ((simple-get
4860: 2d 72 75 6e 73 29 20 20 20 20 20 20 20 20 20 20 -runs)
4870: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 73 69 (apply db:si
4880: 6d 70 6c 65 2d 67 65 74 2d 72 75 6e 73 20 64 62 mple-get-runs db
4890: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
48a0: 20 20 20 20 28 28 67 65 74 2d 6e 75 6d 2d 72 75 ((get-num-ru
48b0: 6e 73 29 20 20 20 20 20 20 20 20 20 20 20 20 20 ns)
48c0: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 (apply db:ge
48d0: 74 2d 6e 75 6d 2d 72 75 6e 73 20 64 62 73 74 72 t-num-runs dbstr
48e0: 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 uct params)).
48f0: 20 28 28 67 65 74 2d 72 75 6e 73 2d 63 6e 74 2d ((get-runs-cnt-
4900: 62 79 2d 70 61 74 74 29 20 20 20 20 20 20 20 20 by-patt)
4910: 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 72 (apply db:get-r
4920: 75 6e 73 2d 63 6e 74 2d 62 79 2d 70 61 74 74 20 uns-cnt-by-patt
4930: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
4940: 29 0a 20 20 20 20 28 28 67 65 74 2d 61 6c 6c 2d ). ((get-all-
4950: 72 75 6e 2d 69 64 73 29 20 20 20 20 20 20 20 20 run-ids)
4960: 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d 61 6c (db:get-al
4970: 6c 2d 72 75 6e 2d 69 64 73 20 64 62 73 74 72 75 l-run-ids dbstru
4980: 63 74 29 29 0a 20 20 20 20 28 28 67 65 74 2d 70 ct)). ((get-p
4990: 72 65 76 2d 72 75 6e 2d 69 64 73 29 20 20 20 20 rev-run-ids)
49a0: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply
49b0: 64 62 3a 67 65 74 2d 70 72 65 76 2d 72 75 6e 2d db:get-prev-run-
49c0: 69 64 73 20 64 62 73 74 72 75 63 74 20 70 61 72 ids dbstruct par
49d0: 61 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 2d ams)). ((get-
49e0: 72 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 run-ids-matching
49f0: 2d 74 61 72 67 65 74 29 20 20 28 61 70 70 6c 79 -target) (apply
4a00: 20 64 62 3a 67 65 74 2d 72 75 6e 2d 69 64 73 2d db:get-run-ids-
4a10: 6d 61 74 63 68 69 6e 67 2d 74 61 72 67 65 74 20 matching-target
4a20: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
4a30: 29 0a 20 20 20 20 28 28 67 65 74 2d 72 75 6e 73 ). ((get-runs
4a40: 2d 62 79 2d 70 61 74 74 29 20 20 20 20 20 20 20 -by-patt)
4a50: 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a (apply db:
4a60: 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 get-runs-by-patt
4a70: 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 dbstruct params
4a80: 29 29 0a 20 20 20 20 28 28 67 65 74 2d 72 75 6e )). ((get-run
4a90: 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 29 20 20 -name-from-id)
4aa0: 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 (apply db
4ab0: 3a 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 :get-run-name-fr
4ac0: 6f 6d 2d 69 64 20 64 62 73 74 72 75 63 74 20 70 om-id dbstruct p
4ad0: 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 67 65 arams)). ((ge
4ae0: 74 2d 6d 61 69 6e 2d 72 75 6e 2d 73 74 61 74 73 t-main-run-stats
4af0: 29 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 ) (app
4b00: 6c 79 20 64 62 3a 67 65 74 2d 6d 61 69 6e 2d 72 ly db:get-main-r
4b10: 75 6e 2d 73 74 61 74 73 20 64 62 73 74 72 75 63 un-stats dbstruc
4b20: 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 t params)). (
4b30: 28 67 65 74 2d 76 61 72 29 20 20 20 20 20 20 20 (get-var)
4b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4b50: 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 76 61 72 apply db:get-var
4b60: 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 dbstruct params
4b70: 29 29 0a 20 20 20 20 28 28 67 65 74 2d 72 75 6e )). ((get-run
4b80: 2d 73 74 61 74 73 29 20 20 20 20 20 20 20 20 20 -stats)
4b90: 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 (apply db
4ba0: 3a 67 65 74 2d 72 75 6e 2d 73 74 61 74 73 20 64 :get-run-stats d
4bb0: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
4bc0: 0a 20 20 20 20 28 28 67 65 74 2d 72 75 6e 2d 74 . ((get-run-t
4bd0: 69 6d 65 73 29 20 20 20 20 20 20 20 20 20 20 20 imes)
4be0: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 (apply db:g
4bf0: 65 74 2d 72 75 6e 2d 74 69 6d 65 73 20 64 62 73 et-run-times dbs
4c00: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 20 0a truct params)) .
4c10: 0a 20 20 20 20 3b 3b 20 53 54 45 50 53 0a 20 20 . ;; STEPS.
4c20: 20 20 28 28 67 65 74 2d 73 74 65 70 73 2d 64 61 ((get-steps-da
4c30: 74 61 29 20 20 20 20 20 20 20 20 20 20 20 20 20 ta)
4c40: 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d (apply db:get-
4c50: 73 74 65 70 73 2d 64 61 74 61 20 64 62 73 74 72 steps-data dbstr
4c60: 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 uct params)).
4c70: 20 28 28 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 ((get-steps-for
4c80: 2d 74 65 73 74 29 20 20 20 20 20 20 20 20 20 20 -test)
4c90: 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 73 (apply db:get-s
4ca0: 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 64 62 teps-for-test db
4cb0: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
4cc0: 20 20 20 20 28 28 67 65 74 2d 73 74 65 70 73 2d ((get-steps-
4cd0: 69 6e 66 6f 2d 62 79 2d 69 64 29 20 20 20 20 20 info-by-id)
4ce0: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 (apply db:ge
4cf0: 74 2d 73 74 65 70 73 2d 69 6e 66 6f 2d 62 79 2d t-steps-info-by-
4d00: 69 64 20 64 62 73 74 72 75 63 74 20 70 61 72 61 id dbstruct para
4d10: 6d 73 29 29 0a 0a 20 20 20 20 3b 3b 20 54 45 53 ms)).. ;; TES
4d20: 54 20 44 41 54 41 0a 20 20 20 20 28 28 72 65 61 T DATA. ((rea
4d30: 64 2d 74 65 73 74 2d 64 61 74 61 29 20 20 20 20 d-test-data)
4d40: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c (appl
4d50: 79 20 64 62 3a 72 65 61 64 2d 74 65 73 74 2d 64 y db:read-test-d
4d60: 61 74 61 20 64 62 73 74 72 75 63 74 20 70 61 72 ata dbstruct par
4d70: 61 6d 73 29 29 0a 20 20 20 20 28 28 72 65 61 64 ams)). ((read
4d80: 2d 74 65 73 74 2d 64 61 74 61 2d 76 61 72 70 61 -test-data-varpa
4d90: 74 74 29 20 20 20 20 20 20 20 28 61 70 70 6c 79 tt) (apply
4da0: 20 64 62 3a 72 65 61 64 2d 74 65 73 74 2d 64 61 db:read-test-da
4db0: 74 61 2d 76 61 72 70 61 74 74 20 64 62 73 74 72 ta-varpatt dbstr
4dc0: 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 uct params)).
4dd0: 20 28 28 67 65 74 2d 64 61 74 61 2d 69 6e 66 6f ((get-data-info
4de0: 2d 62 79 2d 69 64 29 20 20 20 20 20 20 20 20 20 -by-id)
4df0: 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 64 (apply db:get-d
4e00: 61 74 61 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 64 ata-info-by-id d
4e10: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
4e20: 20 0a 0a 20 20 20 20 3b 3b 20 4d 49 53 43 0a 20 .. ;; MISC.
4e30: 20 20 20 28 28 67 65 74 2d 6c 61 74 65 73 74 2d ((get-latest-
4e40: 68 6f 73 74 2d 6c 6f 61 64 29 20 20 20 20 20 20 host-load)
4e50: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 (apply db:get
4e60: 2d 6c 61 74 65 73 74 2d 68 6f 73 74 2d 6c 6f 61 -latest-host-loa
4e70: 64 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d d dbstruct param
4e80: 73 29 29 0a 20 20 20 20 28 28 68 61 76 65 2d 69 s)). ((have-i
4e90: 6e 63 6f 6d 70 6c 65 74 65 73 3f 29 20 20 20 20 ncompletes?)
4ea0: 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 (apply d
4eb0: 62 3a 68 61 76 65 2d 69 6e 63 6f 6d 70 6c 65 74 b:have-incomplet
4ec0: 65 73 3f 20 64 62 73 74 72 75 63 74 20 70 61 72 es? dbstruct par
4ed0: 61 6d 73 29 29 0a 20 20 20 20 28 28 6c 6f 67 69 ams)). ((logi
4ee0: 6e 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n)
4ef0: 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 (apply
4f00: 20 64 62 3a 6c 6f 67 69 6e 20 64 62 73 74 72 75 db:login dbstru
4f10: 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ct params)).
4f20: 28 28 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 29 20 ((general-call)
4f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f40: 28 6c 65 74 20 28 28 73 74 6d 74 6e 61 6d 65 20 (let ((stmtname
4f50: 20 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a (car params)).
4f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f80: 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d 69 (run-i
4f90: 64 20 20 20 20 20 28 63 61 64 72 20 70 61 72 61 d (cadr para
4fa0: 6d 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ms)).
4fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4fd0: 72 65 61 6c 70 61 72 61 6d 73 20 28 63 64 64 72 realparams (cddr
4fe0: 20 70 61 72 61 6d 73 29 29 29 0a 20 20 20 20 20 params))).
4ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5010: 20 28 64 62 3a 67 65 6e 65 72 61 6c 2d 63 61 6c (db:general-cal
5020: 6c 20 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 l dbstruct run-i
5030: 64 20 73 74 6d 74 6e 61 6d 65 20 72 65 61 6c 70 d stmtname realp
5040: 61 72 61 6d 73 29 29 29 0a 20 20 20 20 28 28 73 arams))). ((s
5050: 64 62 2d 71 72 79 29 20 20 20 20 20 20 20 20 20 db-qry)
5060: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 (ap
5070: 70 6c 79 20 73 64 62 3a 71 72 79 20 70 61 72 61 ply sdb:qry para
5080: 6d 73 29 29 0a 20 20 20 20 28 28 70 69 6e 67 29 ms)). ((ping)
5090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
50a0: 20 20 20 20 20 20 20 20 20 28 63 75 72 72 65 6e (curren
50b0: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 0a 20 t-process-id)).
50c0: 20 20 20 28 28 67 65 74 2d 63 68 61 6e 67 65 64 ((get-changed
50d0: 2d 72 65 63 6f 72 64 2d 69 64 73 29 20 20 20 20 -record-ids)
50e0: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 (apply db:get
50f0: 2d 63 68 61 6e 67 65 64 2d 72 65 63 6f 72 64 2d -changed-record-
5100: 69 64 73 20 64 62 73 74 72 75 63 74 20 70 61 72 ids dbstruct par
5110: 61 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 2d ams)). ((get-
5120: 72 75 6e 2d 72 65 63 6f 72 64 2d 69 64 73 29 20 run-record-ids)
5130: 09 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 . (apply db:ge
5140: 74 2d 72 75 6e 2d 72 65 63 6f 72 64 2d 69 64 73 t-run-record-ids
5150: 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 dbstruct params
5160: 29 29 09 0a 20 20 20 20 3b 3b 20 54 45 53 54 4d )).. ;; TESTM
5170: 45 54 41 0a 20 20 20 20 28 28 74 65 73 74 6d 65 ETA. ((testme
5180: 74 61 2d 67 65 74 2d 72 65 63 6f 72 64 29 20 20 ta-get-record)
5190: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 74 (apply db:t
51a0: 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 65 63 6f estmeta-get-reco
51b0: 72 64 20 64 62 73 74 72 75 63 74 20 70 61 72 61 rd dbstruct para
51c0: 6d 73 29 29 0a 0a 20 20 20 20 3b 3b 20 54 41 53 ms)).. ;; TAS
51d0: 4b 53 20 0a 20 20 20 20 28 28 66 69 6e 64 2d 74 KS . ((find-t
51e0: 61 73 6b 2d 71 75 65 75 65 2d 72 65 63 6f 72 64 ask-queue-record
51f0: 73 29 20 20 20 28 61 70 70 6c 79 20 74 61 73 6b s) (apply task
5200: 73 3a 66 69 6e 64 2d 74 61 73 6b 2d 71 75 65 75 s:find-task-queu
5210: 65 2d 72 65 63 6f 72 64 73 20 64 62 73 74 72 75 e-records dbstru
5220: 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ct params)).
5230: 28 65 6c 73 65 0a 20 20 20 20 20 28 64 65 62 75 (else. (debu
5240: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
5250: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 lt-log-port* "ER
5260: 52 4f 52 3a 20 62 61 64 20 61 70 69 20 63 61 6c ROR: bad api cal
5270: 6c 20 22 20 63 6d 64 29 0a 20 20 20 20 20 28 63 l " cmd). (c
5280: 6f 6e 63 20 22 45 52 52 4f 52 3a 20 42 41 44 20 onc "ERROR: BAD
5290: 61 70 69 20 63 61 6c 6c 20 22 20 63 6d 64 29 29 api call " cmd))
52a0: 29 29 0a 0a 3b 3b 20 68 74 74 70 2d 73 65 72 76 ))..;; http-serv
52b0: 65 72 20 20 73 65 6e 64 2d 72 65 73 70 6f 6e 73 er send-respons
52c0: 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 e.;;
52d0: 20 20 20 20 20 61 70 69 3a 70 72 6f 63 65 73 73 api:process
52e0: 2d 72 65 71 75 65 73 74 0a 3b 3b 20 20 20 20 20 -request.;;
52f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 64 d
5300: 62 3a 2a 0a 3b 3b 0a 3b 3b 20 4e 42 2f 2f 20 52 b:*.;;.;; NB// R
5310: 75 6e 73 20 6f 6e 20 74 68 65 20 73 65 72 76 65 uns on the serve
5320: 72 20 61 73 20 70 61 72 74 20 6f 66 20 74 68 65 r as part of the
5330: 20 73 65 72 76 65 72 20 6c 6f 6f 70 0a 3b 3b 0a server loop.;;.
5340: 28 64 65 66 69 6e 65 20 28 61 70 69 3a 70 72 6f (define (api:pro
5350: 63 65 73 73 2d 72 65 71 75 65 73 74 20 64 62 73 cess-request dbs
5360: 74 72 75 63 74 20 24 29 20 3b 3b 20 74 68 65 20 truct $) ;; the
5370: 24 20 69 73 20 74 68 65 20 72 65 71 75 65 73 74 $ is the request
5380: 20 76 61 72 73 20 70 72 6f 63 0a 20 20 28 64 65 vars proc. (de
5390: 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 bug:print 4 *def
53a0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
53b0: 73 65 72 76 65 72 2d 69 64 3a 22 20 20 2a 73 65 server-id:" *se
53c0: 72 76 65 72 2d 69 64 2a 29 0a 20 20 28 6c 65 74 rver-id*). (let
53d0: 2a 20 28 28 63 6d 64 20 20 20 20 20 28 24 20 27 * ((cmd ($ '
53e0: 63 6d 64 29 29 0a 09 20 28 70 61 72 61 6d 73 6a cmd)).. (paramsj
53f0: 20 28 24 20 27 70 61 72 61 6d 73 29 29 0a 20 20 ($ 'params)).
5400: 20 20 20 20 20 20 20 28 6b 65 79 20 20 20 20 20 (key
5410: 28 24 20 27 6b 65 79 29 29 20 20 20 0a 09 20 28 ($ 'key)) .. (
5420: 70 61 72 61 6d 73 20 20 28 64 62 3a 73 74 72 69 params (db:stri
5430: 6e 67 2d 3e 6f 62 6a 20 70 61 72 61 6d 73 6a 20 ng->obj paramsj
5440: 74 72 61 6e 73 70 6f 72 74 3a 20 27 68 74 74 70 transport: 'http
5450: 29 29 29 20 3b 3b 20 69 6e 63 6f 6d 69 6e 67 20 ))) ;; incoming
5460: 64 61 74 61 20 66 72 6f 6d 20 74 68 65 20 50 4f data from the PO
5470: 53 54 20 28 6f 72 20 69 73 20 69 74 20 61 20 47 ST (or is it a G
5480: 45 54 3f 29 0a 20 20 20 20 28 64 65 62 75 67 3a ET?). (debug:
5490: 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 print 4 *default
54a0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6d 64 3a -log-port* "cmd:
54b0: 22 20 63 6d 64 20 22 20 77 69 74 68 20 70 61 72 " cmd " with par
54c0: 61 6d 73 20 22 20 70 61 72 61 6d 73 20 22 6b 65 ams " params "ke
54d0: 79 20 22 20 6b 65 79 29 0a 20 20 20 20 28 69 66 y " key). (if
54e0: 20 28 65 71 75 61 6c 3f 20 6b 65 79 20 2a 73 65 (equal? key *se
54f0: 72 76 65 72 2d 69 64 2a 29 0a 20 20 20 20 20 20 rver-id*).
5500: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 28 (begin. (
5510: 73 65 74 21 20 2a 61 70 69 2d 70 72 6f 63 65 73 set! *api-proces
5520: 73 2d 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a s-request-count*
5530: 20 28 2b 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 (+ *api-process
5540: 2d 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a 20 -request-count*
5550: 31 29 29 0a 20 09 28 6c 65 74 2a 20 28 28 72 65 1)). .(let* ((re
5560: 73 64 61 74 20 20 28 61 70 69 3a 65 78 65 63 75 sdat (api:execu
5570: 74 65 2d 72 65 71 75 65 73 74 73 20 64 62 73 74 te-requests dbst
5580: 72 75 63 74 20 28 76 65 63 74 6f 72 20 63 6d 64 ruct (vector cmd
5590: 20 70 61 72 61 6d 73 29 29 29 20 3b 3b 20 70 72 params))) ;; pr
55a0: 6f 63 65 73 73 20 74 68 65 20 72 65 71 75 65 73 ocess the reques
55b0: 74 2c 20 72 65 73 64 61 74 20 3d 20 23 28 20 66 t, resdat = #( f
55c0: 6c 61 67 20 72 65 73 75 6c 74 20 29 0a 09 20 20 lag result )..
55d0: 20 20 20 20 20 28 73 75 63 63 65 73 73 20 28 76 (success (v
55e0: 65 63 74 6f 72 2d 72 65 66 20 72 65 73 64 61 74 ector-ref resdat
55f0: 20 30 29 29 0a 09 20 20 20 20 20 20 20 28 72 65 0)).. (re
5600: 73 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 s (vector-re
5610: 66 20 72 65 73 64 61 74 20 31 29 29 29 20 3b 3b f resdat 1))) ;;
5620: 20 28 76 65 63 74 6f 72 20 66 6c 61 67 20 70 61 (vector flag pa
5630: 79 6c 6f 61 64 29 2c 20 67 65 74 20 74 68 65 20 yload), get the
5640: 70 61 79 6c 6f 61 64 2c 20 69 67 6e 6f 72 65 20 payload, ignore
5650: 74 68 65 20 66 6c 61 67 20 28 77 68 79 3f 29 0a the flag (why?).
5660: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
5670: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
5680: 6f 72 74 2a 20 22 72 65 73 3a 22 20 72 65 73 29 ort* "res:" res)
5690: 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 73 75 63 .. (if (not suc
56a0: 63 65 73 73 29 0a 09 20 20 20 20 20 20 28 64 65 cess).. (de
56b0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
56c0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
56d0: 45 52 52 4f 52 3a 20 73 75 63 63 65 73 73 20 66 ERROR: success f
56e0: 6c 61 67 20 69 73 20 23 66 20 66 6f 72 20 22 20 lag is #f for "
56f0: 63 6d 64 20 22 20 77 69 74 68 20 70 61 72 61 6d cmd " with param
5700: 73 20 22 20 70 61 72 61 6d 73 29 29 0a 09 20 20 s " params))..
5710: 28 69 66 20 28 3e 20 2a 61 70 69 2d 70 72 6f 63 (if (> *api-proc
5720: 65 73 73 2d 72 65 71 75 65 73 74 2d 63 6f 75 6e ess-request-coun
5730: 74 2a 20 2a 6d 61 78 2d 61 70 69 2d 70 72 6f 63 t* *max-api-proc
5740: 65 73 73 2d 72 65 71 75 65 73 74 73 2a 29 0a 09 ess-requests*)..
5750: 20 20 20 20 20 20 28 73 65 74 21 20 2a 6d 61 78 (set! *max
5760: 2d 61 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 -api-process-req
5770: 75 65 73 74 73 2a 20 2a 61 70 69 2d 70 72 6f 63 uests* *api-proc
5780: 65 73 73 2d 72 65 71 75 65 73 74 2d 63 6f 75 6e ess-request-coun
5790: 74 2a 29 29 0a 09 20 20 28 73 65 74 21 20 2a 61 t*)).. (set! *a
57a0: 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 pi-process-reque
57b0: 73 74 2d 63 6f 75 6e 74 2a 20 28 2d 20 2a 61 70 st-count* (- *ap
57c0: 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 i-process-reques
57d0: 74 2d 63 6f 75 6e 74 2a 20 31 29 29 0a 09 20 20 t-count* 1))..
57e0: 3b 3b 20 54 68 69 73 20 63 61 6e 20 62 65 20 68 ;; This can be h
57f0: 65 72 65 20 62 75 74 20 6e 65 65 64 73 20 63 6f ere but needs co
5800: 6e 74 72 6f 6c 73 20 74 6f 20 65 6e 73 75 72 65 ntrols to ensure
5810: 20 69 74 20 64 6f 65 73 6e 27 74 20 72 75 6e 20 it doesn't run
5820: 6d 6f 72 65 20 74 68 61 6e 20 65 76 65 72 79 20 more than every
5830: 34 20 73 65 63 6f 6e 64 73 0a 09 20 20 3b 3b 20 4 seconds.. ;;
5840: 28 72 6d 74 3a 64 61 74 2d 3e 6a 73 6f 6e 2d 73 (rmt:dat->json-s
5850: 74 72 0a 09 20 20 3b 3b 20 20 28 69 66 20 28 6f tr.. ;; (if (o
5860: 72 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a r (string? res).
5870: 09 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 28 . ;; (
5880: 6c 69 73 74 3f 20 20 20 72 65 73 29 0a 09 20 20 list? res)..
5890: 3b 3b 20 20 20 20 20 20 20 20 20 20 28 6e 75 6d ;; (num
58a0: 62 65 72 3f 20 72 65 73 29 0a 09 20 20 3b 3b 20 ber? res).. ;;
58b0: 20 20 20 20 20 20 20 20 20 28 62 6f 6f 6c 65 61 (boolea
58c0: 6e 3f 20 72 65 73 29 29 0a 09 20 20 3b 3b 20 20 n? res)).. ;;
58d0: 20 20 20 20 72 65 73 20 0a 09 20 20 3b 3b 20 20 res .. ;;
58e0: 20 20 20 20 28 6c 69 73 74 20 22 45 52 52 4f 52 (list "ERROR
58f0: 2c 20 6e 6f 74 20 73 74 72 69 6e 67 2c 20 6c 69 , not string, li
5900: 73 74 2c 20 6e 75 6d 62 65 72 20 6f 72 20 62 6f st, number or bo
5910: 6f 6c 65 61 6e 22 20 31 20 63 6d 64 20 70 61 72 olean" 1 cmd par
5920: 61 6d 73 20 72 65 73 29 29 29 29 29 0a 09 20 20 ams res)))))..
5930: 28 64 62 3a 6f 62 6a 2d 3e 73 74 72 69 6e 67 20 (db:obj->string
5940: 72 65 73 20 74 72 61 6e 73 70 6f 72 74 3a 20 27 res transport: '
5950: 68 74 74 70 29 29 29 0a 09 28 62 65 67 69 6e 0a http)))..(begin.
5960: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
5970: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
5980: 6f 72 74 2a 20 20 20 22 53 65 72 76 65 72 20 72 ort* "Server r
5990: 65 66 75 73 65 64 20 74 6f 20 70 72 6f 63 65 73 efused to proces
59a0: 73 20 72 65 71 75 65 73 74 2e 20 53 65 72 76 65 s request. Serve
59b0: 72 20 69 64 20 6d 69 73 6d 61 74 63 68 2e 20 72 r id mismatch. r
59c0: 65 63 69 76 65 64 20 22 20 6b 65 79 20 22 20 65 ecived " key " e
59d0: 78 70 65 63 74 65 64 3a 20 20 22 20 2a 73 65 72 xpected: " *ser
59e0: 76 65 72 2d 69 64 2a 20 22 2e 5c 6e 4f 74 68 65 ver-id* ".\nOthe
59f0: 72 20 61 72 67 75 6d 65 6e 74 73 20 72 65 63 69 r arguments reci
5a00: 76 65 64 3a 20 63 6d 64 3d 22 20 63 6d 64 20 22 ved: cmd=" cmd "
5a10: 20 70 61 72 61 6d 73 20 3d 20 22 20 70 61 72 61 params = " para
5a20: 6d 73 29 20 0a 09 20 20 28 64 62 3a 6f 62 6a 2d ms) .. (db:obj-
5a30: 3e 73 74 72 69 6e 67 20 28 63 6f 6e 63 20 22 53 >string (conc "S
5a40: 65 72 76 65 72 20 72 65 66 75 73 65 64 20 74 6f erver refused to
5a50: 20 70 72 6f 63 65 73 73 20 72 65 71 75 65 73 74 process request
5a60: 20 73 65 72 76 65 72 2d 69 64 20 6d 69 73 6d 61 server-id misma
5a70: 74 63 68 3a 20 22 20 6b 65 79 20 22 2c 20 22 20 tch: " key ", "
5a80: 2a 73 65 72 76 65 72 2d 69 64 2a 29 20 74 72 61 *server-id*) tra
5a90: 6e 73 70 6f 72 74 3a 20 27 68 74 74 70 29 29 29 nsport: 'http)))
5aa0: 29 29 0a 0a ))..