Artifact
fec0aec4d3467e26deb15be9eb53b4eaa5ccbb71:
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 72 6d 74 29 29 0a 28 64 65 63 6c 61 72 65 20 rmt)).(declare
03c0: 28 75 73 65 73 20 64 62 29 29 0a 28 64 65 63 6c (uses db)).(decl
03d0: 61 72 65 20 28 75 73 65 73 20 64 62 6d 6f 64 29 are (uses dbmod)
03e0: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
03f0: 20 64 62 66 69 6c 65 29 29 0a 28 64 65 63 6c 61 dbfile)).(decla
0400: 72 65 20 28 75 73 65 73 20 74 61 73 6b 73 29 29 re (uses tasks))
0410: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0420: 74 63 70 2d 74 72 61 6e 73 70 6f 72 74 6d 6f 64 tcp-transportmod
0430: 29 29 0a 0a 28 69 6d 70 6f 72 74 20 64 62 6d 6f ))..(import dbmo
0440: 64 29 0a 28 69 6d 70 6f 72 74 20 64 62 66 69 6c d).(import dbfil
0450: 65 29 0a 28 69 6d 70 6f 72 74 20 74 63 70 2d 74 e).(import tcp-t
0460: 72 61 6e 73 70 6f 72 74 6d 6f 64 29 0a 0a 28 75 ransportmod)..(u
0470: 73 65 20 73 72 66 69 2d 36 39 0a 20 20 20 20 20 se srfi-69.
0480: 70 6f 73 69 78 0a 20 20 20 20 20 6d 61 74 63 68 posix. match
0490: 61 62 6c 65 0a 20 20 20 20 20 73 31 31 6e 29 0a able. s11n).
04a0: 0a 3b 3b 20 61 6c 6c 6f 77 20 74 68 65 73 65 20 .;; allow these
04b0: 71 75 65 72 69 65 73 20 74 68 72 6f 75 67 68 20 queries through
04c0: 77 69 74 68 6f 75 74 20 73 74 61 72 74 69 6e 67 without starting
04d0: 20 61 20 73 65 72 76 65 72 0a 3b 3b 0a 28 64 65 a server.;;.(de
04e0: 66 69 6e 65 20 61 70 69 3a 72 65 61 64 2d 6f 6e fine api:read-on
04f0: 6c 79 2d 71 75 65 72 69 65 73 0a 20 20 27 28 67 ly-queries. '(g
0500: 65 74 2d 6b 65 79 2d 76 61 6c 2d 70 61 69 72 73 et-key-val-pairs
0510: 0a 20 20 20 20 67 65 74 2d 76 61 72 0a 20 20 20 . get-var.
0520: 20 67 65 74 2d 6b 65 79 73 0a 20 20 20 20 67 65 get-keys. ge
0530: 74 2d 6b 65 79 2d 76 61 6c 73 0a 20 20 20 20 74 t-key-vals. t
0540: 65 73 74 2d 74 6f 70 6c 65 76 65 6c 2d 6e 75 6d est-toplevel-num
0550: 2d 69 74 65 6d 73 0a 20 20 20 20 67 65 74 2d 74 -items. get-t
0560: 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 0a 20 est-info-by-id.
0570: 20 20 20 67 65 74 2d 74 65 73 74 2d 73 74 61 74 get-test-stat
0580: 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 0a 20 e-status-by-id.
0590: 20 20 20 67 65 74 2d 73 74 65 70 73 2d 69 6e 66 get-steps-inf
05a0: 6f 2d 62 79 2d 69 64 0a 20 20 20 20 67 65 74 2d o-by-id. get-
05b0: 64 61 74 61 2d 69 6e 66 6f 2d 62 79 2d 69 64 0a data-info-by-id.
05c0: 20 20 20 20 74 65 73 74 2d 67 65 74 2d 72 75 6e test-get-run
05d0: 64 69 72 2d 66 72 6f 6d 2d 74 65 73 74 2d 69 64 dir-from-test-id
05e0: 0a 20 20 20 20 67 65 74 2d 63 6f 75 6e 74 2d 74 . get-count-t
05f0: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 ests-running-for
0600: 2d 74 65 73 74 6e 61 6d 65 0a 20 20 20 20 67 65 -testname. ge
0610: 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 t-count-tests-ru
0620: 6e 6e 69 6e 67 0a 20 20 20 20 67 65 74 2d 63 6f nning. get-co
0630: 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e unt-tests-runnin
0640: 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 0a 20 20 g-in-jobgroup.
0650: 20 20 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 get-previous-t
0660: 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 0a 20 est-run-record.
0670: 20 20 20 67 65 74 2d 6d 61 74 63 68 69 6e 67 2d get-matching-
0680: 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 previous-test-ru
0690: 6e 2d 72 65 63 6f 72 64 73 0a 20 20 20 20 74 65 n-records. te
06a0: 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 2d 69 st-get-logfile-i
06b0: 6e 66 6f 0a 20 20 20 20 74 65 73 74 2d 67 65 74 nfo. test-get
06c0: 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 -records-for-ind
06d0: 65 78 2d 66 69 6c 65 0a 20 20 20 20 67 65 74 2d ex-file. get-
06e0: 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 testinfo-state-s
06f0: 74 61 74 75 73 0a 20 20 20 20 74 65 73 74 2d 67 tatus. test-g
0700: 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 et-top-process-p
0710: 69 64 0a 20 20 20 20 74 65 73 74 2d 67 65 74 2d id. test-get-
0720: 70 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 2d 6b paths-matching-k
0730: 65 79 6e 61 6d 65 73 2d 74 61 72 67 65 74 2d 6e eynames-target-n
0740: 65 77 0a 20 20 20 20 67 65 74 2d 70 72 65 72 65 ew. get-prere
0750: 71 73 2d 6e 6f 74 2d 6d 65 74 0a 20 20 20 20 67 qs-not-met. g
0760: 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 et-count-tests-r
0770: 75 6e 6e 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d 69 unning-for-run-i
0780: 64 0a 20 20 20 20 67 65 74 2d 72 75 6e 2d 69 6e d. get-run-in
0790: 66 6f 0a 20 20 20 20 67 65 74 2d 72 75 6e 2d 73 fo. get-run-s
07a0: 74 61 74 75 73 0a 20 20 20 20 67 65 74 2d 72 75 tatus. get-ru
07b0: 6e 2d 73 74 61 74 65 0a 20 20 20 20 67 65 74 2d n-state. get-
07c0: 72 75 6e 2d 73 74 61 74 73 0a 20 20 20 20 67 65 run-stats. ge
07d0: 74 2d 72 75 6e 2d 74 69 6d 65 73 0a 20 20 20 20 t-run-times.
07e0: 67 65 74 2d 74 61 72 67 65 74 0a 20 20 20 20 67 get-target. g
07f0: 65 74 2d 74 61 72 67 65 74 73 0a 20 20 20 20 3b et-targets. ;
0800: 3b 20 72 65 67 69 73 74 65 72 2d 72 75 6e 0a 20 ; register-run.
0810: 20 20 20 67 65 74 2d 74 65 73 74 73 2d 74 61 67 get-tests-tag
0820: 73 0a 20 20 20 20 67 65 74 2d 74 65 73 74 2d 74 s. get-test-t
0830: 69 6d 65 73 0a 20 20 20 20 67 65 74 2d 74 65 73 imes. get-tes
0840: 74 73 2d 66 6f 72 2d 72 75 6e 0a 20 20 20 20 67 ts-for-run. g
0850: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
0860: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 0a 20 20 -state-status.
0870: 20 20 67 65 74 2d 74 65 73 74 2d 69 64 0a 20 20 get-test-id.
0880: 20 20 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d get-tests-for-
0890: 72 75 6e 73 2d 6d 69 6e 64 61 74 61 0a 20 20 20 runs-mindata.
08a0: 20 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 get-tests-for-r
08b0: 75 6e 2d 6d 69 6e 64 61 74 61 0a 20 20 20 20 67 un-mindata. g
08c0: 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d et-run-name-from
08d0: 2d 69 64 0a 20 20 20 20 67 65 74 2d 72 75 6e 73 -id. get-runs
08e0: 0a 20 20 20 20 73 69 6d 70 6c 65 2d 67 65 74 2d . simple-get-
08f0: 72 75 6e 73 0a 20 20 20 20 67 65 74 2d 6e 75 6d runs. get-num
0900: 2d 72 75 6e 73 0a 20 20 20 20 67 65 74 2d 72 75 -runs. get-ru
0910: 6e 73 2d 63 6e 74 2d 62 79 2d 70 61 74 74 0a 20 ns-cnt-by-patt.
0920: 20 20 20 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 get-all-run-i
0930: 64 73 0a 20 20 20 20 67 65 74 2d 70 72 65 76 2d ds. get-prev-
0940: 72 75 6e 2d 69 64 73 0a 20 20 20 20 67 65 74 2d run-ids. get-
0950: 72 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 run-ids-matching
0960: 2d 74 61 72 67 65 74 0a 20 20 20 20 67 65 74 2d -target. get-
0970: 72 75 6e 73 2d 62 79 2d 70 61 74 74 0a 20 20 20 runs-by-patt.
0980: 20 67 65 74 2d 73 74 65 70 73 2d 64 61 74 61 0a get-steps-data.
0990: 20 20 20 20 67 65 74 2d 73 74 65 70 73 2d 66 6f get-steps-fo
09a0: 72 2d 74 65 73 74 0a 20 20 20 20 72 65 61 64 2d r-test. read-
09b0: 74 65 73 74 2d 64 61 74 61 0a 20 20 20 20 72 65 test-data. re
09c0: 61 64 2d 74 65 73 74 2d 64 61 74 61 2d 76 61 72 ad-test-data-var
09d0: 70 61 74 74 0a 20 20 20 20 6c 6f 67 69 6e 0a 20 patt. login.
09e0: 20 20 20 74 61 73 6b 73 2d 67 65 74 2d 6c 61 73 tasks-get-las
09f0: 74 0a 20 20 20 20 74 65 73 74 6d 65 74 61 2d 67 t. testmeta-g
0a00: 65 74 2d 72 65 63 6f 72 64 0a 20 20 20 20 68 61 et-record. ha
0a10: 76 65 2d 69 6e 63 6f 6d 70 6c 65 74 65 73 3f 0a ve-incompletes?.
0a20: 20 20 20 20 3b 3b 20 73 79 6e 63 68 61 73 68 2d ;; synchash-
0a30: 67 65 74 0a 20 20 20 20 67 65 74 2d 63 68 61 6e get. get-chan
0a40: 67 65 64 2d 72 65 63 6f 72 64 2d 69 64 73 0a 20 ged-record-ids.
0a50: 20 20 20 67 65 74 2d 72 75 6e 2d 72 65 63 6f 72 get-run-recor
0a60: 64 2d 69 64 73 20 0a 20 20 20 20 67 65 74 2d 6e d-ids . get-n
0a70: 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 2d 63 6e 74 ot-completed-cnt
0a80: 29 29 0a 0a 28 64 65 66 69 6e 65 20 61 70 69 3a ))..(define api:
0a90: 77 72 69 74 65 2d 71 75 65 72 69 65 73 0a 20 20 write-queries.
0aa0: 27 28 0a 20 20 20 20 67 65 74 2d 6b 65 79 73 2d '(. get-keys-
0ab0: 77 72 69 74 65 20 3b 3b 20 64 75 6d 6d 79 20 22 write ;; dummy "
0ac0: 77 72 69 74 65 22 20 71 75 65 72 79 20 74 6f 20 write" query to
0ad0: 66 6f 72 63 65 20 73 65 72 76 65 72 20 73 74 61 force server sta
0ae0: 72 74 0a 0a 20 20 20 20 3b 3b 20 53 45 52 56 45 rt.. ;; SERVE
0af0: 52 53 0a 20 20 20 20 3b 3b 20 73 74 61 72 74 2d RS. ;; start-
0b00: 73 65 72 76 65 72 0a 20 20 20 20 3b 3b 20 6b 69 server. ;; ki
0b10: 6c 6c 2d 73 65 72 76 65 72 0a 0a 20 20 20 20 3b ll-server.. ;
0b20: 3b 20 54 45 53 54 53 0a 20 20 20 20 74 65 73 74 ; TESTS. test
0b30: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
0b40: 73 2d 62 79 2d 69 64 0a 20 20 20 20 64 65 6c 65 s-by-id. dele
0b50: 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 0a te-test-records.
0b60: 20 20 20 20 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 delete-old-d
0b70: 65 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 63 6f eleted-test-reco
0b80: 72 64 73 0a 20 20 20 20 74 65 73 74 2d 73 65 74 rds. test-set
0b90: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 0a 20 20 -state-status.
0ba0: 20 20 74 65 73 74 2d 73 65 74 2d 74 6f 70 2d 70 test-set-top-p
0bb0: 72 6f 63 65 73 73 2d 70 69 64 0a 20 20 20 20 73 rocess-pid. s
0bc0: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
0bd0: 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d and-roll-up-item
0be0: 73 0a 20 20 20 20 0a 20 20 20 20 75 70 64 61 74 s. . updat
0bf0: 65 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f 75 6e e-pass-fail-coun
0c00: 74 73 0a 20 20 20 20 74 6f 70 2d 74 65 73 74 2d ts. top-test-
0c10: 73 65 74 2d 70 65 72 2d 70 66 2d 63 6f 75 6e 74 set-per-pf-count
0c20: 73 20 3b 3b 20 28 64 62 3a 74 6f 70 2d 74 65 73 s ;; (db:top-tes
0c30: 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 6f 75 t-set-per-pf-cou
0c40: 6e 74 73 20 28 64 62 3a 67 65 74 2d 64 62 20 2a nts (db:get-db *
0c50: 64 62 2a 20 35 29 20 35 20 22 72 75 6e 66 69 72 db* 5) 5 "runfir
0c60: 73 74 22 29 0a 0a 20 20 20 20 3b 3b 20 52 55 4e st").. ;; RUN
0c70: 53 0a 20 20 20 20 72 65 67 69 73 74 65 72 2d 72 S. register-r
0c80: 75 6e 0a 20 20 20 20 73 65 74 2d 74 65 73 74 73 un. set-tests
0c90: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 0a 20 20 -state-status.
0ca0: 20 20 64 65 6c 65 74 65 2d 72 75 6e 0a 20 20 20 delete-run.
0cb0: 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e lock/unlock-run
0cc0: 0a 20 20 20 20 75 70 64 61 74 65 2d 72 75 6e 2d . update-run-
0cd0: 65 76 65 6e 74 5f 74 69 6d 65 0a 20 20 20 20 6d event_time. m
0ce0: 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 0a 20 ark-incomplete.
0cf0: 20 20 20 73 65 74 2d 73 74 61 74 65 2d 73 74 61 set-state-sta
0d00: 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d tus-and-roll-up-
0d10: 72 75 6e 0a 20 20 20 20 3b 3b 20 53 54 45 50 53 run. ;; STEPS
0d20: 0a 20 20 20 20 74 65 73 74 73 74 65 70 2d 73 65 . teststep-se
0d30: 74 2d 73 74 61 74 75 73 21 0a 20 20 20 20 64 65 t-status!. de
0d40: 6c 65 74 65 2d 73 74 65 70 73 2d 66 6f 72 2d 74 lete-steps-for-t
0d50: 65 73 74 0a 20 20 20 20 3b 3b 20 54 45 53 54 20 est. ;; TEST
0d60: 44 41 54 41 0a 20 20 20 20 74 65 73 74 2d 64 61 DATA. test-da
0d70: 74 61 2d 72 6f 6c 6c 75 70 0a 20 20 20 20 63 73 ta-rollup. cs
0d80: 76 2d 3e 74 65 73 74 2d 64 61 74 61 0a 0a 20 20 v->test-data..
0d90: 20 20 3b 3b 20 4d 49 53 43 0a 20 20 20 20 73 79 ;; MISC. sy
0da0: 6e 63 2d 69 6e 6d 65 6d 2d 3e 64 62 0a 20 20 20 nc-inmem->db.
0db0: 20 64 72 6f 70 2d 61 6c 6c 2d 74 72 69 67 67 65 drop-all-trigge
0dc0: 72 73 0a 20 20 20 20 63 72 65 61 74 65 2d 61 6c rs. create-al
0dd0: 6c 2d 74 72 69 67 67 65 72 73 0a 20 20 20 20 75 l-triggers. u
0de0: 70 64 61 74 65 2d 74 65 73 64 61 74 61 2d 6f 6e pdate-tesdata-on
0df0: 2d 72 65 70 69 6c 63 61 74 65 2d 64 62 20 0a 0a -repilcate-db ..
0e00: 20 20 20 20 3b 3b 20 54 45 53 54 4d 45 54 41 0a ;; TESTMETA.
0e10: 20 20 20 20 74 65 73 74 6d 65 74 61 2d 61 64 64 testmeta-add
0e20: 2d 72 65 63 6f 72 64 0a 20 20 20 20 74 65 73 74 -record. test
0e30: 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 69 65 6c meta-update-fiel
0e40: 64 0a 0a 20 20 20 20 3b 3b 20 54 41 53 4b 53 0a d.. ;; TASKS.
0e50: 20 20 20 20 74 61 73 6b 73 2d 61 64 64 0a 20 20 tasks-add.
0e60: 20 20 74 61 73 6b 73 2d 73 65 74 2d 73 74 61 74 tasks-set-stat
0e70: 65 2d 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 e-given-param-ke
0e80: 79 0a 20 20 20 20 29 29 0a 0a 28 64 65 66 69 6e y. ))..(defin
0e90: 65 20 2a 64 62 2d 77 72 69 74 65 2d 6d 75 74 65 e *db-write-mute
0ea0: 78 65 73 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d xes* (make-hash-
0eb0: 74 61 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 table)).(define
0ec0: 2a 73 65 72 76 65 72 2d 73 69 67 6e 61 74 75 72 *server-signatur
0ed0: 65 2a 20 23 66 29 0a 3b 3b 20 54 68 65 73 65 20 e* #f).;; These
0ee0: 61 72 65 20 63 61 6c 6c 65 64 20 62 79 20 74 68 are called by th
0ef0: 65 20 73 65 72 76 65 72 20 6f 6e 20 72 65 63 69 e server on reci
0f00: 70 74 20 6f 66 20 2f 61 70 69 20 63 61 6c 6c 73 pt of /api calls
0f10: 0a 3b 3b 20 20 20 20 2d 20 6b 65 65 70 20 69 74 .;; - keep it
0f20: 20 73 69 6d 70 6c 65 2c 20 6f 6e 6c 79 20 72 65 simple, only re
0f30: 74 75 72 6e 20 74 68 65 20 61 63 74 75 61 6c 20 turn the actual
0f40: 72 65 73 75 6c 74 20 6f 66 20 74 68 65 20 63 61 result of the ca
0f50: 6c 6c 2c 20 69 2e 65 2e 20 6e 6f 20 6d 65 74 61 ll, i.e. no meta
0f60: 20 69 6e 66 6f 20 68 65 72 65 0a 3b 3b 0a 3b 3b info here.;;.;;
0f70: 20 20 20 20 2d 20 72 65 74 75 72 6e 73 20 23 28 - returns #(
0f80: 20 66 6c 61 67 20 72 65 73 75 6c 74 20 29 0a 3b flag result ).;
0f90: 3b 0a 28 64 65 66 69 6e 65 20 28 61 70 69 3a 65 ;.(define (api:e
0fa0: 78 65 63 75 74 65 2d 72 65 71 75 65 73 74 73 20 xecute-requests
0fb0: 64 62 73 74 72 75 63 74 20 64 61 74 29 0a 20 20 dbstruct dat).
0fc0: 28 69 66 20 28 3e 20 2a 61 70 69 2d 70 72 6f 63 (if (> *api-proc
0fd0: 65 73 73 2d 72 65 71 75 65 73 74 2d 63 6f 75 6e ess-request-coun
0fe0: 74 2a 20 32 30 30 29 0a 20 20 20 20 20 20 28 62 t* 200). (b
0ff0: 65 67 69 6e 0a 09 28 69 66 20 28 63 6f 6d 6d 6f egin..(if (commo
1000: 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e n:low-noise-prin
1010: 74 20 33 30 20 22 74 6f 6f 20 6d 61 6e 79 20 74 t 30 "too many t
1020: 68 72 65 61 64 73 22 29 0a 09 20 20 20 20 28 64 hreads").. (d
1030: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
1040: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1050: 22 57 41 52 4e 49 4e 47 3a 20 22 2a 61 70 69 2d "WARNING: "*api-
1060: 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 2d process-request-
1070: 63 6f 75 6e 74 2a 22 20 74 68 72 65 61 64 73 2c count*" threads,
1080: 20 70 6f 74 65 6e 74 69 61 6c 20 6f 76 65 72 6c potential overl
1090: 6f 61 64 2c 20 61 64 64 69 6e 67 20 30 2e 35 20 oad, adding 0.5
10a0: 73 65 63 20 64 65 6c 61 79 2e 22 29 29 0a 09 28 sec delay."))..(
10b0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
10c0: 35 29 20 3b 3b 20 74 61 6b 65 20 61 20 6e 61 70 5) ;; take a nap
10d0: 0a 09 29 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 ..)). (cond.
10e0: 28 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 64 ((not (vector? d
10f0: 61 74 29 29 20 20 20 20 20 20 20 20 20 20 20 20 at))
1100: 20 20 20 20 20 20 20 20 3b 3b 20 69 74 20 69 73 ;; it is
1110: 20 61 6e 20 65 72 72 6f 72 20 74 6f 20 6e 6f 74 an error to not
1120: 20 72 65 63 65 69 76 65 20 61 20 76 65 63 74 6f receive a vecto
1130: 72 0a 20 20 20 20 28 76 65 63 74 6f 72 20 23 66 r. (vector #f
1140: 20 28 76 65 63 74 6f 72 20 23 66 20 22 72 65 6d (vector #f "rem
1150: 6f 74 65 20 6d 75 73 74 20 62 65 20 63 61 6c 6c ote must be call
1160: 65 64 20 77 69 74 68 20 61 20 76 65 63 74 6f 72 ed with a vector
1170: 22 29 29 29 0a 20 20 20 28 65 6c 73 65 20 20 0a "))). (else .
1180: 20 20 20 20 28 6c 65 74 2a 20 28 28 63 6d 64 2d (let* ((cmd-
1190: 69 6e 20 20 20 20 20 20 20 20 20 20 20 20 28 76 in (v
11a0: 65 63 74 6f 72 2d 72 65 66 20 64 61 74 20 30 29 ector-ref dat 0)
11b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 63 6d ). (cm
11c0: 64 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d
11d0: 28 69 66 20 28 73 79 6d 62 6f 6c 3f 20 63 6d 64 (if (symbol? cmd
11e0: 2d 69 6e 29 0a 09 09 09 09 20 20 63 6d 64 2d 69 -in)..... cmd-i
11f0: 6e 0a 09 09 09 09 20 20 28 73 74 72 69 6e 67 2d n..... (string-
1200: 3e 73 79 6d 62 6f 6c 20 63 6d 64 2d 69 6e 29 29 >symbol cmd-in))
1210: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 70 61 ). (pa
1220: 72 61 6d 73 20 20 20 20 20 20 20 20 20 20 20 20 rams
1230: 28 76 65 63 74 6f 72 2d 72 65 66 20 64 61 74 20 (vector-ref dat
1240: 31 29 29 0a 09 20 20 20 28 72 75 6e 2d 69 64 20 1)).. (run-id
1250: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
1260: 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 0a 09 09 null? params)...
1270: 09 09 20 20 30 0a 09 09 09 09 20 20 28 63 61 72 .. 0..... (car
1280: 20 70 61 72 61 6d 73 29 29 29 0a 09 20 20 20 28 params))).. (
1290: 77 72 69 74 65 2d 6d 75 74 65 78 20 20 20 20 20 write-mutex
12a0: 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c (if (hash-tabl
12b0: 65 2d 65 78 69 73 74 73 3f 20 2a 64 62 2d 77 72 e-exists? *db-wr
12c0: 69 74 65 2d 6d 75 74 65 78 65 73 2a 20 72 75 6e ite-mutexes* run
12d0: 2d 69 64 29 0a 09 09 09 09 20 20 28 68 61 73 68 -id)..... (hash
12e0: 2d 74 61 62 6c 65 2d 72 65 66 20 2a 64 62 2d 77 -table-ref *db-w
12f0: 72 69 74 65 2d 6d 75 74 65 78 65 73 2a 20 72 75 rite-mutexes* ru
1300: 6e 2d 69 64 29 0a 09 09 09 09 20 20 28 6c 65 74 n-id)..... (let
1310: 2a 20 28 28 6e 65 77 6d 75 74 65 78 20 28 6d 61 * ((newmutex (ma
1320: 6b 65 2d 6d 75 74 65 78 29 29 29 0a 09 09 09 09 ke-mutex))).....
1330: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
1340: 73 65 74 21 20 2a 64 62 2d 77 72 69 74 65 2d 6d set! *db-write-m
1350: 75 74 65 78 65 73 2a 20 72 75 6e 2d 69 64 20 6e utexes* run-id n
1360: 65 77 6d 75 74 65 78 29 0a 09 09 09 09 20 20 20 ewmutex).....
1370: 20 6e 65 77 6d 75 74 65 78 29 29 29 0a 20 20 20 newmutex))).
1380: 20 20 20 20 20 20 20 20 28 73 74 61 72 74 2d 74 (start-t
1390: 20 20 20 20 20 20 20 20 20 20 20 28 63 75 72 72 (curr
13a0: 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 ent-milliseconds
13b0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 72 )). (r
13c0: 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 20 20 20 eadonly-mode
13d0: 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 72 (dbr:dbstruct-r
13e0: 65 61 64 2d 6f 6e 6c 79 20 64 62 73 74 72 75 63 ead-only dbstruc
13f0: 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 t)). (
1400: 72 65 61 64 6f 6e 6c 79 2d 63 6f 6d 6d 61 6e 64 readonly-command
1410: 20 20 28 6d 65 6d 62 65 72 20 63 6d 64 20 61 70 (member cmd ap
1420: 69 3a 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 i:read-only-quer
1430: 69 65 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ies)).
1440: 20 28 77 72 69 74 65 63 6d 64 2d 69 6e 2d 72 65 (writecmd-in-re
1450: 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 28 61 6e 64 adonly-mode (and
1460: 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 28 readonly-mode (
1470: 6e 6f 74 20 72 65 61 64 6f 6e 6c 79 2d 63 6f 6d not readonly-com
1480: 6d 61 6e 64 29 29 29 29 0a 20 20 20 20 20 20 28 mand)))). (
1490: 69 66 20 28 6e 6f 74 20 72 65 61 64 6f 6e 6c 79 if (not readonly
14a0: 2d 63 6f 6d 6d 61 6e 64 29 0a 09 20 20 28 6d 75 -command).. (mu
14b0: 74 65 78 2d 6c 6f 63 6b 21 20 77 72 69 74 65 2d tex-lock! write-
14c0: 6d 75 74 65 78 29 29 0a 20 20 20 20 20 20 28 6c mutex)). (l
14d0: 65 74 2a 20 28 28 74 6d 70 70 61 74 68 20 20 20 et* ((tmppath
14e0: 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 74 (dbr:dbstruct-t
14f0: 6d 70 70 61 74 68 20 20 64 62 73 74 72 75 63 74 mppath dbstruct
1500: 29 29 0a 09 20 20 20 20 20 28 63 6c 65 61 6e 2d )).. (clean-
1510: 72 75 6e 2d 69 64 20 28 63 6f 6e 64 0a 09 09 09 run-id (cond....
1520: 20 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 72 75 ((number? ru
1530: 6e 2d 69 64 29 20 20 20 72 75 6e 2d 69 64 29 0a n-id) run-id).
1540: 09 09 09 20 20 20 20 28 28 65 71 75 61 6c 3f 20 ... ((equal?
1550: 72 75 6e 2d 69 64 20 23 66 29 20 22 6d 61 69 6e run-id #f) "main
1560: 22 29 0a 09 09 09 20 20 20 20 28 65 6c 73 65 20 ").... (else
1570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 6f "o
1580: 74 68 65 72 22 29 29 29 0a 09 20 20 20 20 20 28 ther"))).. (
1590: 63 72 75 6d 62 66 69 6c 65 20 20 28 64 62 66 69 crumbfile (dbfi
15a0: 6c 65 3a 77 61 69 74 2d 66 6f 72 2d 71 69 66 20 le:wait-for-qif
15b0: 74 6d 70 70 61 74 68 20 63 6c 65 61 6e 2d 72 75 tmppath clean-ru
15c0: 6e 2d 69 64 20 28 63 6f 6e 73 20 63 6d 64 20 70 n-id (cons cmd p
15d0: 61 72 61 6d 73 29 29 29 0a 09 20 20 20 20 20 28 arams))).. (
15e0: 72 65 73 20 20 20 20 0a 20 20 20 20 20 20 20 20 res .
15f0: 20 20 20 20 20 20 28 69 66 20 77 72 69 74 65 63 (if writec
1600: 6d 64 2d 69 6e 2d 72 65 61 64 6f 6e 6c 79 2d 6d md-in-readonly-m
1610: 6f 64 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ode.
1620: 20 20 20 20 20 20 28 63 6f 6e 63 20 22 61 74 74 (conc "att
1630: 65 6d 70 74 20 74 6f 20 72 75 6e 20 77 72 69 74 empt to run writ
1640: 65 20 63 6f 6d 6d 61 6e 64 20 22 63 6d 64 22 20 e command "cmd"
1650: 6f 6e 20 61 20 72 65 61 64 2d 6f 6e 6c 79 20 64 on a read-only d
1660: 61 74 61 62 61 73 65 22 29 0a 09 09 20 20 28 61 atabase")... (a
1670: 70 69 3a 64 69 73 70 61 74 63 68 2d 72 65 71 75 pi:dispatch-requ
1680: 65 73 74 20 64 62 73 74 72 75 63 74 20 63 6d 64 est dbstruct cmd
1690: 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 29 29 run-id params))
16a0: 29 29 0a 09 28 64 65 6c 65 74 65 2d 66 69 6c 65 ))..(delete-file
16b0: 2a 20 63 72 75 6d 62 66 69 6c 65 29 0a 09 28 69 * crumbfile)..(i
16c0: 66 20 28 6e 6f 74 20 72 65 61 64 6f 6e 6c 79 2d f (not readonly-
16d0: 63 6f 6d 6d 61 6e 64 29 0a 09 20 20 20 20 28 6d command).. (m
16e0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 77 72 69 utex-unlock! wri
16f0: 74 65 2d 6d 75 74 65 78 29 29 0a 09 0a 09 3b 3b te-mutex))....;;
1700: 20 73 61 76 65 20 61 6c 6c 20 73 74 61 74 73 0a save all stats.
1710: 09 28 6c 65 74 20 28 28 64 65 6c 74 61 2d 74 20 .(let ((delta-t
1720: 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c (- (current-mill
1730: 69 73 65 63 6f 6e 64 73 29 0a 09 09 09 20 20 73 iseconds).... s
1740: 74 61 72 74 2d 74 29 29 0a 09 20 20 20 20 20 20 tart-t))..
1750: 28 6d 6f 64 69 66 69 65 64 2d 63 6d 64 20 28 69 (modified-cmd (i
1760: 66 20 28 65 71 3f 20 63 6d 64 20 27 67 65 6e 65 f (eq? cmd 'gene
1770: 72 61 6c 2d 63 61 6c 6c 29 0a 09 09 09 09 28 73 ral-call).....(s
1780: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 63 tring->symbol (c
1790: 6f 6e 63 20 22 67 65 6e 65 72 61 6c 2d 63 61 6c onc "general-cal
17a0: 6c 2d 22 20 28 63 61 72 20 70 61 72 61 6d 73 29 l-" (car params)
17b0: 29 29 0a 09 09 09 09 63 6d 64 29 29 29 0a 09 20 )).....cmd)))..
17c0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
17d0: 21 20 2a 64 62 2d 61 70 69 2d 63 61 6c 6c 2d 74 ! *db-api-call-t
17e0: 69 6d 65 2a 20 6d 6f 64 69 66 69 65 64 2d 63 6d ime* modified-cm
17f0: 64 0a 09 09 09 20 20 20 28 63 6f 6e 73 20 64 65 d.... (cons de
1800: 6c 74 61 2d 74 20 28 68 61 73 68 2d 74 61 62 6c lta-t (hash-tabl
1810: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 64 e-ref/default *d
1820: 62 2d 61 70 69 2d 63 61 6c 6c 2d 74 69 6d 65 2a b-api-call-time*
1830: 20 6d 6f 64 69 66 69 65 64 2d 63 6d 64 20 27 28 modified-cmd '(
1840: 29 29 29 29 29 0a 09 28 69 66 20 77 72 69 74 65 )))))..(if write
1850: 63 6d 64 2d 69 6e 2d 72 65 61 64 6f 6e 6c 79 2d cmd-in-readonly-
1860: 6d 6f 64 65 0a 20 20 20 20 20 20 20 20 20 20 20 mode.
1870: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
1880: 20 20 20 20 20 20 23 3b 28 63 6f 6d 6d 6f 6e 3a #;(common:
1890: 74 65 6c 65 6d 65 74 72 79 2d 6c 6f 67 20 28 63 telemetry-log (c
18a0: 6f 6e 63 20 22 61 70 69 2d 6f 75 74 3a 22 28 2d onc "api-out:"(-
18b0: 3e 73 74 72 69 6e 67 20 63 6d 64 29 29 0a 20 20 >string cmd)).
18c0: 20 20 20 20 20 20 20 20 20 20 20 20 70 61 79 6c payl
18d0: 6f 61 64 3a 20 60 28 28 70 61 72 61 6d 73 20 2e oad: `((params .
18e0: 20 2c 70 61 72 61 6d 73 29 0a 20 20 20 20 20 20 ,params).
18f0: 20 20 20 20 20 20 20 20 28 6f 6b 2d 72 65 73 20 (ok-res
1900: 2e 20 23 74 29 29 29 0a 09 20 20 20 20 20 20 28 . #t))).. (
1910: 76 65 63 74 6f 72 20 23 66 20 72 65 73 29 29 0a vector #f res)).
1920: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
1930: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 in.
1940: 20 23 3b 28 63 6f 6d 6d 6f 6e 3a 74 65 6c 65 6d #;(common:telem
1950: 65 74 72 79 2d 6c 6f 67 20 28 63 6f 6e 63 20 22 etry-log (conc "
1960: 61 70 69 2d 6f 75 74 3a 22 28 2d 3e 73 74 72 69 api-out:"(->stri
1970: 6e 67 20 63 6d 64 29 29 0a 20 20 20 20 20 20 20 ng cmd)).
1980: 20 20 20 20 20 20 20 70 61 79 6c 6f 61 64 3a 20 payload:
1990: 60 28 28 70 61 72 61 6d 73 20 2e 20 2c 70 61 72 `((params . ,par
19a0: 61 6d 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 ams).
19b0: 20 20 20 28 6f 6b 2d 72 65 73 20 2e 20 23 66 29 (ok-res . #f)
19c0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
19d0: 20 28 76 65 63 74 6f 72 20 23 74 20 72 65 73 29 (vector #t res)
19e0: 29 29 29 29 29 29 29 0a 0a 3b 3b 20 69 6e 64 61 )))))))..;; inda
19f0: 74 20 69 73 20 28 63 6d 64 20 72 75 6e 2d 69 64 t is (cmd run-id
1a00: 20 70 61 72 61 6d 73 20 6d 65 74 61 29 0a 3b 3b params meta).;;
1a10: 0a 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 44 6f 20 .;; WARNING: Do
1a20: 6e 6f 74 20 70 72 69 6e 74 20 61 6e 79 74 68 69 not print anythi
1a30: 6e 67 20 69 6e 20 74 68 65 20 6c 61 6d 62 64 61 ng in the lambda
1a40: 20 6f 66 20 74 68 69 73 20 66 75 6e 63 74 69 6f of this functio
1a50: 6e 20 61 73 20 69 74 0a 3b 3b 20 20 20 20 20 20 n as it.;;
1a60: 20 20 20 20 72 65 61 64 73 2f 77 72 69 74 65 73 reads/writes
1a70: 20 74 6f 20 63 75 72 72 65 6e 74 20 69 6e 2f 6f to current in/o
1a80: 75 74 20 70 6f 72 74 0a 3b 3b 0a 28 64 65 66 69 ut port.;;.(defi
1a90: 6e 65 20 28 61 70 69 3a 74 63 70 2d 64 69 73 70 ne (api:tcp-disp
1aa0: 61 74 63 68 2d 72 65 71 75 65 73 74 2d 6d 61 6b atch-request-mak
1ab0: 65 2d 68 61 6e 64 6c 65 72 20 64 62 73 74 72 75 e-handler dbstru
1ac0: 63 74 29 20 3b 3b 20 63 6d 64 20 72 75 6e 2d 69 ct) ;; cmd run-i
1ad0: 64 20 70 61 72 61 6d 73 29 0a 20 20 28 61 73 73 d params). (ass
1ae0: 65 72 74 20 2a 74 6f 70 70 61 74 68 2a 20 22 46 ert *toppath* "F
1af0: 41 54 41 4c 3a 20 61 70 69 3a 74 63 70 2d 64 69 ATAL: api:tcp-di
1b00: 73 70 61 74 63 68 2d 72 65 71 75 65 73 74 2d 6d spatch-request-m
1b10: 61 6b 65 2d 68 61 6e 64 6c 65 72 20 63 61 6c 6c ake-handler call
1b20: 65 64 20 62 75 74 20 2a 74 6f 70 70 61 74 68 2a ed but *toppath*
1b30: 20 6e 6f 74 20 73 65 74 2e 22 29 0a 20 20 28 69 not set."). (i
1b40: 66 20 28 6e 6f 74 20 2a 73 65 72 76 65 72 2d 73 f (not *server-s
1b50: 69 67 6e 61 74 75 72 65 2a 29 0a 20 20 20 20 20 ignature*).
1b60: 20 28 73 65 74 21 20 2a 73 65 72 76 65 72 2d 73 (set! *server-s
1b70: 69 67 6e 61 74 75 72 65 2a 20 28 74 74 3a 6d 6b ignature* (tt:mk
1b80: 2d 73 69 67 6e 61 74 75 72 65 20 2a 74 6f 70 70 -signature *topp
1b90: 61 74 68 2a 29 29 29 0a 20 20 28 6c 61 6d 62 64 ath*))). (lambd
1ba0: 61 20 28 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 a (). (let* (
1bb0: 28 69 6e 64 61 74 20 20 20 20 20 20 28 64 65 73 (indat (des
1bc0: 65 72 69 61 6c 69 7a 65 29 29 0a 09 20 20 20 28 erialize)).. (
1bd0: 6e 65 77 63 6f 75 6e 74 20 20 20 28 2b 20 2a 61 newcount (+ *a
1be0: 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 pi-process-reque
1bf0: 73 74 2d 63 6f 75 6e 74 2a 20 31 29 29 0a 09 20 st-count* 1))..
1c00: 20 20 28 64 65 6c 61 79 2d 77 61 69 74 20 28 69 (delay-wait (i
1c10: 66 20 28 3e 20 6e 65 77 63 6f 75 6e 74 20 31 30 f (> newcount 10
1c20: 29 0a 09 09 09 20 20 20 28 2d 20 6e 65 77 63 6f ).... (- newco
1c30: 75 6e 74 20 31 30 29 0a 09 09 09 20 20 20 30 29 unt 10).... 0)
1c40: 29 0a 09 20 20 20 28 6e 6f 72 6d 61 6c 2d 70 72 ).. (normal-pr
1c50: 6f 63 20 28 6c 61 6d 62 64 61 20 28 63 6d 64 20 oc (lambda (cmd
1c60: 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 29 0a 09 run-id params)..
1c70: 09 09 20 20 28 63 61 73 65 20 63 6d 64 0a 09 09 .. (case cmd...
1c80: 09 20 20 20 20 28 28 70 69 6e 67 29 20 2a 73 65 . ((ping) *se
1c90: 72 76 65 72 2d 73 69 67 6e 61 74 75 72 65 2a 29 rver-signature*)
1ca0: 0a 09 09 09 20 20 20 20 28 65 6c 73 65 0a 09 09 .... (else...
1cb0: 09 20 20 20 20 20 28 61 70 69 3a 64 69 73 70 61 . (api:dispa
1cc0: 74 63 68 2d 72 65 71 75 65 73 74 20 64 62 73 74 tch-request dbst
1cd0: 72 75 63 74 20 63 6d 64 20 72 75 6e 2d 69 64 20 ruct cmd run-id
1ce0: 70 61 72 61 6d 73 29 29 29 29 29 29 0a 20 20 20 params)))))).
1cf0: 20 20 20 28 73 65 74 21 20 2a 61 70 69 2d 70 72 (set! *api-pr
1d00: 6f 63 65 73 73 2d 72 65 71 75 65 73 74 2d 63 6f ocess-request-co
1d10: 75 6e 74 2a 20 6e 65 77 63 6f 75 6e 74 29 0a 20 unt* newcount).
1d20: 20 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d 6c (set! *db-l
1d30: 61 73 74 2d 61 63 63 65 73 73 2a 20 28 63 75 72 ast-access* (cur
1d40: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 20 rent-seconds)).
1d50: 20 20 20 20 20 28 6d 61 74 63 68 20 69 6e 64 61 (match inda
1d60: 74 0a 09 28 28 63 6d 64 20 72 75 6e 2d 69 64 20 t..((cmd run-id
1d70: 70 61 72 61 6d 73 20 6d 65 74 61 29 0a 09 20 28 params meta).. (
1d80: 6c 65 74 2a 20 28 28 74 74 64 61 74 20 20 20 2a let* ((ttdat *
1d90: 73 65 72 76 65 72 2d 69 6e 66 6f 2a 29 0a 09 09 server-info*)...
1da0: 28 73 65 72 76 65 72 2d 73 74 61 74 65 20 28 74 (server-state (t
1db0: 74 2d 73 74 61 74 65 20 74 74 64 61 74 29 29 0a t-state ttdat)).
1dc0: 09 09 28 73 74 61 74 75 73 20 20 28 63 6f 6e 64 ..(status (cond
1dd0: 0a 09 09 09 20 20 3b 3b 20 28 28 3e 20 6e 65 77 .... ;; ((> new
1de0: 63 6f 75 6e 74 20 36 30 30 29 20 27 62 75 73 79 count 600) 'busy
1df0: 29 0a 09 09 09 20 20 3b 3b 20 28 28 3e 20 6e 65 ).... ;; ((> ne
1e00: 77 63 6f 75 6e 74 20 33 30 30 29 20 27 6c 6f 61 wcount 300) 'loa
1e10: 64 65 64 29 0a 09 09 09 20 20 28 65 6c 73 65 20 ded).... (else
1e20: 27 6f 6b 29 29 29 0a 09 09 28 65 72 72 6d 73 67 'ok)))...(errmsg
1e30: 20 20 28 63 61 73 65 20 73 74 61 74 75 73 0a 09 (case status..
1e40: 09 09 20 20 20 28 28 62 75 73 79 29 20 20 20 28 .. ((busy) (
1e50: 63 6f 6e 63 20 22 53 65 72 76 65 72 20 6f 76 65 conc "Server ove
1e60: 72 6c 6f 61 64 65 64 2c 20 22 6e 65 77 63 6f 75 rloaded, "newcou
1e70: 6e 74 22 20 74 68 72 65 61 64 73 20 69 6e 20 66 nt" threads in f
1e80: 6c 69 67 68 74 22 29 29 0a 09 09 09 20 20 20 28 light")).... (
1e90: 28 6c 6f 61 64 65 64 29 20 28 63 6f 6e 63 20 22 (loaded) (conc "
1ea0: 53 65 72 76 65 72 20 6c 6f 61 64 65 64 2c 20 22 Server loaded, "
1eb0: 6e 65 77 63 6f 75 6e 74 22 20 74 68 72 65 61 64 newcount" thread
1ec0: 73 20 69 6e 20 66 6c 69 67 68 74 22 29 29 0a 09 s in flight"))..
1ed0: 09 09 20 20 20 28 65 6c 73 65 20 20 20 20 20 23 .. (else #
1ee0: 66 29 29 29 0a 09 09 28 72 65 73 75 6c 74 20 20 f)))...(result
1ef0: 28 63 61 73 65 20 73 74 61 74 75 73 0a 09 09 09 (case status....
1f00: 20 20 20 28 28 62 75 73 79 29 20 20 28 2d 20 6e ((busy) (- n
1f10: 65 77 63 6f 75 6e 74 20 32 39 29 29 20 3b 3b 20 ewcount 29)) ;;
1f20: 63 61 6c 6c 20 62 61 63 6b 20 69 6e 20 61 73 20 call back in as
1f30: 6d 61 6e 79 20 73 65 63 6f 6e 64 73 0a 09 09 09 many seconds....
1f40: 20 20 20 28 28 6c 6f 61 64 65 64 29 0a 09 09 09 ((loaded)....
1f50: 20 20 20 20 28 6e 6f 72 6d 61 6c 2d 70 72 6f 63 (normal-proc
1f60: 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 cmd run-id para
1f70: 6d 73 29 29 0a 09 09 09 20 20 20 28 65 6c 73 65 ms)).... (else
1f80: 0a 09 09 09 20 20 20 20 28 6e 6f 72 6d 61 6c 2d .... (normal-
1f90: 70 72 6f 63 20 63 6d 64 20 72 75 6e 2d 69 64 20 proc cmd run-id
1fa0: 70 61 72 61 6d 73 29 29 29 29 0a 09 09 28 6d 65 params))))...(me
1fb0: 74 61 20 20 20 28 63 61 73 65 20 63 6d 64 0a 09 ta (case cmd..
1fc0: 09 09 20 20 28 28 70 69 6e 67 29 20 60 28 28 73 .. ((ping) `((s
1fd0: 73 74 61 74 65 20 2e 20 2c 73 65 72 76 65 72 2d state . ,server-
1fe0: 73 74 61 74 65 29 29 29 0a 09 09 09 20 20 28 65 state))).... (e
1ff0: 6c 73 65 20 20 20 60 28 28 77 61 69 74 20 2e 20 lse `((wait .
2000: 2c 64 65 6c 61 79 2d 77 61 69 74 29 29 29 29 29 ,delay-wait)))))
2010: 0a 09 09 28 70 61 79 6c 6f 61 64 20 28 6c 69 73 ...(payload (lis
2020: 74 20 73 74 61 74 75 73 20 65 72 72 6d 73 67 20 t status errmsg
2030: 72 65 73 75 6c 74 20 6d 65 74 61 29 29 29 0a 09 result meta)))..
2040: 20 20 20 28 73 65 74 21 20 2a 61 70 69 2d 70 72 (set! *api-pr
2050: 6f 63 65 73 73 2d 72 65 71 75 65 73 74 2d 63 6f ocess-request-co
2060: 75 6e 74 2a 20 28 2d 20 2a 61 70 69 2d 70 72 6f unt* (- *api-pro
2070: 63 65 73 73 2d 72 65 71 75 65 73 74 2d 63 6f 75 cess-request-cou
2080: 6e 74 2a 20 31 29 29 0a 09 20 20 20 28 73 65 72 nt* 1)).. (ser
2090: 69 61 6c 69 7a 65 20 70 61 79 6c 6f 61 64 29 29 ialize payload))
20a0: 29 0a 09 28 65 6c 73 65 0a 09 20 28 61 73 73 65 )..(else.. (asse
20b0: 72 74 20 23 66 20 22 46 41 54 41 4c 3a 20 66 61 rt #f "FATAL: fa
20c0: 69 6c 65 64 20 74 6f 20 64 65 73 65 72 69 61 6c iled to deserial
20d0: 69 7a 65 20 69 6e 64 61 74 20 22 69 6e 64 61 74 ize indat "indat
20e0: 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 0a 0a )))))). ..
20f0: 28 64 65 66 69 6e 65 20 28 61 70 69 3a 64 69 73 (define (api:dis
2100: 70 61 74 63 68 2d 72 65 71 75 65 73 74 20 64 62 patch-request db
2110: 73 74 72 75 63 74 20 63 6d 64 20 72 75 6e 2d 69 struct cmd run-i
2120: 64 20 70 61 72 61 6d 73 29 0a 20 20 28 69 66 20 d params). (if
2130: 28 61 6e 64 20 28 6e 6f 74 20 2a 6e 6f 2d 73 79 (and (not *no-sy
2140: 6e 63 2d 64 62 2a 29 0a 09 20 20 20 28 6d 65 6d nc-db*).. (mem
2150: 62 65 72 20 63 6d 64 20 27 28 64 62 3a 6e 6f 2d ber cmd '(db:no-
2160: 73 79 6e 63 2d 73 65 74 20 64 62 3a 6e 6f 2d 73 sync-set db:no-s
2170: 79 6e 63 2d 67 65 74 2f 64 65 66 61 75 6c 74 20 ync-get/default
2180: 64 62 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 20 db:no-sync-del!
2190: 64 62 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c db:no-sync-get-l
21a0: 6f 63 6b 20 29 29 29 0a 20 20 20 20 20 20 28 64 ock ))). (d
21b0: 62 3a 6f 70 65 6e 2d 6e 6f 2d 73 79 6e 63 2d 64 b:open-no-sync-d
21c0: 62 29 29 0a 20 20 28 63 61 73 65 20 63 6d 64 0a b)). (case cmd.
21d0: 20 20 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==========
21e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2200: 3d 3d 3d 3d 3d 0a 20 20 20 20 3b 3b 20 52 45 41 =====. ;; REA
2210: 44 2f 57 52 49 54 45 20 51 55 45 52 49 45 53 0a D/WRITE QUERIES.
2220: 20 20 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==========
2230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2250: 3d 3d 3d 3d 3d 0a 0a 20 20 20 20 28 28 67 65 74 =====.. ((get
2260: 2d 6b 65 79 73 2d 77 72 69 74 65 29 20 20 20 20 -keys-write)
2270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2280: 20 20 20 20 28 64 62 3a 67 65 74 2d 6b 65 79 73 (db:get-keys
2290: 20 64 62 73 74 72 75 63 74 29 29 20 3b 3b 20 66 dbstruct)) ;; f
22a0: 6f 72 63 65 20 61 20 64 75 6d 6d 79 20 22 77 72 orce a dummy "wr
22b0: 69 74 65 22 20 71 75 65 72 79 20 74 6f 20 66 6f ite" query to fo
22c0: 72 63 65 20 73 65 72 76 65 72 3b 20 66 6f 72 20 rce server; for
22d0: 64 65 62 75 67 20 69 6e 20 2d 72 65 70 6c 0a 20 debug in -repl.
22e0: 20 20 20 0a 20 20 20 20 3b 3b 20 53 45 52 56 45 . ;; SERVE
22f0: 52 53 0a 20 20 20 20 28 28 73 74 61 72 74 2d 73 RS. ((start-s
2300: 65 72 76 65 72 29 20 20 20 20 20 20 20 20 20 20 erver)
2310: 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 (apply
2320: 20 73 65 72 76 65 72 3a 6b 69 6e 64 2d 72 75 6e server:kind-run
2330: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 params)). ((
2340: 6b 69 6c 6c 2d 73 65 72 76 65 72 29 20 20 20 20 kill-server)
2350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2360: 20 28 73 65 74 21 20 2a 73 65 72 76 65 72 2d 72 (set! *server-r
2370: 75 6e 2a 20 23 66 29 29 0a 0a 20 20 20 20 3b 3b un* #f)).. ;;
2380: 20 54 45 53 54 53 0a 0a 20 20 20 20 3b 3b 28 28 TESTS.. ;;((
2390: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
23a0: 74 61 74 75 73 2d 62 79 2d 69 64 29 20 20 20 20 tatus-by-id)
23b0: 20 28 61 70 70 6c 79 20 6d 74 3a 74 65 73 74 2d (apply mt:test-
23c0: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
23d0: 2d 62 79 2d 69 64 20 64 62 73 74 72 75 63 74 20 -by-id dbstruct
23e0: 70 61 72 61 6d 73 29 29 0a 20 20 20 20 3b 3b 42 params)). ;;B
23f0: 42 20 2d 20 63 6f 6d 6d 65 6e 74 65 64 20 6f 75 B - commented ou
2400: 74 20 61 62 6f 76 65 20 62 65 63 61 75 73 65 20 t above because
2410: 69 74 20 77 61 73 20 63 61 6c 6c 69 6e 67 20 62 it was calling b
2420: 65 6c 6f 77 2c 20 65 76 65 6e 74 75 61 6c 6c 79 elow, eventually
2430: 2c 20 69 6e 63 6f 72 72 65 63 74 6c 79 20 28 64 , incorrectly (d
2440: 62 73 74 72 75 63 74 20 70 61 73 73 65 64 20 74 bstruct passed t
2450: 6f 20 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 o mt:test-set-st
2460: 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 ate-status-by-id
2470: 2c 20 77 68 69 63 68 20 70 72 65 76 69 6f 73 6c , which previosl
2480: 79 20 64 69 64 20 6d 6f 72 65 2c 20 62 75 74 20 y did more, but
2490: 6e 6f 77 20 6f 6e 6c 79 20 70 61 73 73 65 73 20 now only passes
24a0: 74 68 72 75 20 74 6f 20 64 62 3a 73 65 74 2d 73 thru to db:set-s
24b0: 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d tate-status-and-
24c0: 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 2e 0a 20 roll-up-items..
24d0: 20 20 20 28 28 74 65 73 74 2d 73 65 74 2d 73 74 ((test-set-st
24e0: 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 ate-status-by-id
24f0: 29 0a 0a 20 20 20 20 20 3b 3b 20 28 64 65 66 69 ).. ;; (defi
2500: 6e 65 20 28 64 62 3a 73 65 74 2d 73 74 61 74 65 ne (db:set-state
2510: 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c -status-and-roll
2520: 2d 75 70 2d 69 74 65 6d 73 20 64 62 73 74 72 75 -up-items dbstru
2530: 63 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e ct run-id test-n
2540: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 73 74 ame item-path st
2550: 61 74 65 20 73 74 61 74 75 73 20 63 6f 6d 6d 65 ate status comme
2560: 6e 74 29 0a 20 20 20 20 20 28 64 62 3a 73 65 74 nt). (db:set
2570: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e -state-status-an
2580: 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 0a d-roll-up-items.
2590: 20 20 20 20 20 20 64 62 73 74 72 75 63 74 0a 20 dbstruct.
25a0: 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 70 (list-ref p
25b0: 61 72 61 6d 73 20 30 29 20 3b 20 72 75 6e 2d 69 arams 0) ; run-i
25c0: 64 0a 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 d. (list-re
25d0: 66 20 70 61 72 61 6d 73 20 31 29 20 3b 20 74 65 f params 1) ; te
25e0: 73 74 2d 6e 61 6d 65 0a 20 20 20 20 20 20 23 66 st-name. #f
25f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2600: 20 20 3b 20 69 74 65 6d 2d 70 61 74 68 0a 20 20 ; item-path.
2610: 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 70 61 (list-ref pa
2620: 72 61 6d 73 20 32 29 20 3b 20 73 74 61 74 65 0a rams 2) ; state.
2630: 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 20 (list-ref
2640: 70 61 72 61 6d 73 20 33 29 20 3b 20 73 74 61 74 params 3) ; stat
2650: 75 73 0a 20 20 20 20 20 20 28 6c 69 73 74 2d 72 us. (list-r
2660: 65 66 20 70 61 72 61 6d 73 20 34 29 20 3b 20 63 ef params 4) ; c
2670: 6f 6d 6d 65 6e 74 0a 20 20 20 20 20 20 29 29 0a omment. )).
2680: 20 20 20 20 0a 20 20 20 20 28 28 64 65 6c 65 74 . ((delet
2690: 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 29 20 e-test-records)
26a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 (app
26b0: 6c 79 20 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 ly db:delete-tes
26c0: 74 2d 72 65 63 6f 72 64 73 20 64 62 73 74 72 75 t-records dbstru
26d0: 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ct params)).
26e0: 28 28 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c ((delete-old-del
26f0: 65 74 65 64 2d 74 65 73 74 2d 72 65 63 6f 72 64 eted-test-record
2700: 73 29 20 28 61 70 70 6c 79 20 64 62 3a 64 65 6c s) (apply db:del
2710: 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 2d ete-old-deleted-
2720: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 73 test-records dbs
2730: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 truct params)).
2740: 20 20 20 28 28 74 65 73 74 2d 73 65 74 2d 73 74 ((test-set-st
2750: 61 74 65 2d 73 74 61 74 75 73 29 20 20 20 20 20 ate-status)
2760: 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a (apply db:
2770: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
2780: 74 61 74 75 73 20 64 62 73 74 72 75 63 74 20 70 tatus dbstruct p
2790: 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 74 65 arams)). ((te
27a0: 73 74 2d 73 65 74 2d 74 6f 70 2d 70 72 6f 63 65 st-set-top-proce
27b0: 73 73 2d 70 69 64 29 20 20 20 20 20 20 20 20 28 ss-pid) (
27c0: 61 70 70 6c 79 20 64 62 3a 74 65 73 74 2d 73 65 apply db:test-se
27d0: 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 t-top-process-pi
27e0: 64 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d d dbstruct param
27f0: 73 29 29 0a 20 20 20 20 28 28 73 65 74 2d 73 74 s)). ((set-st
2800: 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 ate-status-and-r
2810: 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 29 20 28 61 oll-up-items) (a
2820: 70 70 6c 79 20 64 62 3a 73 65 74 2d 73 74 61 74 pply db:set-stat
2830: 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c e-status-and-rol
2840: 6c 2d 75 70 2d 69 74 65 6d 73 20 64 62 73 74 72 l-up-items dbstr
2850: 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 uct params)).
2860: 20 28 28 73 65 74 2d 73 74 61 74 65 2d 73 74 61 ((set-state-sta
2870: 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d tus-and-roll-up-
2880: 72 75 6e 29 20 28 61 70 70 6c 79 20 64 62 3a 73 run) (apply db:s
2890: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
28a0: 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 72 75 6e 20 and-roll-up-run
28b0: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
28c0: 29 20 0a 20 20 20 20 28 28 74 6f 70 2d 74 65 73 ) . ((top-tes
28d0: 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 6f 75 t-set-per-pf-cou
28e0: 6e 74 73 29 20 20 20 20 20 20 28 61 70 70 6c 79 nts) (apply
28f0: 20 64 62 3a 74 6f 70 2d 74 65 73 74 2d 73 65 74 db:top-test-set
2900: 2d 70 65 72 2d 70 66 2d 63 6f 75 6e 74 73 20 64 -per-pf-counts d
2910: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
2920: 0a 20 20 20 20 28 28 74 65 73 74 2d 73 65 74 2d . ((test-set-
2930: 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 archive-block-id
2940: 29 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 ) (apply d
2950: 62 3a 74 65 73 74 2d 73 65 74 2d 61 72 63 68 69 b:test-set-archi
2960: 76 65 2d 62 6c 6f 63 6b 2d 69 64 20 64 62 73 74 ve-block-id dbst
2970: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 0a 20 ruct params))..
2980: 20 20 20 3b 3b 20 52 55 4e 53 0a 20 20 20 20 28 ;; RUNS. (
2990: 28 72 65 67 69 73 74 65 72 2d 72 75 6e 29 20 20 (register-run)
29a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
29b0: 61 70 70 6c 79 20 64 62 3a 72 65 67 69 73 74 65 apply db:registe
29c0: 72 2d 72 75 6e 20 64 62 73 74 72 75 63 74 20 70 r-run dbstruct p
29d0: 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 73 65 arams)). ((se
29e0: 74 2d 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 t-tests-state-st
29f0: 61 74 75 73 29 20 20 20 20 20 20 20 28 61 70 70 atus) (app
2a00: 6c 79 20 64 62 3a 73 65 74 2d 74 65 73 74 73 2d ly db:set-tests-
2a10: 73 74 61 74 65 2d 73 74 61 74 75 73 20 64 62 73 state-status dbs
2a20: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 truct params)).
2a30: 20 20 20 28 28 64 65 6c 65 74 65 2d 72 75 6e 29 ((delete-run)
2a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a50: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 64 65 6c (apply db:del
2a60: 65 74 65 2d 72 75 6e 20 64 62 73 74 72 75 63 74 ete-run dbstruct
2a70: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 params)). ((
2a80: 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 29 lock/unlock-run)
2a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
2aa0: 70 70 6c 79 20 64 62 3a 6c 6f 63 6b 2f 75 6e 6c pply db:lock/unl
2ab0: 6f 63 6b 2d 72 75 6e 20 64 62 73 74 72 75 63 74 ock-run dbstruct
2ac0: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 params)). ((
2ad0: 75 70 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 update-run-event
2ae0: 5f 74 69 6d 65 29 20 20 20 20 20 20 20 20 28 61 _time) (a
2af0: 70 70 6c 79 20 64 62 3a 75 70 64 61 74 65 2d 72 pply db:update-r
2b00: 75 6e 2d 65 76 65 6e 74 5f 74 69 6d 65 20 64 62 un-event_time db
2b10: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
2b20: 20 20 20 20 28 28 75 70 64 61 74 65 2d 72 75 6e ((update-run
2b30: 2d 73 74 61 74 73 29 20 20 20 20 20 20 20 20 20 -stats)
2b40: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 75 70 (apply db:up
2b50: 64 61 74 65 2d 72 75 6e 2d 73 74 61 74 73 20 64 date-run-stats d
2b60: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
2b70: 0a 20 20 20 20 28 28 73 65 74 2d 76 61 72 29 20 . ((set-var)
2b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b90: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 73 (apply db:s
2ba0: 65 74 2d 76 61 72 20 64 62 73 74 72 75 63 74 20 et-var dbstruct
2bb0: 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 69 params)). ((i
2bc0: 6e 63 2d 76 61 72 29 20 20 20 20 20 20 20 20 20 nc-var)
2bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 (ap
2be0: 70 6c 79 20 64 62 3a 69 6e 63 2d 76 61 72 20 64 ply db:inc-var d
2bf0: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
2c00: 0a 20 20 20 20 28 28 64 65 63 2d 76 61 72 29 20 . ((dec-var)
2c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c20: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 64 (apply db:d
2c30: 65 63 2d 76 61 72 20 64 62 73 74 72 75 63 74 20 ec-var dbstruct
2c40: 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 64 params)). ((d
2c50: 65 6c 2d 76 61 72 29 20 20 20 20 20 20 20 20 20 el-var)
2c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 (ap
2c70: 70 6c 79 20 64 62 3a 64 65 6c 2d 76 61 72 20 64 ply db:del-var d
2c80: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
2c90: 0a 20 20 20 20 28 28 61 64 64 2d 76 61 72 29 20 . ((add-var)
2ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cb0: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 61 (apply db:a
2cc0: 64 64 2d 76 61 72 20 64 62 73 74 72 75 63 74 20 dd-var dbstruct
2cd0: 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 3b 3b params)).. ;;
2ce0: 20 53 54 45 50 53 0a 20 20 20 20 28 28 74 65 73 STEPS. ((tes
2cf0: 74 73 74 65 70 2d 73 65 74 2d 73 74 61 74 75 73 tstep-set-status
2d00: 21 29 20 20 20 20 20 20 20 20 20 28 61 70 70 6c !) (appl
2d10: 79 20 64 62 3a 74 65 73 74 73 74 65 70 2d 73 65 y db:teststep-se
2d20: 74 2d 73 74 61 74 75 73 21 20 64 62 73 74 72 75 t-status! dbstru
2d30: 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ct params)).
2d40: 28 28 64 65 6c 65 74 65 2d 73 74 65 70 73 2d 66 ((delete-steps-f
2d50: 6f 72 2d 74 65 73 74 21 29 20 20 20 20 20 20 20 or-test!)
2d60: 28 61 70 70 6c 79 20 64 62 3a 64 65 6c 65 74 65 (apply db:delete
2d70: 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 21 -steps-for-test!
2d80: 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 dbstruct params
2d90: 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 54 )). . ;; T
2da0: 45 53 54 20 44 41 54 41 0a 20 20 20 20 28 28 74 EST DATA. ((t
2db0: 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 70 29 est-data-rollup)
2dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 (ap
2dd0: 70 6c 79 20 64 62 3a 74 65 73 74 2d 64 61 74 61 ply db:test-data
2de0: 2d 72 6f 6c 6c 75 70 20 64 62 73 74 72 75 63 74 -rollup dbstruct
2df0: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 params)). ((
2e00: 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 29 20 csv->test-data)
2e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
2e20: 70 70 6c 79 20 64 62 3a 63 73 76 2d 3e 74 65 73 pply db:csv->tes
2e30: 74 2d 64 61 74 61 20 64 62 73 74 72 75 63 74 20 t-data dbstruct
2e40: 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 3b 3b params)).. ;;
2e50: 20 4d 49 53 43 0a 20 20 20 20 28 28 73 79 6e 63 MISC. ((sync
2e60: 2d 69 6e 6d 65 6d 2d 3e 64 62 29 20 20 20 20 20 -inmem->db)
2e70: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
2e80: 28 72 75 6e 2d 69 64 20 28 63 61 72 20 70 61 72 (run-id (car par
2e90: 61 6d 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 ams))).
2ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 (db
2ec0: 3a 73 79 6e 63 2d 74 6f 75 63 68 65 64 20 64 62 :sync-touched db
2ed0: 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 64 62 struct run-id db
2ee0: 3a 69 6e 69 74 69 61 6c 69 7a 65 2d 6d 61 69 6e :initialize-main
2ef0: 2d 64 62 20 66 6f 72 63 65 2d 73 79 6e 63 3a 20 -db force-sync:
2f00: 23 74 29 29 29 0a 20 20 20 20 28 28 6d 61 72 6b #t))). ((mark
2f10: 2d 69 6e 63 6f 6d 70 6c 65 74 65 29 20 20 20 20 -incomplete)
2f20: 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 (apply
2f30: 20 64 62 3a 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 db:find-and-mar
2f40: 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 64 62 73 k-incomplete dbs
2f50: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 truct params)).
2f60: 20 20 20 28 28 63 72 65 61 74 65 2d 61 6c 6c 2d ((create-all-
2f70: 74 72 69 67 67 65 72 73 29 20 20 20 20 20 20 20 triggers)
2f80: 20 20 20 28 64 62 3a 63 72 65 61 74 65 2d 61 6c (db:create-al
2f90: 6c 2d 74 72 69 67 67 65 72 73 20 64 62 73 74 72 l-triggers dbstr
2fa0: 75 63 74 29 29 0a 20 20 20 20 28 28 64 72 6f 70 uct)). ((drop
2fb0: 2d 61 6c 6c 2d 74 72 69 67 67 65 72 73 29 20 20 -all-triggers)
2fc0: 20 20 20 20 20 20 20 20 20 20 28 64 62 3a 64 72 (db:dr
2fd0: 6f 70 2d 61 6c 6c 2d 74 72 69 67 67 65 72 73 20 op-all-triggers
2fe0: 64 62 73 74 72 75 63 74 29 29 20 0a 0a 20 20 20 dbstruct)) ..
2ff0: 20 3b 3b 20 54 45 53 54 4d 45 54 41 0a 20 20 20 ;; TESTMETA.
3000: 20 28 28 74 65 73 74 6d 65 74 61 2d 61 64 64 2d ((testmeta-add-
3010: 72 65 63 6f 72 64 29 20 20 20 20 20 20 20 28 61 record) (a
3020: 70 70 6c 79 20 64 62 3a 74 65 73 74 6d 65 74 61 pply db:testmeta
3030: 2d 61 64 64 2d 72 65 63 6f 72 64 20 64 62 73 74 -add-record dbst
3040: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
3050: 20 20 28 28 74 65 73 74 6d 65 74 61 2d 75 70 64 ((testmeta-upd
3060: 61 74 65 2d 66 69 65 6c 64 29 20 20 20 20 20 28 ate-field) (
3070: 61 70 70 6c 79 20 64 62 3a 74 65 73 74 6d 65 74 apply db:testmet
3080: 61 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 20 64 a-update-field d
3090: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
30a0: 0a 20 20 20 20 28 28 67 65 74 2d 74 65 73 74 73 . ((get-tests
30b0: 2d 74 61 67 73 29 20 20 20 20 20 20 20 20 20 20 -tags)
30c0: 20 20 28 64 62 3a 67 65 74 2d 74 65 73 74 73 2d (db:get-tests-
30d0: 74 61 67 73 20 64 62 73 74 72 75 63 74 29 29 0a tags dbstruct)).
30e0: 0a 20 20 20 20 3b 3b 20 54 41 53 4b 53 0a 20 20 . ;; TASKS.
30f0: 20 20 28 28 74 61 73 6b 73 2d 61 64 64 29 20 20 ((tasks-add)
3100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3110: 61 70 70 6c 79 20 74 61 73 6b 73 3a 61 64 64 20 apply tasks:add
3120: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
3130: 29 20 20 20 0a 20 20 20 20 28 28 74 61 73 6b 73 ) . ((tasks
3140: 2d 73 65 74 2d 73 74 61 74 65 2d 67 69 76 65 6e -set-state-given
3150: 2d 70 61 72 61 6d 2d 6b 65 79 29 20 28 61 70 70 -param-key) (app
3160: 6c 79 20 74 61 73 6b 73 3a 73 65 74 2d 73 74 61 ly tasks:set-sta
3170: 74 65 2d 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b te-given-param-k
3180: 65 79 20 64 62 73 74 72 75 63 74 20 70 61 72 61 ey dbstruct para
3190: 6d 73 29 29 0a 20 20 20 20 28 28 74 61 73 6b 73 ms)). ((tasks
31a0: 2d 67 65 74 2d 6c 61 73 74 29 20 20 20 20 20 20 -get-last)
31b0: 20 20 20 20 20 20 28 61 70 70 6c 79 20 74 61 73 (apply tas
31c0: 6b 73 3a 67 65 74 2d 6c 61 73 74 20 64 62 73 74 ks:get-last dbst
31d0: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 0a 20 ruct params))..
31e0: 20 20 20 3b 3b 20 4e 4f 20 53 59 4e 43 20 44 42 ;; NO SYNC DB
31f0: 0a 20 20 20 20 28 28 6e 6f 2d 73 79 6e 63 2d 73 . ((no-sync-s
3200: 65 74 29 20 20 20 20 20 20 20 20 20 20 20 20 20 et)
3210: 20 20 28 61 70 70 6c 79 20 64 62 3a 6e 6f 2d 73 (apply db:no-s
3220: 79 6e 63 2d 73 65 74 20 20 20 20 20 20 20 20 20 ync-set
3230: 2a 6e 6f 2d 73 79 6e 63 2d 64 62 2a 20 70 61 72 *no-sync-db* par
3240: 61 6d 73 29 29 0a 20 20 20 20 28 28 6e 6f 2d 73 ams)). ((no-s
3250: 79 6e 63 2d 67 65 74 2f 64 65 66 61 75 6c 74 29 ync-get/default)
3260: 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 (apply db
3270: 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f 64 65 66 :no-sync-get/def
3280: 61 75 6c 74 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 ault *no-sync-db
3290: 2a 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 * params)). (
32a0: 28 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 29 20 20 (no-sync-del!)
32b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 (app
32c0: 6c 79 20 64 62 3a 6e 6f 2d 73 79 6e 63 2d 64 65 ly db:no-sync-de
32d0: 6c 21 20 20 20 20 20 20 20 20 2a 6e 6f 2d 73 79 l! *no-sy
32e0: 6e 63 2d 64 62 2a 20 70 61 72 61 6d 73 29 29 0a nc-db* params)).
32f0: 20 20 20 20 28 28 6e 6f 2d 73 79 6e 63 2d 67 65 ((no-sync-ge
3300: 74 2d 6c 6f 63 6b 29 20 20 20 20 20 20 20 20 20 t-lock)
3310: 20 28 61 70 70 6c 79 20 64 62 3a 6e 6f 2d 73 79 (apply db:no-sy
3320: 6e 63 2d 67 65 74 2d 6c 6f 63 6b 20 20 20 20 2a nc-get-lock *
3330: 6e 6f 2d 73 79 6e 63 2d 64 62 2a 20 70 61 72 61 no-sync-db* para
3340: 6d 73 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b ms)). . ;;
3350: 20 41 52 43 48 49 56 45 53 0a 20 20 20 20 3b 3b ARCHIVES. ;;
3360: 20 28 28 61 72 63 68 69 76 65 2d 67 65 74 2d 61 ((archive-get-a
3370: 6c 6c 6f 63 61 74 69 6f 6e 73 29 20 20 20 0a 20 llocations) .
3380: 20 20 20 28 28 61 72 63 68 69 76 65 2d 72 65 67 ((archive-reg
3390: 69 73 74 65 72 2d 64 69 73 6b 29 20 20 20 20 20 ister-disk)
33a0: 28 61 70 70 6c 79 20 64 62 3a 61 72 63 68 69 76 (apply db:archiv
33b0: 65 2d 72 65 67 69 73 74 65 72 2d 64 69 73 6b 20 e-register-disk
33c0: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
33d0: 29 0a 20 20 20 20 28 28 61 72 63 68 69 76 65 2d ). ((archive-
33e0: 72 65 67 69 73 74 65 72 2d 62 6c 6f 63 6b 2d 6e register-block-n
33f0: 61 6d 65 29 28 61 70 70 6c 79 20 64 62 3a 61 72 ame)(apply db:ar
3400: 63 68 69 76 65 2d 72 65 67 69 73 74 65 72 2d 62 chive-register-b
3410: 6c 6f 63 6b 2d 6e 61 6d 65 20 64 62 73 74 72 75 lock-name dbstru
3420: 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ct params)).
3430: 3b 3b 20 28 28 61 72 63 68 69 76 65 2d 61 6c 6c ;; ((archive-all
3440: 6f 63 61 74 65 2d 74 65 73 74 73 75 69 74 65 2f ocate-testsuite/
3450: 61 72 65 61 2d 74 6f 2d 62 6c 6f 63 6b 29 28 61 area-to-block)(a
3460: 70 70 6c 79 20 64 62 3a 61 72 63 68 69 76 65 2d pply db:archive-
3470: 61 6c 6c 6f 63 61 74 65 2d 74 65 73 74 73 75 69 allocate-testsui
3480: 74 65 2f 61 72 65 61 2d 74 6f 2d 62 6c 6f 63 6b te/area-to-block
3490: 20 64 62 73 74 72 75 63 74 20 62 6c 6f 63 6b 2d dbstruct block-
34a0: 69 64 20 74 65 73 74 73 75 69 74 65 2d 6e 61 6d id testsuite-nam
34b0: 65 20 61 72 65 61 6b 65 79 29 29 0a 0a 20 20 20 e areakey))..
34c0: 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;=============
34d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 3b 3b =========. ;;
3510: 20 52 45 41 44 20 4f 4e 4c 59 20 51 55 45 52 49 READ ONLY QUERI
3520: 45 53 0a 20 20 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d ES. ;;=======
3530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
3570: 0a 20 20 20 20 3b 3b 20 4b 45 59 53 0a 20 20 20 . ;; KEYS.
3580: 20 28 28 67 65 74 2d 6b 65 79 2d 76 61 6c 2d 70 ((get-key-val-p
3590: 61 69 72 73 29 20 20 20 20 20 20 20 20 20 20 20 airs)
35a0: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 (apply db:ge
35b0: 74 2d 6b 65 79 2d 76 61 6c 2d 70 61 69 72 73 20 t-key-val-pairs
35c0: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
35d0: 29 0a 20 20 20 20 28 28 67 65 74 2d 6b 65 79 73 ). ((get-keys
35e0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
35f0: 20 20 20 20 20 20 20 20 20 28 64 62 3a 67 65 74 (db:get
3600: 2d 6b 65 79 73 20 64 62 73 74 72 75 63 74 29 29 -keys dbstruct))
3610: 0a 20 20 20 20 28 28 67 65 74 2d 6b 65 79 2d 76 . ((get-key-v
3620: 61 6c 73 29 20 20 20 20 20 20 20 20 20 20 20 20 als)
3630: 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 (apply d
3640: 62 3a 67 65 74 2d 6b 65 79 2d 76 61 6c 73 20 64 b:get-key-vals d
3650: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
3660: 0a 20 20 20 20 28 28 67 65 74 2d 74 61 72 67 65 . ((get-targe
3670: 74 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t)
3680: 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 (apply d
3690: 62 3a 67 65 74 2d 74 61 72 67 65 74 20 64 62 73 b:get-target dbs
36a0: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 truct params)).
36b0: 20 20 20 28 28 67 65 74 2d 74 61 72 67 65 74 73 ((get-targets
36c0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
36d0: 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d 74 61 (db:get-ta
36e0: 72 67 65 74 73 20 64 62 73 74 72 75 63 74 29 29 rgets dbstruct))
36f0: 0a 0a 20 20 20 20 3b 3b 20 41 52 43 48 49 56 45 .. ;; ARCHIVE
3700: 53 0a 20 20 20 20 28 28 74 65 73 74 2d 67 65 74 S. ((test-get
3710: 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 -archive-block-i
3720: 6e 66 6f 29 20 20 20 20 20 28 61 70 70 6c 79 20 nfo) (apply
3730: 64 62 3a 74 65 73 74 2d 67 65 74 2d 61 72 63 68 db:test-get-arch
3740: 69 76 65 2d 62 6c 6f 63 6b 2d 69 6e 66 6f 20 64 ive-block-info d
3750: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
3760: 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 54 45 53 . . ;; TES
3770: 54 53 0a 20 20 20 20 28 28 74 65 73 74 2d 74 6f TS. ((test-to
3780: 70 6c 65 76 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 plevel-num-items
3790: 29 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 ) (apply
37a0: 20 64 62 3a 74 65 73 74 2d 74 6f 70 6c 65 76 65 db:test-topleve
37b0: 6c 2d 6e 75 6d 2d 69 74 65 6d 73 20 64 62 73 74 l-num-items dbst
37c0: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
37d0: 20 20 28 28 67 65 74 2d 74 65 73 74 2d 69 6e 66 ((get-test-inf
37e0: 6f 2d 62 79 2d 69 64 29 09 20 20 20 20 20 20 20 o-by-id).
37f0: 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 74 65 (apply db:get-te
3800: 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 64 62 st-info-by-id db
3810: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
3820: 20 20 20 20 28 28 67 65 74 2d 74 65 73 74 2d 73 ((get-test-s
3830: 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 tate-status-by-i
3840: 64 29 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 d) (apply db
3850: 3a 67 65 74 2d 74 65 73 74 2d 73 74 61 74 65 2d :get-test-state-
3860: 73 74 61 74 75 73 2d 62 79 2d 69 64 20 64 62 73 status-by-id dbs
3870: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 truct params)).
3880: 20 20 20 28 28 74 65 73 74 2d 67 65 74 2d 72 75 ((test-get-ru
3890: 6e 64 69 72 2d 66 72 6f 6d 2d 74 65 73 74 2d 69 ndir-from-test-i
38a0: 64 29 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a d) (apply db:
38b0: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 2d test-get-rundir-
38c0: 66 72 6f 6d 2d 74 65 73 74 2d 69 64 20 64 62 73 from-test-id dbs
38d0: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 truct params)).
38e0: 20 20 20 28 28 67 65 74 2d 63 6f 75 6e 74 2d 74 ((get-count-t
38f0: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 ests-running-for
3900: 2d 74 65 73 74 6e 61 6d 65 29 20 28 61 70 70 6c -testname) (appl
3910: 79 20 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 y db:get-count-t
3920: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 ests-running-for
3930: 2d 74 65 73 74 6e 61 6d 65 20 64 62 73 74 72 75 -testname dbstru
3940: 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ct params)).
3950: 28 28 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 ((get-count-test
3960: 73 2d 72 75 6e 6e 69 6e 67 29 20 20 20 20 20 20 s-running)
3970: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 (apply db:get
3980: 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e -count-tests-run
3990: 6e 69 6e 67 20 64 62 73 74 72 75 63 74 20 70 61 ning dbstruct pa
39a0: 72 61 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 rams)). ((get
39b0: 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e -count-tests-run
39c0: 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 ning-in-jobgroup
39d0: 29 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d ) (apply db:get-
39e0: 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e count-tests-runn
39f0: 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 ing-in-jobgroup
3a00: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
3a10: 29 0a 20 20 20 20 3b 3b 20 28 28 64 65 6c 65 74 ). ;; ((delet
3a20: 65 2d 74 65 73 74 2d 73 74 65 70 2d 72 65 63 6f e-test-step-reco
3a30: 72 64 73 29 20 20 20 20 20 20 20 20 28 61 70 70 rds) (app
3a40: 6c 79 20 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 ly db:delete-tes
3a50: 74 2d 73 74 65 70 2d 72 65 63 6f 72 64 73 20 64 t-step-records d
3a60: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
3a70: 0a 20 20 20 20 3b 3b 20 28 28 67 65 74 2d 70 72 . ;; ((get-pr
3a80: 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d evious-test-run-
3a90: 72 65 63 6f 72 64 29 20 20 20 20 28 61 70 70 6c record) (appl
3aa0: 79 20 64 62 3a 67 65 74 2d 70 72 65 76 69 6f 75 y db:get-previou
3ab0: 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 s-test-run-recor
3ac0: 64 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d d dbstruct param
3ad0: 73 29 29 0a 20 20 20 20 28 28 67 65 74 2d 6d 61 s)). ((get-ma
3ae0: 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 2d tching-previous-
3af0: 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 73 test-run-records
3b00: 29 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 6d )(apply db:get-m
3b10: 61 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 atching-previous
3b20: 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
3b30: 73 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d s dbstruct param
3b40: 73 29 29 0a 20 20 20 20 28 28 74 65 73 74 2d 67 s)). ((test-g
3b50: 65 74 2d 6c 6f 67 66 69 6c 65 2d 69 6e 66 6f 29 et-logfile-info)
3b60: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c (appl
3b70: 79 20 64 62 3a 74 65 73 74 2d 67 65 74 2d 6c 6f y db:test-get-lo
3b80: 67 66 69 6c 65 2d 69 6e 66 6f 20 64 62 73 74 72 gfile-info dbstr
3b90: 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 uct params)).
3ba0: 20 28 28 74 65 73 74 2d 67 65 74 2d 72 65 63 6f ((test-get-reco
3bb0: 72 64 73 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 69 rds-for-index-fi
3bc0: 6c 65 29 20 20 28 61 70 70 6c 79 20 64 62 3a 74 le) (apply db:t
3bd0: 65 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d est-get-records-
3be0: 66 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 20 64 for-index-file d
3bf0: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
3c00: 0a 20 20 20 20 28 28 67 65 74 2d 74 65 73 74 69 . ((get-testi
3c10: 6e 66 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 73 nfo-state-status
3c20: 29 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 ) (apply d
3c30: 62 3a 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 b:get-testinfo-s
3c40: 74 61 74 65 2d 73 74 61 74 75 73 20 64 62 73 74 tate-status dbst
3c50: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
3c60: 20 20 28 28 74 65 73 74 2d 67 65 74 2d 74 6f 70 ((test-get-top
3c70: 2d 70 72 6f 63 65 73 73 2d 70 69 64 29 20 20 20 -process-pid)
3c80: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 74 (apply db:t
3c90: 65 73 74 2d 67 65 74 2d 74 6f 70 2d 70 72 6f 63 est-get-top-proc
3ca0: 65 73 73 2d 70 69 64 20 64 62 73 74 72 75 63 74 ess-pid dbstruct
3cb0: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 params)). ((
3cc0: 74 65 73 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d test-get-paths-m
3cd0: 61 74 63 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 atching-keynames
3ce0: 2d 74 61 72 67 65 74 2d 6e 65 77 29 20 28 61 70 -target-new) (ap
3cf0: 70 6c 79 20 64 62 3a 74 65 73 74 2d 67 65 74 2d ply db:test-get-
3d00: 70 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 2d 6b paths-matching-k
3d10: 65 79 6e 61 6d 65 73 2d 74 61 72 67 65 74 2d 6e eynames-target-n
3d20: 65 77 20 64 62 73 74 72 75 63 74 20 70 61 72 61 ew dbstruct para
3d30: 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 2d 70 ms)). ((get-p
3d40: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 rereqs-not-met)
3d50: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 (app
3d60: 6c 79 20 64 62 3a 67 65 74 2d 70 72 65 72 65 71 ly db:get-prereq
3d70: 73 2d 6e 6f 74 2d 6d 65 74 20 64 62 73 74 72 75 s-not-met dbstru
3d80: 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ct params)).
3d90: 28 28 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 ((get-count-test
3da0: 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 72 75 s-running-for-ru
3db0: 6e 2d 69 64 29 20 28 61 70 70 6c 79 20 64 62 3a n-id) (apply db:
3dc0: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
3dd0: 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d running-for-run-
3de0: 69 64 20 64 62 73 74 72 75 63 74 20 70 61 72 61 id dbstruct para
3df0: 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 2d 6e ms)). ((get-n
3e00: 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 2d 63 6e 74 ot-completed-cnt
3e10: 29 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 ) (app
3e20: 6c 79 20 64 62 3a 67 65 74 2d 6e 6f 74 2d 63 6f ly db:get-not-co
3e30: 6d 70 6c 65 74 65 64 2d 63 6e 74 20 20 64 62 73 mpleted-cnt dbs
3e40: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 20 0a truct params)) .
3e50: 20 20 20 20 3b 3b 20 28 28 73 79 6e 63 68 61 73 ;; ((synchas
3e60: 68 2d 67 65 74 29 20 20 20 20 20 20 20 20 20 20 h-get)
3e70: 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 (apply
3e80: 20 73 79 6e 63 68 61 73 68 3a 73 65 72 76 65 72 synchash:server
3e90: 2d 67 65 74 20 64 62 73 74 72 75 63 74 20 70 61 -get dbstruct pa
3ea0: 72 61 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 rams)). ((get
3eb0: 2d 72 61 77 2d 72 75 6e 2d 73 74 61 74 73 29 20 -raw-run-stats)
3ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
3ed0: 70 70 6c 79 20 64 62 3a 67 65 74 2d 72 61 77 2d pply db:get-raw-
3ee0: 72 75 6e 2d 73 74 61 74 73 20 64 62 73 74 72 75 run-stats dbstru
3ef0: 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 ct params)).
3f00: 28 28 67 65 74 2d 74 65 73 74 2d 74 69 6d 65 73 ((get-test-times
3f10: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
3f20: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 (apply db:get
3f30: 2d 74 65 73 74 2d 74 69 6d 65 73 20 64 62 73 74 -test-times dbst
3f40: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 0a 20 ruct params))..
3f50: 20 20 20 3b 3b 20 52 55 4e 53 0a 20 20 20 20 28 ;; RUNS. (
3f60: 28 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 29 20 20 (get-run-info)
3f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3f80: 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 72 75 6e apply db:get-run
3f90: 2d 69 6e 66 6f 20 64 62 73 74 72 75 63 74 20 70 -info dbstruct p
3fa0: 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 67 65 arams)). ((ge
3fb0: 74 2d 72 75 6e 2d 73 74 61 74 75 73 29 20 20 20 t-run-status)
3fc0: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 (app
3fd0: 6c 79 20 64 62 3a 67 65 74 2d 72 75 6e 2d 73 74 ly db:get-run-st
3fe0: 61 74 75 73 20 64 62 73 74 72 75 63 74 20 70 61 atus dbstruct pa
3ff0: 72 61 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 rams)). ((get
4000: 2d 72 75 6e 2d 73 74 61 74 65 29 20 20 20 20 20 -run-state)
4010: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c (appl
4020: 79 20 64 62 3a 67 65 74 2d 72 75 6e 2d 73 74 61 y db:get-run-sta
4030: 74 65 20 64 62 73 74 72 75 63 74 20 70 61 72 61 te dbstruct para
4040: 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 2d 72 ms)). ((get-r
4050: 75 6e 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 un-state-status)
4060: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply
4070: 64 62 3a 67 65 74 2d 72 75 6e 2d 73 74 61 74 65 db:get-run-state
4080: 2d 73 74 61 74 75 73 20 64 62 73 74 72 75 63 74 -status dbstruct
4090: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 params)). ((
40a0: 73 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 29 20 set-run-status)
40b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
40c0: 70 70 6c 79 20 64 62 3a 73 65 74 2d 72 75 6e 2d pply db:set-run-
40d0: 73 74 61 74 75 73 20 64 62 73 74 72 75 63 74 20 status dbstruct
40e0: 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 73 params)). ((s
40f0: 65 74 2d 72 75 6e 2d 73 74 61 74 65 2d 73 74 61 et-run-state-sta
4100: 74 75 73 29 20 20 09 09 09 20 28 61 70 70 6c 79 tus) ... (apply
4110: 20 64 62 3a 73 65 74 2d 72 75 6e 2d 73 74 61 74 db:set-run-stat
4120: 65 2d 73 74 61 74 75 73 20 64 62 73 74 72 75 63 e-status dbstruc
4130: 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 t params)). (
4140: 28 75 70 64 61 74 65 2d 74 65 73 64 61 74 61 2d (update-tesdata-
4150: 6f 6e 2d 72 65 70 69 6c 63 61 74 65 2d 64 62 29 on-repilcate-db)
4160: 20 28 61 70 70 6c 79 20 64 62 3a 75 70 64 61 74 (apply db:updat
4170: 65 2d 74 65 73 64 61 74 61 2d 6f 6e 2d 72 65 70 e-tesdata-on-rep
4180: 69 6c 63 61 74 65 2d 64 62 20 20 64 62 73 74 72 ilcate-db dbstr
4190: 75 63 74 20 70 61 72 61 6d 73 29 29 20 0a 20 20 uct params)) .
41a0: 20 20 28 28 67 65 74 2d 74 65 73 74 73 2d 66 6f ((get-tests-fo
41b0: 72 2d 72 75 6e 29 20 20 20 20 20 20 20 20 20 20 r-run)
41c0: 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d (apply db:get-
41d0: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 tests-for-run db
41e0: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
41f0: 20 20 20 20 28 28 67 65 74 2d 74 65 73 74 73 2d ((get-tests-
4200: 66 6f 72 2d 72 75 6e 2d 73 74 61 74 65 2d 73 74 for-run-state-st
4210: 61 74 75 73 29 20 28 61 70 70 6c 79 20 64 62 3a atus) (apply db:
4220: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
4230: 6e 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 64 n-state-status d
4240: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
4250: 0a 20 20 20 20 28 28 67 65 74 2d 74 65 73 74 2d . ((get-test-
4260: 69 64 29 20 20 20 20 20 20 20 20 20 20 20 20 20 id)
4270: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 (apply db:g
4280: 65 74 2d 74 65 73 74 2d 69 64 20 64 62 73 74 72 et-test-id dbstr
4290: 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 uct params)).
42a0: 20 28 28 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 ((get-tests-for
42b0: 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 29 20 20 20 -run-mindata)
42c0: 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 74 (apply db:get-t
42d0: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e ests-for-run-min
42e0: 64 61 74 61 20 64 62 73 74 72 75 63 74 20 70 61 data dbstruct pa
42f0: 72 61 6d 73 29 29 0a 20 20 20 20 3b 3b 20 28 28 rams)). ;; ((
4300: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
4310: 6e 73 2d 6d 69 6e 64 61 74 61 29 20 20 20 28 61 ns-mindata) (a
4320: 70 70 6c 79 20 64 62 3a 67 65 74 2d 74 65 73 74 pply db:get-test
4330: 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 6e 64 61 s-for-runs-minda
4340: 74 61 20 64 62 73 74 72 75 63 74 20 70 61 72 61 ta dbstruct para
4350: 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 2d 72 ms)). ((get-r
4360: 75 6e 73 29 20 20 20 20 20 20 20 20 20 20 20 20 uns)
4370: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply
4380: 64 62 3a 67 65 74 2d 72 75 6e 73 20 64 62 73 74 db:get-runs dbst
4390: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
43a0: 20 20 28 28 73 69 6d 70 6c 65 2d 67 65 74 2d 72 ((simple-get-r
43b0: 75 6e 73 29 20 20 20 20 20 20 20 20 20 20 20 20 uns)
43c0: 20 20 28 61 70 70 6c 79 20 64 62 3a 73 69 6d 70 (apply db:simp
43d0: 6c 65 2d 67 65 74 2d 72 75 6e 73 20 64 62 73 74 le-get-runs dbst
43e0: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
43f0: 20 20 28 28 67 65 74 2d 6e 75 6d 2d 72 75 6e 73 ((get-num-runs
4400: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
4410: 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d (apply db:get-
4420: 6e 75 6d 2d 72 75 6e 73 20 64 62 73 74 72 75 63 num-runs dbstruc
4430: 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 t params)). (
4440: 28 67 65 74 2d 72 75 6e 73 2d 63 6e 74 2d 62 79 (get-runs-cnt-by
4450: 2d 70 61 74 74 29 20 20 20 20 20 20 20 20 20 28 -patt) (
4460: 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 72 75 6e apply db:get-run
4470: 73 2d 63 6e 74 2d 62 79 2d 70 61 74 74 20 64 62 s-cnt-by-patt db
4480: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
4490: 20 20 20 20 28 28 67 65 74 2d 61 6c 6c 2d 72 75 ((get-all-ru
44a0: 6e 2d 69 64 73 29 20 20 20 20 20 20 20 20 20 20 n-ids)
44b0: 20 20 20 20 28 64 62 3a 67 65 74 2d 61 6c 6c 2d (db:get-all-
44c0: 72 75 6e 2d 69 64 73 20 64 62 73 74 72 75 63 74 run-ids dbstruct
44d0: 29 29 0a 20 20 20 20 28 28 67 65 74 2d 70 72 65 )). ((get-pre
44e0: 76 2d 72 75 6e 2d 69 64 73 29 20 20 20 20 20 20 v-run-ids)
44f0: 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 (apply db
4500: 3a 67 65 74 2d 70 72 65 76 2d 72 75 6e 2d 69 64 :get-prev-run-id
4510: 73 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d s dbstruct param
4520: 73 29 29 0a 20 20 20 20 28 28 67 65 74 2d 72 75 s)). ((get-ru
4530: 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 2d 74 n-ids-matching-t
4540: 61 72 67 65 74 29 20 20 28 61 70 70 6c 79 20 64 arget) (apply d
4550: 62 3a 67 65 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 b:get-run-ids-ma
4560: 74 63 68 69 6e 67 2d 74 61 72 67 65 74 20 64 62 tching-target db
4570: 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a struct params)).
4580: 20 20 20 20 28 28 67 65 74 2d 72 75 6e 73 2d 62 ((get-runs-b
4590: 79 2d 70 61 74 74 29 20 20 20 20 20 20 20 20 20 y-patt)
45a0: 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 (apply db:ge
45b0: 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 t-runs-by-patt d
45c0: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
45d0: 0a 20 20 20 20 28 28 67 65 74 2d 72 75 6e 2d 6e . ((get-run-n
45e0: 61 6d 65 2d 66 72 6f 6d 2d 69 64 29 20 20 20 20 ame-from-id)
45f0: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 (apply db:g
4600: 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d et-run-name-from
4610: 2d 69 64 20 64 62 73 74 72 75 63 74 20 70 61 72 -id dbstruct par
4620: 61 6d 73 29 29 0a 20 20 20 20 28 28 67 65 74 2d ams)). ((get-
4630: 6d 61 69 6e 2d 72 75 6e 2d 73 74 61 74 73 29 20 main-run-stats)
4640: 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 (apply
4650: 20 64 62 3a 67 65 74 2d 6d 61 69 6e 2d 72 75 6e db:get-main-run
4660: 2d 73 74 61 74 73 20 64 62 73 74 72 75 63 74 20 -stats dbstruct
4670: 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 67 params)). ((g
4680: 65 74 2d 76 61 72 29 20 20 20 20 20 20 20 20 20 et-var)
4690: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 (ap
46a0: 70 6c 79 20 64 62 3a 67 65 74 2d 76 61 72 20 64 ply db:get-var d
46b0: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
46c0: 0a 20 20 20 20 28 28 67 65 74 2d 72 75 6e 2d 73 . ((get-run-s
46d0: 74 61 74 73 29 20 20 20 20 20 20 20 20 20 20 20 tats)
46e0: 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 (apply db:g
46f0: 65 74 2d 72 75 6e 2d 73 74 61 74 73 20 64 62 73 et-run-stats dbs
4700: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 truct params)).
4710: 20 20 20 28 28 67 65 74 2d 72 75 6e 2d 74 69 6d ((get-run-tim
4720: 65 73 29 20 20 20 20 20 20 20 20 20 20 20 20 20 es)
4730: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 (apply db:get
4740: 2d 72 75 6e 2d 74 69 6d 65 73 20 64 62 73 74 72 -run-times dbstr
4750: 75 63 74 20 70 61 72 61 6d 73 29 29 20 0a 0a 20 uct params)) ..
4760: 20 20 20 3b 3b 20 53 54 45 50 53 0a 20 20 20 20 ;; STEPS.
4770: 28 28 67 65 74 2d 73 74 65 70 73 2d 64 61 74 61 ((get-steps-data
4780: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
4790: 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 73 74 (apply db:get-st
47a0: 65 70 73 2d 64 61 74 61 20 64 62 73 74 72 75 63 eps-data dbstruc
47b0: 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 t params)). (
47c0: 28 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 (get-steps-for-t
47d0: 65 73 74 29 20 20 20 20 20 20 20 20 20 20 20 28 est) (
47e0: 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 73 74 65 apply db:get-ste
47f0: 70 73 2d 66 6f 72 2d 74 65 73 74 20 64 62 73 74 ps-for-test dbst
4800: 72 75 63 74 20 70 61 72 61 6d 73 29 29 0a 20 20 ruct params)).
4810: 20 20 28 28 67 65 74 2d 73 74 65 70 73 2d 69 6e ((get-steps-in
4820: 66 6f 2d 62 79 2d 69 64 29 20 20 20 20 20 20 20 fo-by-id)
4830: 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d (apply db:get-
4840: 73 74 65 70 73 2d 69 6e 66 6f 2d 62 79 2d 69 64 steps-info-by-id
4850: 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 dbstruct params
4860: 29 29 0a 0a 20 20 20 20 3b 3b 20 54 45 53 54 20 )).. ;; TEST
4870: 44 41 54 41 0a 20 20 20 20 28 28 72 65 61 64 2d DATA. ((read-
4880: 74 65 73 74 2d 64 61 74 61 29 20 20 20 20 20 20 test-data)
4890: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply
48a0: 64 62 3a 72 65 61 64 2d 74 65 73 74 2d 64 61 74 db:read-test-dat
48b0: 61 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d a dbstruct param
48c0: 73 29 29 0a 20 20 20 20 28 28 72 65 61 64 2d 74 s)). ((read-t
48d0: 65 73 74 2d 64 61 74 61 2d 76 61 72 70 61 74 74 est-data-varpatt
48e0: 29 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 ) (apply d
48f0: 62 3a 72 65 61 64 2d 74 65 73 74 2d 64 61 74 61 b:read-test-data
4900: 2d 76 61 72 70 61 74 74 20 64 62 73 74 72 75 63 -varpatt dbstruc
4910: 74 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 t params)). (
4920: 28 67 65 74 2d 64 61 74 61 2d 69 6e 66 6f 2d 62 (get-data-info-b
4930: 79 2d 69 64 29 20 20 20 20 20 20 20 20 20 20 28 y-id) (
4940: 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 64 61 74 apply db:get-dat
4950: 61 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 64 62 73 a-info-by-id dbs
4960: 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 20 0a truct params)) .
4970: 0a 20 20 20 20 3b 3b 20 4d 49 53 43 0a 20 20 20 . ;; MISC.
4980: 20 28 28 67 65 74 2d 6c 61 74 65 73 74 2d 68 6f ((get-latest-ho
4990: 73 74 2d 6c 6f 61 64 29 20 20 20 20 20 20 20 20 st-load)
49a0: 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 6c (apply db:get-l
49b0: 61 74 65 73 74 2d 68 6f 73 74 2d 6c 6f 61 64 20 atest-host-load
49c0: 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 dbstruct params)
49d0: 29 0a 20 20 20 20 28 28 68 61 76 65 2d 69 6e 63 ). ((have-inc
49e0: 6f 6d 70 6c 65 74 65 73 3f 29 20 20 20 20 20 20 ompletes?)
49f0: 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 62 3a (apply db:
4a00: 68 61 76 65 2d 69 6e 63 6f 6d 70 6c 65 74 65 73 have-incompletes
4a10: 3f 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d ? dbstruct param
4a20: 73 29 29 0a 20 20 20 20 28 28 6c 6f 67 69 6e 29 s)). ((login)
4a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a40: 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 64 (apply d
4a50: 62 3a 6c 6f 67 69 6e 20 64 62 73 74 72 75 63 74 b:login dbstruct
4a60: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 28 params)). ((
4a70: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 29 20 20 20 general-call)
4a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
4a90: 65 74 20 28 28 73 74 6d 74 6e 61 6d 65 20 20 20 et ((stmtname
4aa0: 28 63 61 72 20 70 61 72 61 6d 73 29 29 0a 20 20 (car params)).
4ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ad0: 20 20 20 20 20 20 20 20 28 72 75 6e 2d 69 64 20 (run-id
4ae0: 20 20 20 20 28 63 61 64 72 20 70 61 72 61 6d 73 (cadr params
4af0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
4b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 (re
4b20: 61 6c 70 61 72 61 6d 73 20 28 63 64 64 72 20 70 alparams (cddr p
4b30: 61 72 61 6d 73 29 29 29 0a 20 20 20 20 20 20 20 arams))).
4b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4b60: 64 62 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 db:general-call
4b70: 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 dbstruct run-id
4b80: 73 74 6d 74 6e 61 6d 65 20 72 65 61 6c 70 61 72 stmtname realpar
4b90: 61 6d 73 29 29 29 0a 20 20 20 20 28 28 73 64 62 ams))). ((sdb
4ba0: 2d 71 72 79 29 20 20 20 20 20 20 20 20 20 20 20 -qry)
4bb0: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c (appl
4bc0: 79 20 73 64 62 3a 71 72 79 20 70 61 72 61 6d 73 y sdb:qry params
4bd0: 29 29 0a 20 20 20 20 28 28 70 69 6e 67 29 20 20 )). ((ping)
4be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4bf0: 20 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d (current-
4c00: 70 72 6f 63 65 73 73 2d 69 64 29 29 0a 20 20 20 process-id)).
4c10: 20 28 28 67 65 74 2d 63 68 61 6e 67 65 64 2d 72 ((get-changed-r
4c20: 65 63 6f 72 64 2d 69 64 73 29 20 20 20 20 20 20 ecord-ids)
4c30: 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d 63 (apply db:get-c
4c40: 68 61 6e 67 65 64 2d 72 65 63 6f 72 64 2d 69 64 hanged-record-id
4c50: 73 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d s dbstruct param
4c60: 73 29 29 0a 20 20 20 20 28 28 67 65 74 2d 72 75 s)). ((get-ru
4c70: 6e 2d 72 65 63 6f 72 64 2d 69 64 73 29 20 09 20 n-record-ids) .
4c80: 20 20 28 61 70 70 6c 79 20 64 62 3a 67 65 74 2d (apply db:get-
4c90: 72 75 6e 2d 72 65 63 6f 72 64 2d 69 64 73 20 64 run-record-ids d
4ca0: 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 29 29 bstruct params))
4cb0: 09 0a 20 20 20 20 3b 3b 20 54 45 53 54 4d 45 54 .. ;; TESTMET
4cc0: 41 0a 20 20 20 20 28 28 74 65 73 74 6d 65 74 61 A. ((testmeta
4cd0: 2d 67 65 74 2d 72 65 63 6f 72 64 29 20 20 20 20 -get-record)
4ce0: 20 20 20 28 61 70 70 6c 79 20 64 62 3a 74 65 73 (apply db:tes
4cf0: 74 6d 65 74 61 2d 67 65 74 2d 72 65 63 6f 72 64 tmeta-get-record
4d00: 20 64 62 73 74 72 75 63 74 20 70 61 72 61 6d 73 dbstruct params
4d10: 29 29 0a 0a 20 20 20 20 3b 3b 20 54 41 53 4b 53 )).. ;; TASKS
4d20: 20 0a 20 20 20 20 28 28 66 69 6e 64 2d 74 61 73 . ((find-tas
4d30: 6b 2d 71 75 65 75 65 2d 72 65 63 6f 72 64 73 29 k-queue-records)
4d40: 20 20 20 28 61 70 70 6c 79 20 74 61 73 6b 73 3a (apply tasks:
4d50: 66 69 6e 64 2d 74 61 73 6b 2d 71 75 65 75 65 2d find-task-queue-
4d60: 72 65 63 6f 72 64 73 20 64 62 73 74 72 75 63 74 records dbstruct
4d70: 20 70 61 72 61 6d 73 29 29 0a 20 20 20 20 28 65 params)). (e
4d80: 6c 73 65 0a 20 20 20 20 20 28 64 65 62 75 67 3a lse. (debug:
4d90: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
4da0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f -log-port* "ERRO
4db0: 52 3a 20 62 61 64 20 61 70 69 20 63 61 6c 6c 20 R: bad api call
4dc0: 22 20 63 6d 64 29 0a 20 20 20 20 20 28 63 6f 6e " cmd). (con
4dd0: 63 20 22 45 52 52 4f 52 3a 20 42 41 44 20 61 70 c "ERROR: BAD ap
4de0: 69 20 63 61 6c 6c 20 22 20 63 6d 64 29 29 29 29 i call " cmd))))
4df0: 0a 0a 3b 3b 20 68 74 74 70 2d 73 65 72 76 65 72 ..;; http-server
4e00: 20 20 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 0a send-response.
4e10: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
4e20: 20 20 20 61 70 69 3a 70 72 6f 63 65 73 73 2d 72 api:process-r
4e30: 65 71 75 65 73 74 0a 3b 3b 20 20 20 20 20 20 20 equest.;;
4e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 64 62 3a db:
4e50: 2a 0a 3b 3b 0a 3b 3b 20 4e 42 2f 2f 20 52 75 6e *.;;.;; NB// Run
4e60: 73 20 6f 6e 20 74 68 65 20 73 65 72 76 65 72 20 s on the server
4e70: 61 73 20 70 61 72 74 20 6f 66 20 74 68 65 20 73 as part of the s
4e80: 65 72 76 65 72 20 6c 6f 6f 70 0a 3b 3b 0a 28 64 erver loop.;;.(d
4e90: 65 66 69 6e 65 20 28 61 70 69 3a 70 72 6f 63 65 efine (api:proce
4ea0: 73 73 2d 72 65 71 75 65 73 74 20 64 62 73 74 72 ss-request dbstr
4eb0: 75 63 74 20 24 29 20 3b 3b 20 74 68 65 20 24 20 uct $) ;; the $
4ec0: 69 73 20 74 68 65 20 72 65 71 75 65 73 74 20 76 is the request v
4ed0: 61 72 73 20 70 72 6f 63 0a 20 20 28 64 65 62 75 ars proc. (debu
4ee0: 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 g:print 4 *defau
4ef0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 65 lt-log-port* "se
4f00: 72 76 65 72 2d 69 64 3a 22 20 20 2a 73 65 72 76 rver-id:" *serv
4f10: 65 72 2d 69 64 2a 29 0a 20 20 28 6c 65 74 2a 20 er-id*). (let*
4f20: 28 28 63 6d 64 20 20 20 20 20 28 24 20 27 63 6d ((cmd ($ 'cm
4f30: 64 29 29 0a 09 20 28 70 61 72 61 6d 73 6a 20 28 d)).. (paramsj (
4f40: 24 20 27 70 61 72 61 6d 73 29 29 0a 20 20 20 20 $ 'params)).
4f50: 20 20 20 20 20 28 6b 65 79 20 20 20 20 20 28 24 (key ($
4f60: 20 27 6b 65 79 29 29 20 20 20 0a 09 20 28 70 61 'key)) .. (pa
4f70: 72 61 6d 73 20 20 28 64 62 3a 73 74 72 69 6e 67 rams (db:string
4f80: 2d 3e 6f 62 6a 20 70 61 72 61 6d 73 6a 20 74 72 ->obj paramsj tr
4f90: 61 6e 73 70 6f 72 74 3a 20 27 68 74 74 70 29 29 ansport: 'http))
4fa0: 29 20 3b 3b 20 69 6e 63 6f 6d 69 6e 67 20 64 61 ) ;; incoming da
4fb0: 74 61 20 66 72 6f 6d 20 74 68 65 20 50 4f 53 54 ta from the POST
4fc0: 20 28 6f 72 20 69 73 20 69 74 20 61 20 47 45 54 (or is it a GET
4fd0: 3f 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 ?). (debug:pr
4fe0: 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c int 4 *default-l
4ff0: 6f 67 2d 70 6f 72 74 2a 20 22 63 6d 64 3a 22 20 og-port* "cmd:"
5000: 63 6d 64 20 22 20 77 69 74 68 20 70 61 72 61 6d cmd " with param
5010: 73 20 22 20 70 61 72 61 6d 73 20 22 6b 65 79 20 s " params "key
5020: 22 20 6b 65 79 29 0a 20 20 20 20 28 69 66 20 28 " key). (if (
5030: 65 71 75 61 6c 3f 20 6b 65 79 20 2a 73 65 72 76 equal? key *serv
5040: 65 72 2d 69 64 2a 29 0a 20 20 20 20 20 20 28 62 er-id*). (b
5050: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 28 73 65 egin. (se
5060: 74 21 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 2d t! *api-process-
5070: 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a 20 28 request-count* (
5080: 2b 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 2d 72 + *api-process-r
5090: 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a 20 31 29 equest-count* 1)
50a0: 29 0a 20 09 28 6c 65 74 2a 20 28 28 72 65 73 64 ). .(let* ((resd
50b0: 61 74 20 20 28 61 70 69 3a 65 78 65 63 75 74 65 at (api:execute
50c0: 2d 72 65 71 75 65 73 74 73 20 64 62 73 74 72 75 -requests dbstru
50d0: 63 74 20 28 76 65 63 74 6f 72 20 63 6d 64 20 70 ct (vector cmd p
50e0: 61 72 61 6d 73 29 29 29 20 3b 3b 20 70 72 6f 63 arams))) ;; proc
50f0: 65 73 73 20 74 68 65 20 72 65 71 75 65 73 74 2c ess the request,
5100: 20 72 65 73 64 61 74 20 3d 20 23 28 20 66 6c 61 resdat = #( fla
5110: 67 20 72 65 73 75 6c 74 20 29 0a 09 20 20 20 20 g result )..
5120: 20 20 20 28 73 75 63 63 65 73 73 20 28 76 65 63 (success (vec
5130: 74 6f 72 2d 72 65 66 20 72 65 73 64 61 74 20 30 tor-ref resdat 0
5140: 29 29 0a 09 20 20 20 20 20 20 20 28 72 65 73 20 )).. (res
5150: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
5160: 72 65 73 64 61 74 20 31 29 29 29 20 3b 3b 20 28 resdat 1))) ;; (
5170: 76 65 63 74 6f 72 20 66 6c 61 67 20 70 61 79 6c vector flag payl
5180: 6f 61 64 29 2c 20 67 65 74 20 74 68 65 20 70 61 oad), get the pa
5190: 79 6c 6f 61 64 2c 20 69 67 6e 6f 72 65 20 74 68 yload, ignore th
51a0: 65 20 66 6c 61 67 20 28 77 68 79 3f 29 0a 09 20 e flag (why?)..
51b0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
51c0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
51d0: 74 2a 20 22 72 65 73 3a 22 20 72 65 73 29 0a 09 t* "res:" res)..
51e0: 20 20 28 69 66 20 28 6e 6f 74 20 73 75 63 63 65 (if (not succe
51f0: 73 73 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 ss).. (debu
5200: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
5210: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 lt-log-port* "ER
5220: 52 4f 52 3a 20 73 75 63 63 65 73 73 20 66 6c 61 ROR: success fla
5230: 67 20 69 73 20 23 66 20 66 6f 72 20 22 20 63 6d g is #f for " cm
5240: 64 20 22 20 77 69 74 68 20 70 61 72 61 6d 73 20 d " with params
5250: 22 20 70 61 72 61 6d 73 29 29 0a 09 20 20 28 69 " params)).. (i
5260: 66 20 28 3e 20 2a 61 70 69 2d 70 72 6f 63 65 73 f (> *api-proces
5270: 73 2d 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a s-request-count*
5280: 20 2a 6d 61 78 2d 61 70 69 2d 70 72 6f 63 65 73 *max-api-proces
5290: 73 2d 72 65 71 75 65 73 74 73 2a 29 0a 09 20 20 s-requests*)..
52a0: 20 20 20 20 28 73 65 74 21 20 2a 6d 61 78 2d 61 (set! *max-a
52b0: 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 pi-process-reque
52c0: 73 74 73 2a 20 2a 61 70 69 2d 70 72 6f 63 65 73 sts* *api-proces
52d0: 73 2d 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a s-request-count*
52e0: 29 29 0a 09 20 20 28 73 65 74 21 20 2a 61 70 69 )).. (set! *api
52f0: 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 -process-request
5300: 2d 63 6f 75 6e 74 2a 20 28 2d 20 2a 61 70 69 2d -count* (- *api-
5310: 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 2d process-request-
5320: 63 6f 75 6e 74 2a 20 31 29 29 0a 09 20 20 3b 3b count* 1)).. ;;
5330: 20 54 68 69 73 20 63 61 6e 20 62 65 20 68 65 72 This can be her
5340: 65 20 62 75 74 20 6e 65 65 64 73 20 63 6f 6e 74 e but needs cont
5350: 72 6f 6c 73 20 74 6f 20 65 6e 73 75 72 65 20 69 rols to ensure i
5360: 74 20 64 6f 65 73 6e 27 74 20 72 75 6e 20 6d 6f t doesn't run mo
5370: 72 65 20 74 68 61 6e 20 65 76 65 72 79 20 34 20 re than every 4
5380: 73 65 63 6f 6e 64 73 0a 09 20 20 3b 3b 20 28 72 seconds.. ;; (r
5390: 6d 74 3a 64 61 74 2d 3e 6a 73 6f 6e 2d 73 74 72 mt:dat->json-str
53a0: 0a 09 20 20 3b 3b 20 20 28 69 66 20 28 6f 72 20 .. ;; (if (or
53b0: 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 20 (string? res)..
53c0: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 28 6c 69 ;; (li
53d0: 73 74 3f 20 20 20 72 65 73 29 0a 09 20 20 3b 3b st? res).. ;;
53e0: 20 20 20 20 20 20 20 20 20 20 28 6e 75 6d 62 65 (numbe
53f0: 72 3f 20 72 65 73 29 0a 09 20 20 3b 3b 20 20 20 r? res).. ;;
5400: 20 20 20 20 20 20 20 28 62 6f 6f 6c 65 61 6e 3f (boolean?
5410: 20 72 65 73 29 29 0a 09 20 20 3b 3b 20 20 20 20 res)).. ;;
5420: 20 20 72 65 73 20 0a 09 20 20 3b 3b 20 20 20 20 res .. ;;
5430: 20 20 28 6c 69 73 74 20 22 45 52 52 4f 52 2c 20 (list "ERROR,
5440: 6e 6f 74 20 73 74 72 69 6e 67 2c 20 6c 69 73 74 not string, list
5450: 2c 20 6e 75 6d 62 65 72 20 6f 72 20 62 6f 6f 6c , number or bool
5460: 65 61 6e 22 20 31 20 63 6d 64 20 70 61 72 61 6d ean" 1 cmd param
5470: 73 20 72 65 73 29 29 29 29 29 0a 09 20 20 28 64 s res))))).. (d
5480: 62 3a 6f 62 6a 2d 3e 73 74 72 69 6e 67 20 72 65 b:obj->string re
5490: 73 20 74 72 61 6e 73 70 6f 72 74 3a 20 27 68 74 s transport: 'ht
54a0: 74 70 29 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 tp)))..(begin..
54b0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
54c0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
54d0: 74 2a 20 20 20 22 53 65 72 76 65 72 20 72 65 66 t* "Server ref
54e0: 75 73 65 64 20 74 6f 20 70 72 6f 63 65 73 73 20 used to process
54f0: 72 65 71 75 65 73 74 2e 20 53 65 72 76 65 72 20 request. Server
5500: 69 64 20 6d 69 73 6d 61 74 63 68 2e 20 72 65 63 id mismatch. rec
5510: 69 76 65 64 20 22 20 6b 65 79 20 22 20 65 78 70 ived " key " exp
5520: 65 63 74 65 64 3a 20 20 22 20 2a 73 65 72 76 65 ected: " *serve
5530: 72 2d 69 64 2a 20 22 2e 5c 6e 4f 74 68 65 72 20 r-id* ".\nOther
5540: 61 72 67 75 6d 65 6e 74 73 20 72 65 63 69 76 65 arguments recive
5550: 64 3a 20 63 6d 64 3d 22 20 63 6d 64 20 22 20 70 d: cmd=" cmd " p
5560: 61 72 61 6d 73 20 3d 20 22 20 70 61 72 61 6d 73 arams = " params
5570: 29 20 0a 09 20 20 28 64 62 3a 6f 62 6a 2d 3e 73 ) .. (db:obj->s
5580: 74 72 69 6e 67 20 28 63 6f 6e 63 20 22 53 65 72 tring (conc "Ser
5590: 76 65 72 20 72 65 66 75 73 65 64 20 74 6f 20 70 ver refused to p
55a0: 72 6f 63 65 73 73 20 72 65 71 75 65 73 74 20 73 rocess request s
55b0: 65 72 76 65 72 2d 69 64 20 6d 69 73 6d 61 74 63 erver-id mismatc
55c0: 68 3a 20 22 20 6b 65 79 20 22 2c 20 22 20 2a 73 h: " key ", " *s
55d0: 65 72 76 65 72 2d 69 64 2a 29 20 74 72 61 6e 73 erver-id*) trans
55e0: 70 6f 72 74 3a 20 27 68 74 74 70 29 29 29 29 29 port: 'http)))))
55f0: 0a 0a ..