Artifact
95daefe19da4e29e77a3dfecef22a6a0f1b8bbc9:
0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 32 2c 20 4d 61 74 74 68 65 77 06-2012, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 28 72 65 71 75 PURPOSE...(requ
0150: 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 73 ire-extension (s
0160: 72 66 69 20 31 38 29 20 65 78 74 72 61 73 20 74 rfi 18) extras t
0170: 63 70 20 73 31 31 6e 29 0a 0a 28 75 73 65 20 73 cp s11n)..(use s
0180: 71 6c 69 74 65 33 20 73 72 66 69 2d 31 20 70 6f qlite3 srfi-1 po
0190: 73 69 78 20 72 65 67 65 78 20 72 65 67 65 78 2d six regex regex-
01a0: 63 61 73 65 20 73 72 66 69 2d 36 39 20 68 6f 73 case srfi-69 hos
01b0: 74 69 6e 66 6f 20 6d 64 35 20 6d 65 73 73 61 67 tinfo md5 messag
01c0: 65 2d 64 69 67 65 73 74 29 0a 28 69 6d 70 6f 72 e-digest).(impor
01d0: 74 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 t (prefix sqlite
01e0: 33 20 73 71 6c 69 74 65 33 3a 29 29 0a 0a 28 75 3 sqlite3:))..(u
01f0: 73 65 20 73 70 69 66 66 79 20 75 72 69 2d 63 6f se spiffy uri-co
0200: 6d 6d 6f 6e 20 69 6e 74 61 72 77 65 62 20 68 74 mmon intarweb ht
0210: 74 70 2d 63 6c 69 65 6e 74 20 73 70 69 66 66 79 tp-client spiffy
0220: 2d 72 65 71 75 65 73 74 2d 76 61 72 73 20 69 6e -request-vars in
0230: 74 61 72 77 65 62 20 73 70 69 66 66 79 2d 64 69 tarweb spiffy-di
0240: 72 65 63 74 6f 72 79 2d 6c 69 73 74 69 6e 67 29 rectory-listing)
0250: 0a 0a 3b 3b 20 43 6f 6e 66 69 67 75 72 61 74 69 ..;; Configurati
0260: 6f 6e 73 20 66 6f 72 20 73 65 72 76 65 72 0a 28 ons for server.(
0270: 74 63 70 2d 62 75 66 66 65 72 2d 73 69 7a 65 20 tcp-buffer-size
0280: 32 30 34 38 29 0a 28 6d 61 78 2d 63 6f 6e 6e 65 2048).(max-conne
0290: 63 74 69 6f 6e 73 20 32 30 34 38 29 20 0a 0a 28 ctions 2048) ..(
02a0: 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 68 74 declare (unit ht
02b0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 29 29 0a 0a tp-transport))..
02c0: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 (declare (uses c
02d0: 6f 6d 6d 6f 6e 29 29 0a 28 64 65 63 6c 61 72 65 ommon)).(declare
02e0: 20 28 75 73 65 73 20 64 62 29 29 0a 28 64 65 63 (uses db)).(dec
02f0: 6c 61 72 65 20 28 75 73 65 73 20 74 65 73 74 73 lare (uses tests
0300: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0310: 73 20 74 61 73 6b 73 29 29 20 3b 3b 20 74 61 73 s tasks)) ;; tas
0320: 6b 73 20 61 72 65 20 77 68 65 72 65 20 73 74 75 ks are where stu
0330: 66 66 20 69 73 20 6d 61 69 6e 74 61 69 6e 65 64 ff is maintained
0340: 20 61 62 6f 75 74 20 77 68 61 74 20 69 73 20 72 about what is r
0350: 75 6e 6e 69 6e 67 2e 0a 28 64 65 63 6c 61 72 65 unning..(declare
0360: 20 28 75 73 65 73 20 73 65 72 76 65 72 29 29 0a (uses server)).
0370: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 (declare (uses d
0380: 61 65 6d 6f 6e 29 29 0a 0a 28 69 6e 63 6c 75 64 aemon))..(includ
0390: 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 e "common_record
03a0: 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 s.scm").(include
03b0: 20 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 63 6d "db_records.scm
03c0: 22 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 ")..(define (htt
03d0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6d 61 6b 65 p-transport:make
03e0: 2d 73 65 72 76 65 72 2d 75 72 6c 20 68 6f 73 74 -server-url host
03f0: 70 6f 72 74 29 0a 20 20 28 69 66 20 28 6e 6f 74 port). (if (not
0400: 20 68 6f 73 74 70 6f 72 74 29 0a 20 20 20 20 20 hostport).
0410: 20 23 66 0a 20 20 20 20 20 20 28 63 6f 6e 63 20 #f. (conc
0420: 22 68 74 74 70 3a 2f 2f 22 20 28 63 61 72 20 68 "http://" (car h
0430: 6f 73 74 70 6f 72 74 29 20 22 3a 22 20 28 63 61 ostport) ":" (ca
0440: 64 72 20 68 6f 73 74 70 6f 72 74 29 29 29 29 0a dr hostport)))).
0450: 0a 28 64 65 66 69 6e 65 20 2a 73 65 72 76 65 72 .(define *server
0460: 2d 6c 6f 6f 70 2d 68 65 61 72 74 2d 62 65 61 74 -loop-heart-beat
0470: 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e * (current-secon
0480: 64 73 29 29 0a 28 64 65 66 69 6e 65 20 2a 68 65 ds)).(define *he
0490: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 20 28 artbeat-mutex* (
04a0: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 3b 3b make-mutex))..;;
04b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04f0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 20 ======.;; S E R
0500: 56 20 45 20 52 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d V E R.;;========
0510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
0550: 3b 3b 20 43 61 6c 6c 20 74 68 69 73 20 74 6f 20 ;; Call this to
0560: 73 74 61 72 74 20 74 68 65 20 61 63 74 75 61 6c start the actual
0570: 20 73 65 72 76 65 72 0a 3b 3b 0a 0a 28 64 65 66 server.;;..(def
0580: 69 6e 65 20 2a 64 62 3a 70 72 6f 63 65 73 73 2d ine *db:process-
0590: 71 75 65 75 65 2d 6d 75 74 65 78 2a 20 28 6d 61 queue-mutex* (ma
05a0: 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 28 64 65 66 ke-mutex))..(def
05b0: 69 6e 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d ine (server:get-
05c0: 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 65 best-guess-addre
05d0: 73 73 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 ss hostname). (
05e0: 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 0a 20 let ((res #f)).
05f0: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 (for-each .
0600: 20 20 20 28 6c 61 6d 62 64 61 20 28 61 64 72 29 (lambda (adr)
0610: 0a 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 . (if (not
0620: 20 28 65 71 3f 20 28 75 38 76 65 63 74 6f 72 2d (eq? (u8vector-
0630: 72 65 66 20 61 64 72 20 30 29 20 31 32 37 29 29 ref adr 0) 127))
0640: 0a 09 20 20 20 28 73 65 74 21 20 72 65 73 20 61 .. (set! res a
0650: 64 72 29 29 29 0a 20 20 20 20 20 28 76 65 63 74 dr))). (vect
0660: 6f 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 69 6e or->list (hostin
0670: 66 6f 2d 61 64 64 72 65 73 73 65 73 20 28 68 6f fo-addresses (ho
0680: 73 74 6e 61 6d 65 2d 3e 68 6f 73 74 69 6e 66 6f stname->hostinfo
0690: 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 0a 20 20 hostname)))).
06a0: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
06b0: 70 65 72 73 65 20 0a 20 20 20 20 20 28 6d 61 70 perse . (map
06c0: 20 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 0a number->string.
06d0: 09 20 20 28 75 38 76 65 63 74 6f 72 2d 3e 6c 69 . (u8vector->li
06e0: 73 74 0a 09 20 20 20 28 69 66 20 72 65 73 20 72 st.. (if res r
06f0: 65 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 69 70 es (hostname->ip
0700: 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 20 22 2e hostname)))) ".
0710: 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 ")))..(define (h
0720: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 ttp-transport:ru
0730: 6e 20 68 6f 73 74 6e 20 72 75 6e 2d 69 64 20 73 n hostn run-id s
0740: 65 72 76 65 72 2d 69 64 29 0a 20 20 28 64 65 62 erver-id). (deb
0750: 75 67 3a 70 72 69 6e 74 20 32 20 22 41 74 74 65 ug:print 2 "Atte
0760: 6d 70 74 69 6e 67 20 74 6f 20 73 74 61 72 74 20 mpting to start
0770: 74 68 65 20 73 65 72 76 65 72 20 2e 2e 2e 22 29 the server ...")
0780: 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 . (let* ((db
0790: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 20 3b #f) ;
07a0: 3b 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 64 ; (open-d
07b0: 62 29 29 20 3b 3b 20 77 65 20 64 6f 6e 27 74 20 b)) ;; we don't
07c0: 77 61 6e 74 20 74 68 65 20 73 65 72 76 65 72 20 want the server
07d0: 74 6f 20 62 65 20 6f 70 65 6e 69 6e 67 20 61 6e to be opening an
07e0: 64 20 63 6c 6f 73 69 6e 67 20 74 68 65 20 64 62 d closing the db
07f0: 20 75 6e 6e 65 63 65 73 61 72 69 6c 79 0a 09 20 unnecesarily..
0800: 28 68 6f 73 74 6e 61 6d 65 20 20 20 20 20 20 20 (hostname
0810: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
0820: 29 0a 09 20 28 69 70 61 64 64 72 73 74 72 20 20 ).. (ipaddrstr
0830: 20 20 20 20 20 28 6c 65 74 20 28 28 69 70 73 74 (let ((ipst
0840: 72 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 r (if (string=?
0850: 22 2d 22 20 68 6f 73 74 6e 29 0a 09 09 09 09 09 "-" hostn)......
0860: 20 20 20 3b 3b 20 28 73 74 72 69 6e 67 2d 69 6e ;; (string-in
0870: 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 6e tersperse (map n
0880: 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 75 umber->string (u
0890: 38 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 8vector->list (h
08a0: 6f 73 74 6e 61 6d 65 2d 3e 69 70 20 68 6f 73 74 ostname->ip host
08b0: 6e 61 6d 65 29 29 29 20 22 2e 22 29 0a 09 09 09 name))) ".")....
08c0: 09 09 20 20 20 28 73 65 72 76 65 72 3a 67 65 74 .. (server:get
08d0: 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 -best-guess-addr
08e0: 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 0a 09 09 ess hostname)...
08f0: 09 09 09 20 20 20 23 66 29 29 29 0a 09 09 09 20 ... #f)))....
0900: 20 20 20 28 69 66 20 69 70 73 74 72 20 69 70 73 (if ipstr ips
0910: 74 72 20 68 6f 73 74 6e 29 29 29 20 3b 3b 20 68 tr hostn))) ;; h
0920: 6f 73 74 6e 61 6d 65 29 29 29 20 0a 09 20 28 73 ostname))) .. (s
0930: 74 61 72 74 2d 70 6f 72 74 20 20 20 20 20 20 28 tart-port (
0940: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 open-run-close t
0950: 61 73 6b 73 3a 73 65 72 76 65 72 2d 67 65 74 2d asks:server-get-
0960: 6e 65 78 74 2d 70 6f 72 74 20 74 61 73 6b 73 3a next-port tasks:
0970: 6f 70 65 6e 2d 64 62 29 29 0a 09 20 28 6c 69 6e open-db)).. (lin
0980: 6b 2d 74 72 65 65 2d 70 61 74 68 20 20 28 63 6f k-tree-path (co
0990: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
09a0: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
09b0: 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 29 0a 20 "linktree"))).
09c0: 20 20 20 28 73 65 74 21 20 64 62 20 2a 69 6e 6d (set! db *inm
09d0: 65 6d 64 62 2a 29 0a 20 20 20 20 28 72 6f 6f 74 emdb*). (root
09e0: 2d 70 61 74 68 20 20 20 20 20 28 69 66 20 6c 69 -path (if li
09f0: 6e 6b 2d 74 72 65 65 2d 70 61 74 68 20 0a 09 09 nk-tree-path ...
0a00: 20 20 20 20 20 20 20 6c 69 6e 6b 2d 74 72 65 65 link-tree
0a10: 2d 70 61 74 68 0a 09 09 20 20 20 20 20 20 20 28 -path... (
0a20: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
0a30: 79 29 29 29 20 3b 3b 20 57 41 52 4e 49 4e 47 3a y))) ;; WARNING:
0a40: 20 53 45 43 55 52 49 54 59 20 48 4f 4c 45 2e 20 SECURITY HOLE.
0a50: 46 49 58 20 41 53 41 50 21 0a 20 20 20 20 28 68 FIX ASAP!. (h
0a60: 61 6e 64 6c 65 2d 64 69 72 65 63 74 6f 72 79 20 andle-directory
0a70: 73 70 69 66 66 79 2d 64 69 72 65 63 74 6f 72 79 spiffy-directory
0a80: 2d 6c 69 73 74 69 6e 67 29 0a 20 20 20 20 3b 3b -listing). ;;
0a90: 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a http-transport:
0aa0: 68 61 6e 64 6c 65 2d 64 69 72 65 63 74 6f 72 79 handle-directory
0ab0: 29 20 3b 3b 20 73 69 6d 70 6c 65 2d 64 69 72 65 ) ;; simple-dire
0ac0: 63 74 6f 72 79 2d 68 61 6e 64 6c 65 72 29 0a 20 ctory-handler).
0ad0: 20 20 20 3b 3b 20 53 65 74 75 70 20 74 68 65 20 ;; Setup the
0ae0: 77 65 62 20 73 65 72 76 65 72 20 61 6e 64 20 61 web server and a
0af0: 20 2f 63 74 72 6c 20 69 6e 74 65 72 66 61 63 65 /ctrl interface
0b00: 0a 20 20 20 20 3b 3b 0a 20 20 20 20 28 76 68 6f . ;;. (vho
0b10: 73 74 2d 6d 61 70 20 60 28 28 28 2a 20 61 6e 79 st-map `(((* any
0b20: 29 20 2e 20 2c 28 6c 61 6d 62 64 61 20 28 63 6f ) . ,(lambda (co
0b30: 6e 74 69 6e 75 65 29 0a 09 09 09 20 20 20 20 20 ntinue)....
0b40: 20 20 3b 3b 20 6f 70 65 6e 20 74 68 65 20 64 62 ;; open the db
0b50: 20 6f 6e 20 74 68 65 20 66 69 72 73 74 20 63 61 on the first ca
0b60: 6c 6c 20 0a 09 09 09 09 20 3b 3b 20 54 68 69 73 ll ..... ;; This
0b70: 20 69 73 20 77 65 72 65 20 77 65 20 73 65 74 20 is were we set
0b80: 75 70 20 74 68 65 20 64 61 74 61 62 61 73 65 20 up the database
0b90: 63 6f 6e 6e 65 63 74 69 6f 6e 73 0a 09 09 09 20 connections....
0ba0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 24 20 (let* (($
0bb0: 20 20 28 72 65 71 75 65 73 74 2d 76 61 72 73 20 (request-vars
0bc0: 73 6f 75 72 63 65 3a 20 27 62 6f 74 68 29 29 0a source: 'both)).
0bd0: 09 09 09 09 20 20 20 20 20 20 28 64 61 74 20 28 .... (dat (
0be0: 24 20 27 64 61 74 29 29 0a 09 09 09 09 20 20 20 $ 'dat)).....
0bf0: 20 20 20 28 72 65 73 20 23 66 29 29 0a 09 09 09 (res #f))....
0c00: 09 20 28 63 6f 6e 64 0a 09 09 09 09 20 20 28 28 . (cond..... ((
0c10: 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 equal? (uri-path
0c20: 20 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 (request-uri (c
0c30: 75 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 urrent-request))
0c40: 29 0a 09 09 09 09 09 20 20 20 27 28 2f 20 22 61 )...... '(/ "a
0c50: 70 69 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 pi"))..... (se
0c60: 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 nd-response body
0c70: 3a 20 20 20 20 28 61 70 69 3a 70 72 6f 63 65 73 : (api:proces
0c80: 73 2d 72 65 71 75 65 73 74 20 64 62 20 24 29 20 s-request db $)
0c90: 3b 3b 20 74 68 65 20 24 20 69 73 20 74 68 65 20 ;; the $ is the
0ca0: 72 65 71 75 65 73 74 20 76 61 72 73 20 70 72 6f request vars pro
0cb0: 63 0a 09 09 09 09 09 09 20 20 68 65 61 64 65 72 c....... header
0cc0: 73 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 s: '((content-ty
0cd0: 70 65 20 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 pe text/plain)))
0ce0: 0a 09 09 09 09 20 20 20 28 6d 75 74 65 78 2d 6c ..... (mutex-l
0cf0: 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d ock! *heartbeat-
0d00: 6d 75 74 65 78 2a 29 0a 09 09 09 09 20 20 20 28 mutex*)..... (
0d10: 73 65 74 21 20 2a 6c 61 73 74 2d 64 62 2d 61 63 set! *last-db-ac
0d20: 63 65 73 73 2a 20 28 63 75 72 72 65 6e 74 2d 73 cess* (current-s
0d30: 65 63 6f 6e 64 73 29 29 0a 09 09 09 09 20 20 20 econds)).....
0d40: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
0d50: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
0d60: 29 29 0a 09 09 09 09 20 20 3b 3b 20 54 68 69 73 ))..... ;; This
0d70: 20 69 73 20 74 68 65 20 2f 63 74 72 6c 20 70 61 is the /ctrl pa
0d80: 74 68 20 77 68 65 72 65 20 64 61 74 61 20 69 73 th where data is
0d90: 20 68 61 6e 64 65 64 20 74 6f 20 74 68 65 20 73 handed to the s
0da0: 65 72 76 65 72 20 61 6e 64 0a 09 09 09 09 20 20 erver and.....
0db0: 3b 3b 20 72 65 73 70 6f 6e 73 65 73 20 0a 09 09 ;; responses ...
0dc0: 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 .. ((equal? (ur
0dd0: 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 2d i-path (request-
0de0: 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 uri (current-req
0df0: 75 65 73 74 29 29 29 0a 09 09 09 09 09 20 20 20 uest)))......
0e00: 27 28 2f 20 22 63 74 72 6c 22 29 29 0a 09 09 09 '(/ "ctrl"))....
0e10: 09 20 20 20 28 6c 65 74 2a 20 28 28 70 61 63 6b . (let* ((pack
0e20: 65 74 20 28 64 62 3a 73 74 72 69 6e 67 2d 3e 6f et (db:string->o
0e30: 62 6a 20 64 61 74 29 29 0a 09 09 09 09 09 20 20 bj dat))......
0e40: 28 71 74 79 70 65 20 20 28 63 64 62 3a 70 61 63 (qtype (cdb:pac
0e50: 6b 65 74 2d 67 65 74 2d 71 74 79 70 65 20 70 61 ket-get-qtype pa
0e60: 63 6b 65 74 29 29 29 0a 09 09 09 09 20 20 20 20 cket))).....
0e70: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
0e80: 66 6f 20 31 32 20 22 73 65 72 76 65 72 3d 3e 20 fo 12 "server=>
0e90: 72 65 63 65 69 76 65 64 20 70 61 63 6b 65 74 3d received packet=
0ea0: 22 20 70 61 63 6b 65 74 29 0a 09 09 09 09 20 20 " packet).....
0eb0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6d 65 6d (if (not (mem
0ec0: 62 65 72 20 71 74 79 70 65 20 27 28 73 79 6e 63 ber qtype '(sync
0ed0: 20 70 69 6e 67 29 29 29 0a 09 09 09 09 09 20 28 ping)))...... (
0ee0: 62 65 67 69 6e 0a 09 09 09 09 09 20 20 20 28 6d begin...... (m
0ef0: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 utex-lock! *hear
0f00: 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 09 09 tbeat-mutex*)...
0f10: 09 09 09 20 20 20 28 73 65 74 21 20 2a 6c 61 73 ... (set! *las
0f20: 74 2d 64 62 2d 61 63 63 65 73 73 2a 20 28 63 75 t-db-access* (cu
0f30: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
0f40: 09 09 09 09 09 20 20 20 28 6d 75 74 65 78 2d 75 ..... (mutex-u
0f50: 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 nlock! *heartbea
0f60: 74 2d 6d 75 74 65 78 2a 29 29 29 0a 09 09 09 09 t-mutex*))).....
0f70: 20 20 20 20 20 3b 3b 20 28 6d 75 74 65 78 2d 6c ;; (mutex-l
0f80: 6f 63 6b 21 20 2a 64 62 3a 70 72 6f 63 65 73 73 ock! *db:process
0f90: 2d 71 75 65 75 65 2d 6d 75 74 65 78 2a 29 20 3b -queue-mutex*) ;
0fa0: 3b 20 74 72 79 69 6e 67 20 61 20 6d 75 74 65 78 ; trying a mutex
0fb0: 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 28 73 65 ..... ;; (se
0fc0: 74 21 20 72 65 73 20 28 6f 70 65 6e 2d 72 75 6e t! res (open-run
0fd0: 2d 63 6c 6f 73 65 20 64 62 3a 70 72 6f 63 65 73 -close db:proces
0fe0: 73 2d 71 75 65 75 65 2d 69 74 65 6d 20 6f 70 65 s-queue-item ope
0ff0: 6e 2d 64 62 20 70 61 63 6b 65 74 29 29 0a 09 09 n-db packet))...
1000: 09 09 20 20 20 20 20 28 73 65 74 21 20 72 65 73 .. (set! res
1010: 20 28 64 62 3a 70 72 6f 63 65 73 73 2d 71 75 65 (db:process-que
1020: 75 65 2d 69 74 65 6d 20 64 62 20 70 61 63 6b 65 ue-item db packe
1030: 74 29 29 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 t))..... ;;
1040: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
1050: 64 62 3a 70 72 6f 63 65 73 73 2d 71 75 65 75 65 db:process-queue
1060: 2d 6d 75 74 65 78 2a 29 0a 09 09 09 09 20 20 20 -mutex*).....
1070: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
1080: 6e 66 6f 20 31 31 20 22 52 65 74 75 72 6e 20 76 nfo 11 "Return v
1090: 61 6c 75 65 20 66 72 6f 6d 20 64 62 3a 70 72 6f alue from db:pro
10a0: 63 65 73 73 2d 71 75 65 75 65 2d 69 74 65 6d 20 cess-queue-item
10b0: 69 73 20 22 20 72 65 73 29 0a 09 09 09 09 20 20 is " res).....
10c0: 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 (send-respons
10d0: 65 20 62 6f 64 79 3a 20 28 63 6f 6e 63 20 22 3c e body: (conc "<
10e0: 68 65 61 64 3e 63 74 72 6c 20 64 61 74 61 3c 2f head>ctrl data</
10f0: 68 65 61 64 3e 5c 6e 3c 62 6f 64 79 3e 22 0a 09 head>\n<body>"..
1100: 09 09 09 09 09 09 09 72 65 73 0a 09 09 09 09 09 .......res......
1110: 09 09 09 22 3c 2f 62 6f 64 79 3e 22 29 0a 09 09 ..."</body>")...
1120: 09 09 09 09 20 20 20 20 68 65 61 64 65 72 73 3a .... headers:
1130: 20 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 65 '((content-type
1140: 20 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 29 29 text/plain)))))
1150: 0a 09 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 ..... ((equal?
1160: 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 (uri-path (reque
1170: 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d st-uri (current-
1180: 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 09 09 request))) .....
1190: 09 20 20 20 27 28 2f 20 22 22 29 29 0a 09 09 09 . '(/ ""))....
11a0: 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e . (send-respon
11b0: 73 65 20 62 6f 64 79 3a 20 28 68 74 74 70 2d 74 se body: (http-t
11c0: 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 61 ransport:main-pa
11d0: 67 65 29 29 29 0a 09 09 09 09 20 20 28 28 65 71 ge)))..... ((eq
11e0: 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 28 ual? (uri-path (
11f0: 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 72 request-uri (cur
1200: 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 20 rent-request)))
1210: 0a 09 09 09 09 09 20 20 20 27 28 2f 20 22 72 75 ...... '(/ "ru
1220: 6e 73 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 ns"))..... (se
1230: 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 nd-response body
1240: 3a 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 : (http-transpor
1250: 74 3a 6d 61 69 6e 2d 70 61 67 65 29 29 29 0a 09 t:main-page)))..
1260: 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 ... ((equal? (u
1270: 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 ri-path (request
1280: 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 -uri (current-re
1290: 71 75 65 73 74 29 29 29 20 0a 09 09 09 09 09 20 quest))) ......
12a0: 20 20 27 28 2f 20 61 6e 79 29 29 0a 09 09 09 09 '(/ any)).....
12b0: 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 (send-respons
12c0: 65 20 62 6f 64 79 3a 20 22 68 65 79 20 74 68 65 e body: "hey the
12d0: 72 65 21 5c 6e 22 0a 09 09 09 09 09 09 20 20 68 re!\n"....... h
12e0: 65 61 64 65 72 73 3a 20 27 28 28 63 6f 6e 74 65 eaders: '((conte
12f0: 6e 74 2d 74 79 70 65 20 74 65 78 74 2f 70 6c 61 nt-type text/pla
1300: 69 6e 29 29 29 29 0a 09 09 09 09 20 20 28 28 65 in))))..... ((e
1310: 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 qual? (uri-path
1320: 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 (request-uri (cu
1330: 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 rrent-request)))
1340: 20 0a 09 09 09 09 09 20 20 20 27 28 2f 20 22 68 ...... '(/ "h
1350: 65 79 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 ey"))..... (se
1360: 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 nd-response body
1370: 3a 20 22 68 65 79 20 74 68 65 72 65 21 5c 6e 22 : "hey there!\n"
1380: 0a 09 09 09 09 09 09 20 20 68 65 61 64 65 72 73 ....... headers
1390: 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 : '((content-typ
13a0: 65 20 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 29 e text/plain))))
13b0: 0a 09 09 09 09 20 20 28 65 6c 73 65 20 28 63 6f ..... (else (co
13c0: 6e 74 69 6e 75 65 29 29 29 29 29 29 29 29 0a 20 ntinue)))))))).
13d0: 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f (http-transpo
13e0: 72 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 rt:try-start-ser
13f0: 76 65 72 20 72 75 6e 2d 69 64 20 69 70 61 64 64 ver run-id ipadd
1400: 72 73 74 72 20 73 74 61 72 74 2d 70 6f 72 74 20 rstr start-port
1410: 73 65 72 76 65 72 2d 69 64 29 29 29 0a 0a 3b 3b server-id)))..;;
1420: 20 54 68 69 73 20 69 73 20 72 65 63 75 72 73 69 This is recursi
1430: 76 65 6c 79 20 72 75 6e 20 62 79 20 68 74 74 70 vely run by http
1440: 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 20 75 -transport:run u
1450: 6e 74 69 6c 20 73 75 63 65 73 73 66 75 6c 0a 3b ntil sucessful.;
1460: 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ;.(define (http-
1470: 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 74 transport:try-st
1480: 61 72 74 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 art-server run-i
1490: 64 20 69 70 61 64 64 72 73 74 72 20 70 6f 72 74 d ipaddrstr port
14a0: 6e 75 6d 20 73 65 72 76 65 72 2d 69 64 29 0a 20 num server-id).
14b0: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
14c0: 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 62 ons. exn. (b
14d0: 65 67 69 6e 0a 20 20 20 20 20 28 70 72 69 6e 74 egin. (print
14e0: 2d 65 72 72 6f 72 2d 6d 65 73 73 61 67 65 20 65 -error-message e
14f0: 78 6e 29 0a 20 20 20 20 20 28 69 66 20 28 3c 20 xn). (if (<
1500: 70 6f 72 74 6e 75 6d 20 39 30 30 30 29 0a 09 20 portnum 9000)..
1510: 28 62 65 67 69 6e 20 0a 09 20 20 20 28 64 65 62 (begin .. (deb
1520: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
1530: 49 4e 47 3a 20 66 61 69 6c 65 64 20 74 6f 20 73 ING: failed to s
1540: 74 61 72 74 20 6f 6e 20 70 6f 72 74 6e 75 6d 3a tart on portnum:
1550: 20 22 20 70 6f 72 74 6e 75 6d 20 22 2c 20 74 72 " portnum ", tr
1560: 79 69 6e 67 20 6e 65 78 74 20 70 6f 72 74 22 29 ying next port")
1570: 0a 09 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 .. (thread-sle
1580: 65 70 21 20 30 2e 31 29 0a 0a 09 20 20 20 3b 3b ep! 0.1)... ;;
1590: 20 67 65 74 5f 6e 65 78 74 5f 70 6f 72 74 20 67 get_next_port g
15a0: 6f 65 73 20 68 65 72 65 0a 0a 09 20 20 20 28 68 oes here... (h
15b0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 ttp-transport:tr
15c0: 79 2d 73 74 61 72 74 2d 73 65 72 76 65 72 20 72 y-start-server r
15d0: 75 6e 2d 69 64 20 69 70 61 64 64 72 73 74 72 20 un-id ipaddrstr
15e0: 28 2b 20 70 6f 72 74 6e 75 6d 20 31 29 20 73 65 (+ portnum 1) se
15f0: 72 76 65 72 2d 69 64 29 29 0a 09 20 28 62 65 67 rver-id)).. (beg
1600: 69 6e 0a 09 20 20 20 28 6f 70 65 6e 2d 72 75 6e in.. (open-run
1610: 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 -close tasks:ser
1620: 76 65 72 2d 66 6f 72 63 65 2d 63 6c 65 61 6e 2d ver-force-clean-
1630: 72 75 6e 2d 72 65 63 6f 72 64 20 74 61 73 6b 73 run-record tasks
1640: 3a 6f 70 65 6e 2d 64 62 20 72 75 6e 2d 69 64 20 :open-db run-id
1650: 69 70 61 64 64 72 73 74 72 20 70 6f 72 74 6e 75 ipaddrstr portnu
1660: 6d 20 22 20 68 74 74 70 2d 74 72 61 6e 73 70 6f m " http-transpo
1670: 72 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 rt:try-start-ser
1680: 76 65 72 22 29 0a 09 20 20 20 28 70 72 69 6e 74 ver").. (print
1690: 20 22 45 52 52 4f 52 3a 20 54 72 69 65 64 20 61 "ERROR: Tried a
16a0: 6e 64 20 74 72 69 65 64 20 62 75 74 20 63 6f 75 nd tried but cou
16b0: 6c 64 20 6e 6f 74 20 73 74 61 72 74 20 74 68 65 ld not start the
16c0: 20 73 65 72 76 65 72 22 29 29 29 29 0a 20 20 20 server")))).
16d0: 3b 3b 20 61 6e 79 20 65 72 72 6f 72 20 69 6e 20 ;; any error in
16e0: 66 6f 6c 6c 6f 77 69 6e 67 20 73 74 65 70 73 20 following steps
16f0: 77 69 6c 6c 20 72 65 73 75 6c 74 20 69 6e 20 61 will result in a
1700: 20 72 65 74 72 79 0a 20 20 20 28 73 65 74 21 20 retry. (set!
1710: 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 28 6c *server-info* (l
1720: 69 73 74 20 69 70 61 64 64 72 73 74 72 20 70 6f ist ipaddrstr po
1730: 72 74 6e 75 6d 29 29 0a 20 20 20 28 6f 70 65 6e rtnum)). (open
1740: 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 -run-close tasks
1750: 3a 73 65 72 76 65 72 2d 73 65 74 2d 69 6e 74 65 :server-set-inte
1760: 72 66 61 63 65 2d 70 6f 72 74 20 0a 09 09 20 20 rface-port ...
1770: 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 0a tasks:open-db .
1780: 09 09 20 20 20 73 65 72 76 65 72 2d 69 64 20 0a .. server-id .
1790: 09 09 20 20 20 69 70 61 64 64 72 73 74 72 20 70 .. ipaddrstr p
17a0: 6f 72 74 6e 75 6d 29 0a 20 20 20 28 64 65 62 75 ortnum). (debu
17b0: 67 3a 70 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a g:print 1 "INFO:
17c0: 20 54 72 79 69 6e 67 20 74 6f 20 73 74 61 72 74 Trying to start
17d0: 20 73 65 72 76 65 72 20 6f 6e 20 22 20 69 70 61 server on " ipa
17e0: 64 64 72 73 74 72 20 22 3a 22 20 70 6f 72 74 6e ddrstr ":" portn
17f0: 75 6d 29 0a 20 20 20 3b 3b 20 54 68 69 73 20 73 um). ;; This s
1800: 74 61 72 74 73 20 74 68 65 20 73 70 69 66 66 79 tarts the spiffy
1810: 20 73 65 72 76 65 72 0a 20 20 20 3b 3b 20 4e 45 server. ;; NE
1820: 45 44 20 57 41 59 20 54 4f 20 53 45 54 20 49 50 ED WAY TO SET IP
1830: 20 54 4f 20 23 66 20 54 4f 20 42 49 4e 44 20 41 TO #f TO BIND A
1840: 4c 4c 0a 20 20 20 3b 3b 20 28 73 74 61 72 74 2d LL. ;; (start-
1850: 73 65 72 76 65 72 20 62 69 6e 64 2d 61 64 64 72 server bind-addr
1860: 65 73 73 3a 20 69 70 61 64 64 72 73 74 72 20 70 ess: ipaddrstr p
1870: 6f 72 74 3a 20 70 6f 72 74 6e 75 6d 29 0a 20 20 ort: portnum).
1880: 20 28 73 74 61 72 74 2d 73 65 72 76 65 72 20 70 (start-server p
1890: 6f 72 74 3a 20 70 6f 72 74 6e 75 6d 29 0a 20 20 ort: portnum).
18a0: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
18b0: 20 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 66 6f tasks:server-fo
18c0: 72 63 65 2d 63 6c 65 61 6e 2d 72 75 6e 2d 72 65 rce-clean-run-re
18d0: 63 6f 72 64 20 74 61 73 6b 73 3a 6f 70 65 6e 2d cord tasks:open-
18e0: 64 62 20 72 75 6e 2d 69 64 20 69 70 61 64 64 72 db run-id ipaddr
18f0: 73 74 72 20 70 6f 72 74 6e 75 6d 20 22 20 68 74 str portnum " ht
1900: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 tp-transport:try
1910: 2d 73 74 61 72 74 2d 73 65 72 76 65 72 22 29 0a -start-server").
1920: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
1930: 31 20 22 49 4e 46 4f 3a 20 73 65 72 76 65 72 20 1 "INFO: server
1940: 68 61 73 20 62 65 65 6e 20 73 74 6f 70 70 65 64 has been stopped
1950: 22 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ")))..;;========
1960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
19a0: 3b 20 53 20 45 20 52 20 56 20 45 20 52 20 20 20 ; S E R V E R
19b0: 55 20 54 20 49 20 4c 20 49 20 54 20 49 20 45 20 U T I L I T I E
19c0: 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S .;;===========
19d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d ===========..;;=
1a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a50: 3d 3d 3d 3d 3d 0a 3b 3b 20 43 20 4c 20 49 20 45 =====.;; C L I E
1a60: 20 4e 20 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d N T S.;;=======
1a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
1ab0: 0a 28 64 65 66 69 6e 65 20 2a 68 74 74 70 2d 6d .(define *http-m
1ac0: 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 utex* (make-mute
1ad0: 78 29 29 0a 0a 3b 3b 20 4e 4f 54 45 3a 20 4c 61 x))..;; NOTE: La
1ae0: 72 67 65 20 62 6c 6f 63 6b 20 6f 66 20 63 6f 64 rge block of cod
1af0: 65 20 66 72 6f 6d 20 33 32 34 33 36 62 34 32 36 e from 32436b426
1b00: 31 38 38 30 38 30 66 37 32 66 63 65 62 36 38 39 188080f72fceb689
1b10: 34 61 66 35 34 31 66 62 61 64 39 39 32 31 65 20 4af541fbad9921e
1b20: 72 65 6d 6f 76 65 64 20 68 65 72 65 0a 3b 3b 20 removed here.;;
1b30: 20 20 20 20 20 20 49 27 6d 20 70 72 65 74 74 79 I'm pretty
1b40: 20 73 75 72 65 20 69 74 20 69 73 20 64 65 66 75 sure it is defu
1b50: 6e 63 74 2e 0a 0a 3b 3b 20 54 68 69 73 20 6e 65 nct...;; This ne
1b60: 78 74 20 62 6c 6f 63 6b 20 61 6c 6c 20 69 6d 70 xt block all imp
1b70: 6f 72 74 65 64 20 65 6e 2d 6d 61 73 73 20 66 72 orted en-mass fr
1b80: 6f 6d 20 74 68 65 20 61 70 69 20 62 72 61 6e 63 om the api branc
1b90: 68 0a 28 64 65 66 69 6e 65 20 2a 68 74 74 70 2d h.(define *http-
1ba0: 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 requests-in-prog
1bb0: 72 65 73 73 2a 20 30 29 0a 28 64 65 66 69 6e 65 ress* 0).(define
1bc0: 20 2a 68 74 74 70 2d 63 6f 6e 6e 65 63 74 69 6f *http-connectio
1bd0: 6e 73 2d 6e 65 78 74 2d 63 6c 65 61 6e 75 70 2a ns-next-cleanup*
1be0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
1bf0: 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 s))..(define (ht
1c00: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 67 65 74 tp-transport:get
1c10: 2d 74 69 6d 65 2d 74 6f 2d 63 6c 65 61 6e 75 70 -time-to-cleanup
1c20: 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 ). (let ((res #
1c30: 66 29 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 6c f)). (mutex-l
1c40: 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 ock! *http-mutex
1c50: 2a 29 0a 20 20 20 20 28 73 65 74 21 20 72 65 73 *). (set! res
1c60: 20 28 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (> (current-sec
1c70: 6f 6e 64 73 29 20 2a 68 74 74 70 2d 63 6f 6e 6e onds) *http-conn
1c80: 65 63 74 69 6f 6e 73 2d 6e 65 78 74 2d 63 6c 65 ections-next-cle
1c90: 61 6e 75 70 2a 29 29 0a 20 20 20 20 28 6d 75 74 anup*)). (mut
1ca0: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 ex-unlock! *http
1cb0: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 72 65 73 -mutex*). res
1cc0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 ))..(define (htt
1cd0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 69 6e 63 2d p-transport:inc-
1ce0: 72 65 71 75 65 73 74 73 2d 63 6f 75 6e 74 29 0a requests-count).
1cf0: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
1d00: 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 28 http-mutex*). (
1d10: 73 65 74 21 20 2a 68 74 74 70 2d 72 65 71 75 65 set! *http-reque
1d20: 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a sts-in-progress*
1d30: 20 28 2b 20 31 20 2a 68 74 74 70 2d 72 65 71 75 (+ 1 *http-requ
1d40: 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 ests-in-progress
1d50: 2a 29 29 0a 20 20 3b 3b 20 55 73 65 20 74 68 69 *)). ;; Use thi
1d60: 73 20 6f 70 70 6f 72 74 75 6e 69 74 79 20 74 6f s opportunity to
1d70: 20 73 6c 6f 77 20 74 68 69 6e 67 73 20 64 6f 77 slow things dow
1d80: 6e 20 69 66 66 20 74 68 65 72 65 20 61 72 65 20 n iff there are
1d90: 74 6f 6f 20 6d 61 6e 79 20 72 65 71 75 65 73 74 too many request
1da0: 73 20 69 6e 20 66 6c 69 67 68 74 0a 20 20 28 69 s in flight. (i
1db0: 66 20 28 3e 20 2a 68 74 74 70 2d 72 65 71 75 65 f (> *http-reque
1dc0: 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a sts-in-progress*
1dd0: 20 35 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 5). (begin
1de0: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
1df0: 6e 66 6f 20 30 20 22 57 68 6f 61 20 74 68 65 72 nfo 0 "Whoa ther
1e00: 65 20 62 75 64 64 79 2c 20 65 61 73 65 20 75 70 e buddy, ease up
1e10: 2e 2e 2e 22 29 0a 09 28 74 68 72 65 61 64 2d 73 ...")..(thread-s
1e20: 6c 65 65 70 21 20 31 29 29 29 0a 20 20 28 6d 75 leep! 1))). (mu
1e30: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 tex-unlock! *htt
1e40: 70 2d 6d 75 74 65 78 2a 29 29 0a 0a 28 64 65 66 p-mutex*))..(def
1e50: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
1e60: 6f 72 74 3a 64 65 63 2d 72 65 71 75 65 73 74 73 ort:dec-requests
1e70: 2d 63 6f 75 6e 74 20 70 72 6f 63 29 20 0a 20 20 -count proc) .
1e80: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 (mutex-lock! *ht
1e90: 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 28 70 72 tp-mutex*). (pr
1ea0: 6f 63 29 0a 20 20 28 73 65 74 21 20 2a 68 74 74 oc). (set! *htt
1eb0: 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 p-requests-in-pr
1ec0: 6f 67 72 65 73 73 2a 20 28 2d 20 2a 68 74 74 70 ogress* (- *http
1ed0: 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f -requests-in-pro
1ee0: 67 72 65 73 73 2a 20 31 29 29 0a 20 20 28 6d 75 gress* 1)). (mu
1ef0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 tex-unlock! *htt
1f00: 70 2d 6d 75 74 65 78 2a 29 29 0a 0a 28 64 65 66 p-mutex*))..(def
1f10: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
1f20: 6f 72 74 3a 64 65 63 2d 72 65 71 75 65 73 74 73 ort:dec-requests
1f30: 2d 63 6f 75 6e 74 2d 61 6e 64 2d 63 6c 6f 73 65 -count-and-close
1f40: 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 -all-connections
1f50: 29 0a 20 20 28 73 65 74 21 20 2a 68 74 74 70 2d ). (set! *http-
1f60: 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 requests-in-prog
1f70: 72 65 73 73 2a 20 28 2d 20 2a 68 74 74 70 2d 72 ress* (- *http-r
1f80: 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 equests-in-progr
1f90: 65 73 73 2a 20 31 29 29 0a 20 20 28 6c 65 74 20 ess* 1)). (let
1fa0: 6c 6f 6f 70 20 28 28 65 74 69 6d 65 20 28 2b 20 loop ((etime (+
1fb0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
1fc0: 29 20 35 29 29 29 20 3b 3b 20 67 69 76 65 20 75 ) 5))) ;; give u
1fd0: 70 20 69 6e 20 66 69 76 65 20 73 65 63 6f 6e 64 p in five second
1fe0: 73 0a 20 20 20 20 28 69 66 20 28 3e 20 2a 68 74 s. (if (> *ht
1ff0: 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 tp-requests-in-p
2000: 72 6f 67 72 65 73 73 2a 20 30 29 0a 09 28 69 66 rogress* 0)..(if
2010: 20 28 3e 20 65 74 69 6d 65 20 28 63 75 72 72 65 (> etime (curre
2020: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 nt-seconds))..
2030: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
2040: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
2050: 2e 30 35 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f .05).. (loo
2060: 70 20 65 74 69 6d 65 29 29 0a 09 20 20 20 20 28 p etime)).. (
2070: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
2080: 52 52 4f 52 3a 20 72 65 71 75 65 73 74 73 20 73 RROR: requests s
2090: 74 69 6c 6c 20 69 6e 20 70 72 6f 67 72 65 73 73 till in progress
20a0: 20 61 66 74 65 72 20 35 20 73 65 63 6f 6e 64 73 after 5 seconds
20b0: 20 6f 66 20 77 61 69 74 69 6e 67 2e 20 49 27 6d of waiting. I'm
20c0: 20 67 6f 69 6e 67 20 74 6f 20 70 61 73 73 20 6f going to pass o
20d0: 6e 20 63 6c 65 61 6e 69 6e 67 20 75 70 20 68 74 n cleaning up ht
20e0: 74 70 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 22 29 tp connections")
20f0: 29 0a 09 28 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f )..(close-all-co
2100: 6e 6e 65 63 74 69 6f 6e 73 21 29 29 29 0a 20 20 nnections!))).
2110: 28 73 65 74 21 20 2a 68 74 74 70 2d 63 6f 6e 6e (set! *http-conn
2120: 65 63 74 69 6f 6e 73 2d 6e 65 78 74 2d 63 6c 65 ections-next-cle
2130: 61 6e 75 70 2a 20 28 2b 20 28 63 75 72 72 65 6e anup* (+ (curren
2140: 74 2d 73 65 63 6f 6e 64 73 29 20 31 30 29 29 0a t-seconds) 10)).
2150: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
2160: 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 29 0a *http-mutex*)).
2170: 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 .(define (http-t
2180: 72 61 6e 73 70 6f 72 74 3a 69 6e 63 2d 72 65 71 ransport:inc-req
2190: 75 65 73 74 73 2d 61 6e 64 2d 70 72 65 70 2d 74 uests-and-prep-t
21a0: 6f 2d 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e o-close-all-conn
21b0: 65 63 74 69 6f 6e 73 29 0a 20 20 28 6d 75 74 65 ections). (mute
21c0: 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 x-lock! *http-mu
21d0: 74 65 78 2a 29 0a 20 20 28 73 65 74 21 20 2a 68 tex*). (set! *h
21e0: 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d ttp-requests-in-
21f0: 70 72 6f 67 72 65 73 73 2a 20 28 2b 20 31 20 2a progress* (+ 1 *
2200: 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e http-requests-in
2210: 2d 70 72 6f 67 72 65 73 73 2a 29 29 29 0a 0a 3b -progress*)))..;
2220: 3b 20 53 65 6e 64 20 22 63 6d 64 22 20 77 69 74 ; Send "cmd" wit
2230: 68 20 6a 73 6f 6e 20 70 61 79 6c 6f 61 64 20 22 h json payload "
2240: 70 61 72 61 6d 73 22 20 74 6f 20 73 65 72 76 65 params" to serve
2250: 72 64 61 74 20 61 6e 64 20 72 65 63 65 69 76 65 rdat and receive
2260: 20 72 65 73 75 6c 74 0a 3b 3b 0a 28 64 65 66 69 result.;;.(defi
2270: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
2280: 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 rt:client-api-se
2290: 6e 64 2d 72 65 63 65 69 76 65 20 72 75 6e 2d 69 nd-receive run-i
22a0: 64 20 73 65 72 76 65 72 64 61 74 20 63 6d 64 20 d serverdat cmd
22b0: 70 61 72 61 6d 73 20 23 21 6b 65 79 20 28 6e 75 params #!key (nu
22c0: 6d 72 65 74 72 69 65 73 20 33 30 29 29 0a 20 20 mretries 30)).
22d0: 28 6c 65 74 2a 20 28 28 66 75 6c 6c 75 72 6c 20 (let* ((fullurl
22e0: 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 73 65 (if (list? se
22f0: 72 76 65 72 64 61 74 29 0a 09 09 09 20 28 6c 69 rverdat).... (li
2300: 73 74 2d 72 65 66 20 73 65 72 76 65 72 64 61 74 st-ref serverdat
2310: 20 34 29 20 3b 3b 20 28 63 61 64 64 64 72 20 73 4) ;; (cadddr s
2320: 65 72 76 65 72 64 61 74 29 20 3b 3b 20 74 68 69 erverdat) ;; thi
2330: 73 20 69 73 20 74 68 65 20 75 72 69 20 66 6f 72 s is the uri for
2340: 20 2f 61 70 69 0a 09 09 09 20 28 62 65 67 69 6e /api.... (begin
2350: 0a 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 .... (debug:pr
2360: 69 6e 74 20 30 20 22 46 41 54 41 4c 20 45 52 52 int 0 "FATAL ERR
2370: 4f 52 3a 20 68 74 74 70 2d 74 72 61 6e 73 70 6f OR: http-transpo
2380: 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 rt:client-api-se
2390: 6e 64 2d 72 65 63 65 69 76 65 20 63 61 6c 6c 65 nd-receive calle
23a0: 64 20 77 69 74 68 20 6e 6f 20 73 65 72 76 65 72 d with no server
23b0: 20 69 6e 66 6f 22 29 0a 09 09 09 20 20 20 28 65 info").... (e
23c0: 78 69 74 20 31 29 29 29 29 0a 09 20 28 72 65 73 xit 1)))).. (res
23d0: 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 #f)).
23e0: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
23f0: 6f 6e 73 0a 20 20 20 20 20 65 78 6e 0a 20 20 20 ons. exn.
2400: 20 20 28 69 66 20 28 3e 20 6e 75 6d 72 65 74 72 (if (> numretr
2410: 69 65 73 20 30 29 0a 09 20 28 62 65 67 69 6e 0a ies 0).. (begin.
2420: 09 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 . (mutex-unloc
2430: 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 k! *http-mutex*)
2440: 0a 09 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 .. (thread-sle
2450: 65 70 21 20 31 30 29 0a 09 20 20 20 28 68 74 74 ep! 10).. (htt
2460: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 p-transport:clie
2470: 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 nt-api-send-rece
2480: 69 76 65 20 72 75 6e 2d 69 64 20 73 65 72 76 65 ive run-id serve
2490: 72 64 61 74 20 63 6d 64 20 70 61 72 61 6d 73 20 rdat cmd params
24a0: 28 2d 20 6e 75 6d 72 65 74 72 69 65 73 20 31 29 (- numretries 1)
24b0: 29 29 0a 09 20 23 66 29 0a 20 20 20 20 20 28 62 )).. #f). (b
24c0: 65 67 69 6e 0a 20 20 20 20 20 20 20 28 64 65 62 egin. (deb
24d0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 31 ug:print-info 11
24e0: 20 22 66 75 6c 6c 75 72 6c 3d 22 20 66 75 6c 6c "fullurl=" full
24f0: 75 72 6c 20 22 2c 20 63 6d 64 3d 22 20 63 6d 64 url ", cmd=" cmd
2500: 20 22 2c 20 70 61 72 61 6d 73 3d 22 20 70 61 72 ", params=" par
2510: 61 6d 73 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 ams ", run-id="
2520: 72 75 6e 2d 69 64 20 22 5c 6e 22 29 0a 20 20 20 run-id "\n").
2530: 20 20 20 20 3b 3b 20 73 65 74 20 75 70 20 74 68 ;; set up th
2540: 65 20 68 74 74 70 2d 63 6c 69 65 6e 74 20 68 65 e http-client he
2550: 72 65 0a 20 20 20 20 20 20 20 28 6d 61 78 2d 72 re. (max-r
2560: 65 74 72 79 2d 61 74 74 65 6d 70 74 73 20 35 29 etry-attempts 5)
2570: 0a 20 20 20 20 20 20 20 3b 3b 20 63 6f 6e 73 69 . ;; consi
2580: 64 65 72 20 61 6c 6c 20 72 65 71 75 65 73 74 73 der all requests
2590: 20 69 6e 64 65 6d 70 6f 74 65 6e 74 0a 20 20 20 indempotent.
25a0: 20 20 20 20 28 72 65 74 72 79 2d 72 65 71 75 65 (retry-reque
25b0: 73 74 3f 20 28 6c 61 6d 62 64 61 20 28 72 65 71 st? (lambda (req
25c0: 75 65 73 74 29 0a 09 09 09 20 23 74 29 29 0a 20 uest).... #t)).
25d0: 20 20 20 20 20 20 3b 3b 20 73 65 6e 64 20 74 68 ;; send th
25e0: 65 20 64 61 74 61 20 61 6e 64 20 67 65 74 20 74 e data and get t
25f0: 68 65 20 72 65 73 70 6f 6e 73 65 0a 20 20 20 20 he response.
2600: 20 20 20 3b 3b 20 65 78 74 72 61 63 74 20 74 68 ;; extract th
2610: 65 20 6e 65 65 64 65 64 20 69 6e 66 6f 20 66 72 e needed info fr
2620: 6f 6d 20 74 68 65 20 68 74 74 70 20 64 61 74 61 om the http data
2630: 20 61 6e 64 20 0a 20 20 20 20 20 20 20 3b 3b 20 and . ;;
2640: 70 72 6f 63 65 73 73 20 61 6e 64 20 72 65 74 75 process and retu
2650: 72 6e 20 69 74 2e 0a 20 20 20 20 20 20 20 28 6c rn it.. (l
2660: 65 74 2a 20 28 28 73 65 6e 64 2d 72 65 63 69 65 et* ((send-recie
2670: 76 65 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 ve (lambda ()...
2680: 09 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f . (mutex-lo
2690: 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a ck! *http-mutex*
26a0: 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 74 21 ).... (set!
26b0: 20 72 65 73 20 28 77 69 74 68 2d 69 6e 70 75 74 res (with-input
26c0: 2d 66 72 6f 6d 2d 72 65 71 75 65 73 74 20 3b 3b -from-request ;;
26d0: 20 77 61 73 20 64 61 74 0a 09 09 09 09 09 20 66 was dat...... f
26e0: 75 6c 6c 75 72 6c 20 0a 09 09 09 09 09 20 28 6c ullurl ...... (l
26f0: 69 73 74 20 28 63 6f 6e 73 20 27 6b 65 79 20 22 ist (cons 'key "
2700: 74 68 65 6b 65 79 22 29 0a 09 09 09 09 09 20 20 thekey")......
2710: 20 20 20 20 20 28 63 6f 6e 73 20 27 63 6d 64 20 (cons 'cmd
2720: 63 6d 64 29 0a 09 09 09 09 09 20 20 20 20 20 20 cmd)......
2730: 20 28 63 6f 6e 73 20 27 70 61 72 61 6d 73 20 70 (cons 'params p
2740: 61 72 61 6d 73 29 29 0a 09 09 09 09 09 20 72 65 arams))...... re
2750: 61 64 2d 73 74 72 69 6e 67 29 29 0a 09 09 09 20 ad-string))....
2760: 20 20 20 20 20 3b 3b 20 53 68 6f 75 6c 64 6e 27 ;; Shouldn'
2770: 74 20 74 68 69 73 20 62 65 20 61 20 63 61 6c 6c t this be a call
2780: 20 74 6f 20 74 68 65 20 6d 61 6e 61 67 65 64 20 to the managed
2790: 63 61 6c 6c 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 call-all-connect
27a0: 69 6f 6e 73 20 73 74 75 66 66 20 61 62 6f 76 65 ions stuff above
27b0: 3f 0a 09 09 09 20 20 20 20 20 20 28 63 6c 6f 73 ?.... (clos
27c0: 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e e-all-connection
27d0: 73 21 29 0a 09 09 09 20 20 20 20 20 20 28 6d 75 s!).... (mu
27e0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 tex-unlock! *htt
27f0: 70 2d 6d 75 74 65 78 2a 29 0a 09 09 09 20 20 20 p-mutex*)....
2800: 20 20 20 29 29 0a 09 20 20 20 20 20 20 28 74 69 )).. (ti
2810: 6d 65 2d 6f 75 74 20 20 20 20 20 28 6c 61 6d 62 me-out (lamb
2820: 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 28 da ().... (
2830: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 34 35 thread-sleep! 45
2840: 29 0a 09 09 09 20 20 20 20 20 20 23 66 29 29 0a ).... #f)).
2850: 09 20 20 20 20 20 20 28 74 68 31 20 28 6d 61 6b . (th1 (mak
2860: 65 2d 74 68 72 65 61 64 20 73 65 6e 64 2d 72 65 e-thread send-re
2870: 63 69 65 76 65 20 22 77 69 74 68 2d 69 6e 70 75 cieve "with-inpu
2880: 74 2d 66 72 6f 6d 2d 72 65 71 75 65 73 74 22 29 t-from-request")
2890: 29 0a 09 20 20 20 20 20 20 28 74 68 32 20 28 6d ).. (th2 (m
28a0: 61 6b 65 2d 74 68 72 65 61 64 20 74 69 6d 65 2d ake-thread time-
28b0: 6f 75 74 20 20 20 20 20 22 74 69 6d 65 20 6f 75 out "time ou
28c0: 74 22 29 29 29 0a 09 20 28 74 68 72 65 61 64 2d t"))).. (thread-
28d0: 73 74 61 72 74 21 20 74 68 31 29 0a 09 20 28 74 start! th1).. (t
28e0: 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 hread-start! th2
28f0: 29 0a 09 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e ).. (thread-join
2900: 21 20 74 68 31 29 0a 09 20 28 74 68 72 65 61 64 ! th1).. (thread
2910: 2d 74 65 72 6d 69 6e 61 74 65 21 20 74 68 32 29 -terminate! th2)
2920: 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d .. (debug:print-
2930: 69 6e 66 6f 20 31 31 20 22 67 6f 74 20 72 65 73 info 11 "got res
2940: 3d 22 20 72 65 73 29 0a 09 20 72 65 73 29 29 29 =" res).. res)))
2950: 29 29 0a 0a 3b 3b 0a 3b 3b 20 63 6f 6e 6e 65 63 ))..;;.;; connec
2960: 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 t.;;.(define (ht
2970: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 tp-transport:cli
2980: 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 69 66 61 63 ent-connect ifac
2990: 65 20 70 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 e port). (let*
29a0: 28 28 61 70 69 2d 75 72 6c 20 20 20 20 20 28 63 ((api-url (c
29b0: 6f 6e 63 20 22 68 74 74 70 3a 2f 2f 22 20 69 66 onc "http://" if
29c0: 61 63 65 20 22 3a 22 20 70 6f 72 74 20 22 2f 61 ace ":" port "/a
29d0: 70 69 22 29 29 0a 09 20 28 75 72 69 2d 64 61 74 pi")).. (uri-dat
29e0: 20 20 20 20 20 28 6d 61 6b 65 2d 72 65 71 75 65 (make-reque
29f0: 73 74 20 6d 65 74 68 6f 64 3a 20 27 50 4f 53 54 st method: 'POST
2a00: 20 75 72 69 3a 20 28 75 72 69 2d 72 65 66 65 72 uri: (uri-refer
2a10: 65 6e 63 65 20 28 63 6f 6e 63 20 22 68 74 74 70 ence (conc "http
2a20: 3a 2f 2f 22 20 69 66 61 63 65 20 22 3a 22 20 70 ://" iface ":" p
2a30: 6f 72 74 20 22 2f 63 74 72 6c 22 29 29 29 29 0a ort "/ctrl")))).
2a40: 09 20 3b 3b 20 28 75 72 69 2d 64 61 74 20 20 20 . ;; (uri-dat
2a50: 20 20 28 6d 61 6b 65 2d 72 65 71 75 65 73 74 20 (make-request
2a60: 6d 65 74 68 6f 64 3a 20 27 47 45 54 20 75 72 69 method: 'GET uri
2a70: 3a 20 28 75 72 69 2d 72 65 66 65 72 65 6e 63 65 : (uri-reference
2a80: 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f 22 (conc "http://"
2a90: 20 69 66 61 63 65 20 22 3a 22 20 70 6f 72 74 20 iface ":" port
2aa0: 22 2f 63 74 72 6c 22 29 29 29 29 0a 09 20 28 75 "/ctrl")))).. (u
2ab0: 72 69 2d 61 70 69 2d 64 61 74 20 28 6d 61 6b 65 ri-api-dat (make
2ac0: 2d 72 65 71 75 65 73 74 20 6d 65 74 68 6f 64 3a -request method:
2ad0: 20 27 50 4f 53 54 20 75 72 69 3a 20 61 70 69 2d 'POST uri: api-
2ae0: 75 72 6c 29 29 20 3b 3b 20 28 75 72 69 2d 72 65 url)) ;; (uri-re
2af0: 66 65 72 65 6e 63 65 20 28 63 6f 6e 63 20 22 68 ference (conc "h
2b00: 74 74 70 3a 2f 2f 22 20 69 66 61 63 65 20 22 3a ttp://" iface ":
2b10: 22 20 70 6f 72 74 20 22 2f 61 70 69 22 29 29 29 " port "/api")))
2b20: 29 0a 09 20 3b 3b 20 28 75 72 69 2d 61 70 69 2d ).. ;; (uri-api-
2b30: 64 61 74 20 28 6d 61 6b 65 2d 72 65 71 75 65 73 dat (make-reques
2b40: 74 20 6d 65 74 68 6f 64 3a 20 27 47 45 54 20 75 t method: 'GET u
2b50: 72 69 3a 20 28 75 72 69 2d 72 65 66 65 72 65 6e ri: (uri-referen
2b60: 63 65 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f ce (conc "http:/
2b70: 2f 22 20 69 66 61 63 65 20 22 3a 22 20 70 6f 72 /" iface ":" por
2b80: 74 20 22 2f 61 70 69 22 29 29 29 29 0a 09 20 28 t "/api")))).. (
2b90: 73 65 72 76 65 72 2d 64 61 74 20 20 28 6c 69 73 server-dat (lis
2ba0: 74 20 69 66 61 63 65 20 70 6f 72 74 20 75 72 69 t iface port uri
2bb0: 2d 64 61 74 20 75 72 69 2d 61 70 69 2d 64 61 74 -dat uri-api-dat
2bc0: 20 61 70 69 2d 75 72 6c 29 29 29 0a 3b 3b 09 20 api-url))).;;.
2bd0: 28 6c 6f 67 69 6e 2d 72 65 73 20 20 20 28 73 65 (login-res (se
2be0: 72 76 65 72 3a 70 69 6e 67 2d 73 65 72 76 65 72 rver:ping-server
2bf0: 20 72 75 6e 2d 69 64 20 73 65 72 76 65 72 2d 64 run-id server-d
2c00: 61 74 29 29 29 20 3b 3b 20 6c 6f 67 69 6e 2d 6e at))) ;; login-n
2c10: 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 o-auto-client-se
2c20: 74 75 70 20 73 65 72 76 65 72 2d 64 61 74 20 72 tup server-dat r
2c30: 75 6e 2d 69 64 29 29 29 0a 20 20 20 20 73 65 72 un-id))). ser
2c40: 76 65 72 2d 64 61 74 29 29 0a 3b 3b 20 20 20 20 ver-dat)).;;
2c50: 20 28 69 66 20 28 61 6e 64 20 28 6c 69 73 74 3f (if (and (list?
2c60: 20 6c 6f 67 69 6e 2d 72 65 73 29 0a 09 20 20 28 login-res).. (
2c70: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
2c80: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d *runremote* run-
2c90: 69 64 20 73 65 72 76 65 72 2d 64 61 74 29 0a 09 id server-dat)..
2ca0: 20 20 73 65 72 76 65 72 2d 64 61 74 29 0a 3b 3b server-dat).;;
2cb0: 20 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d . (hash-table-
2cc0: 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a set! *runremote*
2cd0: 20 72 75 6e 2d 69 64 20 73 65 72 76 65 72 2d 64 run-id server-d
2ce0: 61 74 29 0a 3b 3b 20 09 20 20 28 64 65 62 75 67 at).;; . (debug
2cf0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 4c :print-info 2 "L
2d00: 6f 67 67 65 64 20 69 6e 20 61 6e 64 20 63 6f 6e ogged in and con
2d10: 6e 65 63 74 65 64 20 74 6f 20 22 20 69 66 61 63 nected to " ifac
2d20: 65 20 22 3a 22 20 70 6f 72 74 29 0a 3b 3b 20 09 e ":" port).;; .
2d30: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
2d40: 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 t! *runremote* r
2d50: 75 6e 2d 69 64 20 73 65 72 76 65 72 2d 64 61 74 un-id server-dat
2d60: 29 0a 3b 3b 20 09 20 20 73 65 72 76 65 72 2d 64 ).;; . server-d
2d70: 61 74 29 0a 3b 3b 20 09 28 62 65 67 69 6e 0a 3b at).;; .(begin.;
2d80: 3b 20 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ; . (debug:prin
2d90: 74 2d 69 6e 66 6f 20 30 20 22 45 52 52 4f 52 3a t-info 0 "ERROR:
2da0: 20 46 61 69 6c 65 64 20 74 6f 20 6c 6f 67 69 6e Failed to login
2db0: 20 6f 72 20 63 6f 6e 6e 65 63 74 20 74 6f 20 22 or connect to "
2dc0: 20 69 66 61 63 65 20 22 3a 22 20 70 6f 72 74 29 iface ":" port)
2dd0: 0a 3b 3b 20 09 20 20 23 66 29 29 29 29 0a 0a 3b .;; . #f))))..;
2de0: 3b 20 72 75 6e 20 68 74 74 70 2d 74 72 61 6e 73 ; run http-trans
2df0: 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e port:keep-runnin
2e00: 67 20 69 6e 20 61 20 70 61 72 61 6c 6c 65 6c 20 g in a parallel
2e10: 74 68 72 65 61 64 20 74 6f 20 6d 6f 6e 69 74 6f thread to monito
2e20: 72 20 74 68 61 74 20 74 68 65 20 64 62 20 69 73 r that the db is
2e30: 20 62 65 69 6e 67 20 0a 3b 3b 20 75 73 65 64 20 being .;; used
2e40: 61 6e 64 20 74 6f 20 73 68 75 74 64 6f 77 6e 20 and to shutdown
2e50: 61 66 74 65 72 20 73 6f 6d 65 74 69 6d 65 20 69 after sometime i
2e60: 66 20 69 74 20 69 73 20 6e 6f 74 2e 0a 3b 3b 0a f it is not..;;.
2e70: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
2e80: 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e ansport:keep-run
2e90: 6e 69 6e 67 20 73 65 72 76 65 72 2d 69 64 29 0a ning server-id).
2ea0: 20 20 3b 3b 20 69 66 20 6e 6f 6e 65 20 72 75 6e ;; if none run
2eb0: 6e 69 6e 67 20 6f 72 20 69 66 20 3e 20 32 30 20 ning or if > 20
2ec0: 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 0a 20 seconds since .
2ed0: 20 3b 3b 20 73 65 72 76 65 72 20 6c 61 73 74 20 ;; server last
2ee0: 75 73 65 64 20 74 68 65 6e 20 73 74 61 72 74 20 used then start
2ef0: 73 68 75 74 64 6f 77 6e 0a 20 20 3b 3b 20 54 68 shutdown. ;; Th
2f00: 69 73 20 74 68 72 65 61 64 20 77 61 69 74 73 20 is thread waits
2f10: 66 6f 72 20 74 68 65 20 73 65 72 76 65 72 20 74 for the server t
2f20: 6f 20 63 6f 6d 65 20 61 6c 69 76 65 0a 20 20 28 o come alive. (
2f30: 6c 65 74 2a 20 28 28 73 65 72 76 65 72 2d 69 6e let* ((server-in
2f40: 66 6f 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 73 fo (let loop ((s
2f50: 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 tart-time (curre
2f60: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 09 nt-seconds))....
2f70: 09 20 28 63 68 61 6e 67 65 64 20 20 20 20 23 74 . (changed #t
2f80: 29 0a 09 09 09 09 20 28 6c 61 73 74 2d 73 64 61 )..... (last-sda
2f90: 74 20 20 22 6e 6f 74 20 74 68 69 73 22 29 29 0a t "not this")).
2fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2fb0: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 (let ((s
2fc0: 64 61 74 20 23 66 29 29 0a 20 20 20 20 20 20 20 dat #f)).
2fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2fe0: 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 (mutex-lock!
2ff0: 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 *heartbeat-mutex
3000: 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 *).
3010: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 (se
3020: 74 21 20 73 64 61 74 20 2a 73 65 72 76 65 72 2d t! sdat *server-
3030: 69 6e 66 6f 2a 29 0a 20 20 20 20 20 20 20 20 20 info*).
3040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3050: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
3060: 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 *heartbeat-mutex
3070: 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 *).
3080: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
3090: 20 28 61 6e 64 20 73 64 61 74 0a 09 09 09 09 20 (and sdat.....
30a0: 20 20 28 6e 6f 74 20 63 68 61 6e 67 65 64 29 0a (not changed).
30b0: 09 09 09 09 20 20 20 28 3e 20 28 2d 20 28 63 75 .... (> (- (cu
30c0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 rrent-seconds) s
30d0: 74 61 72 74 2d 74 69 6d 65 29 20 32 29 29 0a 09 tart-time) 2))..
30e0: 09 09 20 20 20 20 20 20 73 64 61 74 0a 20 20 20 .. sdat.
30f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3100: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
3110: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
3120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3130: 20 20 28 73 6c 65 65 70 20 34 29 0a 20 20 20 20 (sleep 4).
3140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3150: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f (loo
3160: 70 20 73 74 61 72 74 2d 74 69 6d 65 0a 09 09 09 p start-time....
3170: 09 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 73 . (equal? s
3180: 64 61 74 20 6c 61 73 74 2d 73 64 61 74 29 0a 09 dat last-sdat)..
3190: 09 09 09 20 20 20 20 20 20 73 64 61 74 29 29 29 ... sdat)))
31a0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 69 66 ))). (if
31b0: 61 63 65 20 20 20 20 20 20 20 28 63 61 72 20 73 ace (car s
31c0: 65 72 76 65 72 2d 69 6e 66 6f 29 29 0a 20 20 20 erver-info)).
31d0: 20 20 20 20 20 20 28 70 6f 72 74 20 20 20 20 20 (port
31e0: 20 20 20 28 63 61 64 72 20 73 65 72 76 65 72 2d (cadr server-
31f0: 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 info)).
3200: 28 6c 61 73 74 2d 61 63 63 65 73 73 20 30 29 0a (last-access 0).
3210: 09 20 28 74 64 62 20 20 20 20 20 20 20 20 20 28 . (tdb (
3220: 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 0a tasks:open-db)).
3230: 09 20 28 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 . (server-timeou
3240: 74 20 28 6c 65 74 20 28 28 74 6d 6f 20 28 63 6f t (let ((tmo (co
3250: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 20 2a 63 nfigf:lookup *c
3260: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 onfigdat* "serve
3270: 72 22 20 22 74 69 6d 65 6f 75 74 22 29 29 29 0a r" "timeout"))).
3280: 09 09 09 20 20 20 28 69 66 20 28 61 6e 64 20 28 ... (if (and (
3290: 73 74 72 69 6e 67 3f 20 74 6d 6f 29 0a 09 09 09 string? tmo)....
32a0: 09 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 . (string->nu
32b0: 6d 62 65 72 20 74 6d 6f 29 29 0a 09 09 09 20 20 mber tmo))....
32c0: 20 20 20 20 20 28 2a 20 36 30 20 36 30 20 28 73 (* 60 60 (s
32d0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 74 6d tring->number tm
32e0: 6f 29 29 0a 09 09 09 20 20 20 20 20 20 20 3b 3b o)).... ;;
32f0: 20 28 2a 20 33 20 32 34 20 36 30 20 36 30 29 20 (* 3 24 60 60)
3300: 3b 3b 20 64 65 66 61 75 6c 74 20 74 6f 20 74 68 ;; default to th
3310: 72 65 65 20 64 61 79 73 0a 09 09 09 20 20 20 20 ree days....
3320: 20 20 20 3b 3b 20 28 2a 20 36 30 20 31 29 20 20 ;; (* 60 1)
3330: 20 20 20 20 20 20 20 3b 3b 20 64 65 66 61 75 6c ;; defaul
3340: 74 20 74 6f 20 6f 6e 65 20 6d 69 6e 75 74 65 0a t to one minute.
3350: 09 09 09 20 20 20 20 20 20 20 28 2a 20 36 30 20 ... (* 60
3360: 36 30 20 32 35 29 20 20 20 20 20 20 3b 3b 20 64 60 25) ;; d
3370: 65 66 61 75 6c 74 20 74 6f 20 32 35 20 68 6f 75 efault to 25 hou
3380: 72 73 0a 09 09 09 20 20 20 20 20 20 20 29 29 29 rs.... )))
3390: 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ). (let loop
33a0: 28 28 63 6f 75 6e 74 20 20 20 20 20 20 20 20 20 ((count
33b0: 30 29 0a 09 20 20 20 20 20 20 20 28 73 65 72 76 0).. (serv
33c0: 65 72 2d 73 74 61 74 65 20 27 61 76 61 69 6c 61 er-state 'availa
33d0: 62 6c 65 29 29 0a 20 20 20 20 20 20 3b 3b 20 55 ble)). ;; U
33e0: 73 65 20 74 68 69 73 20 6f 70 70 6f 72 74 75 6e se this opportun
33f0: 69 74 79 20 74 6f 20 73 79 6e 63 20 74 68 65 20 ity to sync the
3400: 69 6e 6d 65 6d 64 62 20 74 6f 20 64 62 0a 20 20 inmemdb to db.
3410: 20 20 20 20 28 6c 65 74 20 28 28 73 74 61 72 74 (let ((start
3420: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d -time (current-m
3430: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 09 20 illiseconds))..
3440: 20 20 20 28 73 79 6e 63 2d 74 69 6d 65 20 20 23 (sync-time #
3450: 66 29 0a 09 20 20 20 20 28 72 65 6d 2d 74 69 6d f).. (rem-tim
3460: 65 20 20 20 23 66 29 29 0a 0a 09 28 69 66 20 2a e #f))...(if *
3470: 69 6e 6d 65 6d 64 62 2a 20 28 64 62 3a 73 79 6e inmemdb* (db:syn
3480: 63 2d 74 6f 75 63 68 65 64 20 2a 69 6e 6d 65 6d c-touched *inmem
3490: 64 62 2a 20 66 6f 72 63 65 2d 73 79 6e 63 3a 20 db* force-sync:
34a0: 23 74 29 29 0a 09 28 73 65 74 21 20 73 79 6e 63 #t))..(set! sync
34b0: 2d 74 69 6d 65 20 20 28 2d 20 28 63 75 72 72 65 -time (- (curre
34c0: 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
34d0: 20 73 74 61 72 74 2d 74 69 6d 65 29 29 0a 09 28 start-time))..(
34e0: 73 65 74 21 20 72 65 6d 2d 74 69 6d 65 20 28 71 set! rem-time (q
34f0: 75 6f 74 69 65 6e 74 20 28 2d 20 34 30 30 30 20 uotient (- 4000
3500: 73 79 6e 63 2d 74 69 6d 65 29 20 31 30 30 30 29 sync-time) 1000)
3510: 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 )..(debug:print
3520: 30 20 22 53 59 4e 43 3a 20 74 69 6d 65 3d 20 22 0 "SYNC: time= "
3530: 20 73 79 6e 63 2d 74 69 6d 65 20 22 2c 20 72 65 sync-time ", re
3540: 6d 2d 74 69 6d 65 3d 22 20 72 65 6d 2d 74 69 6d m-time=" rem-tim
3550: 65 29 0a 0a 20 20 20 20 20 20 3b 3b 0a 20 20 20 e).. ;;.
3560: 20 20 20 3b 3b 20 73 65 74 5f 72 75 6e 6e 69 6e ;; set_runnin
3570: 67 20 61 66 74 65 72 20 6f 75 72 20 66 69 72 73 g after our firs
3580: 74 20 70 61 73 73 20 74 68 72 6f 75 67 68 0a 20 t pass through.
3590: 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 20 28 69 ;;. (i
35a0: 66 20 28 65 71 3f 20 73 65 72 76 65 72 2d 73 74 f (eq? server-st
35b0: 61 74 65 20 27 61 76 61 69 6c 61 62 6c 65 29 0a ate 'available).
35c0: 09 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 . (tasks:server
35d0: 2d 73 65 74 2d 73 74 61 74 65 21 20 74 64 62 20 -set-state! tdb
35e0: 73 65 72 76 65 72 2d 69 64 20 22 72 75 6e 6e 69 server-id "runni
35f0: 6e 67 22 29 29 0a 0a 20 20 20 20 20 20 28 69 66 ng")).. (if
3600: 20 28 61 6e 64 20 28 3c 3d 20 72 65 6d 2d 74 69 (and (<= rem-ti
3610: 6d 65 20 34 29 0a 09 20 20 20 20 20 20 20 28 3e me 4).. (>
3620: 20 72 65 6d 2d 74 69 6d 65 20 30 29 29 0a 09 20 rem-time 0))..
3630: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
3640: 72 65 6d 2d 74 69 6d 65 29 0a 09 20 20 28 74 68 rem-time).. (th
3650: 72 65 61 64 2d 73 6c 65 65 70 21 20 34 29 29 29 read-sleep! 4)))
3660: 20 3b 3b 20 66 61 6c 6c 62 61 63 6b 20 66 6f 72 ;; fallback for
3670: 20 69 66 20 74 68 65 20 6d 61 74 68 20 69 73 20 if the math is
3680: 63 68 61 6e 67 65 64 20 2e 2e 2e 0a 20 20 20 20 changed ....
3690: 20 20 0a 20 20 20 20 20 20 28 69 66 20 28 3c 20 . (if (<
36a0: 63 6f 75 6e 74 20 31 29 20 3b 3b 20 33 78 33 20 count 1) ;; 3x3
36b0: 3d 20 39 20 73 65 63 73 20 61 70 72 6f 78 0a 09 = 9 secs aprox..
36c0: 20 20 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 (loop (+ count
36d0: 20 31 29 20 27 72 75 6e 6e 69 6e 67 29 29 0a 20 1) 'running)).
36e0: 20 20 20 20 20 0a 20 20 20 20 20 20 3b 3b 20 43 . ;; C
36f0: 68 65 63 6b 20 74 68 61 74 20 69 66 61 63 65 20 heck that iface
3700: 61 6e 64 20 70 6f 72 74 20 68 61 76 65 20 6e 6f and port have no
3710: 74 20 63 68 61 6e 67 65 64 20 28 63 61 6e 20 68 t changed (can h
3720: 61 70 70 65 6e 20 69 66 20 73 65 72 76 65 72 20 appen if server
3730: 70 6f 72 74 20 63 6f 6c 6c 69 64 65 73 29 0a 20 port collides).
3740: 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b (mutex-lock
3750: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
3760: 65 78 2a 29 0a 20 20 20 20 20 20 28 73 65 74 21 ex*). (set!
3770: 20 73 64 61 74 20 2a 73 65 72 76 65 72 2d 69 6e sdat *server-in
3780: 66 6f 2a 29 0a 20 20 20 20 20 20 28 6d 75 74 65 fo*). (mute
3790: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 x-unlock! *heart
37a0: 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 beat-mutex*).
37b0: 20 20 20 0a 20 20 20 20 20 20 28 69 66 20 28 6f . (if (o
37c0: 72 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 73 r (not (equal? s
37d0: 64 61 74 20 28 6c 69 73 74 20 69 66 61 63 65 20 dat (list iface
37e0: 70 6f 72 74 29 29 29 0a 09 20 20 20 20 20 20 28 port))).. (
37f0: 6e 6f 74 20 73 65 72 76 65 72 2d 69 64 29 29 0a not server-id)).
3800: 09 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 . (begin ..
3810: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
3820: 6f 20 30 20 22 69 6e 74 65 72 66 61 63 65 20 63 o 0 "interface c
3830: 68 61 6e 67 65 64 2c 20 72 65 66 72 65 73 68 69 hanged, refreshi
3840: 6e 67 20 69 66 61 63 65 20 61 6e 64 20 70 6f 72 ng iface and por
3850: 74 20 69 6e 66 6f 22 29 0a 09 20 20 20 20 28 73 t info").. (s
3860: 65 74 21 20 69 66 61 63 65 20 28 63 61 72 20 73 et! iface (car s
3870: 64 61 74 29 29 0a 09 20 20 20 20 28 73 65 74 21 dat)).. (set!
3880: 20 70 6f 72 74 20 20 28 63 61 64 72 20 73 64 61 port (cadr sda
3890: 74 29 29 29 29 0a 20 20 20 20 20 20 0a 20 20 20 t)))). .
38a0: 20 20 20 3b 3b 20 54 72 61 6e 73 66 65 72 20 2a ;; Transfer *
38b0: 6c 61 73 74 2d 64 62 2d 61 63 63 65 73 73 2a 20 last-db-access*
38c0: 74 6f 20 6c 61 73 74 2d 61 63 63 65 73 73 20 74 to last-access t
38d0: 6f 20 75 73 65 20 69 6e 20 63 68 65 63 6b 69 6e o use in checkin
38e0: 67 20 74 68 61 74 20 77 65 20 61 72 65 20 73 74 g that we are st
38f0: 69 6c 6c 20 61 6c 69 76 65 0a 20 20 20 20 20 20 ill alive.
3900: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 (mutex-lock! *he
3910: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
3920: 20 20 20 20 20 20 28 73 65 74 21 20 6c 61 73 74 (set! last
3930: 2d 61 63 63 65 73 73 20 2a 6c 61 73 74 2d 64 62 -access *last-db
3940: 2d 61 63 63 65 73 73 2a 29 0a 20 20 20 20 20 20 -access*).
3950: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
3960: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
3970: 29 0a 0a 20 20 20 20 20 20 3b 3b 20 28 64 65 62 ).. ;; (deb
3980: 75 67 3a 70 72 69 6e 74 20 31 31 20 22 6c 61 73 ug:print 11 "las
3990: 74 2d 61 63 63 65 73 73 3d 22 20 6c 61 73 74 2d t-access=" last-
39a0: 61 63 63 65 73 73 20 22 2c 20 73 65 72 76 65 72 access ", server
39b0: 2d 74 69 6d 65 6f 75 74 3d 22 20 73 65 72 76 65 -timeout=" serve
39c0: 72 2d 74 69 6d 65 6f 75 74 29 0a 20 20 20 20 20 r-timeout).
39d0: 20 3b 3b 0a 20 20 20 20 20 20 3b 3b 20 6e 6f 5f ;;. ;; no_
39e0: 74 72 61 66 66 69 63 0a 20 20 20 20 20 20 3b 3b traffic. ;;
39f0: 0a 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 . (if (and
3a00: 2a 73 65 72 76 65 72 2d 72 75 6e 2a 0a 09 20 20 *server-run*..
3a10: 20 20 20 20 20 28 3e 20 28 2b 20 6c 61 73 74 2d (> (+ last-
3a20: 61 63 63 65 73 73 20 73 65 72 76 65 72 2d 74 69 access server-ti
3a30: 6d 65 6f 75 74 29 0a 09 09 20 20 28 63 75 72 72 meout)... (curr
3a40: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 ent-seconds)))..
3a50: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 64 (begin.. (d
3a60: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3a70: 30 20 22 53 65 72 76 65 72 20 63 6f 6e 74 69 6e 0 "Server contin
3a80: 75 69 6e 67 2c 20 73 65 63 6f 6e 64 73 20 73 69 uing, seconds si
3a90: 6e 63 65 20 6c 61 73 74 20 64 62 20 61 63 63 65 nce last db acce
3aa0: 73 73 3a 20 22 20 28 2d 20 28 63 75 72 72 65 6e ss: " (- (curren
3ab0: 74 2d 73 65 63 6f 6e 64 73 29 20 6c 61 73 74 2d t-seconds) last-
3ac0: 61 63 63 65 73 73 29 29 0a 09 20 20 20 20 3b 3b access)).. ;;
3ad0: 0a 09 20 20 20 20 3b 3b 20 43 6f 6e 73 69 64 65 .. ;; Conside
3ae0: 72 20 69 6d 70 6c 65 6d 65 6e 74 69 6e 67 20 73 r implementing s
3af0: 6f 6d 65 20 73 6d 61 72 74 73 20 68 65 72 65 20 ome smarts here
3b00: 74 6f 20 72 65 2d 69 6e 73 65 72 74 20 74 68 65 to re-insert the
3b10: 20 72 65 63 6f 72 64 20 6f 72 20 6b 69 6c 6c 20 record or kill
3b20: 73 65 6c 66 20 69 73 0a 09 20 20 20 20 3b 3b 20 self is.. ;;
3b30: 74 68 65 20 64 62 20 69 6e 64 69 63 61 74 65 73 the db indicates
3b40: 20 73 6f 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 so.. ;;..
3b50: 20 3b 3b 20 28 69 66 20 28 74 61 73 6b 73 3a 73 ;; (if (tasks:s
3b60: 65 72 76 65 72 2d 61 6d 2d 69 2d 74 68 65 2d 73 erver-am-i-the-s
3b70: 65 72 76 65 72 3f 20 74 64 62 20 72 75 6e 2d 69 erver? tdb run-i
3b80: 64 29 0a 09 20 20 20 20 3b 3b 20 20 20 20 20 28 d).. ;; (
3b90: 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 73 65 74 tasks:server-set
3ba0: 2d 73 74 61 74 65 21 20 74 64 62 20 73 65 72 76 -state! tdb serv
3bb0: 65 72 2d 69 64 20 22 72 75 6e 6e 69 6e 67 22 29 er-id "running")
3bc0: 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 ).. ;;.. (
3bd0: 6c 6f 6f 70 20 30 20 73 65 72 76 65 72 2d 73 74 loop 0 server-st
3be0: 61 74 65 29 29 0a 09 20 20 28 62 65 67 69 6e 0a ate)).. (begin.
3bf0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
3c00: 74 2d 69 6e 66 6f 20 30 20 22 53 74 61 72 74 69 t-info 0 "Starti
3c10: 6e 67 20 74 6f 20 73 68 75 74 64 6f 77 6e 20 74 ng to shutdown t
3c20: 68 65 20 73 65 72 76 65 72 2e 22 29 0a 09 20 20 he server.")..
3c30: 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 64 65 6c ;; need to del
3c40: 65 74 65 20 6f 6e 6c 79 20 2a 6d 79 2a 20 73 65 ete only *my* se
3c50: 72 76 65 72 20 65 6e 74 72 79 20 28 66 75 74 75 rver entry (futu
3c60: 72 65 20 75 73 65 29 0a 09 20 20 20 20 28 73 65 re use).. (se
3c70: 74 21 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 t! *time-to-exit
3c80: 2a 20 23 74 29 0a 09 20 20 20 20 28 69 66 20 2a * #t).. (if *
3c90: 69 6e 6d 65 6d 64 62 2a 20 28 64 62 3a 73 79 6e inmemdb* (db:syn
3ca0: 63 2d 74 6f 75 63 68 65 64 20 2a 69 6e 6d 65 6d c-touched *inmem
3cb0: 64 62 2a 20 66 6f 72 63 65 2d 73 79 6e 63 3a 20 db* force-sync:
3cc0: 23 74 29 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 #t)).. ;;..
3cd0: 20 20 3b 3b 20 73 74 61 72 74 5f 73 68 75 74 64 ;; start_shutd
3ce0: 6f 77 6e 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 own.. ;;..
3cf0: 20 28 20 74 61 73 6b 73 3a 73 65 72 76 65 72 2d ( tasks:server-
3d00: 73 65 74 2d 73 74 61 74 65 21 20 74 64 62 20 73 set-state! tdb s
3d10: 65 72 76 65 72 2d 69 64 20 22 73 68 75 74 74 69 erver-id "shutti
3d20: 6e 67 2d 64 6f 77 6e 22 29 0a 09 20 20 20 20 28 ng-down").. (
3d30: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 thread-sleep! 5)
3d40: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
3d50: 6e 74 2d 69 6e 66 6f 20 30 20 22 4d 61 78 20 63 nt-info 0 "Max c
3d60: 61 63 68 65 64 20 71 75 65 72 69 65 73 20 77 61 ached queries wa
3d70: 73 20 20 20 20 22 20 2a 6d 61 78 2d 63 61 63 68 s " *max-cach
3d80: 65 2d 73 69 7a 65 2a 29 0a 09 20 20 20 20 28 64 e-size*).. (d
3d90: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3da0: 30 20 22 4e 75 6d 62 65 72 20 6f 66 20 63 61 63 0 "Number of cac
3db0: 68 65 64 20 77 72 69 74 65 73 20 20 20 22 20 2a hed writes " *
3dc0: 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 number-of-writes
3dd0: 2a 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 *).. (debug:p
3de0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 41 76 65 rint-info 0 "Ave
3df0: 72 61 67 65 20 63 61 63 68 65 64 20 77 72 69 74 rage cached writ
3e00: 65 20 74 69 6d 65 20 22 0a 09 09 09 20 20 20 20 e time "....
3e10: 20 20 28 69 66 20 28 65 71 3f 20 2a 6e 75 6d 62 (if (eq? *numb
3e20: 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a 20 30 29 er-of-writes* 0)
3e30: 0a 09 09 09 09 20 20 22 6e 2f 61 20 28 6e 6f 20 ..... "n/a (no
3e40: 77 72 69 74 65 73 29 22 0a 09 09 09 09 20 20 28 writes)"..... (
3e50: 2f 20 2a 77 72 69 74 65 73 2d 74 6f 74 61 6c 2d / *writes-total-
3e60: 64 65 6c 61 79 2a 0a 09 09 09 09 20 20 20 20 20 delay*.....
3e70: 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 *number-of-write
3e80: 73 2a 29 29 0a 09 09 09 20 20 20 20 20 20 22 20 s*)).... "
3e90: 6d 73 22 29 0a 09 20 20 20 20 28 64 65 62 75 67 ms").. (debug
3ea0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 4e :print-info 0 "N
3eb0: 75 6d 62 65 72 20 6e 6f 6e 2d 63 61 63 68 65 64 umber non-cached
3ec0: 20 71 75 65 72 69 65 73 20 22 20 20 2a 6e 75 6d queries " *num
3ed0: 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 ber-non-write-qu
3ee0: 65 72 69 65 73 2a 29 0a 09 20 20 20 20 28 64 65 eries*).. (de
3ef0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
3f00: 20 22 41 76 65 72 61 67 65 20 6e 6f 6e 2d 63 61 "Average non-ca
3f10: 63 68 65 64 20 74 69 6d 65 20 20 20 22 0a 09 09 ched time "...
3f20: 09 20 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 . (if (eq?
3f30: 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 *number-non-writ
3f40: 65 2d 71 75 65 72 69 65 73 2a 20 30 29 0a 09 09 e-queries* 0)...
3f50: 09 09 20 20 22 6e 2f 61 20 28 6e 6f 20 71 75 65 .. "n/a (no que
3f60: 72 69 65 73 29 22 0a 09 09 09 09 20 20 28 2f 20 ries)"..... (/
3f70: 2a 74 6f 74 61 6c 2d 6e 6f 6e 2d 77 72 69 74 65 *total-non-write
3f80: 2d 64 65 6c 61 79 2a 20 0a 09 09 09 09 20 20 20 -delay* .....
3f90: 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 *number-non-wr
3fa0: 69 74 65 2d 71 75 65 72 69 65 73 2a 29 29 0a 09 ite-queries*))..
3fb0: 09 09 20 20 20 20 20 20 22 20 6d 73 22 29 0a 09 .. " ms")..
3fc0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
3fd0: 2d 69 6e 66 6f 20 30 20 22 53 65 72 76 65 72 20 -info 0 "Server
3fe0: 73 68 75 74 64 6f 77 6e 20 63 6f 6d 70 6c 65 74 shutdown complet
3ff0: 65 2e 20 45 78 69 74 69 6e 67 22 29 0a 09 20 20 e. Exiting")..
4000: 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d (tasks:server-
4010: 64 65 6c 65 74 65 2d 72 65 63 6f 72 64 20 74 64 delete-record td
4020: 62 20 73 65 72 76 65 72 2d 69 64 20 22 20 68 74 b server-id " ht
4030: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6b 65 65 tp-transport:kee
4040: 70 2d 72 75 6e 6e 69 6e 67 22 29 0a 09 20 20 20 p-running")..
4050: 20 28 65 78 69 74 29 29 29 29 29 29 0a 0a 3b 3b (exit))))))..;;
4060: 20 61 6c 6c 20 72 6f 75 74 65 73 20 74 68 6f 75 all routes thou
4070: 67 68 20 68 65 72 65 20 65 6e 64 20 69 6e 20 65 gh here end in e
4080: 78 69 74 20 2e 2e 2e 0a 3b 3b 0a 3b 3b 20 73 74 xit ....;;.;; st
4090: 61 72 74 5f 73 65 72 76 65 72 3f 20 0a 3b 3b 0a art_server? .;;.
40a0: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
40b0: 61 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 20 72 ansport:launch r
40c0: 75 6e 2d 69 64 29 0a 20 20 28 73 65 74 21 20 2a un-id). (set! *
40d0: 72 75 6e 2d 69 64 2a 20 20 20 72 75 6e 2d 69 64 run-id* run-id
40e0: 29 0a 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 ). (if (args:ge
40f0: 74 2d 61 72 67 20 22 2d 64 61 65 6d 6f 6e 69 7a t-arg "-daemoniz
4100: 65 22 29 0a 20 20 20 20 20 20 28 64 61 65 6d 6f e"). (daemo
4110: 6e 3a 69 7a 65 29 29 0a 20 20 28 69 66 20 28 73 n:ize)). (if (s
4120: 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 erver:check-if-r
4130: 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 29 0a 20 unning run-id).
4140: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 64 65 (begin..(de
4150: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 49 4e 46 bug:print 0 "INF
4160: 4f 3a 20 53 65 72 76 65 72 20 66 6f 72 20 72 75 O: Server for ru
4170: 6e 2d 69 64 20 22 20 72 75 6e 2d 69 64 20 22 20 n-id " run-id "
4180: 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 22 already running"
4190: 29 0a 09 28 65 78 69 74 20 30 29 29 29 0a 20 20 )..(exit 0))).
41a0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 73 65 72 76 (let loop ((serv
41b0: 65 72 2d 69 64 20 28 6f 70 65 6e 2d 72 75 6e 2d er-id (open-run-
41c0: 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 76 close tasks:serv
41d0: 65 72 2d 6c 6f 63 6b 2d 73 6c 6f 74 20 74 61 73 er-lock-slot tas
41e0: 6b 73 3a 6f 70 65 6e 2d 64 62 20 72 75 6e 2d 69 ks:open-db run-i
41f0: 64 29 29 0a 09 20 20 20 20 20 28 72 65 6d 74 72 d)).. (remtr
4200: 69 65 73 20 20 34 29 29 0a 20 20 20 20 28 69 66 ies 4)). (if
4210: 20 28 6e 6f 74 20 73 65 72 76 65 72 2d 69 64 29 (not server-id)
4220: 0a 09 28 69 66 20 28 3e 20 72 65 6d 74 72 69 65 ..(if (> remtrie
4230: 73 20 30 29 0a 09 20 20 20 20 28 62 65 67 69 6e s 0).. (begin
4240: 0a 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d .. (thread-
4250: 73 6c 65 65 70 21 20 32 29 0a 09 20 20 20 20 20 sleep! 2)..
4260: 20 28 6c 6f 6f 70 20 28 6f 70 65 6e 2d 72 75 6e (loop (open-run
4270: 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 -close tasks:ser
4280: 76 65 72 2d 6c 6f 63 6b 2d 73 6c 6f 74 20 74 61 ver-lock-slot ta
4290: 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 72 75 6e 2d sks:open-db run-
42a0: 69 64 29 0a 09 09 20 20 20 20 28 2d 20 72 65 6d id)... (- rem
42b0: 74 72 69 65 73 20 31 29 29 29 0a 09 20 20 20 20 tries 1)))..
42c0: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 3b 3b (begin.. ;;
42d0: 20 73 69 6e 63 65 20 77 65 20 64 69 64 6e 27 74 since we didn't
42e0: 20 67 65 74 20 74 68 65 20 73 65 72 76 65 72 20 get the server
42f0: 6c 6f 63 6b 20 77 65 20 61 72 65 20 67 6f 69 6e lock we are goin
4300: 67 20 74 6f 20 63 6c 65 61 6e 20 75 70 20 61 6e g to clean up an
4310: 64 20 62 61 69 6c 20 6f 75 74 0a 09 20 20 20 20 d bail out..
4320: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
4330: 6e 66 6f 20 32 20 22 49 4e 46 4f 3a 20 73 65 72 nfo 2 "INFO: ser
4340: 76 65 72 20 70 69 64 3d 22 20 28 63 75 72 72 65 ver pid=" (curre
4350: 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 22 nt-process-id) "
4360: 2c 20 68 6f 73 74 6e 61 6d 65 3d 22 20 28 67 65 , hostname=" (ge
4370: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 20 6e t-host-name) " n
4380: 6f 74 20 73 74 61 72 74 69 6e 67 20 64 75 65 20 ot starting due
4390: 74 6f 20 6f 74 68 65 72 20 63 61 6e 64 69 64 61 to other candida
43a0: 74 65 73 20 61 68 65 61 64 20 69 6e 20 73 74 61 tes ahead in sta
43b0: 72 74 20 71 75 65 75 65 22 29 0a 09 20 20 20 20 rt queue")..
43c0: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
43d0: 65 20 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 64 e tasks:server-d
43e0: 65 6c 65 74 65 2d 72 65 63 6f 72 64 73 2d 66 6f elete-records-fo
43f0: 72 2d 74 68 69 73 2d 70 69 64 20 74 61 73 6b 73 r-this-pid tasks
4400: 3a 6f 70 65 6e 2d 64 62 20 22 20 68 74 74 70 2d :open-db " http-
4410: 74 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 transport:launch
4420: 22 29 0a 09 20 20 20 20 20 20 29 29 0a 09 28 6c ").. ))..(l
4430: 65 74 2a 20 28 28 74 68 32 20 28 6d 61 6b 65 2d et* ((th2 (make-
4440: 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 thread (lambda (
4450: 29 0a 09 09 09 09 20 20 20 28 68 74 74 70 2d 74 )..... (http-t
4460: 72 61 6e 73 70 6f 72 74 3a 72 75 6e 20 0a 09 09 ransport:run ...
4470: 09 09 20 20 20 20 28 69 66 20 28 61 72 67 73 3a .. (if (args:
4480: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
4490: 22 29 0a 09 09 09 09 09 28 61 72 67 73 3a 67 65 ")......(args:ge
44a0: 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 t-arg "-server")
44b0: 0a 09 09 09 09 09 22 2d 22 29 0a 09 09 09 09 20 ......"-").....
44c0: 20 20 20 72 75 6e 2d 69 64 0a 09 09 09 09 20 20 run-id.....
44d0: 20 20 73 65 72 76 65 72 2d 69 64 29 29 20 22 53 server-id)) "S
44e0: 65 72 76 65 72 20 72 75 6e 22 29 29 0a 09 20 20 erver run"))..
44f0: 20 20 20 20 20 28 74 68 33 20 28 6d 61 6b 65 2d (th3 (make-
4500: 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 thread (lambda (
4510: 29 0a 09 09 09 09 20 20 20 28 68 74 74 70 2d 74 )..... (http-t
4520: 72 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 ransport:keep-ru
4530: 6e 6e 69 6e 67 20 73 65 72 76 65 72 2d 69 64 29 nning server-id)
4540: 29 0a 09 09 09 09 20 22 4b 65 65 70 20 72 75 6e )..... "Keep run
4550: 6e 69 6e 67 22 29 29 29 0a 09 20 20 3b 3b 20 44 ning"))).. ;; D
4560: 61 74 61 62 61 73 65 20 63 6f 6e 6e 65 63 74 69 atabase connecti
4570: 6f 6e 0a 09 20 20 28 73 65 74 21 20 2a 69 6e 6d on.. (set! *inm
4580: 65 6d 64 62 2a 20 20 28 64 62 3a 73 65 74 75 70 emdb* (db:setup
4590: 20 72 75 6e 2d 69 64 29 29 0a 09 20 20 28 74 68 run-id)).. (th
45a0: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 read-start! th2)
45b0: 0a 09 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 .. (thread-star
45c0: 74 21 20 74 68 33 29 0a 09 20 20 28 73 65 74 21 t! th3).. (set!
45d0: 20 2a 64 69 64 73 6f 6d 65 74 68 69 6e 67 2a 20 *didsomething*
45e0: 23 74 29 0a 09 20 20 28 74 68 72 65 61 64 2d 6a #t).. (thread-j
45f0: 6f 69 6e 21 20 74 68 32 29 0a 09 20 20 28 65 78 oin! th2).. (ex
4600: 69 74 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 it)))))..(define
4610: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
4620: 3a 73 65 72 76 65 72 2d 73 69 67 6e 61 6c 2d 68 :server-signal-h
4630: 61 6e 64 6c 65 72 20 73 69 67 6e 75 6d 29 0a 20 andler signum).
4640: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
4650: 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 64 ons. exn. (d
4660: 65 62 75 67 3a 70 72 69 6e 74 20 22 20 2e 2e 2e ebug:print " ...
4670: 20 65 78 69 74 69 6e 67 20 2e 2e 2e 22 29 0a 20 exiting ...").
4680: 20 20 28 6c 65 74 20 28 28 74 68 31 20 28 6d 61 (let ((th1 (ma
4690: 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 ke-thread (lambd
46a0: 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 74 68 a ().... (th
46b0: 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 29 0a read-sleep! 1)).
46c0: 09 09 09 20 20 20 22 65 61 74 20 72 65 73 70 6f ... "eat respo
46d0: 6e 73 65 22 29 29 0a 09 20 28 74 68 32 20 28 6d nse")).. (th2 (m
46e0: 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 ake-thread (lamb
46f0: 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 64 da ().... (d
4700: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
4710: 52 4f 52 3a 20 52 65 63 65 69 76 65 64 20 5e 43 ROR: Received ^C
4720: 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 63 6c 65 , attempting cle
4730: 61 6e 20 65 78 69 74 2e 20 50 6c 65 61 73 65 20 an exit. Please
4740: 62 65 20 70 61 74 69 65 6e 74 20 61 6e 64 20 77 be patient and w
4750: 61 69 74 20 61 20 66 65 77 20 73 65 63 6f 6e 64 ait a few second
4760: 73 20 62 65 66 6f 72 65 20 68 69 74 74 69 6e 67 s before hitting
4770: 20 5e 43 20 61 67 61 69 6e 2e 22 29 0a 09 09 09 ^C again.")....
4780: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
4790: 65 70 21 20 33 29 20 3b 3b 20 67 69 76 65 20 74 ep! 3) ;; give t
47a0: 68 65 20 66 6c 75 73 68 20 74 68 72 65 65 20 73 he flush three s
47b0: 65 63 6f 6e 64 73 20 74 6f 20 64 6f 20 69 74 27 econds to do it'
47c0: 73 20 73 74 75 66 66 0a 09 09 09 20 20 20 20 20 s stuff....
47d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
47e0: 20 20 20 20 20 20 20 44 6f 6e 65 2e 22 29 0a 09 Done.")..
47f0: 09 09 20 20 20 20 20 28 65 78 69 74 20 34 29 29 .. (exit 4))
4800: 0a 09 09 09 20 20 20 22 65 78 69 74 20 6f 6e 20 .... "exit on
4810: 5e 43 20 74 69 6d 65 72 22 29 29 29 0a 20 20 20 ^C timer"))).
4820: 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 (thread-start!
4830: 20 74 68 32 29 0a 20 20 20 20 20 28 74 68 72 65 th2). (thre
4840: 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a 20 ad-start! th1).
4850: 20 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e (thread-join
4860: 21 20 74 68 32 29 29 29 29 0a 0a 3b 3b 3d 3d 3d ! th2))))..;;===
4870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
48a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
48b0: 3d 3d 3d 0a 3b 3b 20 77 65 62 20 70 61 67 65 73 ===.;; web pages
48c0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
48d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
48e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
48f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
4910: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
4920: 72 74 3a 6d 61 69 6e 2d 70 61 67 65 29 0a 20 20 rt:main-page).
4930: 28 6c 65 74 20 28 28 6c 69 6e 6b 70 61 74 68 20 (let ((linkpath
4940: 28 72 6f 6f 74 2d 70 61 74 68 29 29 29 0a 20 20 (root-path))).
4950: 20 20 28 63 6f 6e 63 20 22 3c 68 65 61 64 3e 3c (conc "<head><
4960: 68 31 3e 22 20 28 70 61 74 68 6e 61 6d 65 2d 73 h1>" (pathname-s
4970: 74 72 69 70 2d 64 69 72 65 63 74 6f 72 79 20 2a trip-directory *
4980: 74 6f 70 70 61 74 68 2a 29 20 22 3c 2f 68 31 3e toppath*) "</h1>
4990: 3c 2f 68 65 61 64 3e 22 0a 09 20 20 22 3c 62 6f </head>".. "<bo
49a0: 64 79 3e 22 0a 09 20 20 22 52 75 6e 20 61 72 65 dy>".. "Run are
49b0: 61 3a 20 22 20 2a 74 6f 70 70 61 74 68 2a 0a 09 a: " *toppath*..
49c0: 20 20 22 3c 68 32 3e 53 65 72 76 65 72 20 53 74 "<h2>Server St
49d0: 61 74 73 3c 2f 68 32 3e 22 0a 09 20 20 28 68 74 ats</h2>".. (ht
49e0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 74 61 tp-transport:sta
49f0: 74 73 2d 74 61 62 6c 65 29 20 0a 09 20 20 22 3c ts-table) .. "<
4a00: 68 72 3e 22 0a 09 20 20 28 68 74 74 70 2d 74 72 hr>".. (http-tr
4a10: 61 6e 73 70 6f 72 74 3a 72 75 6e 73 20 6c 69 6e ansport:runs lin
4a20: 6b 70 61 74 68 29 0a 09 20 20 22 3c 68 72 3e 22 kpath).. "<hr>"
4a30: 0a 09 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 .. (http-transp
4a40: 6f 72 74 3a 72 75 6e 2d 73 74 61 74 73 29 0a 09 ort:run-stats)..
4a50: 20 20 22 3c 2f 62 6f 64 79 3e 22 0a 09 20 20 29 "</body>".. )
4a60: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 ))..(define (htt
4a70: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 74 61 74 p-transport:stat
4a80: 73 2d 74 61 62 6c 65 29 0a 20 20 28 6d 75 74 65 s-table). (mute
4a90: 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 x-lock! *heartbe
4aa0: 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 28 6c 65 at-mutex*). (le
4ab0: 74 20 28 28 72 65 73 20 0a 09 20 28 63 6f 6e 63 t ((res .. (conc
4ac0: 20 22 3c 74 61 62 6c 65 3e 22 0a 09 20 20 20 20 "<table>"..
4ad0: 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4d 61 78 20 "<tr><td>Max
4ae0: 63 61 63 68 65 64 20 71 75 65 72 69 65 73 3c 2f cached queries</
4af0: 74 64 3e 20 20 20 20 20 20 20 20 3c 74 64 3e 22 td> <td>"
4b00: 20 2a 6d 61 78 2d 63 61 63 68 65 2d 73 69 7a 65 *max-cache-size
4b10: 2a 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 * "</td></tr>"..
4b20: 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e "<tr><td>
4b30: 4e 75 6d 62 65 72 20 6f 66 20 63 61 63 68 65 64 Number of cached
4b40: 20 77 72 69 74 65 73 3c 2f 74 64 3e 20 20 20 3c writes</td> <
4b50: 74 64 3e 22 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d td>" *number-of-
4b60: 77 72 69 74 65 73 2a 20 22 3c 2f 74 64 3e 3c 2f writes* "</td></
4b70: 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c 74 tr>".. "<t
4b80: 72 3e 3c 74 64 3e 41 76 65 72 61 67 65 20 63 61 r><td>Average ca
4b90: 63 68 65 64 20 77 72 69 74 65 20 74 69 6d 65 3c ched write time<
4ba0: 2f 74 64 3e 20 3c 74 64 3e 22 20 28 69 66 20 28 /td> <td>" (if (
4bb0: 65 71 3f 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 eq? *number-of-w
4bc0: 72 69 74 65 73 2a 20 30 29 0a 09 09 09 09 09 09 rites* 0).......
4bd0: 09 09 20 22 6e 2f 61 20 28 6e 6f 20 77 72 69 74 .. "n/a (no writ
4be0: 65 73 29 22 0a 09 09 09 09 09 09 09 09 20 28 2f es)"......... (/
4bf0: 20 2a 77 72 69 74 65 73 2d 74 6f 74 61 6c 2d 64 *writes-total-d
4c00: 65 6c 61 79 2a 0a 09 09 09 09 09 09 09 09 20 20 elay*.........
4c10: 20 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 *number-of-wri
4c20: 74 65 73 2a 29 29 0a 09 20 20 20 20 20 20 20 22 tes*)).. "
4c30: 20 6d 73 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 ms</td></tr>"..
4c40: 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e "<tr><td>
4c50: 4e 75 6d 62 65 72 20 6e 6f 6e 2d 63 61 63 68 65 Number non-cache
4c60: 64 20 71 75 65 72 69 65 73 3c 2f 74 64 3e 20 3c d queries</td> <
4c70: 74 64 3e 22 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f td>" *number-no
4c80: 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a n-write-queries*
4c90: 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 "</td></tr>"..
4ca0: 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 41 "<tr><td>A
4cb0: 76 65 72 61 67 65 20 6e 6f 6e 2d 63 61 63 68 65 verage non-cache
4cc0: 64 20 74 69 6d 65 3c 2f 74 64 3e 20 20 20 3c 74 d time</td> <t
4cd0: 64 3e 22 20 28 69 66 20 28 65 71 3f 20 2a 6e 75 d>" (if (eq? *nu
4ce0: 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 mber-non-write-q
4cf0: 75 65 72 69 65 73 2a 20 30 29 0a 09 09 09 09 09 ueries* 0)......
4d00: 09 09 09 20 22 6e 2f 61 20 28 6e 6f 20 71 75 65 ... "n/a (no que
4d10: 72 69 65 73 29 22 0a 09 09 09 09 09 09 09 09 20 ries)".........
4d20: 28 2f 20 2a 74 6f 74 61 6c 2d 6e 6f 6e 2d 77 72 (/ *total-non-wr
4d30: 69 74 65 2d 64 65 6c 61 79 2a 20 0a 09 09 09 09 ite-delay* .....
4d40: 09 09 09 09 20 20 20 20 2a 6e 75 6d 62 65 72 2d .... *number-
4d50: 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 non-write-querie
4d60: 73 2a 29 29 0a 09 20 20 20 20 20 20 20 22 20 6d s*)).. " m
4d70: 73 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 s</td></tr>"..
4d80: 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4c 61 "<tr><td>La
4d90: 73 74 20 61 63 63 65 73 73 3c 2f 74 64 3e 3c 74 st access</td><t
4da0: 64 3e 22 20 20 20 20 20 20 20 20 20 20 20 20 20 d>"
4db0: 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d (seconds->time-
4dc0: 73 74 72 69 6e 67 20 2a 6c 61 73 74 2d 64 62 2d string *last-db-
4dd0: 61 63 63 65 73 73 2a 29 20 22 3c 2f 74 64 3e 3c access*) "</td><
4de0: 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c /tr>".. "<
4df0: 2f 74 61 62 6c 65 3e 22 29 29 29 0a 20 20 20 20 /table>"))).
4e00: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
4e10: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
4e20: 29 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 ). res))..(de
4e30: 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
4e40: 70 6f 72 74 3a 72 75 6e 73 20 6c 69 6e 6b 70 61 port:runs linkpa
4e50: 74 68 29 0a 20 20 28 63 6f 6e 63 20 22 3c 68 33 th). (conc "<h3
4e60: 3e 52 75 6e 73 3c 2f 68 33 3e 22 0a 09 28 73 74 >Runs</h3>"..(st
4e70: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
4e80: 0a 09 20 28 6c 65 74 20 28 28 66 69 6c 65 73 20 .. (let ((files
4e90: 28 6d 61 70 20 70 61 74 68 6e 61 6d 65 2d 73 74 (map pathname-st
4ea0: 72 69 70 2d 64 69 72 65 63 74 6f 72 79 20 28 67 rip-directory (g
4eb0: 6c 6f 62 20 28 63 6f 6e 63 20 6c 69 6e 6b 70 61 lob (conc linkpa
4ec0: 74 68 20 22 2f 2a 22 29 29 29 29 29 0a 09 20 20 th "/*")))))..
4ed0: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 70 (map (lambda (p
4ee0: 29 0a 09 09 20 20 28 63 6f 6e 63 20 22 3c 61 20 )... (conc "<a
4ef0: 68 72 65 66 3d 5c 22 22 20 70 20 22 5c 22 3e 22 href=\"" p "\">"
4f00: 20 70 20 22 3c 2f 61 3e 3c 62 72 3e 22 29 29 0a p "</a><br>")).
4f10: 09 09 66 69 6c 65 73 29 29 0a 09 20 22 20 22 29 ..files)).. " ")
4f20: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 ))..(define (htt
4f30: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 2d p-transport:run-
4f40: 73 74 61 74 73 29 0a 20 20 28 6c 65 74 20 28 28 stats). (let ((
4f50: 73 74 61 74 73 20 28 6f 70 65 6e 2d 72 75 6e 2d stats (open-run-
4f60: 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 72 75 6e close db:get-run
4f70: 6e 69 6e 67 2d 73 74 61 74 73 20 23 66 29 29 29 ning-stats #f)))
4f80: 0a 20 20 20 20 28 63 6f 6e 63 20 22 3c 74 61 62 . (conc "<tab
4f90: 6c 65 3e 22 0a 09 20 20 28 73 74 72 69 6e 67 2d le>".. (string-
4fa0: 69 6e 74 65 72 73 70 65 72 73 65 0a 09 20 20 20 intersperse..
4fb0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 73 74 (map (lambda (st
4fc0: 61 74 29 0a 09 09 20 20 28 63 6f 6e 63 20 22 3c at)... (conc "<
4fd0: 74 72 3e 3c 74 64 3e 22 20 28 63 61 72 20 73 74 tr><td>" (car st
4fe0: 61 74 29 20 22 3c 2f 74 64 3e 3c 74 64 3e 22 20 at) "</td><td>"
4ff0: 28 63 61 64 72 20 73 74 61 74 29 20 22 3c 2f 74 (cadr stat) "</t
5000: 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 73 74 61 d></tr>"))...sta
5010: 74 73 29 0a 09 20 20 20 22 20 22 29 0a 09 20 20 ts).. " ")..
5020: 22 3c 2f 74 61 62 6c 65 3e 22 29 29 29 0a "</table>"))).