Artifact
d2de8d2ff63fc8ff4cdd4f219a9728caf5de55cf:
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 3b 3b 20 28 28 65 71 75 61 6c 3f 20 .. ;; ((equal?
0dd0: 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 (uri-path (reque
0de0: 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d st-uri (current-
0df0: 72 65 71 75 65 73 74 29 29 29 0a 09 09 09 09 20 request))).....
0e00: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 27 28 2f ;; '(/
0e10: 20 22 63 74 72 6c 22 29 29 0a 09 09 09 09 20 20 "ctrl")).....
0e20: 3b 3b 20 20 28 6c 65 74 2a 20 28 28 70 61 63 6b ;; (let* ((pack
0e30: 65 74 20 28 64 62 3a 73 74 72 69 6e 67 2d 3e 6f et (db:string->o
0e40: 62 6a 20 64 61 74 29 29 0a 09 09 09 09 20 20 3b bj dat))..... ;
0e50: 3b 20 20 20 20 20 20 20 20 20 28 71 74 79 70 65 ; (qtype
0e60: 20 20 28 63 64 62 3a 70 61 63 6b 65 74 2d 67 65 (cdb:packet-ge
0e70: 74 2d 71 74 79 70 65 20 70 61 63 6b 65 74 29 29 t-qtype packet))
0e80: 29 0a 09 09 09 09 20 20 3b 3b 20 20 20 20 28 64 )..... ;; (d
0e90: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
0ea0: 31 32 20 22 73 65 72 76 65 72 3d 3e 20 72 65 63 12 "server=> rec
0eb0: 65 69 76 65 64 20 70 61 63 6b 65 74 3d 22 20 70 eived packet=" p
0ec0: 61 63 6b 65 74 29 0a 09 09 09 09 20 20 3b 3b 20 acket)..... ;;
0ed0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6d 65 6d (if (not (mem
0ee0: 62 65 72 20 71 74 79 70 65 20 27 28 73 79 6e 63 ber qtype '(sync
0ef0: 20 70 69 6e 67 29 29 29 0a 09 09 09 09 20 20 3b ping)))..... ;
0f00: 3b 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a ; (begin.
0f10: 09 09 09 09 20 20 3b 3b 20 20 20 20 20 20 20 20 .... ;;
0f20: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
0f30: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
0f40: 29 0a 09 09 09 09 20 20 3b 3b 20 20 20 20 20 20 )..... ;;
0f50: 20 20 20 20 28 73 65 74 21 20 2a 6c 61 73 74 2d (set! *last-
0f60: 64 62 2d 61 63 63 65 73 73 2a 20 28 63 75 72 72 db-access* (curr
0f70: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 ent-seconds))...
0f80: 09 09 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 .. ;;
0f90: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
0fa0: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
0fb0: 29 29 29 0a 09 09 09 09 20 20 3b 3b 20 20 20 20 )))..... ;;
0fc0: 3b 3b 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 ;; (mutex-lock!
0fd0: 2a 64 62 3a 70 72 6f 63 65 73 73 2d 71 75 65 75 *db:process-queu
0fe0: 65 2d 6d 75 74 65 78 2a 29 20 3b 3b 20 74 72 79 e-mutex*) ;; try
0ff0: 69 6e 67 20 61 20 6d 75 74 65 78 0a 09 09 09 09 ing a mutex.....
1000: 20 20 3b 3b 20 20 20 20 3b 3b 20 28 73 65 74 21 ;; ;; (set!
1010: 20 72 65 73 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 res (open-run-c
1020: 6c 6f 73 65 20 64 62 3a 70 72 6f 63 65 73 73 2d lose db:process-
1030: 71 75 65 75 65 2d 69 74 65 6d 20 6f 70 65 6e 2d queue-item open-
1040: 64 62 20 70 61 63 6b 65 74 29 29 0a 09 09 09 09 db packet)).....
1050: 20 20 3b 3b 20 20 20 20 28 73 65 74 21 20 72 65 ;; (set! re
1060: 73 20 28 64 62 3a 70 72 6f 63 65 73 73 2d 71 75 s (db:process-qu
1070: 65 75 65 2d 69 74 65 6d 20 64 62 20 70 61 63 6b eue-item db pack
1080: 65 74 29 29 0a 09 09 09 09 20 20 3b 3b 20 20 20 et))..... ;;
1090: 20 3b 3b 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 ;; (mutex-unloc
10a0: 6b 21 20 2a 64 62 3a 70 72 6f 63 65 73 73 2d 71 k! *db:process-q
10b0: 75 65 75 65 2d 6d 75 74 65 78 2a 29 0a 09 09 09 ueue-mutex*)....
10c0: 09 20 20 3b 3b 20 20 20 20 28 64 65 62 75 67 3a . ;; (debug:
10d0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 31 20 22 52 print-info 11 "R
10e0: 65 74 75 72 6e 20 76 61 6c 75 65 20 66 72 6f 6d eturn value from
10f0: 20 64 62 3a 70 72 6f 63 65 73 73 2d 71 75 65 75 db:process-queu
1100: 65 2d 69 74 65 6d 20 69 73 20 22 20 72 65 73 29 e-item is " res)
1110: 0a 09 09 09 09 20 20 3b 3b 20 20 20 20 28 73 65 ..... ;; (se
1120: 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 nd-response body
1130: 3a 20 28 63 6f 6e 63 20 22 3c 68 65 61 64 3e 63 : (conc "<head>c
1140: 74 72 6c 20 64 61 74 61 3c 2f 68 65 61 64 3e 5c trl data</head>\
1150: 6e 3c 62 6f 64 79 3e 22 0a 09 09 09 09 20 20 3b n<body>"..... ;
1160: 3b 20 20 20 20 20 20 20 09 09 09 72 65 73 0a 09 ; ...res..
1170: 09 09 09 20 20 3b 3b 20 20 20 20 20 20 20 09 09 ... ;; ..
1180: 09 22 3c 2f 62 6f 64 79 3e 22 29 0a 09 09 09 09 ."</body>").....
1190: 20 20 3b 3b 20 20 20 20 20 20 20 09 20 20 20 20 ;; .
11a0: 68 65 61 64 65 72 73 3a 20 27 28 28 63 6f 6e 74 headers: '((cont
11b0: 65 6e 74 2d 74 79 70 65 20 74 65 78 74 2f 70 6c ent-type text/pl
11c0: 61 69 6e 29 29 29 29 29 0a 09 09 09 09 20 20 28 ain)))))..... (
11d0: 28 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 (equal? (uri-pat
11e0: 68 20 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 h (request-uri (
11f0: 63 75 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 current-request)
1200: 29 29 20 0a 09 09 09 09 09 20 20 20 27 28 2f 20 )) ...... '(/
1210: 22 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e ""))..... (sen
1220: 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a d-response body:
1230: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
1240: 3a 6d 61 69 6e 2d 70 61 67 65 29 29 29 0a 09 09 :main-page)))...
1250: 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 .. ((equal? (ur
1260: 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 2d i-path (request-
1270: 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 uri (current-req
1280: 75 65 73 74 29 29 29 20 0a 09 09 09 09 09 20 20 uest))) ......
1290: 20 27 28 2f 20 22 72 75 6e 73 22 29 29 0a 09 09 '(/ "runs"))...
12a0: 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f .. (send-respo
12b0: 6e 73 65 20 62 6f 64 79 3a 20 28 68 74 74 70 2d nse body: (http-
12c0: 74 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 transport:main-p
12d0: 61 67 65 29 29 29 0a 09 09 09 09 20 20 28 28 65 age)))..... ((e
12e0: 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 qual? (uri-path
12f0: 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 (request-uri (cu
1300: 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 rrent-request)))
1310: 20 0a 09 09 09 09 09 20 20 20 27 28 2f 20 61 6e ...... '(/ an
1320: 79 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e 64 y))..... (send
1330: 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 -response body:
1340: 22 68 65 79 20 74 68 65 72 65 21 5c 6e 22 0a 09 "hey there!\n"..
1350: 09 09 09 09 09 20 20 68 65 61 64 65 72 73 3a 20 ..... headers:
1360: 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 '((content-type
1370: 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 29 0a 09 text/plain))))..
1380: 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 ... ((equal? (u
1390: 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 ri-path (request
13a0: 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 -uri (current-re
13b0: 71 75 65 73 74 29 29 29 20 0a 09 09 09 09 09 20 quest))) ......
13c0: 20 20 27 28 2f 20 22 68 65 79 22 29 29 0a 09 09 '(/ "hey"))...
13d0: 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f .. (send-respo
13e0: 6e 73 65 20 62 6f 64 79 3a 20 22 68 65 79 20 74 nse body: "hey t
13f0: 68 65 72 65 21 5c 6e 22 0a 09 09 09 09 09 09 20 here!\n".......
1400: 20 68 65 61 64 65 72 73 3a 20 27 28 28 63 6f 6e headers: '((con
1410: 74 65 6e 74 2d 74 79 70 65 20 74 65 78 74 2f 70 tent-type text/p
1420: 6c 61 69 6e 29 29 29 29 0a 09 09 09 09 20 20 28 lain))))..... (
1430: 65 6c 73 65 20 28 63 6f 6e 74 69 6e 75 65 29 29 else (continue))
1440: 29 29 29 29 29 29 0a 20 20 20 20 28 68 74 74 70 )))))). (http
1450: 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 -transport:try-s
1460: 74 61 72 74 2d 73 65 72 76 65 72 20 72 75 6e 2d tart-server run-
1470: 69 64 20 69 70 61 64 64 72 73 74 72 20 73 74 61 id ipaddrstr sta
1480: 72 74 2d 70 6f 72 74 20 73 65 72 76 65 72 2d 69 rt-port server-i
1490: 64 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 69 73 d)))..;; This is
14a0: 20 72 65 63 75 72 73 69 76 65 6c 79 20 72 75 6e recursively run
14b0: 20 62 79 20 68 74 74 70 2d 74 72 61 6e 73 70 6f by http-transpo
14c0: 72 74 3a 72 75 6e 20 75 6e 74 69 6c 20 73 75 63 rt:run until suc
14d0: 65 73 73 66 75 6c 0a 3b 3b 0a 28 64 65 66 69 6e essful.;;.(defin
14e0: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
14f0: 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 76 t:try-start-serv
1500: 65 72 20 72 75 6e 2d 69 64 20 69 70 61 64 64 72 er run-id ipaddr
1510: 73 74 72 20 70 6f 72 74 6e 75 6d 20 73 65 72 76 str portnum serv
1520: 65 72 2d 69 64 29 0a 20 20 28 68 61 6e 64 6c 65 er-id). (handle
1530: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 -exceptions. e
1540: 78 6e 0a 20 20 20 28 62 65 67 69 6e 0a 20 20 20 xn. (begin.
1550: 20 20 28 70 72 69 6e 74 2d 65 72 72 6f 72 2d 6d (print-error-m
1560: 65 73 73 61 67 65 20 65 78 6e 29 0a 20 20 20 20 essage exn).
1570: 20 28 69 66 20 28 3c 20 70 6f 72 74 6e 75 6d 20 (if (< portnum
1580: 39 30 30 30 29 0a 09 20 28 62 65 67 69 6e 20 0a 9000).. (begin .
1590: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
15a0: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 66 61 69 0 "WARNING: fai
15b0: 6c 65 64 20 74 6f 20 73 74 61 72 74 20 6f 6e 20 led to start on
15c0: 70 6f 72 74 6e 75 6d 3a 20 22 20 70 6f 72 74 6e portnum: " portn
15d0: 75 6d 20 22 2c 20 74 72 79 69 6e 67 20 6e 65 78 um ", trying nex
15e0: 74 20 70 6f 72 74 22 29 0a 09 20 20 20 28 74 68 t port").. (th
15f0: 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 31 29 read-sleep! 0.1)
1600: 0a 0a 09 20 20 20 3b 3b 20 67 65 74 5f 6e 65 78 ... ;; get_nex
1610: 74 5f 70 6f 72 74 20 67 6f 65 73 20 68 65 72 65 t_port goes here
1620: 0a 0a 09 20 20 20 28 68 74 74 70 2d 74 72 61 6e ... (http-tran
1630: 73 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 74 2d sport:try-start-
1640: 73 65 72 76 65 72 20 72 75 6e 2d 69 64 20 69 70 server run-id ip
1650: 61 64 64 72 73 74 72 20 28 2b 20 70 6f 72 74 6e addrstr (+ portn
1660: 75 6d 20 31 29 20 73 65 72 76 65 72 2d 69 64 29 um 1) server-id)
1670: 29 0a 09 20 28 62 65 67 69 6e 0a 09 20 20 20 28 ).. (begin.. (
1680: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 open-run-close t
1690: 61 73 6b 73 3a 73 65 72 76 65 72 2d 66 6f 72 63 asks:server-forc
16a0: 65 2d 63 6c 65 61 6e 2d 72 75 6e 2d 72 65 63 6f e-clean-run-reco
16b0: 72 64 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 rd tasks:open-db
16c0: 20 72 75 6e 2d 69 64 20 69 70 61 64 64 72 73 74 run-id ipaddrst
16d0: 72 20 70 6f 72 74 6e 75 6d 20 22 20 68 74 74 70 r portnum " http
16e0: 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 -transport:try-s
16f0: 74 61 72 74 2d 73 65 72 76 65 72 22 29 0a 09 20 tart-server")..
1700: 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a (print "ERROR:
1710: 20 54 72 69 65 64 20 61 6e 64 20 74 72 69 65 64 Tried and tried
1720: 20 62 75 74 20 63 6f 75 6c 64 20 6e 6f 74 20 73 but could not s
1730: 74 61 72 74 20 74 68 65 20 73 65 72 76 65 72 22 tart the server"
1740: 29 29 29 29 0a 20 20 20 3b 3b 20 61 6e 79 20 65 )))). ;; any e
1750: 72 72 6f 72 20 69 6e 20 66 6f 6c 6c 6f 77 69 6e rror in followin
1760: 67 20 73 74 65 70 73 20 77 69 6c 6c 20 72 65 73 g steps will res
1770: 75 6c 74 20 69 6e 20 61 20 72 65 74 72 79 0a 20 ult in a retry.
1780: 20 20 28 73 65 74 21 20 2a 73 65 72 76 65 72 2d (set! *server-
1790: 69 6e 66 6f 2a 20 28 6c 69 73 74 20 69 70 61 64 info* (list ipad
17a0: 64 72 73 74 72 20 70 6f 72 74 6e 75 6d 29 29 0a drstr portnum)).
17b0: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
17c0: 73 65 20 74 61 73 6b 73 3a 73 65 72 76 65 72 2d se tasks:server-
17d0: 73 65 74 2d 69 6e 74 65 72 66 61 63 65 2d 70 6f set-interface-po
17e0: 72 74 20 0a 09 09 20 20 20 74 61 73 6b 73 3a 6f rt ... tasks:o
17f0: 70 65 6e 2d 64 62 20 0a 09 09 20 20 20 73 65 72 pen-db ... ser
1800: 76 65 72 2d 69 64 20 0a 09 09 20 20 20 69 70 61 ver-id ... ipa
1810: 64 64 72 73 74 72 20 70 6f 72 74 6e 75 6d 29 0a ddrstr portnum).
1820: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
1830: 31 20 22 49 4e 46 4f 3a 20 54 72 79 69 6e 67 20 1 "INFO: Trying
1840: 74 6f 20 73 74 61 72 74 20 73 65 72 76 65 72 20 to start server
1850: 6f 6e 20 22 20 69 70 61 64 64 72 73 74 72 20 22 on " ipaddrstr "
1860: 3a 22 20 70 6f 72 74 6e 75 6d 29 0a 20 20 20 3b :" portnum). ;
1870: 3b 20 54 68 69 73 20 73 74 61 72 74 73 20 74 68 ; This starts th
1880: 65 20 73 70 69 66 66 79 20 73 65 72 76 65 72 0a e spiffy server.
1890: 20 20 20 3b 3b 20 4e 45 45 44 20 57 41 59 20 54 ;; NEED WAY T
18a0: 4f 20 53 45 54 20 49 50 20 54 4f 20 23 66 20 54 O SET IP TO #f T
18b0: 4f 20 42 49 4e 44 20 41 4c 4c 0a 20 20 20 3b 3b O BIND ALL. ;;
18c0: 20 28 73 74 61 72 74 2d 73 65 72 76 65 72 20 62 (start-server b
18d0: 69 6e 64 2d 61 64 64 72 65 73 73 3a 20 69 70 61 ind-address: ipa
18e0: 64 64 72 73 74 72 20 70 6f 72 74 3a 20 70 6f 72 ddrstr port: por
18f0: 74 6e 75 6d 29 0a 20 20 20 28 73 74 61 72 74 2d tnum). (start-
1900: 73 65 72 76 65 72 20 70 6f 72 74 3a 20 70 6f 72 server port: por
1910: 74 6e 75 6d 29 0a 20 20 20 28 6f 70 65 6e 2d 72 tnum). (open-r
1920: 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 un-close tasks:s
1930: 65 72 76 65 72 2d 66 6f 72 63 65 2d 63 6c 65 61 erver-force-clea
1940: 6e 2d 72 75 6e 2d 72 65 63 6f 72 64 20 74 61 73 n-run-record tas
1950: 6b 73 3a 6f 70 65 6e 2d 64 62 20 72 75 6e 2d 69 ks:open-db run-i
1960: 64 20 69 70 61 64 64 72 73 74 72 20 70 6f 72 74 d ipaddrstr port
1970: 6e 75 6d 20 22 20 68 74 74 70 2d 74 72 61 6e 73 num " http-trans
1980: 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 port:try-start-s
1990: 65 72 76 65 72 22 29 0a 20 20 20 28 64 65 62 75 erver"). (debu
19a0: 67 3a 70 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a g:print 1 "INFO:
19b0: 20 73 65 72 76 65 72 20 68 61 73 20 62 65 65 6e server has been
19c0: 20 73 74 6f 70 70 65 64 22 29 29 29 0a 0a 3b 3b stopped")))..;;
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 3d 3d 3d 3d 3d ================
1a10: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 20 ======.;; S E R
1a20: 56 20 45 20 52 20 20 20 55 20 54 20 49 20 4c 20 V E R U T I L
1a30: 49 20 54 20 49 20 45 20 53 20 0a 3b 3b 3d 3d 3d I T I E S .;;===
1a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a80: 3d 3d 3d 0a 0a 3b 3b 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 3d ================
1ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
1ad0: 20 43 20 4c 20 49 20 45 20 4e 20 54 20 53 0a 3b C L I E N T S.;
1ae0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
1af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b20: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
1b30: 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 20 28 6d *http-mutex* (m
1b40: 61 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 3b 3b 20 ake-mutex))..;;
1b50: 4e 4f 54 45 3a 20 4c 61 72 67 65 20 62 6c 6f 63 NOTE: Large bloc
1b60: 6b 20 6f 66 20 63 6f 64 65 20 66 72 6f 6d 20 33 k of code from 3
1b70: 32 34 33 36 62 34 32 36 31 38 38 30 38 30 66 37 2436b426188080f7
1b80: 32 66 63 65 62 36 38 39 34 61 66 35 34 31 66 62 2fceb6894af541fb
1b90: 61 64 39 39 32 31 65 20 72 65 6d 6f 76 65 64 20 ad9921e removed
1ba0: 68 65 72 65 0a 3b 3b 20 20 20 20 20 20 20 49 27 here.;; I'
1bb0: 6d 20 70 72 65 74 74 79 20 73 75 72 65 20 69 74 m pretty sure it
1bc0: 20 69 73 20 64 65 66 75 6e 63 74 2e 0a 0a 3b 3b is defunct...;;
1bd0: 20 54 68 69 73 20 6e 65 78 74 20 62 6c 6f 63 6b This next block
1be0: 20 61 6c 6c 20 69 6d 70 6f 72 74 65 64 20 65 6e all imported en
1bf0: 2d 6d 61 73 73 20 66 72 6f 6d 20 74 68 65 20 61 -mass from the a
1c00: 70 69 20 62 72 61 6e 63 68 0a 28 64 65 66 69 6e pi branch.(defin
1c10: 65 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 e *http-requests
1c20: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 30 29 -in-progress* 0)
1c30: 0a 28 64 65 66 69 6e 65 20 2a 68 74 74 70 2d 63 .(define *http-c
1c40: 6f 6e 6e 65 63 74 69 6f 6e 73 2d 6e 65 78 74 2d onnections-next-
1c50: 63 6c 65 61 6e 75 70 2a 20 28 63 75 72 72 65 6e cleanup* (curren
1c60: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 0a 28 64 65 t-seconds))..(de
1c70: 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
1c80: 70 6f 72 74 3a 67 65 74 2d 74 69 6d 65 2d 74 6f port:get-time-to
1c90: 2d 63 6c 65 61 6e 75 70 29 0a 20 20 28 6c 65 74 -cleanup). (let
1ca0: 20 28 28 72 65 73 20 23 66 29 29 0a 20 20 20 20 ((res #f)).
1cb0: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 (mutex-lock! *ht
1cc0: 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 28 tp-mutex*). (
1cd0: 73 65 74 21 20 72 65 73 20 28 3e 20 28 63 75 72 set! res (> (cur
1ce0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 2a 68 rent-seconds) *h
1cf0: 74 74 70 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 2d ttp-connections-
1d00: 6e 65 78 74 2d 63 6c 65 61 6e 75 70 2a 29 29 0a next-cleanup*)).
1d10: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
1d20: 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 k! *http-mutex*)
1d30: 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 . res))..(def
1d40: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
1d50: 6f 72 74 3a 69 6e 63 2d 72 65 71 75 65 73 74 73 ort:inc-requests
1d60: 2d 63 6f 75 6e 74 29 0a 20 20 28 6d 75 74 65 78 -count). (mutex
1d70: 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 -lock! *http-mut
1d80: 65 78 2a 29 0a 20 20 28 73 65 74 21 20 2a 68 74 ex*). (set! *ht
1d90: 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 tp-requests-in-p
1da0: 72 6f 67 72 65 73 73 2a 20 28 2b 20 31 20 2a 68 rogress* (+ 1 *h
1db0: 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d ttp-requests-in-
1dc0: 70 72 6f 67 72 65 73 73 2a 29 29 0a 20 20 3b 3b progress*)). ;;
1dd0: 20 55 73 65 20 74 68 69 73 20 6f 70 70 6f 72 74 Use this opport
1de0: 75 6e 69 74 79 20 74 6f 20 73 6c 6f 77 20 74 68 unity to slow th
1df0: 69 6e 67 73 20 64 6f 77 6e 20 69 66 66 20 74 68 ings down iff th
1e00: 65 72 65 20 61 72 65 20 74 6f 6f 20 6d 61 6e 79 ere are too many
1e10: 20 72 65 71 75 65 73 74 73 20 69 6e 20 66 6c 69 requests in fli
1e20: 67 68 74 0a 20 20 28 69 66 20 28 3e 20 2a 68 74 ght. (if (> *ht
1e30: 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 tp-requests-in-p
1e40: 72 6f 67 72 65 73 73 2a 20 35 29 0a 20 20 20 20 rogress* 5).
1e50: 20 20 28 62 65 67 69 6e 0a 09 28 64 65 62 75 67 (begin..(debug
1e60: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 57 :print-info 0 "W
1e70: 68 6f 61 20 74 68 65 72 65 20 62 75 64 64 79 2c hoa there buddy,
1e80: 20 65 61 73 65 20 75 70 2e 2e 2e 22 29 0a 09 28 ease up...")..(
1e90: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
1ea0: 29 29 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f )). (mutex-unlo
1eb0: 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a ck! *http-mutex*
1ec0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 ))..(define (htt
1ed0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 64 65 63 2d p-transport:dec-
1ee0: 72 65 71 75 65 73 74 73 2d 63 6f 75 6e 74 20 70 requests-count p
1ef0: 72 6f 63 29 20 0a 20 20 28 6d 75 74 65 78 2d 6c roc) . (mutex-l
1f00: 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 ock! *http-mutex
1f10: 2a 29 0a 20 20 28 70 72 6f 63 29 0a 20 20 28 73 *). (proc). (s
1f20: 65 74 21 20 2a 68 74 74 70 2d 72 65 71 75 65 73 et! *http-reques
1f30: 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 ts-in-progress*
1f40: 28 2d 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 (- *http-request
1f50: 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 31 s-in-progress* 1
1f60: 29 29 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f )). (mutex-unlo
1f70: 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a ck! *http-mutex*
1f80: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 ))..(define (htt
1f90: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 64 65 63 2d p-transport:dec-
1fa0: 72 65 71 75 65 73 74 73 2d 63 6f 75 6e 74 2d 61 requests-count-a
1fb0: 6e 64 2d 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e nd-close-all-con
1fc0: 6e 65 63 74 69 6f 6e 73 29 0a 20 20 28 73 65 74 nections). (set
1fd0: 21 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 ! *http-requests
1fe0: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 28 2d -in-progress* (-
1ff0: 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d *http-requests-
2000: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 31 29 29 in-progress* 1))
2010: 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 65 . (let loop ((e
2020: 74 69 6d 65 20 28 2b 20 28 63 75 72 72 65 6e 74 time (+ (current
2030: 2d 73 65 63 6f 6e 64 73 29 20 35 29 29 29 20 3b -seconds) 5))) ;
2040: 3b 20 67 69 76 65 20 75 70 20 69 6e 20 66 69 76 ; give up in fiv
2050: 65 20 73 65 63 6f 6e 64 73 0a 20 20 20 20 28 69 e seconds. (i
2060: 66 20 28 3e 20 2a 68 74 74 70 2d 72 65 71 75 65 f (> *http-reque
2070: 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a sts-in-progress*
2080: 20 30 29 0a 09 28 69 66 20 28 3e 20 65 74 69 6d 0)..(if (> etim
2090: 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e e (current-secon
20a0: 64 73 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e ds)).. (begin
20b0: 0a 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d .. (thread-
20c0: 73 6c 65 65 70 21 20 30 2e 30 35 29 0a 09 20 20 sleep! 0.05)..
20d0: 20 20 20 20 28 6c 6f 6f 70 20 65 74 69 6d 65 29 (loop etime)
20e0: 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
20f0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 72 65 int 0 "ERROR: re
2100: 71 75 65 73 74 73 20 73 74 69 6c 6c 20 69 6e 20 quests still in
2110: 70 72 6f 67 72 65 73 73 20 61 66 74 65 72 20 35 progress after 5
2120: 20 73 65 63 6f 6e 64 73 20 6f 66 20 77 61 69 74 seconds of wait
2130: 69 6e 67 2e 20 49 27 6d 20 67 6f 69 6e 67 20 74 ing. I'm going t
2140: 6f 20 70 61 73 73 20 6f 6e 20 63 6c 65 61 6e 69 o pass on cleani
2150: 6e 67 20 75 70 20 68 74 74 70 20 63 6f 6e 6e 65 ng up http conne
2160: 63 74 69 6f 6e 73 22 29 29 0a 09 28 63 6c 6f 73 ctions"))..(clos
2170: 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e e-all-connection
2180: 73 21 29 29 29 0a 20 20 28 73 65 74 21 20 2a 68 s!))). (set! *h
2190: 74 74 70 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 2d ttp-connections-
21a0: 6e 65 78 74 2d 63 6c 65 61 6e 75 70 2a 20 28 2b next-cleanup* (+
21b0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
21c0: 73 29 20 31 30 29 29 0a 20 20 28 6d 75 74 65 78 s) 10)). (mutex
21d0: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d -unlock! *http-m
21e0: 75 74 65 78 2a 29 29 0a 0a 28 64 65 66 69 6e 65 utex*))..(define
21f0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
2200: 3a 69 6e 63 2d 72 65 71 75 65 73 74 73 2d 61 6e :inc-requests-an
2210: 64 2d 70 72 65 70 2d 74 6f 2d 63 6c 6f 73 65 2d d-prep-to-close-
2220: 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 29 all-connections)
2230: 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 . (mutex-lock!
2240: 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 *http-mutex*).
2250: 28 73 65 74 21 20 2a 68 74 74 70 2d 72 65 71 75 (set! *http-requ
2260: 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 ests-in-progress
2270: 2a 20 28 2b 20 31 20 2a 68 74 74 70 2d 72 65 71 * (+ 1 *http-req
2280: 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 uests-in-progres
2290: 73 2a 29 29 29 0a 0a 3b 3b 20 53 65 6e 64 20 22 s*)))..;; Send "
22a0: 63 6d 64 22 20 77 69 74 68 20 6a 73 6f 6e 20 70 cmd" with json p
22b0: 61 79 6c 6f 61 64 20 22 70 61 72 61 6d 73 22 20 ayload "params"
22c0: 74 6f 20 73 65 72 76 65 72 64 61 74 20 61 6e 64 to serverdat and
22d0: 20 72 65 63 65 69 76 65 20 72 65 73 75 6c 74 0a receive result.
22e0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 ;;.(define (http
22f0: 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e -transport:clien
2300: 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 t-api-send-recei
2310: 76 65 20 72 75 6e 2d 69 64 20 73 65 72 76 65 72 ve run-id server
2320: 64 61 74 20 63 6d 64 20 70 61 72 61 6d 73 20 23 dat cmd params #
2330: 21 6b 65 79 20 28 6e 75 6d 72 65 74 72 69 65 73 !key (numretries
2340: 20 33 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 3)). (let* ((f
2350: 75 6c 6c 75 72 6c 20 20 20 20 28 69 66 20 28 6c ullurl (if (l
2360: 69 73 74 3f 20 73 65 72 76 65 72 64 61 74 29 0a ist? serverdat).
2370: 09 09 09 20 28 6c 69 73 74 2d 72 65 66 20 73 65 ... (list-ref se
2380: 72 76 65 72 64 61 74 20 34 29 20 3b 3b 20 28 63 rverdat 4) ;; (c
2390: 61 64 64 64 72 20 73 65 72 76 65 72 64 61 74 29 adddr serverdat)
23a0: 20 3b 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 ;; this is the
23b0: 75 72 69 20 66 6f 72 20 2f 61 70 69 0a 09 09 09 uri for /api....
23c0: 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 28 64 (begin.... (d
23d0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 46 41 ebug:print 0 "FA
23e0: 54 41 4c 20 45 52 52 4f 52 3a 20 68 74 74 70 2d TAL ERROR: http-
23f0: 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 transport:client
2400: 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 -api-send-receiv
2410: 65 20 63 61 6c 6c 65 64 20 77 69 74 68 20 6e 6f e called with no
2420: 20 73 65 72 76 65 72 20 69 6e 66 6f 22 29 0a 09 server info")..
2430: 09 09 20 20 20 28 65 78 69 74 20 31 29 29 29 29 .. (exit 1))))
2440: 0a 09 20 28 72 65 73 20 20 20 20 20 20 20 20 23 .. (res #
2450: 66 29 29 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d f)). (handle-
2460: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 exceptions.
2470: 65 78 6e 0a 20 20 20 20 20 28 69 66 20 28 3e 20 exn. (if (>
2480: 6e 75 6d 72 65 74 72 69 65 73 20 30 29 0a 09 20 numretries 0)..
2490: 28 62 65 67 69 6e 0a 09 20 20 20 28 6d 75 74 65 (begin.. (mute
24a0: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d x-unlock! *http-
24b0: 6d 75 74 65 78 2a 29 0a 09 20 20 20 28 74 68 72 mutex*).. (thr
24c0: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 20 ead-sleep! 1)..
24d0: 20 20 28 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e (close-all-con
24e0: 6e 65 63 74 69 6f 6e 73 21 29 0a 09 20 20 20 28 nections!).. (
24f0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
2500: 41 52 4e 49 4e 47 3a 20 46 61 69 6c 65 64 20 74 ARNING: Failed t
2510: 6f 20 63 6f 6d 6d 75 6e 69 63 61 74 65 20 77 69 o communicate wi
2520: 74 68 20 73 65 72 76 65 72 2c 20 74 72 79 69 6e th server, tryin
2530: 67 20 61 67 61 69 6e 2c 20 6e 75 6d 72 65 74 72 g again, numretr
2540: 69 65 73 20 6c 65 66 74 3a 20 22 20 6e 75 6d 72 ies left: " numr
2550: 65 74 72 69 65 73 29 0a 09 20 20 20 28 68 74 74 etries).. (htt
2560: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 p-transport:clie
2570: 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 nt-api-send-rece
2580: 69 76 65 20 72 75 6e 2d 69 64 20 73 65 72 76 65 ive run-id serve
2590: 72 64 61 74 20 63 6d 64 20 70 61 72 61 6d 73 20 rdat cmd params
25a0: 6e 75 6d 72 65 74 72 69 65 73 3a 20 28 2d 20 6e numretries: (- n
25b0: 75 6d 72 65 74 72 69 65 73 20 31 29 29 29 0a 09 umretries 1)))..
25c0: 20 28 62 65 67 69 6e 0a 09 20 20 20 28 6d 75 74 (begin.. (mut
25d0: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 ex-unlock! *http
25e0: 2d 6d 75 74 65 78 2a 29 0a 09 20 20 20 23 66 29 -mutex*).. #f)
25f0: 29 0a 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 ). (begin.
2600: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
2610: 74 2d 69 6e 66 6f 20 31 31 20 22 66 75 6c 6c 75 t-info 11 "fullu
2620: 72 6c 3d 22 20 66 75 6c 6c 75 72 6c 20 22 2c 20 rl=" fullurl ",
2630: 63 6d 64 3d 22 20 63 6d 64 20 22 2c 20 70 61 72 cmd=" cmd ", par
2640: 61 6d 73 3d 22 20 70 61 72 61 6d 73 20 22 2c 20 ams=" params ",
2650: 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 run-id=" run-id
2660: 22 5c 6e 22 29 0a 20 20 20 20 20 20 20 3b 3b 20 "\n"). ;;
2670: 73 65 74 20 75 70 20 74 68 65 20 68 74 74 70 2d set up the http-
2680: 63 6c 69 65 6e 74 20 68 65 72 65 0a 20 20 20 20 client here.
2690: 20 20 20 28 6d 61 78 2d 72 65 74 72 79 2d 61 74 (max-retry-at
26a0: 74 65 6d 70 74 73 20 31 29 0a 20 20 20 20 20 20 tempts 1).
26b0: 20 3b 3b 20 63 6f 6e 73 69 64 65 72 20 61 6c 6c ;; consider all
26c0: 20 72 65 71 75 65 73 74 73 20 69 6e 64 65 6d 70 requests indemp
26d0: 6f 74 65 6e 74 0a 20 20 20 20 20 20 20 28 72 65 otent. (re
26e0: 74 72 79 2d 72 65 71 75 65 73 74 3f 20 28 6c 61 try-request? (la
26f0: 6d 62 64 61 20 28 72 65 71 75 65 73 74 29 0a 09 mbda (request)..
2700: 09 09 20 23 66 29 29 0a 20 20 20 20 20 20 20 3b .. #f)). ;
2710: 3b 20 73 65 6e 64 20 74 68 65 20 64 61 74 61 20 ; send the data
2720: 61 6e 64 20 67 65 74 20 74 68 65 20 72 65 73 70 and get the resp
2730: 6f 6e 73 65 0a 20 20 20 20 20 20 20 3b 3b 20 65 onse. ;; e
2740: 78 74 72 61 63 74 20 74 68 65 20 6e 65 65 64 65 xtract the neede
2750: 64 20 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 20 d info from the
2760: 68 74 74 70 20 64 61 74 61 20 61 6e 64 20 0a 20 http data and .
2770: 20 20 20 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 ;; process
2780: 20 61 6e 64 20 72 65 74 75 72 6e 20 69 74 2e 0a and return it..
2790: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 (let* ((s
27a0: 65 6e 64 2d 72 65 63 69 65 76 65 20 28 6c 61 6d end-recieve (lam
27b0: 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 bda ()....
27c0: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 (mutex-lock! *ht
27d0: 74 70 2d 6d 75 74 65 78 2a 29 0a 09 09 09 20 20 tp-mutex*)....
27e0: 20 20 20 20 28 73 65 74 21 20 72 65 73 20 28 77 (set! res (w
27f0: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 ith-input-from-r
2800: 65 71 75 65 73 74 20 3b 3b 20 77 61 73 20 64 61 equest ;; was da
2810: 74 0a 09 09 09 09 09 20 66 75 6c 6c 75 72 6c 20 t...... fullurl
2820: 0a 09 09 09 09 09 20 28 6c 69 73 74 20 28 63 6f ...... (list (co
2830: 6e 73 20 27 6b 65 79 20 22 74 68 65 6b 65 79 22 ns 'key "thekey"
2840: 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 63 )...... (c
2850: 6f 6e 73 20 27 63 6d 64 20 63 6d 64 29 0a 09 09 ons 'cmd cmd)...
2860: 09 09 09 20 20 20 20 20 20 20 28 63 6f 6e 73 20 ... (cons
2870: 27 70 61 72 61 6d 73 20 70 61 72 61 6d 73 29 29 'params params))
2880: 0a 09 09 09 09 09 20 72 65 61 64 2d 73 74 72 69 ...... read-stri
2890: 6e 67 29 29 0a 09 09 09 20 20 20 20 20 20 3b 3b ng)).... ;;
28a0: 20 53 68 6f 75 6c 64 6e 27 74 20 74 68 69 73 20 Shouldn't this
28b0: 62 65 20 61 20 63 61 6c 6c 20 74 6f 20 74 68 65 be a call to the
28c0: 20 6d 61 6e 61 67 65 64 20 63 61 6c 6c 2d 61 6c managed call-al
28d0: 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 73 74 l-connections st
28e0: 75 66 66 20 61 62 6f 76 65 3f 0a 09 09 09 20 20 uff above?....
28f0: 20 20 20 20 28 63 6c 6f 73 65 2d 61 6c 6c 2d 63 (close-all-c
2900: 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 0a 09 09 09 onnections!)....
2910: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
2920: 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 ock! *http-mutex
2930: 2a 29 0a 09 09 09 20 20 20 20 20 20 29 29 0a 09 *).... ))..
2940: 20 20 20 20 20 20 28 74 69 6d 65 2d 6f 75 74 20 (time-out
2950: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 (lambda ()..
2960: 09 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d .. (thread-
2970: 73 6c 65 65 70 21 20 34 35 29 0a 09 09 09 20 20 sleep! 45)....
2980: 20 20 20 20 23 66 29 29 0a 09 20 20 20 20 20 20 #f))..
2990: 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 (th1 (make-threa
29a0: 64 20 73 65 6e 64 2d 72 65 63 69 65 76 65 20 22 d send-recieve "
29b0: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
29c0: 72 65 71 75 65 73 74 22 29 29 0a 09 20 20 20 20 request"))..
29d0: 20 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 (th2 (make-thr
29e0: 65 61 64 20 74 69 6d 65 2d 6f 75 74 20 20 20 20 ead time-out
29f0: 20 22 74 69 6d 65 20 6f 75 74 22 29 29 29 0a 09 "time out")))..
2a00: 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 (thread-start!
2a10: 74 68 31 29 0a 09 20 28 74 68 72 65 61 64 2d 73 th1).. (thread-s
2a20: 74 61 72 74 21 20 74 68 32 29 0a 09 20 28 74 68 tart! th2).. (th
2a30: 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 29 0a read-join! th1).
2a40: 09 20 28 74 68 72 65 61 64 2d 74 65 72 6d 69 6e . (thread-termin
2a50: 61 74 65 21 20 74 68 32 29 0a 09 20 28 64 65 62 ate! th2).. (deb
2a60: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 31 ug:print-info 11
2a70: 20 22 67 6f 74 20 72 65 73 3d 22 20 72 65 73 29 "got res=" res)
2a80: 0a 09 20 72 65 73 29 29 29 29 29 0a 0a 3b 3b 20 .. res)))))..;;
2a90: 63 61 72 65 66 75 6c 20 63 6c 6f 73 69 6e 67 20 careful closing
2aa0: 6f 66 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 73 of connections s
2ab0: 74 6f 72 65 64 20 69 6e 20 2a 72 75 6e 72 65 6d tored in *runrem
2ac0: 6f 74 65 2a 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ote*.;;.(define
2ad0: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
2ae0: 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 6f 6e close-connection
2af0: 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 74 s run-id). (let
2b00: 2a 20 28 28 73 65 72 76 65 72 2d 64 61 74 20 28 * ((server-dat (
2b10: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
2b20: 65 66 61 75 6c 74 20 2a 72 75 6e 72 65 6d 6f 74 efault *runremot
2b30: 65 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 29 0a e* run-id #f))).
2b40: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6c 69 (if (and (li
2b50: 73 74 3f 20 73 65 72 76 65 72 2d 64 61 74 29 0a st? server-dat).
2b60: 09 20 20 20 20 20 28 3e 3d 20 28 6c 65 6e 67 74 . (>= (lengt
2b70: 68 20 73 65 72 76 65 72 2d 64 61 74 29 20 35 29 h server-dat) 5)
2b80: 29 0a 09 28 6c 65 74 20 28 28 63 74 72 6c 2d 64 )..(let ((ctrl-d
2b90: 61 74 20 28 6c 69 73 74 2d 72 65 66 20 73 65 72 at (list-ref ser
2ba0: 76 65 72 2d 64 61 74 20 32 29 29 0a 09 20 20 20 ver-dat 2))..
2bb0: 20 20 20 28 61 70 69 2d 64 61 74 20 20 28 6c 69 (api-dat (li
2bc0: 73 74 2d 72 65 66 20 73 65 72 76 65 72 2d 64 61 st-ref server-da
2bd0: 74 20 33 29 29 29 0a 09 20 20 28 63 6c 6f 73 65 t 3))).. (close
2be0: 2d 63 6f 6e 6e 65 63 74 69 6f 6e 21 20 63 74 72 -connection! ctr
2bf0: 6c 2d 64 61 74 29 0a 09 20 20 28 63 6c 6f 73 65 l-dat).. (close
2c00: 2d 63 6f 6e 6e 65 63 74 69 6f 6e 21 20 61 70 69 -connection! api
2c10: 2d 64 61 74 29 0a 09 20 20 23 74 29 0a 09 23 66 -dat).. #t)..#f
2c20: 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 6d )))...(define (m
2c30: 61 6b 65 2d 68 74 74 70 2d 74 72 61 6e 73 70 6f ake-http-transpo
2c40: 72 74 3a 73 65 72 76 65 72 2d 64 61 74 29 28 6d rt:server-dat)(m
2c50: 61 6b 65 2d 76 65 63 74 6f 72 20 35 29 29 0a 28 ake-vector 5)).(
2c60: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
2c70: 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 nsport:server-da
2c80: 74 2d 67 65 74 2d 69 66 61 63 65 20 20 20 20 20 t-get-iface
2c90: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
2ca0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 30 29 29 tor-ref vec 0))
2cb0: 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 .(define (http-t
2cc0: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
2cd0: 64 61 74 2d 67 65 74 2d 70 6f 72 74 20 20 20 20 dat-get-port
2ce0: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
2cf0: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 ector-ref vec 1
2d00: 29 29 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 )).(define (http
2d10: 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 -transport:serve
2d20: 72 2d 64 61 74 2d 67 65 74 2d 61 70 69 2d 75 72 r-dat-get-api-ur
2d30: 69 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 i vec)
2d40: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
2d50: 20 32 29 29 0a 28 64 65 66 69 6e 65 20 28 68 74 2)).(define (ht
2d60: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
2d70: 76 65 72 2d 64 61 74 2d 67 65 74 2d 61 70 69 2d ver-dat-get-api-
2d80: 75 72 6c 20 20 20 20 20 20 20 76 65 63 29 20 20 url vec)
2d90: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
2da0: 65 63 20 33 29 29 0a 28 64 65 66 69 6e 65 20 28 ec 3)).(define (
2db0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
2dc0: 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 61 70 erver-dat-get-ap
2dd0: 69 2d 72 65 71 75 65 73 74 20 20 20 76 65 63 29 i-request vec)
2de0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
2df0: 20 76 65 63 20 34 29 29 0a 0a 3b 3b 0a 3b 3b 20 vec 4))..;;.;;
2e00: 63 6f 6e 6e 65 63 74 0a 3b 3b 0a 28 64 65 66 69 connect.;;.(defi
2e10: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
2e20: 72 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 rt:client-connec
2e30: 74 20 69 66 61 63 65 20 70 6f 72 74 29 0a 20 20 t iface port).
2e40: 28 6c 65 74 2a 20 28 28 61 70 69 2d 75 72 6c 20 (let* ((api-url
2e50: 20 20 20 20 20 28 63 6f 6e 63 20 22 68 74 74 70 (conc "http
2e60: 3a 2f 2f 22 20 69 66 61 63 65 20 22 3a 22 20 70 ://" iface ":" p
2e70: 6f 72 74 20 22 2f 61 70 69 22 29 29 0a 09 20 28 ort "/api")).. (
2e80: 61 70 69 2d 75 72 69 20 20 20 20 20 20 28 75 72 api-uri (ur
2e90: 69 2d 72 65 66 65 72 65 6e 63 65 20 28 63 6f 6e i-reference (con
2ea0: 63 20 22 68 74 74 70 3a 2f 2f 22 20 69 66 61 63 c "http://" ifac
2eb0: 65 20 22 3a 22 20 70 6f 72 74 20 22 2f 61 70 69 e ":" port "/api
2ec0: 22 29 29 29 0a 09 20 28 75 72 69 2d 61 70 69 2d "))).. (uri-api-
2ed0: 64 61 74 20 20 28 6d 61 6b 65 2d 72 65 71 75 65 dat (make-reque
2ee0: 73 74 20 6d 65 74 68 6f 64 3a 20 27 50 4f 53 54 st method: 'POST
2ef0: 20 75 72 69 3a 20 61 70 69 2d 75 72 69 29 29 0a uri: api-uri)).
2f00: 09 20 3b 3b 20 28 75 72 69 2d 63 74 72 6c 2d 64 . ;; (uri-ctrl-d
2f10: 61 74 20 28 6d 61 6b 65 2d 72 65 71 75 65 73 74 at (make-request
2f20: 20 6d 65 74 68 6f 64 3a 20 27 50 4f 53 54 20 75 method: 'POST u
2f30: 72 69 3a 20 28 75 72 69 2d 72 65 66 65 72 65 6e ri: (uri-referen
2f40: 63 65 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f ce (conc "http:/
2f50: 2f 22 20 69 66 61 63 65 20 22 3a 22 20 70 6f 72 /" iface ":" por
2f60: 74 20 22 2f 63 74 72 6c 22 29 29 29 29 0a 09 20 t "/ctrl"))))..
2f70: 28 75 72 69 2d 63 74 72 6c 2d 64 61 74 20 23 66 (uri-ctrl-dat #f
2f80: 29 20 3b 3b 20 6e 6f 74 20 75 73 65 64 20 61 6e ) ;; not used an
2f90: 79 6d 6f 72 65 0a 09 20 28 73 65 72 76 65 72 2d ymore.. (server-
2fa0: 64 61 74 20 20 20 28 76 65 63 74 6f 72 20 69 66 dat (vector if
2fb0: 61 63 65 20 70 6f 72 74 20 75 72 69 2d 63 74 72 ace port uri-ctr
2fc0: 6c 2d 64 61 74 20 75 72 69 2d 61 70 69 2d 64 61 l-dat uri-api-da
2fd0: 74 20 61 70 69 2d 75 72 6c 29 29 29 0a 20 20 20 t api-url))).
2fe0: 20 73 65 72 76 65 72 2d 64 61 74 29 29 0a 0a 3b server-dat))..;
2ff0: 3b 20 72 75 6e 20 68 74 74 70 2d 74 72 61 6e 73 ; run http-trans
3000: 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e port:keep-runnin
3010: 67 20 69 6e 20 61 20 70 61 72 61 6c 6c 65 6c 20 g in a parallel
3020: 74 68 72 65 61 64 20 74 6f 20 6d 6f 6e 69 74 6f thread to monito
3030: 72 20 74 68 61 74 20 74 68 65 20 64 62 20 69 73 r that the db is
3040: 20 62 65 69 6e 67 20 0a 3b 3b 20 75 73 65 64 20 being .;; used
3050: 61 6e 64 20 74 6f 20 73 68 75 74 64 6f 77 6e 20 and to shutdown
3060: 61 66 74 65 72 20 73 6f 6d 65 74 69 6d 65 20 69 after sometime i
3070: 66 20 69 74 20 69 73 20 6e 6f 74 2e 0a 3b 3b 0a f it is not..;;.
3080: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
3090: 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e ansport:keep-run
30a0: 6e 69 6e 67 20 73 65 72 76 65 72 2d 69 64 29 0a ning server-id).
30b0: 20 20 3b 3b 20 69 66 20 6e 6f 6e 65 20 72 75 6e ;; if none run
30c0: 6e 69 6e 67 20 6f 72 20 69 66 20 3e 20 32 30 20 ning or if > 20
30d0: 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 0a 20 seconds since .
30e0: 20 3b 3b 20 73 65 72 76 65 72 20 6c 61 73 74 20 ;; server last
30f0: 75 73 65 64 20 74 68 65 6e 20 73 74 61 72 74 20 used then start
3100: 73 68 75 74 64 6f 77 6e 0a 20 20 3b 3b 20 54 68 shutdown. ;; Th
3110: 69 73 20 74 68 72 65 61 64 20 77 61 69 74 73 20 is thread waits
3120: 66 6f 72 20 74 68 65 20 73 65 72 76 65 72 20 74 for the server t
3130: 6f 20 63 6f 6d 65 20 61 6c 69 76 65 0a 20 20 28 o come alive. (
3140: 6c 65 74 2a 20 28 28 73 65 72 76 65 72 2d 69 6e let* ((server-in
3150: 66 6f 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 73 fo (let loop ((s
3160: 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 tart-time (curre
3170: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 09 nt-seconds))....
3180: 09 20 28 63 68 61 6e 67 65 64 20 20 20 20 23 74 . (changed #t
3190: 29 0a 09 09 09 09 20 28 6c 61 73 74 2d 73 64 61 )..... (last-sda
31a0: 74 20 20 22 6e 6f 74 20 74 68 69 73 22 29 29 0a t "not this")).
31b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
31c0: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 (let ((s
31d0: 64 61 74 20 23 66 29 29 0a 20 20 20 20 20 20 20 dat #f)).
31e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
31f0: 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 (mutex-lock!
3200: 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 *heartbeat-mutex
3210: 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 *).
3220: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 (se
3230: 74 21 20 73 64 61 74 20 2a 73 65 72 76 65 72 2d t! sdat *server-
3240: 69 6e 66 6f 2a 29 0a 20 20 20 20 20 20 20 20 20 info*).
3250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3260: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
3270: 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 *heartbeat-mutex
3280: 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 *).
3290: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
32a0: 20 28 61 6e 64 20 73 64 61 74 0a 09 09 09 09 20 (and sdat.....
32b0: 20 20 28 6e 6f 74 20 63 68 61 6e 67 65 64 29 0a (not changed).
32c0: 09 09 09 09 20 20 20 28 3e 20 28 2d 20 28 63 75 .... (> (- (cu
32d0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 rrent-seconds) s
32e0: 74 61 72 74 2d 74 69 6d 65 29 20 32 29 29 0a 09 tart-time) 2))..
32f0: 09 09 20 20 20 20 20 20 73 64 61 74 0a 20 20 20 .. sdat.
3300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3310: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
3320: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
3330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3340: 20 20 28 73 6c 65 65 70 20 34 29 0a 20 20 20 20 (sleep 4).
3350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3360: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f (loo
3370: 70 20 73 74 61 72 74 2d 74 69 6d 65 0a 09 09 09 p start-time....
3380: 09 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 73 . (equal? s
3390: 64 61 74 20 6c 61 73 74 2d 73 64 61 74 29 0a 09 dat last-sdat)..
33a0: 09 09 09 20 20 20 20 20 20 73 64 61 74 29 29 29 ... sdat)))
33b0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 69 66 ))). (if
33c0: 61 63 65 20 20 20 20 20 20 20 28 63 61 72 20 73 ace (car s
33d0: 65 72 76 65 72 2d 69 6e 66 6f 29 29 0a 20 20 20 erver-info)).
33e0: 20 20 20 20 20 20 28 70 6f 72 74 20 20 20 20 20 (port
33f0: 20 20 20 28 63 61 64 72 20 73 65 72 76 65 72 2d (cadr server-
3400: 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 info)).
3410: 28 6c 61 73 74 2d 61 63 63 65 73 73 20 30 29 0a (last-access 0).
3420: 09 20 28 74 64 62 20 20 20 20 20 20 20 20 20 28 . (tdb (
3430: 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 0a tasks:open-db)).
3440: 09 20 28 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 . (server-timeou
3450: 74 20 28 6c 65 74 20 28 28 74 6d 6f 20 28 63 6f t (let ((tmo (co
3460: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 20 2a 63 nfigf:lookup *c
3470: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 onfigdat* "serve
3480: 72 22 20 22 74 69 6d 65 6f 75 74 22 29 29 29 0a r" "timeout"))).
3490: 09 09 09 20 20 20 28 69 66 20 28 61 6e 64 20 28 ... (if (and (
34a0: 73 74 72 69 6e 67 3f 20 74 6d 6f 29 0a 09 09 09 string? tmo)....
34b0: 09 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 . (string->nu
34c0: 6d 62 65 72 20 74 6d 6f 29 29 0a 09 09 09 20 20 mber tmo))....
34d0: 20 20 20 20 20 28 2a 20 36 30 20 36 30 20 28 73 (* 60 60 (s
34e0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 74 6d tring->number tm
34f0: 6f 29 29 0a 09 09 09 20 20 20 20 20 20 20 3b 3b o)).... ;;
3500: 20 28 2a 20 33 20 32 34 20 36 30 20 36 30 29 20 (* 3 24 60 60)
3510: 3b 3b 20 64 65 66 61 75 6c 74 20 74 6f 20 74 68 ;; default to th
3520: 72 65 65 20 64 61 79 73 0a 09 09 09 20 20 20 20 ree days....
3530: 20 20 20 3b 3b 20 28 2a 20 36 30 20 31 29 20 20 ;; (* 60 1)
3540: 20 20 20 20 20 20 20 3b 3b 20 64 65 66 61 75 6c ;; defaul
3550: 74 20 74 6f 20 6f 6e 65 20 6d 69 6e 75 74 65 0a t to one minute.
3560: 09 09 09 20 20 20 20 20 20 20 28 2a 20 36 30 20 ... (* 60
3570: 36 30 20 32 35 29 20 20 20 20 20 20 3b 3b 20 64 60 25) ;; d
3580: 65 66 61 75 6c 74 20 74 6f 20 32 35 20 68 6f 75 efault to 25 hou
3590: 72 73 0a 09 09 09 20 20 20 20 20 20 20 29 29 29 rs.... )))
35a0: 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ). (let loop
35b0: 28 28 63 6f 75 6e 74 20 20 20 20 20 20 20 20 20 ((count
35c0: 30 29 0a 09 20 20 20 20 20 20 20 28 73 65 72 76 0).. (serv
35d0: 65 72 2d 73 74 61 74 65 20 27 61 76 61 69 6c 61 er-state 'availa
35e0: 62 6c 65 29 29 0a 20 20 20 20 20 20 3b 3b 20 55 ble)). ;; U
35f0: 73 65 20 74 68 69 73 20 6f 70 70 6f 72 74 75 6e se this opportun
3600: 69 74 79 20 74 6f 20 73 79 6e 63 20 74 68 65 20 ity to sync the
3610: 69 6e 6d 65 6d 64 62 20 74 6f 20 64 62 0a 20 20 inmemdb to db.
3620: 20 20 20 20 28 6c 65 74 20 28 28 73 74 61 72 74 (let ((start
3630: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d -time (current-m
3640: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 09 20 illiseconds))..
3650: 20 20 20 28 73 79 6e 63 2d 74 69 6d 65 20 20 23 (sync-time #
3660: 66 29 0a 09 20 20 20 20 28 72 65 6d 2d 74 69 6d f).. (rem-tim
3670: 65 20 20 20 23 66 29 29 0a 0a 09 28 69 66 20 2a e #f))...(if *
3680: 69 6e 6d 65 6d 64 62 2a 20 28 64 62 3a 73 79 6e inmemdb* (db:syn
3690: 63 2d 74 6f 75 63 68 65 64 20 2a 69 6e 6d 65 6d c-touched *inmem
36a0: 64 62 2a 20 66 6f 72 63 65 2d 73 79 6e 63 3a 20 db* force-sync:
36b0: 23 74 29 29 0a 09 28 73 65 74 21 20 73 79 6e 63 #t))..(set! sync
36c0: 2d 74 69 6d 65 20 20 28 2d 20 28 63 75 72 72 65 -time (- (curre
36d0: 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
36e0: 20 73 74 61 72 74 2d 74 69 6d 65 29 29 0a 09 28 start-time))..(
36f0: 73 65 74 21 20 72 65 6d 2d 74 69 6d 65 20 28 71 set! rem-time (q
3700: 75 6f 74 69 65 6e 74 20 28 2d 20 34 30 30 30 20 uotient (- 4000
3710: 73 79 6e 63 2d 74 69 6d 65 29 20 31 30 30 30 29 sync-time) 1000)
3720: 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 )..(debug:print
3730: 30 20 22 53 59 4e 43 3a 20 74 69 6d 65 3d 20 22 0 "SYNC: time= "
3740: 20 73 79 6e 63 2d 74 69 6d 65 20 22 2c 20 72 65 sync-time ", re
3750: 6d 2d 74 69 6d 65 3d 22 20 72 65 6d 2d 74 69 6d m-time=" rem-tim
3760: 65 29 0a 0a 20 20 20 20 20 20 3b 3b 0a 20 20 20 e).. ;;.
3770: 20 20 20 3b 3b 20 73 65 74 5f 72 75 6e 6e 69 6e ;; set_runnin
3780: 67 20 61 66 74 65 72 20 6f 75 72 20 66 69 72 73 g after our firs
3790: 74 20 70 61 73 73 20 74 68 72 6f 75 67 68 0a 20 t pass through.
37a0: 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 20 28 69 ;;. (i
37b0: 66 20 28 65 71 3f 20 73 65 72 76 65 72 2d 73 74 f (eq? server-st
37c0: 61 74 65 20 27 61 76 61 69 6c 61 62 6c 65 29 0a ate 'available).
37d0: 09 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 . (tasks:server
37e0: 2d 73 65 74 2d 73 74 61 74 65 21 20 74 64 62 20 -set-state! tdb
37f0: 73 65 72 76 65 72 2d 69 64 20 22 72 75 6e 6e 69 server-id "runni
3800: 6e 67 22 29 29 0a 0a 20 20 20 20 20 20 28 69 66 ng")).. (if
3810: 20 28 61 6e 64 20 28 3c 3d 20 72 65 6d 2d 74 69 (and (<= rem-ti
3820: 6d 65 20 34 29 0a 09 20 20 20 20 20 20 20 28 3e me 4).. (>
3830: 20 72 65 6d 2d 74 69 6d 65 20 30 29 29 0a 09 20 rem-time 0))..
3840: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
3850: 72 65 6d 2d 74 69 6d 65 29 0a 09 20 20 28 74 68 rem-time).. (th
3860: 72 65 61 64 2d 73 6c 65 65 70 21 20 34 29 29 29 read-sleep! 4)))
3870: 20 3b 3b 20 66 61 6c 6c 62 61 63 6b 20 66 6f 72 ;; fallback for
3880: 20 69 66 20 74 68 65 20 6d 61 74 68 20 69 73 20 if the math is
3890: 63 68 61 6e 67 65 64 20 2e 2e 2e 0a 20 20 20 20 changed ....
38a0: 20 20 0a 20 20 20 20 20 20 28 69 66 20 28 3c 20 . (if (<
38b0: 63 6f 75 6e 74 20 31 29 20 3b 3b 20 33 78 33 20 count 1) ;; 3x3
38c0: 3d 20 39 20 73 65 63 73 20 61 70 72 6f 78 0a 09 = 9 secs aprox..
38d0: 20 20 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 (loop (+ count
38e0: 20 31 29 20 27 72 75 6e 6e 69 6e 67 29 29 0a 20 1) 'running)).
38f0: 20 20 20 20 20 0a 20 20 20 20 20 20 3b 3b 20 43 . ;; C
3900: 68 65 63 6b 20 74 68 61 74 20 69 66 61 63 65 20 heck that iface
3910: 61 6e 64 20 70 6f 72 74 20 68 61 76 65 20 6e 6f and port have no
3920: 74 20 63 68 61 6e 67 65 64 20 28 63 61 6e 20 68 t changed (can h
3930: 61 70 70 65 6e 20 69 66 20 73 65 72 76 65 72 20 appen if server
3940: 70 6f 72 74 20 63 6f 6c 6c 69 64 65 73 29 0a 20 port collides).
3950: 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b (mutex-lock
3960: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
3970: 65 78 2a 29 0a 20 20 20 20 20 20 28 73 65 74 21 ex*). (set!
3980: 20 73 64 61 74 20 2a 73 65 72 76 65 72 2d 69 6e sdat *server-in
3990: 66 6f 2a 29 0a 20 20 20 20 20 20 28 6d 75 74 65 fo*). (mute
39a0: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 x-unlock! *heart
39b0: 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 beat-mutex*).
39c0: 20 20 20 0a 20 20 20 20 20 20 28 69 66 20 28 6f . (if (o
39d0: 72 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 73 r (not (equal? s
39e0: 64 61 74 20 28 6c 69 73 74 20 69 66 61 63 65 20 dat (list iface
39f0: 70 6f 72 74 29 29 29 0a 09 20 20 20 20 20 20 28 port))).. (
3a00: 6e 6f 74 20 73 65 72 76 65 72 2d 69 64 29 29 0a not server-id)).
3a10: 09 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 . (begin ..
3a20: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
3a30: 6f 20 30 20 22 69 6e 74 65 72 66 61 63 65 20 63 o 0 "interface c
3a40: 68 61 6e 67 65 64 2c 20 72 65 66 72 65 73 68 69 hanged, refreshi
3a50: 6e 67 20 69 66 61 63 65 20 61 6e 64 20 70 6f 72 ng iface and por
3a60: 74 20 69 6e 66 6f 22 29 0a 09 20 20 20 20 28 73 t info").. (s
3a70: 65 74 21 20 69 66 61 63 65 20 28 63 61 72 20 73 et! iface (car s
3a80: 64 61 74 29 29 0a 09 20 20 20 20 28 73 65 74 21 dat)).. (set!
3a90: 20 70 6f 72 74 20 20 28 63 61 64 72 20 73 64 61 port (cadr sda
3aa0: 74 29 29 29 29 0a 20 20 20 20 20 20 0a 20 20 20 t)))). .
3ab0: 20 20 20 3b 3b 20 54 72 61 6e 73 66 65 72 20 2a ;; Transfer *
3ac0: 6c 61 73 74 2d 64 62 2d 61 63 63 65 73 73 2a 20 last-db-access*
3ad0: 74 6f 20 6c 61 73 74 2d 61 63 63 65 73 73 20 74 to last-access t
3ae0: 6f 20 75 73 65 20 69 6e 20 63 68 65 63 6b 69 6e o use in checkin
3af0: 67 20 74 68 61 74 20 77 65 20 61 72 65 20 73 74 g that we are st
3b00: 69 6c 6c 20 61 6c 69 76 65 0a 20 20 20 20 20 20 ill alive.
3b10: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 (mutex-lock! *he
3b20: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
3b30: 20 20 20 20 20 20 28 73 65 74 21 20 6c 61 73 74 (set! last
3b40: 2d 61 63 63 65 73 73 20 2a 6c 61 73 74 2d 64 62 -access *last-db
3b50: 2d 61 63 63 65 73 73 2a 29 0a 20 20 20 20 20 20 -access*).
3b60: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
3b70: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
3b80: 29 0a 0a 20 20 20 20 20 20 3b 3b 20 28 64 65 62 ).. ;; (deb
3b90: 75 67 3a 70 72 69 6e 74 20 31 31 20 22 6c 61 73 ug:print 11 "las
3ba0: 74 2d 61 63 63 65 73 73 3d 22 20 6c 61 73 74 2d t-access=" last-
3bb0: 61 63 63 65 73 73 20 22 2c 20 73 65 72 76 65 72 access ", server
3bc0: 2d 74 69 6d 65 6f 75 74 3d 22 20 73 65 72 76 65 -timeout=" serve
3bd0: 72 2d 74 69 6d 65 6f 75 74 29 0a 20 20 20 20 20 r-timeout).
3be0: 20 3b 3b 0a 20 20 20 20 20 20 3b 3b 20 6e 6f 5f ;;. ;; no_
3bf0: 74 72 61 66 66 69 63 0a 20 20 20 20 20 20 3b 3b traffic. ;;
3c00: 0a 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 . (if (and
3c10: 2a 73 65 72 76 65 72 2d 72 75 6e 2a 0a 09 20 20 *server-run*..
3c20: 20 20 20 20 20 28 3e 20 28 2b 20 6c 61 73 74 2d (> (+ last-
3c30: 61 63 63 65 73 73 20 73 65 72 76 65 72 2d 74 69 access server-ti
3c40: 6d 65 6f 75 74 29 0a 09 09 20 20 28 63 75 72 72 meout)... (curr
3c50: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 ent-seconds)))..
3c60: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 64 (begin.. (d
3c70: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3c80: 30 20 22 53 65 72 76 65 72 20 63 6f 6e 74 69 6e 0 "Server contin
3c90: 75 69 6e 67 2c 20 73 65 63 6f 6e 64 73 20 73 69 uing, seconds si
3ca0: 6e 63 65 20 6c 61 73 74 20 64 62 20 61 63 63 65 nce last db acce
3cb0: 73 73 3a 20 22 20 28 2d 20 28 63 75 72 72 65 6e ss: " (- (curren
3cc0: 74 2d 73 65 63 6f 6e 64 73 29 20 6c 61 73 74 2d t-seconds) last-
3cd0: 61 63 63 65 73 73 29 29 0a 09 20 20 20 20 3b 3b access)).. ;;
3ce0: 0a 09 20 20 20 20 3b 3b 20 43 6f 6e 73 69 64 65 .. ;; Conside
3cf0: 72 20 69 6d 70 6c 65 6d 65 6e 74 69 6e 67 20 73 r implementing s
3d00: 6f 6d 65 20 73 6d 61 72 74 73 20 68 65 72 65 20 ome smarts here
3d10: 74 6f 20 72 65 2d 69 6e 73 65 72 74 20 74 68 65 to re-insert the
3d20: 20 72 65 63 6f 72 64 20 6f 72 20 6b 69 6c 6c 20 record or kill
3d30: 73 65 6c 66 20 69 73 0a 09 20 20 20 20 3b 3b 20 self is.. ;;
3d40: 74 68 65 20 64 62 20 69 6e 64 69 63 61 74 65 73 the db indicates
3d50: 20 73 6f 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 so.. ;;..
3d60: 20 3b 3b 20 28 69 66 20 28 74 61 73 6b 73 3a 73 ;; (if (tasks:s
3d70: 65 72 76 65 72 2d 61 6d 2d 69 2d 74 68 65 2d 73 erver-am-i-the-s
3d80: 65 72 76 65 72 3f 20 74 64 62 20 72 75 6e 2d 69 erver? tdb run-i
3d90: 64 29 0a 09 20 20 20 20 3b 3b 20 20 20 20 20 28 d).. ;; (
3da0: 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 73 65 74 tasks:server-set
3db0: 2d 73 74 61 74 65 21 20 74 64 62 20 73 65 72 76 -state! tdb serv
3dc0: 65 72 2d 69 64 20 22 72 75 6e 6e 69 6e 67 22 29 er-id "running")
3dd0: 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 ).. ;;.. (
3de0: 6c 6f 6f 70 20 30 20 73 65 72 76 65 72 2d 73 74 loop 0 server-st
3df0: 61 74 65 29 29 0a 09 20 20 28 62 65 67 69 6e 0a ate)).. (begin.
3e00: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
3e10: 74 2d 69 6e 66 6f 20 30 20 22 53 74 61 72 74 69 t-info 0 "Starti
3e20: 6e 67 20 74 6f 20 73 68 75 74 64 6f 77 6e 20 74 ng to shutdown t
3e30: 68 65 20 73 65 72 76 65 72 2e 22 29 0a 09 20 20 he server.")..
3e40: 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 64 65 6c ;; need to del
3e50: 65 74 65 20 6f 6e 6c 79 20 2a 6d 79 2a 20 73 65 ete only *my* se
3e60: 72 76 65 72 20 65 6e 74 72 79 20 28 66 75 74 75 rver entry (futu
3e70: 72 65 20 75 73 65 29 0a 09 20 20 20 20 28 73 65 re use).. (se
3e80: 74 21 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 t! *time-to-exit
3e90: 2a 20 23 74 29 0a 09 20 20 20 20 28 69 66 20 2a * #t).. (if *
3ea0: 69 6e 6d 65 6d 64 62 2a 20 28 64 62 3a 73 79 6e inmemdb* (db:syn
3eb0: 63 2d 74 6f 75 63 68 65 64 20 2a 69 6e 6d 65 6d c-touched *inmem
3ec0: 64 62 2a 20 66 6f 72 63 65 2d 73 79 6e 63 3a 20 db* force-sync:
3ed0: 23 74 29 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 #t)).. ;;..
3ee0: 20 20 3b 3b 20 73 74 61 72 74 5f 73 68 75 74 64 ;; start_shutd
3ef0: 6f 77 6e 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 own.. ;;..
3f00: 20 28 20 74 61 73 6b 73 3a 73 65 72 76 65 72 2d ( tasks:server-
3f10: 73 65 74 2d 73 74 61 74 65 21 20 74 64 62 20 73 set-state! tdb s
3f20: 65 72 76 65 72 2d 69 64 20 22 73 68 75 74 74 69 erver-id "shutti
3f30: 6e 67 2d 64 6f 77 6e 22 29 0a 09 20 20 20 20 28 ng-down").. (
3f40: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 thread-sleep! 5)
3f50: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
3f60: 6e 74 2d 69 6e 66 6f 20 30 20 22 4d 61 78 20 63 nt-info 0 "Max c
3f70: 61 63 68 65 64 20 71 75 65 72 69 65 73 20 77 61 ached queries wa
3f80: 73 20 20 20 20 22 20 2a 6d 61 78 2d 63 61 63 68 s " *max-cach
3f90: 65 2d 73 69 7a 65 2a 29 0a 09 20 20 20 20 28 64 e-size*).. (d
3fa0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3fb0: 30 20 22 4e 75 6d 62 65 72 20 6f 66 20 63 61 63 0 "Number of cac
3fc0: 68 65 64 20 77 72 69 74 65 73 20 20 20 22 20 2a hed writes " *
3fd0: 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 number-of-writes
3fe0: 2a 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 *).. (debug:p
3ff0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 41 76 65 rint-info 0 "Ave
4000: 72 61 67 65 20 63 61 63 68 65 64 20 77 72 69 74 rage cached writ
4010: 65 20 74 69 6d 65 20 22 0a 09 09 09 20 20 20 20 e time "....
4020: 20 20 28 69 66 20 28 65 71 3f 20 2a 6e 75 6d 62 (if (eq? *numb
4030: 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a 20 30 29 er-of-writes* 0)
4040: 0a 09 09 09 09 20 20 22 6e 2f 61 20 28 6e 6f 20 ..... "n/a (no
4050: 77 72 69 74 65 73 29 22 0a 09 09 09 09 20 20 28 writes)"..... (
4060: 2f 20 2a 77 72 69 74 65 73 2d 74 6f 74 61 6c 2d / *writes-total-
4070: 64 65 6c 61 79 2a 0a 09 09 09 09 20 20 20 20 20 delay*.....
4080: 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 *number-of-write
4090: 73 2a 29 29 0a 09 09 09 20 20 20 20 20 20 22 20 s*)).... "
40a0: 6d 73 22 29 0a 09 20 20 20 20 28 64 65 62 75 67 ms").. (debug
40b0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 4e :print-info 0 "N
40c0: 75 6d 62 65 72 20 6e 6f 6e 2d 63 61 63 68 65 64 umber non-cached
40d0: 20 71 75 65 72 69 65 73 20 22 20 20 2a 6e 75 6d queries " *num
40e0: 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 ber-non-write-qu
40f0: 65 72 69 65 73 2a 29 0a 09 20 20 20 20 28 64 65 eries*).. (de
4100: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
4110: 20 22 41 76 65 72 61 67 65 20 6e 6f 6e 2d 63 61 "Average non-ca
4120: 63 68 65 64 20 74 69 6d 65 20 20 20 22 0a 09 09 ched time "...
4130: 09 20 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 . (if (eq?
4140: 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 *number-non-writ
4150: 65 2d 71 75 65 72 69 65 73 2a 20 30 29 0a 09 09 e-queries* 0)...
4160: 09 09 20 20 22 6e 2f 61 20 28 6e 6f 20 71 75 65 .. "n/a (no que
4170: 72 69 65 73 29 22 0a 09 09 09 09 20 20 28 2f 20 ries)"..... (/
4180: 2a 74 6f 74 61 6c 2d 6e 6f 6e 2d 77 72 69 74 65 *total-non-write
4190: 2d 64 65 6c 61 79 2a 20 0a 09 09 09 09 20 20 20 -delay* .....
41a0: 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 *number-non-wr
41b0: 69 74 65 2d 71 75 65 72 69 65 73 2a 29 29 0a 09 ite-queries*))..
41c0: 09 09 20 20 20 20 20 20 22 20 6d 73 22 29 0a 09 .. " ms")..
41d0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
41e0: 2d 69 6e 66 6f 20 30 20 22 53 65 72 76 65 72 20 -info 0 "Server
41f0: 73 68 75 74 64 6f 77 6e 20 63 6f 6d 70 6c 65 74 shutdown complet
4200: 65 2e 20 45 78 69 74 69 6e 67 22 29 0a 09 20 20 e. Exiting")..
4210: 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d (tasks:server-
4220: 64 65 6c 65 74 65 2d 72 65 63 6f 72 64 20 74 64 delete-record td
4230: 62 20 73 65 72 76 65 72 2d 69 64 20 22 20 68 74 b server-id " ht
4240: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6b 65 65 tp-transport:kee
4250: 70 2d 72 75 6e 6e 69 6e 67 22 29 0a 09 20 20 20 p-running")..
4260: 20 28 65 78 69 74 29 29 29 29 29 29 0a 0a 3b 3b (exit))))))..;;
4270: 20 61 6c 6c 20 72 6f 75 74 65 73 20 74 68 6f 75 all routes thou
4280: 67 68 20 68 65 72 65 20 65 6e 64 20 69 6e 20 65 gh here end in e
4290: 78 69 74 20 2e 2e 2e 0a 3b 3b 0a 3b 3b 20 73 74 xit ....;;.;; st
42a0: 61 72 74 5f 73 65 72 76 65 72 3f 20 0a 3b 3b 0a art_server? .;;.
42b0: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
42c0: 61 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 20 72 ansport:launch r
42d0: 75 6e 2d 69 64 29 0a 20 20 28 73 65 74 21 20 2a un-id). (set! *
42e0: 72 75 6e 2d 69 64 2a 20 20 20 72 75 6e 2d 69 64 run-id* run-id
42f0: 29 0a 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 ). (if (args:ge
4300: 74 2d 61 72 67 20 22 2d 64 61 65 6d 6f 6e 69 7a t-arg "-daemoniz
4310: 65 22 29 0a 20 20 20 20 20 20 28 64 61 65 6d 6f e"). (daemo
4320: 6e 3a 69 7a 65 29 29 0a 20 20 28 69 66 20 28 73 n:ize)). (if (s
4330: 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 erver:check-if-r
4340: 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 29 0a 20 unning run-id).
4350: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 64 65 (begin..(de
4360: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 49 4e 46 bug:print 0 "INF
4370: 4f 3a 20 53 65 72 76 65 72 20 66 6f 72 20 72 75 O: Server for ru
4380: 6e 2d 69 64 20 22 20 72 75 6e 2d 69 64 20 22 20 n-id " run-id "
4390: 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 22 already running"
43a0: 29 0a 09 28 65 78 69 74 20 30 29 29 29 0a 20 20 )..(exit 0))).
43b0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 73 65 72 76 (let loop ((serv
43c0: 65 72 2d 69 64 20 28 6f 70 65 6e 2d 72 75 6e 2d er-id (open-run-
43d0: 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 76 close tasks:serv
43e0: 65 72 2d 6c 6f 63 6b 2d 73 6c 6f 74 20 74 61 73 er-lock-slot tas
43f0: 6b 73 3a 6f 70 65 6e 2d 64 62 20 72 75 6e 2d 69 ks:open-db run-i
4400: 64 29 29 0a 09 20 20 20 20 20 28 72 65 6d 74 72 d)).. (remtr
4410: 69 65 73 20 20 34 29 29 0a 20 20 20 20 28 69 66 ies 4)). (if
4420: 20 28 6e 6f 74 20 73 65 72 76 65 72 2d 69 64 29 (not server-id)
4430: 0a 09 28 69 66 20 28 3e 20 72 65 6d 74 72 69 65 ..(if (> remtrie
4440: 73 20 30 29 0a 09 20 20 20 20 28 62 65 67 69 6e s 0).. (begin
4450: 0a 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d .. (thread-
4460: 73 6c 65 65 70 21 20 32 29 0a 09 20 20 20 20 20 sleep! 2)..
4470: 20 28 6c 6f 6f 70 20 28 6f 70 65 6e 2d 72 75 6e (loop (open-run
4480: 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 -close tasks:ser
4490: 76 65 72 2d 6c 6f 63 6b 2d 73 6c 6f 74 20 74 61 ver-lock-slot ta
44a0: 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 72 75 6e 2d sks:open-db run-
44b0: 69 64 29 0a 09 09 20 20 20 20 28 2d 20 72 65 6d id)... (- rem
44c0: 74 72 69 65 73 20 31 29 29 29 0a 09 20 20 20 20 tries 1)))..
44d0: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 3b 3b (begin.. ;;
44e0: 20 73 69 6e 63 65 20 77 65 20 64 69 64 6e 27 74 since we didn't
44f0: 20 67 65 74 20 74 68 65 20 73 65 72 76 65 72 20 get the server
4500: 6c 6f 63 6b 20 77 65 20 61 72 65 20 67 6f 69 6e lock we are goin
4510: 67 20 74 6f 20 63 6c 65 61 6e 20 75 70 20 61 6e g to clean up an
4520: 64 20 62 61 69 6c 20 6f 75 74 0a 09 20 20 20 20 d bail out..
4530: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
4540: 6e 66 6f 20 32 20 22 49 4e 46 4f 3a 20 73 65 72 nfo 2 "INFO: ser
4550: 76 65 72 20 70 69 64 3d 22 20 28 63 75 72 72 65 ver pid=" (curre
4560: 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 22 nt-process-id) "
4570: 2c 20 68 6f 73 74 6e 61 6d 65 3d 22 20 28 67 65 , hostname=" (ge
4580: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 20 6e t-host-name) " n
4590: 6f 74 20 73 74 61 72 74 69 6e 67 20 64 75 65 20 ot starting due
45a0: 74 6f 20 6f 74 68 65 72 20 63 61 6e 64 69 64 61 to other candida
45b0: 74 65 73 20 61 68 65 61 64 20 69 6e 20 73 74 61 tes ahead in sta
45c0: 72 74 20 71 75 65 75 65 22 29 0a 09 20 20 20 20 rt queue")..
45d0: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
45e0: 65 20 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 64 e tasks:server-d
45f0: 65 6c 65 74 65 2d 72 65 63 6f 72 64 73 2d 66 6f elete-records-fo
4600: 72 2d 74 68 69 73 2d 70 69 64 20 74 61 73 6b 73 r-this-pid tasks
4610: 3a 6f 70 65 6e 2d 64 62 20 22 20 68 74 74 70 2d :open-db " http-
4620: 74 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 transport:launch
4630: 22 29 0a 09 20 20 20 20 20 20 29 29 0a 09 28 6c ").. ))..(l
4640: 65 74 2a 20 28 28 74 68 32 20 28 6d 61 6b 65 2d et* ((th2 (make-
4650: 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 thread (lambda (
4660: 29 0a 09 09 09 09 20 20 20 28 68 74 74 70 2d 74 )..... (http-t
4670: 72 61 6e 73 70 6f 72 74 3a 72 75 6e 20 0a 09 09 ransport:run ...
4680: 09 09 20 20 20 20 28 69 66 20 28 61 72 67 73 3a .. (if (args:
4690: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
46a0: 22 29 0a 09 09 09 09 09 28 61 72 67 73 3a 67 65 ")......(args:ge
46b0: 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 t-arg "-server")
46c0: 0a 09 09 09 09 09 22 2d 22 29 0a 09 09 09 09 20 ......"-").....
46d0: 20 20 20 72 75 6e 2d 69 64 0a 09 09 09 09 20 20 run-id.....
46e0: 20 20 73 65 72 76 65 72 2d 69 64 29 29 20 22 53 server-id)) "S
46f0: 65 72 76 65 72 20 72 75 6e 22 29 29 0a 09 20 20 erver run"))..
4700: 20 20 20 20 20 28 74 68 33 20 28 6d 61 6b 65 2d (th3 (make-
4710: 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 thread (lambda (
4720: 29 0a 09 09 09 09 20 20 20 28 68 74 74 70 2d 74 )..... (http-t
4730: 72 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 ransport:keep-ru
4740: 6e 6e 69 6e 67 20 73 65 72 76 65 72 2d 69 64 29 nning server-id)
4750: 29 0a 09 09 09 09 20 22 4b 65 65 70 20 72 75 6e )..... "Keep run
4760: 6e 69 6e 67 22 29 29 29 0a 09 20 20 3b 3b 20 44 ning"))).. ;; D
4770: 61 74 61 62 61 73 65 20 63 6f 6e 6e 65 63 74 69 atabase connecti
4780: 6f 6e 0a 09 20 20 28 73 65 74 21 20 2a 69 6e 6d on.. (set! *inm
4790: 65 6d 64 62 2a 20 20 28 64 62 3a 73 65 74 75 70 emdb* (db:setup
47a0: 20 72 75 6e 2d 69 64 29 29 0a 09 20 20 28 74 68 run-id)).. (th
47b0: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 read-start! th2)
47c0: 0a 09 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 .. (thread-star
47d0: 74 21 20 74 68 33 29 0a 09 20 20 28 73 65 74 21 t! th3).. (set!
47e0: 20 2a 64 69 64 73 6f 6d 65 74 68 69 6e 67 2a 20 *didsomething*
47f0: 23 74 29 0a 09 20 20 28 74 68 72 65 61 64 2d 6a #t).. (thread-j
4800: 6f 69 6e 21 20 74 68 32 29 0a 09 20 20 28 65 78 oin! th2).. (ex
4810: 69 74 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 it)))))..(define
4820: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
4830: 3a 73 65 72 76 65 72 2d 73 69 67 6e 61 6c 2d 68 :server-signal-h
4840: 61 6e 64 6c 65 72 20 73 69 67 6e 75 6d 29 0a 20 andler signum).
4850: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
4860: 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 64 ons. exn. (d
4870: 65 62 75 67 3a 70 72 69 6e 74 20 22 20 2e 2e 2e ebug:print " ...
4880: 20 65 78 69 74 69 6e 67 20 2e 2e 2e 22 29 0a 20 exiting ...").
4890: 20 20 28 6c 65 74 20 28 28 74 68 31 20 28 6d 61 (let ((th1 (ma
48a0: 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 ke-thread (lambd
48b0: 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 74 68 a ().... (th
48c0: 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 29 0a read-sleep! 1)).
48d0: 09 09 09 20 20 20 22 65 61 74 20 72 65 73 70 6f ... "eat respo
48e0: 6e 73 65 22 29 29 0a 09 20 28 74 68 32 20 28 6d nse")).. (th2 (m
48f0: 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 ake-thread (lamb
4900: 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 64 da ().... (d
4910: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
4920: 52 4f 52 3a 20 52 65 63 65 69 76 65 64 20 5e 43 ROR: Received ^C
4930: 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 63 6c 65 , attempting cle
4940: 61 6e 20 65 78 69 74 2e 20 50 6c 65 61 73 65 20 an exit. Please
4950: 62 65 20 70 61 74 69 65 6e 74 20 61 6e 64 20 77 be patient and w
4960: 61 69 74 20 61 20 66 65 77 20 73 65 63 6f 6e 64 ait a few second
4970: 73 20 62 65 66 6f 72 65 20 68 69 74 74 69 6e 67 s before hitting
4980: 20 5e 43 20 61 67 61 69 6e 2e 22 29 0a 09 09 09 ^C again.")....
4990: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
49a0: 65 70 21 20 33 29 20 3b 3b 20 67 69 76 65 20 74 ep! 3) ;; give t
49b0: 68 65 20 66 6c 75 73 68 20 74 68 72 65 65 20 73 he flush three s
49c0: 65 63 6f 6e 64 73 20 74 6f 20 64 6f 20 69 74 27 econds to do it'
49d0: 73 20 73 74 75 66 66 0a 09 09 09 20 20 20 20 20 s stuff....
49e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
49f0: 20 20 20 20 20 20 20 44 6f 6e 65 2e 22 29 0a 09 Done.")..
4a00: 09 09 20 20 20 20 20 28 65 78 69 74 20 34 29 29 .. (exit 4))
4a10: 0a 09 09 09 20 20 20 22 65 78 69 74 20 6f 6e 20 .... "exit on
4a20: 5e 43 20 74 69 6d 65 72 22 29 29 29 0a 20 20 20 ^C timer"))).
4a30: 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 (thread-start!
4a40: 20 74 68 32 29 0a 20 20 20 20 20 28 74 68 72 65 th2). (thre
4a50: 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a 20 ad-start! th1).
4a60: 20 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e (thread-join
4a70: 21 20 74 68 32 29 29 29 29 0a 0a 3b 3b 3d 3d 3d ! th2))))..;;===
4a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ac0: 3d 3d 3d 0a 3b 3b 20 77 65 62 20 70 61 67 65 73 ===.;; web pages
4ad0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
4ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
4b20: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
4b30: 72 74 3a 6d 61 69 6e 2d 70 61 67 65 29 0a 20 20 rt:main-page).
4b40: 28 6c 65 74 20 28 28 6c 69 6e 6b 70 61 74 68 20 (let ((linkpath
4b50: 28 72 6f 6f 74 2d 70 61 74 68 29 29 29 0a 20 20 (root-path))).
4b60: 20 20 28 63 6f 6e 63 20 22 3c 68 65 61 64 3e 3c (conc "<head><
4b70: 68 31 3e 22 20 28 70 61 74 68 6e 61 6d 65 2d 73 h1>" (pathname-s
4b80: 74 72 69 70 2d 64 69 72 65 63 74 6f 72 79 20 2a trip-directory *
4b90: 74 6f 70 70 61 74 68 2a 29 20 22 3c 2f 68 31 3e toppath*) "</h1>
4ba0: 3c 2f 68 65 61 64 3e 22 0a 09 20 20 22 3c 62 6f </head>".. "<bo
4bb0: 64 79 3e 22 0a 09 20 20 22 52 75 6e 20 61 72 65 dy>".. "Run are
4bc0: 61 3a 20 22 20 2a 74 6f 70 70 61 74 68 2a 0a 09 a: " *toppath*..
4bd0: 20 20 22 3c 68 32 3e 53 65 72 76 65 72 20 53 74 "<h2>Server St
4be0: 61 74 73 3c 2f 68 32 3e 22 0a 09 20 20 28 68 74 ats</h2>".. (ht
4bf0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 74 61 tp-transport:sta
4c00: 74 73 2d 74 61 62 6c 65 29 20 0a 09 20 20 22 3c ts-table) .. "<
4c10: 68 72 3e 22 0a 09 20 20 28 68 74 74 70 2d 74 72 hr>".. (http-tr
4c20: 61 6e 73 70 6f 72 74 3a 72 75 6e 73 20 6c 69 6e ansport:runs lin
4c30: 6b 70 61 74 68 29 0a 09 20 20 22 3c 68 72 3e 22 kpath).. "<hr>"
4c40: 0a 09 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 .. (http-transp
4c50: 6f 72 74 3a 72 75 6e 2d 73 74 61 74 73 29 0a 09 ort:run-stats)..
4c60: 20 20 22 3c 2f 62 6f 64 79 3e 22 0a 09 20 20 29 "</body>".. )
4c70: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 ))..(define (htt
4c80: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 74 61 74 p-transport:stat
4c90: 73 2d 74 61 62 6c 65 29 0a 20 20 28 6d 75 74 65 s-table). (mute
4ca0: 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 x-lock! *heartbe
4cb0: 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 28 6c 65 at-mutex*). (le
4cc0: 74 20 28 28 72 65 73 20 0a 09 20 28 63 6f 6e 63 t ((res .. (conc
4cd0: 20 22 3c 74 61 62 6c 65 3e 22 0a 09 20 20 20 20 "<table>"..
4ce0: 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4d 61 78 20 "<tr><td>Max
4cf0: 63 61 63 68 65 64 20 71 75 65 72 69 65 73 3c 2f cached queries</
4d00: 74 64 3e 20 20 20 20 20 20 20 20 3c 74 64 3e 22 td> <td>"
4d10: 20 2a 6d 61 78 2d 63 61 63 68 65 2d 73 69 7a 65 *max-cache-size
4d20: 2a 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 * "</td></tr>"..
4d30: 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e "<tr><td>
4d40: 4e 75 6d 62 65 72 20 6f 66 20 63 61 63 68 65 64 Number of cached
4d50: 20 77 72 69 74 65 73 3c 2f 74 64 3e 20 20 20 3c writes</td> <
4d60: 74 64 3e 22 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d td>" *number-of-
4d70: 77 72 69 74 65 73 2a 20 22 3c 2f 74 64 3e 3c 2f writes* "</td></
4d80: 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c 74 tr>".. "<t
4d90: 72 3e 3c 74 64 3e 41 76 65 72 61 67 65 20 63 61 r><td>Average ca
4da0: 63 68 65 64 20 77 72 69 74 65 20 74 69 6d 65 3c ched write time<
4db0: 2f 74 64 3e 20 3c 74 64 3e 22 20 28 69 66 20 28 /td> <td>" (if (
4dc0: 65 71 3f 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 eq? *number-of-w
4dd0: 72 69 74 65 73 2a 20 30 29 0a 09 09 09 09 09 09 rites* 0).......
4de0: 09 09 20 22 6e 2f 61 20 28 6e 6f 20 77 72 69 74 .. "n/a (no writ
4df0: 65 73 29 22 0a 09 09 09 09 09 09 09 09 20 28 2f es)"......... (/
4e00: 20 2a 77 72 69 74 65 73 2d 74 6f 74 61 6c 2d 64 *writes-total-d
4e10: 65 6c 61 79 2a 0a 09 09 09 09 09 09 09 09 20 20 elay*.........
4e20: 20 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 *number-of-wri
4e30: 74 65 73 2a 29 29 0a 09 20 20 20 20 20 20 20 22 tes*)).. "
4e40: 20 6d 73 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 ms</td></tr>"..
4e50: 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e "<tr><td>
4e60: 4e 75 6d 62 65 72 20 6e 6f 6e 2d 63 61 63 68 65 Number non-cache
4e70: 64 20 71 75 65 72 69 65 73 3c 2f 74 64 3e 20 3c d queries</td> <
4e80: 74 64 3e 22 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f td>" *number-no
4e90: 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a n-write-queries*
4ea0: 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 "</td></tr>"..
4eb0: 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 41 "<tr><td>A
4ec0: 76 65 72 61 67 65 20 6e 6f 6e 2d 63 61 63 68 65 verage non-cache
4ed0: 64 20 74 69 6d 65 3c 2f 74 64 3e 20 20 20 3c 74 d time</td> <t
4ee0: 64 3e 22 20 28 69 66 20 28 65 71 3f 20 2a 6e 75 d>" (if (eq? *nu
4ef0: 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 mber-non-write-q
4f00: 75 65 72 69 65 73 2a 20 30 29 0a 09 09 09 09 09 ueries* 0)......
4f10: 09 09 09 20 22 6e 2f 61 20 28 6e 6f 20 71 75 65 ... "n/a (no que
4f20: 72 69 65 73 29 22 0a 09 09 09 09 09 09 09 09 20 ries)".........
4f30: 28 2f 20 2a 74 6f 74 61 6c 2d 6e 6f 6e 2d 77 72 (/ *total-non-wr
4f40: 69 74 65 2d 64 65 6c 61 79 2a 20 0a 09 09 09 09 ite-delay* .....
4f50: 09 09 09 09 20 20 20 20 2a 6e 75 6d 62 65 72 2d .... *number-
4f60: 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 non-write-querie
4f70: 73 2a 29 29 0a 09 20 20 20 20 20 20 20 22 20 6d s*)).. " m
4f80: 73 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 s</td></tr>"..
4f90: 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4c 61 "<tr><td>La
4fa0: 73 74 20 61 63 63 65 73 73 3c 2f 74 64 3e 3c 74 st access</td><t
4fb0: 64 3e 22 20 20 20 20 20 20 20 20 20 20 20 20 20 d>"
4fc0: 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d (seconds->time-
4fd0: 73 74 72 69 6e 67 20 2a 6c 61 73 74 2d 64 62 2d string *last-db-
4fe0: 61 63 63 65 73 73 2a 29 20 22 3c 2f 74 64 3e 3c access*) "</td><
4ff0: 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c /tr>".. "<
5000: 2f 74 61 62 6c 65 3e 22 29 29 29 0a 20 20 20 20 /table>"))).
5010: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
5020: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
5030: 29 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 ). res))..(de
5040: 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
5050: 70 6f 72 74 3a 72 75 6e 73 20 6c 69 6e 6b 70 61 port:runs linkpa
5060: 74 68 29 0a 20 20 28 63 6f 6e 63 20 22 3c 68 33 th). (conc "<h3
5070: 3e 52 75 6e 73 3c 2f 68 33 3e 22 0a 09 28 73 74 >Runs</h3>"..(st
5080: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
5090: 0a 09 20 28 6c 65 74 20 28 28 66 69 6c 65 73 20 .. (let ((files
50a0: 28 6d 61 70 20 70 61 74 68 6e 61 6d 65 2d 73 74 (map pathname-st
50b0: 72 69 70 2d 64 69 72 65 63 74 6f 72 79 20 28 67 rip-directory (g
50c0: 6c 6f 62 20 28 63 6f 6e 63 20 6c 69 6e 6b 70 61 lob (conc linkpa
50d0: 74 68 20 22 2f 2a 22 29 29 29 29 29 0a 09 20 20 th "/*")))))..
50e0: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 70 (map (lambda (p
50f0: 29 0a 09 09 20 20 28 63 6f 6e 63 20 22 3c 61 20 )... (conc "<a
5100: 68 72 65 66 3d 5c 22 22 20 70 20 22 5c 22 3e 22 href=\"" p "\">"
5110: 20 70 20 22 3c 2f 61 3e 3c 62 72 3e 22 29 29 0a p "</a><br>")).
5120: 09 09 66 69 6c 65 73 29 29 0a 09 20 22 20 22 29 ..files)).. " ")
5130: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 ))..(define (htt
5140: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 2d p-transport:run-
5150: 73 74 61 74 73 29 0a 20 20 28 6c 65 74 20 28 28 stats). (let ((
5160: 73 74 61 74 73 20 28 6f 70 65 6e 2d 72 75 6e 2d stats (open-run-
5170: 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 72 75 6e close db:get-run
5180: 6e 69 6e 67 2d 73 74 61 74 73 20 23 66 29 29 29 ning-stats #f)))
5190: 0a 20 20 20 20 28 63 6f 6e 63 20 22 3c 74 61 62 . (conc "<tab
51a0: 6c 65 3e 22 0a 09 20 20 28 73 74 72 69 6e 67 2d le>".. (string-
51b0: 69 6e 74 65 72 73 70 65 72 73 65 0a 09 20 20 20 intersperse..
51c0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 73 74 (map (lambda (st
51d0: 61 74 29 0a 09 09 20 20 28 63 6f 6e 63 20 22 3c at)... (conc "<
51e0: 74 72 3e 3c 74 64 3e 22 20 28 63 61 72 20 73 74 tr><td>" (car st
51f0: 61 74 29 20 22 3c 2f 74 64 3e 3c 74 64 3e 22 20 at) "</td><td>"
5200: 28 63 61 64 72 20 73 74 61 74 29 20 22 3c 2f 74 (cadr stat) "</t
5210: 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 73 74 61 d></tr>"))...sta
5220: 74 73 29 0a 09 20 20 20 22 20 22 29 0a 09 20 20 ts).. " ")..
5230: 22 3c 2f 74 61 62 6c 65 3e 22 29 29 29 0a "</table>"))).