Artifact
14ceeefe67f0c52d8dd6ad985beb14bfb2b91c6b:
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 76 ullurl (if (v
2360: 65 63 74 6f 72 3f 20 73 65 72 76 65 72 64 61 74 ector? serverdat
2370: 29 0a 09 09 09 20 28 68 74 74 70 2d 74 72 61 6e ).... (http-tran
2380: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 sport:server-dat
2390: 2d 67 65 74 2d 61 70 69 2d 72 65 71 20 73 65 72 -get-api-req ser
23a0: 76 65 72 64 61 74 29 0a 09 09 09 20 28 62 65 67 verdat).... (beg
23b0: 69 6e 0a 09 09 09 20 20 20 28 64 65 62 75 67 3a in.... (debug:
23c0: 70 72 69 6e 74 20 30 20 22 46 41 54 41 4c 20 45 print 0 "FATAL E
23d0: 52 52 4f 52 3a 20 68 74 74 70 2d 74 72 61 6e 73 RROR: http-trans
23e0: 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d port:client-api-
23f0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 61 6c send-receive cal
2400: 6c 65 64 20 77 69 74 68 20 6e 6f 20 73 65 72 76 led with no serv
2410: 65 72 20 69 6e 66 6f 22 29 0a 09 09 09 20 20 20 er info")....
2420: 28 65 78 69 74 20 31 29 29 29 29 0a 09 20 28 72 (exit 1)))).. (r
2430: 65 73 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 es #f)).
2440: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
2450: 74 69 6f 6e 73 0a 20 20 20 20 20 65 78 6e 0a 20 tions. exn.
2460: 20 20 20 20 28 69 66 20 28 3e 20 6e 75 6d 72 65 (if (> numre
2470: 74 72 69 65 73 20 30 29 0a 09 20 28 62 65 67 69 tries 0).. (begi
2480: 6e 0a 09 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c n.. (mutex-unl
2490: 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 ock! *http-mutex
24a0: 2a 29 0a 09 20 20 20 28 74 68 72 65 61 64 2d 73 *).. (thread-s
24b0: 6c 65 65 70 21 20 31 29 0a 09 20 20 20 28 63 6c leep! 1).. (cl
24c0: 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 ose-all-connecti
24d0: 6f 6e 73 21 29 0a 09 20 20 20 28 64 65 62 75 67 ons!).. (debug
24e0: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
24f0: 47 3a 20 46 61 69 6c 65 64 20 74 6f 20 63 6f 6d G: Failed to com
2500: 6d 75 6e 69 63 61 74 65 20 77 69 74 68 20 73 65 municate with se
2510: 72 76 65 72 2c 20 74 72 79 69 6e 67 20 61 67 61 rver, trying aga
2520: 69 6e 2c 20 6e 75 6d 72 65 74 72 69 65 73 20 6c in, numretries l
2530: 65 66 74 3a 20 22 20 6e 75 6d 72 65 74 72 69 65 eft: " numretrie
2540: 73 29 0a 09 20 20 20 28 68 74 74 70 2d 74 72 61 s).. (http-tra
2550: 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 nsport:client-ap
2560: 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 20 72 i-send-receive r
2570: 75 6e 2d 69 64 20 73 65 72 76 65 72 64 61 74 20 un-id serverdat
2580: 63 6d 64 20 70 61 72 61 6d 73 20 6e 75 6d 72 65 cmd params numre
2590: 74 72 69 65 73 3a 20 28 2d 20 6e 75 6d 72 65 74 tries: (- numret
25a0: 72 69 65 73 20 31 29 29 29 0a 09 20 28 62 65 67 ries 1))).. (beg
25b0: 69 6e 0a 09 20 20 20 28 6d 75 74 65 78 2d 75 6e in.. (mutex-un
25c0: 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 lock! *http-mute
25d0: 78 2a 29 0a 09 20 20 20 23 66 29 29 0a 20 20 20 x*).. #f)).
25e0: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
25f0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
2600: 6f 20 31 31 20 22 66 75 6c 6c 75 72 6c 3d 22 20 o 11 "fullurl="
2610: 66 75 6c 6c 75 72 6c 20 22 2c 20 63 6d 64 3d 22 fullurl ", cmd="
2620: 20 63 6d 64 20 22 2c 20 70 61 72 61 6d 73 3d 22 cmd ", params="
2630: 20 70 61 72 61 6d 73 20 22 2c 20 72 75 6e 2d 69 params ", run-i
2640: 64 3d 22 20 72 75 6e 2d 69 64 20 22 5c 6e 22 29 d=" run-id "\n")
2650: 0a 20 20 20 20 20 20 20 3b 3b 20 73 65 74 20 75 . ;; set u
2660: 70 20 74 68 65 20 68 74 74 70 2d 63 6c 69 65 6e p the http-clien
2670: 74 20 68 65 72 65 0a 20 20 20 20 20 20 20 28 6d t here. (m
2680: 61 78 2d 72 65 74 72 79 2d 61 74 74 65 6d 70 74 ax-retry-attempt
2690: 73 20 31 29 0a 20 20 20 20 20 20 20 3b 3b 20 63 s 1). ;; c
26a0: 6f 6e 73 69 64 65 72 20 61 6c 6c 20 72 65 71 75 onsider all requ
26b0: 65 73 74 73 20 69 6e 64 65 6d 70 6f 74 65 6e 74 ests indempotent
26c0: 0a 20 20 20 20 20 20 20 28 72 65 74 72 79 2d 72 . (retry-r
26d0: 65 71 75 65 73 74 3f 20 28 6c 61 6d 62 64 61 20 equest? (lambda
26e0: 28 72 65 71 75 65 73 74 29 0a 09 09 09 20 23 66 (request).... #f
26f0: 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 73 65 6e )). ;; sen
2700: 64 20 74 68 65 20 64 61 74 61 20 61 6e 64 20 67 d the data and g
2710: 65 74 20 74 68 65 20 72 65 73 70 6f 6e 73 65 0a et the response.
2720: 20 20 20 20 20 20 20 3b 3b 20 65 78 74 72 61 63 ;; extrac
2730: 74 20 74 68 65 20 6e 65 65 64 65 64 20 69 6e 66 t the needed inf
2740: 6f 20 66 72 6f 6d 20 74 68 65 20 68 74 74 70 20 o from the http
2750: 64 61 74 61 20 61 6e 64 20 0a 20 20 20 20 20 20 data and .
2760: 20 3b 3b 20 70 72 6f 63 65 73 73 20 61 6e 64 20 ;; process and
2770: 72 65 74 75 72 6e 20 69 74 2e 0a 20 20 20 20 20 return it..
2780: 20 20 28 6c 65 74 2a 20 28 28 73 65 6e 64 2d 72 (let* ((send-r
2790: 65 63 69 65 76 65 20 28 6c 61 6d 62 64 61 20 28 ecieve (lambda (
27a0: 29 0a 09 09 09 20 20 20 20 20 20 28 6d 75 74 65 ).... (mute
27b0: 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 x-lock! *http-mu
27c0: 74 65 78 2a 29 0a 09 09 09 20 20 20 20 20 20 28 tex*).... (
27d0: 73 65 74 21 20 72 65 73 20 28 77 69 74 68 2d 69 set! res (with-i
27e0: 6e 70 75 74 2d 66 72 6f 6d 2d 72 65 71 75 65 73 nput-from-reques
27f0: 74 20 3b 3b 20 77 61 73 20 64 61 74 0a 09 09 09 t ;; was dat....
2800: 09 09 20 66 75 6c 6c 75 72 6c 20 0a 09 09 09 09 .. fullurl .....
2810: 09 20 28 6c 69 73 74 20 28 63 6f 6e 73 20 27 6b . (list (cons 'k
2820: 65 79 20 22 74 68 65 6b 65 79 22 29 0a 09 09 09 ey "thekey")....
2830: 09 09 20 20 20 20 20 20 20 28 63 6f 6e 73 20 27 .. (cons '
2840: 63 6d 64 20 63 6d 64 29 0a 09 09 09 09 09 20 20 cmd cmd)......
2850: 20 20 20 20 20 28 63 6f 6e 73 20 27 70 61 72 61 (cons 'para
2860: 6d 73 20 70 61 72 61 6d 73 29 29 0a 09 09 09 09 ms params)).....
2870: 09 20 72 65 61 64 2d 73 74 72 69 6e 67 29 29 0a . read-string)).
2880: 09 09 09 20 20 20 20 20 20 3b 3b 20 53 68 6f 75 ... ;; Shou
2890: 6c 64 6e 27 74 20 74 68 69 73 20 62 65 20 61 20 ldn't this be a
28a0: 63 61 6c 6c 20 74 6f 20 74 68 65 20 6d 61 6e 61 call to the mana
28b0: 67 65 64 20 63 61 6c 6c 2d 61 6c 6c 2d 63 6f 6e ged call-all-con
28c0: 6e 65 63 74 69 6f 6e 73 20 73 74 75 66 66 20 61 nections stuff a
28d0: 62 6f 76 65 3f 0a 09 09 09 20 20 20 20 20 20 28 bove?.... (
28e0: 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 close-all-connec
28f0: 74 69 6f 6e 73 21 29 0a 09 09 09 20 20 20 20 20 tions!)....
2900: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
2910: 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 09 09 *http-mutex*)...
2920: 09 20 20 20 20 20 20 29 29 0a 09 20 20 20 20 20 . ))..
2930: 20 28 74 69 6d 65 2d 6f 75 74 20 20 20 20 20 28 (time-out (
2940: 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 lambda ()....
2950: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
2960: 21 20 34 35 29 0a 09 09 09 20 20 20 20 20 20 23 ! 45).... #
2970: 66 29 29 0a 09 20 20 20 20 20 20 28 74 68 31 20 f)).. (th1
2980: 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 73 65 6e (make-thread sen
2990: 64 2d 72 65 63 69 65 76 65 20 22 77 69 74 68 2d d-recieve "with-
29a0: 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 65 71 75 65 input-from-reque
29b0: 73 74 22 29 29 0a 09 20 20 20 20 20 20 28 74 68 st")).. (th
29c0: 32 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 74 2 (make-thread t
29d0: 69 6d 65 2d 6f 75 74 20 20 20 20 20 22 74 69 6d ime-out "tim
29e0: 65 20 6f 75 74 22 29 29 29 0a 09 20 28 74 68 72 e out"))).. (thr
29f0: 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a ead-start! th1).
2a00: 09 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 . (thread-start!
2a10: 20 74 68 32 29 0a 09 20 28 74 68 72 65 61 64 2d th2).. (thread-
2a20: 6a 6f 69 6e 21 20 74 68 31 29 0a 09 20 28 74 68 join! th1).. (th
2a30: 72 65 61 64 2d 74 65 72 6d 69 6e 61 74 65 21 20 read-terminate!
2a40: 74 68 32 29 0a 09 20 28 64 65 62 75 67 3a 70 72 th2).. (debug:pr
2a50: 69 6e 74 2d 69 6e 66 6f 20 31 31 20 22 67 6f 74 int-info 11 "got
2a60: 20 72 65 73 3d 22 20 72 65 73 29 0a 09 20 72 65 res=" res).. re
2a70: 73 29 29 29 29 29 0a 0a 3b 3b 20 63 61 72 65 66 s)))))..;; caref
2a80: 75 6c 20 63 6c 6f 73 69 6e 67 20 6f 66 20 63 6f ul closing of co
2a90: 6e 6e 65 63 74 69 6f 6e 73 20 73 74 6f 72 65 64 nnections stored
2aa0: 20 69 6e 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 0a in *runremote*.
2ab0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 ;;.(define (http
2ac0: 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 6f 73 65 -transport:close
2ad0: 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 72 75 6e -connections run
2ae0: 2d 69 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 -id). (let* ((s
2af0: 65 72 76 65 72 2d 64 61 74 20 28 68 61 73 68 2d erver-dat (hash-
2b00: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
2b10: 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 t *runremote* ru
2b20: 6e 2d 69 64 20 23 66 29 29 29 0a 20 20 20 20 28 n-id #f))). (
2b30: 69 66 20 28 76 65 63 74 6f 72 3f 20 73 65 72 76 if (vector? serv
2b40: 65 72 2d 64 61 74 29 0a 09 28 6c 65 74 20 28 28 er-dat)..(let ((
2b50: 61 70 69 2d 64 61 74 20 28 68 74 74 70 2d 74 72 api-dat (http-tr
2b60: 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 ansport:server-d
2b70: 61 74 2d 67 65 74 2d 61 70 69 2d 75 72 69 20 73 at-get-api-uri s
2b80: 65 72 76 65 72 2d 64 61 74 29 29 29 0a 09 20 20 erver-dat)))..
2b90: 28 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 6f (close-connectio
2ba0: 6e 21 20 61 70 69 2d 64 61 74 29 0a 09 20 20 23 n! api-dat).. #
2bb0: 74 29 0a 09 23 66 29 29 29 0a 0a 0a 28 64 65 66 t)..#f)))...(def
2bc0: 69 6e 65 20 28 6d 61 6b 65 2d 68 74 74 70 2d 74 ine (make-http-t
2bd0: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
2be0: 64 61 74 29 28 6d 61 6b 65 2d 76 65 63 74 6f 72 dat)(make-vector
2bf0: 20 35 29 29 0a 28 64 65 66 69 6e 65 20 28 68 74 5)).(define (ht
2c00: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
2c10: 76 65 72 2d 64 61 74 2d 67 65 74 2d 69 66 61 63 ver-dat-get-ifac
2c20: 65 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 e vec)
2c30: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
2c40: 65 63 20 30 29 29 0a 28 64 65 66 69 6e 65 20 28 ec 0)).(define (
2c50: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
2c60: 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 70 6f erver-dat-get-po
2c70: 72 74 20 20 20 20 20 20 20 20 20 20 76 65 63 29 rt vec)
2c80: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
2c90: 20 76 65 63 20 31 29 29 0a 28 64 65 66 69 6e 65 vec 1)).(define
2ca0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
2cb0: 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d :server-dat-get-
2cc0: 61 70 69 2d 75 72 69 20 20 20 20 20 20 20 76 65 api-uri ve
2cd0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
2ce0: 66 20 20 76 65 63 20 32 29 29 0a 28 64 65 66 69 f vec 2)).(defi
2cf0: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
2d00: 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 rt:server-dat-ge
2d10: 74 2d 61 70 69 2d 75 72 6c 20 20 20 20 20 20 20 t-api-url
2d20: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
2d30: 72 65 66 20 20 76 65 63 20 33 29 29 0a 28 64 65 ref vec 3)).(de
2d40: 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
2d50: 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
2d60: 67 65 74 2d 61 70 69 2d 72 65 71 20 20 20 20 20 get-api-req
2d70: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
2d80: 72 2d 72 65 66 20 20 76 65 63 20 34 29 29 0a 0a r-ref vec 4))..
2d90: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
2da0: 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 ansport:server-d
2db0: 61 74 2d 6d 61 6b 65 2d 75 72 6c 20 76 65 63 29 at-make-url vec)
2dc0: 0a 20 20 28 69 66 20 28 61 6e 64 20 28 68 74 74 . (if (and (htt
2dd0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 p-transport:serv
2de0: 65 72 2d 64 61 74 2d 67 65 74 2d 69 66 61 63 65 er-dat-get-iface
2df0: 20 76 65 63 29 0a 09 20 20 20 28 68 74 74 70 2d vec).. (http-
2e00: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
2e10: 2d 64 61 74 2d 67 65 74 2d 70 6f 72 74 20 20 76 -dat-get-port v
2e20: 65 63 29 29 0a 20 20 20 20 20 20 28 63 6f 6e 63 ec)). (conc
2e30: 20 22 68 74 74 70 3a 2f 2f 22 20 0a 09 20 20 20 "http://" ..
2e40: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
2e50: 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d :server-dat-get-
2e60: 69 66 61 63 65 20 76 65 63 29 0a 09 20 20 20 20 iface vec)..
2e70: 22 3a 22 0a 09 20 20 20 20 28 68 74 74 70 2d 74 ":".. (http-t
2e80: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
2e90: 64 61 74 2d 67 65 74 2d 70 6f 72 74 20 20 76 65 dat-get-port ve
2ea0: 63 29 29 0a 20 20 20 20 20 20 23 66 29 29 0a 0a c)). #f))..
2eb0: 3b 3b 0a 3b 3b 20 63 6f 6e 6e 65 63 74 0a 3b 3b ;;.;; connect.;;
2ec0: 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 .(define (http-t
2ed0: 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d ransport:client-
2ee0: 63 6f 6e 6e 65 63 74 20 69 66 61 63 65 20 70 6f connect iface po
2ef0: 72 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 70 rt). (let* ((ap
2f00: 69 2d 75 72 6c 20 20 20 20 20 20 28 63 6f 6e 63 i-url (conc
2f10: 20 22 68 74 74 70 3a 2f 2f 22 20 69 66 61 63 65 "http://" iface
2f20: 20 22 3a 22 20 70 6f 72 74 20 22 2f 61 70 69 22 ":" port "/api"
2f30: 29 29 0a 09 20 28 61 70 69 2d 75 72 69 20 20 20 )).. (api-uri
2f40: 20 20 20 28 75 72 69 2d 72 65 66 65 72 65 6e 63 (uri-referenc
2f50: 65 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f e (conc "http://
2f60: 22 20 69 66 61 63 65 20 22 3a 22 20 70 6f 72 74 " iface ":" port
2f70: 20 22 2f 61 70 69 22 29 29 29 0a 09 20 28 61 70 "/api"))).. (ap
2f80: 69 2d 72 65 71 20 20 20 20 20 20 28 6d 61 6b 65 i-req (make
2f90: 2d 72 65 71 75 65 73 74 20 6d 65 74 68 6f 64 3a -request method:
2fa0: 20 27 50 4f 53 54 20 75 72 69 3a 20 61 70 69 2d 'POST uri: api-
2fb0: 75 72 69 29 29 0a 09 20 28 73 65 72 76 65 72 2d uri)).. (server-
2fc0: 64 61 74 20 20 20 28 76 65 63 74 6f 72 20 69 66 dat (vector if
2fd0: 61 63 65 20 70 6f 72 74 20 61 70 69 2d 75 72 69 ace port api-uri
2fe0: 20 61 70 69 2d 75 72 6c 20 61 70 69 2d 72 65 71 api-url api-req
2ff0: 29 29 29 0a 20 20 20 20 73 65 72 76 65 72 2d 64 ))). server-d
3000: 61 74 29 29 0a 0a 3b 3b 20 72 75 6e 20 68 74 74 at))..;; run htt
3010: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6b 65 65 70 p-transport:keep
3020: 2d 72 75 6e 6e 69 6e 67 20 69 6e 20 61 20 70 61 -running in a pa
3030: 72 61 6c 6c 65 6c 20 74 68 72 65 61 64 20 74 6f rallel thread to
3040: 20 6d 6f 6e 69 74 6f 72 20 74 68 61 74 20 74 68 monitor that th
3050: 65 20 64 62 20 69 73 20 62 65 69 6e 67 20 0a 3b e db is being .;
3060: 3b 20 75 73 65 64 20 61 6e 64 20 74 6f 20 73 68 ; used and to sh
3070: 75 74 64 6f 77 6e 20 61 66 74 65 72 20 73 6f 6d utdown after som
3080: 65 74 69 6d 65 20 69 66 20 69 74 20 69 73 20 6e etime if it is n
3090: 6f 74 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ot..;;.(define (
30a0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6b http-transport:k
30b0: 65 65 70 2d 72 75 6e 6e 69 6e 67 20 73 65 72 76 eep-running serv
30c0: 65 72 2d 69 64 29 0a 20 20 3b 3b 20 69 66 20 6e er-id). ;; if n
30d0: 6f 6e 65 20 72 75 6e 6e 69 6e 67 20 6f 72 20 69 one running or i
30e0: 66 20 3e 20 32 30 20 73 65 63 6f 6e 64 73 20 73 f > 20 seconds s
30f0: 69 6e 63 65 20 0a 20 20 3b 3b 20 73 65 72 76 65 ince . ;; serve
3100: 72 20 6c 61 73 74 20 75 73 65 64 20 74 68 65 6e r last used then
3110: 20 73 74 61 72 74 20 73 68 75 74 64 6f 77 6e 0a start shutdown.
3120: 20 20 3b 3b 20 54 68 69 73 20 74 68 72 65 61 64 ;; This thread
3130: 20 77 61 69 74 73 20 66 6f 72 20 74 68 65 20 73 waits for the s
3140: 65 72 76 65 72 20 74 6f 20 63 6f 6d 65 20 61 6c erver to come al
3150: 69 76 65 0a 20 20 28 6c 65 74 2a 20 28 28 73 65 ive. (let* ((se
3160: 72 76 65 72 2d 69 6e 66 6f 20 28 6c 65 74 20 6c rver-info (let l
3170: 6f 6f 70 20 28 28 73 74 61 72 74 2d 74 69 6d 65 oop ((start-time
3180: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
3190: 73 29 29 0a 09 09 09 09 20 28 63 68 61 6e 67 65 s))..... (change
31a0: 64 20 20 20 20 23 74 29 0a 09 09 09 09 20 28 6c d #t)..... (l
31b0: 61 73 74 2d 73 64 61 74 20 20 22 6e 6f 74 20 74 ast-sdat "not t
31c0: 68 69 73 22 29 29 0a 20 20 20 20 20 20 20 20 20 his")).
31d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
31e0: 6c 65 74 20 28 28 73 64 61 74 20 23 66 29 29 0a let ((sdat #f)).
31f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3200: 20 20 20 20 20 20 20 20 20 20 28 6d 75 74 65 78 (mutex
3210: 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 -lock! *heartbea
3220: 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 t-mutex*).
3230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3240: 20 20 20 20 28 73 65 74 21 20 73 64 61 74 20 2a (set! sdat *
3250: 73 65 72 76 65 72 2d 69 6e 66 6f 2a 29 0a 20 20 server-info*).
3260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3270: 20 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 (mutex-u
3280: 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 nlock! *heartbea
3290: 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 t-mutex*).
32a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
32b0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 73 64 61 (if (and sda
32c0: 74 0a 09 09 09 09 20 20 20 28 6e 6f 74 20 63 68 t..... (not ch
32d0: 61 6e 67 65 64 29 0a 09 09 09 09 20 20 20 28 3e anged)..... (>
32e0: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
32f0: 6f 6e 64 73 29 20 73 74 61 72 74 2d 74 69 6d 65 onds) start-time
3300: 29 20 32 29 29 0a 09 09 09 20 20 20 20 20 20 73 ) 2)).... s
3310: 64 61 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 dat.
3320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3330: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
3340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3350: 20 20 20 20 20 20 20 20 20 28 73 6c 65 65 70 20 (sleep
3360: 34 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 4).
3370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3380: 20 20 20 28 6c 6f 6f 70 20 73 74 61 72 74 2d 74 (loop start-t
3390: 69 6d 65 0a 09 09 09 09 20 20 20 20 20 20 28 65 ime..... (e
33a0: 71 75 61 6c 3f 20 73 64 61 74 20 6c 61 73 74 2d qual? sdat last-
33b0: 73 64 61 74 29 0a 09 09 09 09 20 20 20 20 20 20 sdat).....
33c0: 73 64 61 74 29 29 29 29 29 29 0a 20 20 20 20 20 sdat)))))).
33d0: 20 20 20 20 28 69 66 61 63 65 20 20 20 20 20 20 (iface
33e0: 20 28 63 61 72 20 73 65 72 76 65 72 2d 69 6e 66 (car server-inf
33f0: 6f 29 29 0a 20 20 20 20 20 20 20 20 20 28 70 6f o)). (po
3400: 72 74 20 20 20 20 20 20 20 20 28 63 61 64 72 20 rt (cadr
3410: 73 65 72 76 65 72 2d 69 6e 66 6f 29 29 0a 20 20 server-info)).
3420: 20 20 20 20 20 20 20 28 6c 61 73 74 2d 61 63 63 (last-acc
3430: 65 73 73 20 30 29 0a 09 20 28 74 64 62 20 20 20 ess 0).. (tdb
3440: 20 20 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 (tasks:ope
3450: 6e 2d 64 62 29 29 0a 09 20 28 73 65 72 76 65 72 n-db)).. (server
3460: 2d 74 69 6d 65 6f 75 74 20 28 6c 65 74 20 28 28 -timeout (let ((
3470: 74 6d 6f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f tmo (configf:loo
3480: 6b 75 70 20 20 2a 63 6f 6e 66 69 67 64 61 74 2a kup *configdat*
3490: 20 22 73 65 72 76 65 72 22 20 22 74 69 6d 65 6f "server" "timeo
34a0: 75 74 22 29 29 29 0a 09 09 09 20 20 20 28 69 66 ut"))).... (if
34b0: 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 74 (and (string? t
34c0: 6d 6f 29 0a 09 09 09 09 20 20 20 20 28 73 74 72 mo)..... (str
34d0: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 74 6d 6f 29 ing->number tmo)
34e0: 29 0a 09 09 09 20 20 20 20 20 20 20 28 2a 20 36 ).... (* 6
34f0: 30 20 36 30 20 28 73 74 72 69 6e 67 2d 3e 6e 75 0 60 (string->nu
3500: 6d 62 65 72 20 74 6d 6f 29 29 0a 09 09 09 20 20 mber tmo))....
3510: 20 20 20 20 20 3b 3b 20 28 2a 20 33 20 32 34 20 ;; (* 3 24
3520: 36 30 20 36 30 29 20 3b 3b 20 64 65 66 61 75 6c 60 60) ;; defaul
3530: 74 20 74 6f 20 74 68 72 65 65 20 64 61 79 73 0a t to three days.
3540: 09 09 09 20 20 20 20 20 20 20 3b 3b 20 28 2a 20 ... ;; (*
3550: 36 30 20 31 29 20 20 20 20 20 20 20 20 20 3b 3b 60 1) ;;
3560: 20 64 65 66 61 75 6c 74 20 74 6f 20 6f 6e 65 20 default to one
3570: 6d 69 6e 75 74 65 0a 09 09 09 20 20 20 20 20 20 minute....
3580: 20 28 2a 20 36 30 20 36 30 20 32 35 29 20 20 20 (* 60 60 25)
3590: 20 20 20 3b 3b 20 64 65 66 61 75 6c 74 20 74 6f ;; default to
35a0: 20 32 35 20 68 6f 75 72 73 0a 09 09 09 20 20 20 25 hours....
35b0: 20 20 20 20 29 29 29 29 0a 20 20 20 20 28 6c 65 )))). (le
35c0: 74 20 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 20 t loop ((count
35d0: 20 20 20 20 20 20 20 30 29 0a 09 20 20 20 20 20 0)..
35e0: 20 20 28 73 65 72 76 65 72 2d 73 74 61 74 65 20 (server-state
35f0: 27 61 76 61 69 6c 61 62 6c 65 29 29 0a 20 20 20 'available)).
3600: 20 20 20 3b 3b 20 55 73 65 20 74 68 69 73 20 6f ;; Use this o
3610: 70 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 73 79 pportunity to sy
3620: 6e 63 20 74 68 65 20 69 6e 6d 65 6d 64 62 20 74 nc the inmemdb t
3630: 6f 20 64 62 0a 20 20 20 20 20 20 28 6c 65 74 20 o db. (let
3640: 28 28 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 ((start-time (cu
3650: 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e rrent-millisecon
3660: 64 73 29 29 0a 09 20 20 20 20 28 73 79 6e 63 2d ds)).. (sync-
3670: 74 69 6d 65 20 20 23 66 29 0a 09 20 20 20 20 28 time #f).. (
3680: 72 65 6d 2d 74 69 6d 65 20 20 20 23 66 29 29 0a rem-time #f)).
3690: 0a 09 28 69 66 20 2a 69 6e 6d 65 6d 64 62 2a 20 ..(if *inmemdb*
36a0: 28 64 62 3a 73 79 6e 63 2d 74 6f 75 63 68 65 64 (db:sync-touched
36b0: 20 2a 69 6e 6d 65 6d 64 62 2a 20 66 6f 72 63 65 *inmemdb* force
36c0: 2d 73 79 6e 63 3a 20 23 74 29 29 0a 09 28 73 65 -sync: #t))..(se
36d0: 74 21 20 73 79 6e 63 2d 74 69 6d 65 20 20 28 2d t! sync-time (-
36e0: 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 (current-millis
36f0: 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d 74 69 econds) start-ti
3700: 6d 65 29 29 0a 09 28 73 65 74 21 20 72 65 6d 2d me))..(set! rem-
3710: 74 69 6d 65 20 28 71 75 6f 74 69 65 6e 74 20 28 time (quotient (
3720: 2d 20 34 30 30 30 20 73 79 6e 63 2d 74 69 6d 65 - 4000 sync-time
3730: 29 20 31 30 30 30 29 29 0a 09 28 64 65 62 75 67 ) 1000))..(debug
3740: 3a 70 72 69 6e 74 20 30 20 22 53 59 4e 43 3a 20 :print 0 "SYNC:
3750: 74 69 6d 65 3d 20 22 20 73 79 6e 63 2d 74 69 6d time= " sync-tim
3760: 65 20 22 2c 20 72 65 6d 2d 74 69 6d 65 3d 22 20 e ", rem-time="
3770: 72 65 6d 2d 74 69 6d 65 29 0a 0a 20 20 20 20 20 rem-time)..
3780: 20 3b 3b 0a 20 20 20 20 20 20 3b 3b 20 73 65 74 ;;. ;; set
3790: 5f 72 75 6e 6e 69 6e 67 20 61 66 74 65 72 20 6f _running after o
37a0: 75 72 20 66 69 72 73 74 20 70 61 73 73 20 74 68 ur first pass th
37b0: 72 6f 75 67 68 0a 20 20 20 20 20 20 3b 3b 0a 20 rough. ;;.
37c0: 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 73 65 (if (eq? se
37d0: 72 76 65 72 2d 73 74 61 74 65 20 27 61 76 61 69 rver-state 'avai
37e0: 6c 61 62 6c 65 29 0a 09 20 20 28 74 61 73 6b 73 lable).. (tasks
37f0: 3a 73 65 72 76 65 72 2d 73 65 74 2d 73 74 61 74 :server-set-stat
3800: 65 21 20 74 64 62 20 73 65 72 76 65 72 2d 69 64 e! tdb server-id
3810: 20 22 72 75 6e 6e 69 6e 67 22 29 29 0a 0a 20 20 "running"))..
3820: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 3c 3d (if (and (<=
3830: 20 72 65 6d 2d 74 69 6d 65 20 34 29 0a 09 20 20 rem-time 4)..
3840: 20 20 20 20 20 28 3e 20 72 65 6d 2d 74 69 6d 65 (> rem-time
3850: 20 30 29 29 0a 09 20 20 28 74 68 72 65 61 64 2d 0)).. (thread-
3860: 73 6c 65 65 70 21 20 72 65 6d 2d 74 69 6d 65 29 sleep! rem-time)
3870: 0a 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .. (thread-slee
3880: 70 21 20 34 29 29 29 20 3b 3b 20 66 61 6c 6c 62 p! 4))) ;; fallb
3890: 61 63 6b 20 66 6f 72 20 69 66 20 74 68 65 20 6d ack for if the m
38a0: 61 74 68 20 69 73 20 63 68 61 6e 67 65 64 20 2e ath is changed .
38b0: 2e 2e 0a 20 20 20 20 20 20 0a 20 20 20 20 20 20 ... .
38c0: 28 69 66 20 28 3c 20 63 6f 75 6e 74 20 31 29 20 (if (< count 1)
38d0: 3b 3b 20 33 78 33 20 3d 20 39 20 73 65 63 73 20 ;; 3x3 = 9 secs
38e0: 61 70 72 6f 78 0a 09 20 20 28 6c 6f 6f 70 20 28 aprox.. (loop (
38f0: 2b 20 63 6f 75 6e 74 20 31 29 20 27 72 75 6e 6e + count 1) 'runn
3900: 69 6e 67 29 29 0a 20 20 20 20 20 20 0a 20 20 20 ing)). .
3910: 20 20 20 3b 3b 20 43 68 65 63 6b 20 74 68 61 74 ;; Check that
3920: 20 69 66 61 63 65 20 61 6e 64 20 70 6f 72 74 20 iface and port
3930: 68 61 76 65 20 6e 6f 74 20 63 68 61 6e 67 65 64 have not changed
3940: 20 28 63 61 6e 20 68 61 70 70 65 6e 20 69 66 20 (can happen if
3950: 73 65 72 76 65 72 20 70 6f 72 74 20 63 6f 6c 6c server port coll
3960: 69 64 65 73 29 0a 20 20 20 20 20 20 28 6d 75 74 ides). (mut
3970: 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 ex-lock! *heartb
3980: 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 eat-mutex*).
3990: 20 20 28 73 65 74 21 20 73 64 61 74 20 2a 73 65 (set! sdat *se
39a0: 72 76 65 72 2d 69 6e 66 6f 2a 29 0a 20 20 20 20 rver-info*).
39b0: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
39c0: 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 *heartbeat-mute
39d0: 78 2a 29 0a 20 20 20 20 20 20 0a 20 20 20 20 20 x*). .
39e0: 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 65 (if (or (not (e
39f0: 71 75 61 6c 3f 20 73 64 61 74 20 28 6c 69 73 74 qual? sdat (list
3a00: 20 69 66 61 63 65 20 70 6f 72 74 29 29 29 0a 09 iface port)))..
3a10: 20 20 20 20 20 20 28 6e 6f 74 20 73 65 72 76 65 (not serve
3a20: 72 2d 69 64 29 29 0a 09 20 20 28 62 65 67 69 6e r-id)).. (begin
3a30: 20 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
3a40: 69 6e 74 2d 69 6e 66 6f 20 30 20 22 69 6e 74 65 int-info 0 "inte
3a50: 72 66 61 63 65 20 63 68 61 6e 67 65 64 2c 20 72 rface changed, r
3a60: 65 66 72 65 73 68 69 6e 67 20 69 66 61 63 65 20 efreshing iface
3a70: 61 6e 64 20 70 6f 72 74 20 69 6e 66 6f 22 29 0a and port info").
3a80: 09 20 20 20 20 28 73 65 74 21 20 69 66 61 63 65 . (set! iface
3a90: 20 28 63 61 72 20 73 64 61 74 29 29 0a 09 20 20 (car sdat))..
3aa0: 20 20 28 73 65 74 21 20 70 6f 72 74 20 20 28 63 (set! port (c
3ab0: 61 64 72 20 73 64 61 74 29 29 29 29 0a 20 20 20 adr sdat)))).
3ac0: 20 20 20 0a 20 20 20 20 20 20 3b 3b 20 54 72 61 . ;; Tra
3ad0: 6e 73 66 65 72 20 2a 6c 61 73 74 2d 64 62 2d 61 nsfer *last-db-a
3ae0: 63 63 65 73 73 2a 20 74 6f 20 6c 61 73 74 2d 61 ccess* to last-a
3af0: 63 63 65 73 73 20 74 6f 20 75 73 65 20 69 6e 20 ccess to use in
3b00: 63 68 65 63 6b 69 6e 67 20 74 68 61 74 20 77 65 checking that we
3b10: 20 61 72 65 20 73 74 69 6c 6c 20 61 6c 69 76 65 are still alive
3b20: 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f . (mutex-lo
3b30: 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
3b40: 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 73 65 utex*). (se
3b50: 74 21 20 6c 61 73 74 2d 61 63 63 65 73 73 20 2a t! last-access *
3b60: 6c 61 73 74 2d 64 62 2d 61 63 63 65 73 73 2a 29 last-db-access*)
3b70: 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e . (mutex-un
3b80: 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 lock! *heartbeat
3b90: 2d 6d 75 74 65 78 2a 29 0a 0a 20 20 20 20 20 20 -mutex*)..
3ba0: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
3bb0: 31 31 20 22 6c 61 73 74 2d 61 63 63 65 73 73 3d 11 "last-access=
3bc0: 22 20 6c 61 73 74 2d 61 63 63 65 73 73 20 22 2c " last-access ",
3bd0: 20 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 3d server-timeout=
3be0: 22 20 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 " server-timeout
3bf0: 29 0a 20 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 ). ;;.
3c00: 20 3b 3b 20 6e 6f 5f 74 72 61 66 66 69 63 0a 20 ;; no_traffic.
3c10: 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 20 28 69 ;;. (i
3c20: 66 20 28 61 6e 64 20 2a 73 65 72 76 65 72 2d 72 f (and *server-r
3c30: 75 6e 2a 0a 09 20 20 20 20 20 20 20 28 3e 20 28 un*.. (> (
3c40: 2b 20 6c 61 73 74 2d 61 63 63 65 73 73 20 73 65 + last-access se
3c50: 72 76 65 72 2d 74 69 6d 65 6f 75 74 29 0a 09 09 rver-timeout)...
3c60: 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e (current-secon
3c70: 64 73 29 29 29 0a 09 20 20 28 62 65 67 69 6e 0a ds))).. (begin.
3c80: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
3c90: 74 2d 69 6e 66 6f 20 30 20 22 53 65 72 76 65 72 t-info 0 "Server
3ca0: 20 63 6f 6e 74 69 6e 75 69 6e 67 2c 20 73 65 63 continuing, sec
3cb0: 6f 6e 64 73 20 73 69 6e 63 65 20 6c 61 73 74 20 onds since last
3cc0: 64 62 20 61 63 63 65 73 73 3a 20 22 20 28 2d 20 db access: " (-
3cd0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
3ce0: 29 20 6c 61 73 74 2d 61 63 63 65 73 73 29 29 0a ) last-access)).
3cf0: 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 . ;;.. ;;
3d00: 43 6f 6e 73 69 64 65 72 20 69 6d 70 6c 65 6d 65 Consider impleme
3d10: 6e 74 69 6e 67 20 73 6f 6d 65 20 73 6d 61 72 74 nting some smart
3d20: 73 20 68 65 72 65 20 74 6f 20 72 65 2d 69 6e 73 s here to re-ins
3d30: 65 72 74 20 74 68 65 20 72 65 63 6f 72 64 20 6f ert the record o
3d40: 72 20 6b 69 6c 6c 20 73 65 6c 66 20 69 73 0a 09 r kill self is..
3d50: 20 20 20 20 3b 3b 20 74 68 65 20 64 62 20 69 6e ;; the db in
3d60: 64 69 63 61 74 65 73 20 73 6f 0a 09 20 20 20 20 dicates so..
3d70: 3b 3b 0a 09 20 20 20 20 3b 3b 20 28 69 66 20 28 ;;.. ;; (if (
3d80: 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 61 6d 2d tasks:server-am-
3d90: 69 2d 74 68 65 2d 73 65 72 76 65 72 3f 20 74 64 i-the-server? td
3da0: 62 20 72 75 6e 2d 69 64 29 0a 09 20 20 20 20 3b b run-id).. ;
3db0: 3b 20 20 20 20 20 28 74 61 73 6b 73 3a 73 65 72 ; (tasks:ser
3dc0: 76 65 72 2d 73 65 74 2d 73 74 61 74 65 21 20 74 ver-set-state! t
3dd0: 64 62 20 73 65 72 76 65 72 2d 69 64 20 22 72 75 db server-id "ru
3de0: 6e 6e 69 6e 67 22 29 29 0a 09 20 20 20 20 3b 3b nning")).. ;;
3df0: 0a 09 20 20 20 20 28 6c 6f 6f 70 20 30 20 73 65 .. (loop 0 se
3e00: 72 76 65 72 2d 73 74 61 74 65 29 29 0a 09 20 20 rver-state))..
3e10: 28 62 65 67 69 6e 0a 09 20 20 20 20 28 64 65 62 (begin.. (deb
3e20: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
3e30: 22 53 74 61 72 74 69 6e 67 20 74 6f 20 73 68 75 "Starting to shu
3e40: 74 64 6f 77 6e 20 74 68 65 20 73 65 72 76 65 72 tdown the server
3e50: 2e 22 29 0a 09 20 20 20 20 3b 3b 20 6e 65 65 64 .").. ;; need
3e60: 20 74 6f 20 64 65 6c 65 74 65 20 6f 6e 6c 79 20 to delete only
3e70: 2a 6d 79 2a 20 73 65 72 76 65 72 20 65 6e 74 72 *my* server entr
3e80: 79 20 28 66 75 74 75 72 65 20 75 73 65 29 0a 09 y (future use)..
3e90: 20 20 20 20 28 73 65 74 21 20 2a 74 69 6d 65 2d (set! *time-
3ea0: 74 6f 2d 65 78 69 74 2a 20 23 74 29 0a 09 20 20 to-exit* #t)..
3eb0: 20 20 28 69 66 20 2a 69 6e 6d 65 6d 64 62 2a 20 (if *inmemdb*
3ec0: 28 64 62 3a 73 79 6e 63 2d 74 6f 75 63 68 65 64 (db:sync-touched
3ed0: 20 2a 69 6e 6d 65 6d 64 62 2a 20 66 6f 72 63 65 *inmemdb* force
3ee0: 2d 73 79 6e 63 3a 20 23 74 29 29 0a 09 20 20 20 -sync: #t))..
3ef0: 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 73 74 61 72 ;;.. ;; star
3f00: 74 5f 73 68 75 74 64 6f 77 6e 0a 09 20 20 20 20 t_shutdown..
3f10: 3b 3b 0a 09 20 20 20 20 28 20 74 61 73 6b 73 3a ;;.. ( tasks:
3f20: 73 65 72 76 65 72 2d 73 65 74 2d 73 74 61 74 65 server-set-state
3f30: 21 20 74 64 62 20 73 65 72 76 65 72 2d 69 64 20 ! tdb server-id
3f40: 22 73 68 75 74 74 69 6e 67 2d 64 6f 77 6e 22 29 "shutting-down")
3f50: 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c .. (thread-sl
3f60: 65 65 70 21 20 35 29 0a 09 20 20 20 20 28 64 65 eep! 5).. (de
3f70: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
3f80: 20 22 4d 61 78 20 63 61 63 68 65 64 20 71 75 65 "Max cached que
3f90: 72 69 65 73 20 77 61 73 20 20 20 20 22 20 2a 6d ries was " *m
3fa0: 61 78 2d 63 61 63 68 65 2d 73 69 7a 65 2a 29 0a ax-cache-size*).
3fb0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
3fc0: 74 2d 69 6e 66 6f 20 30 20 22 4e 75 6d 62 65 72 t-info 0 "Number
3fd0: 20 6f 66 20 63 61 63 68 65 64 20 77 72 69 74 65 of cached write
3fe0: 73 20 20 20 22 20 2a 6e 75 6d 62 65 72 2d 6f 66 s " *number-of
3ff0: 2d 77 72 69 74 65 73 2a 29 0a 09 20 20 20 20 28 -writes*).. (
4000: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
4010: 20 30 20 22 41 76 65 72 61 67 65 20 63 61 63 68 0 "Average cach
4020: 65 64 20 77 72 69 74 65 20 74 69 6d 65 20 22 0a ed write time ".
4030: 09 09 09 20 20 20 20 20 20 28 69 66 20 28 65 71 ... (if (eq
4040: 3f 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 ? *number-of-wri
4050: 74 65 73 2a 20 30 29 0a 09 09 09 09 20 20 22 6e tes* 0)..... "n
4060: 2f 61 20 28 6e 6f 20 77 72 69 74 65 73 29 22 0a /a (no writes)".
4070: 09 09 09 09 20 20 28 2f 20 2a 77 72 69 74 65 73 .... (/ *writes
4080: 2d 74 6f 74 61 6c 2d 64 65 6c 61 79 2a 0a 09 09 -total-delay*...
4090: 09 09 20 20 20 20 20 2a 6e 75 6d 62 65 72 2d 6f .. *number-o
40a0: 66 2d 77 72 69 74 65 73 2a 29 29 0a 09 09 09 20 f-writes*))....
40b0: 20 20 20 20 20 22 20 6d 73 22 29 0a 09 20 20 20 " ms")..
40c0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
40d0: 66 6f 20 30 20 22 4e 75 6d 62 65 72 20 6e 6f 6e fo 0 "Number non
40e0: 2d 63 61 63 68 65 64 20 71 75 65 72 69 65 73 20 -cached queries
40f0: 22 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 " *number-non-w
4100: 72 69 74 65 2d 71 75 65 72 69 65 73 2a 29 0a 09 rite-queries*)..
4110: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4120: 2d 69 6e 66 6f 20 30 20 22 41 76 65 72 61 67 65 -info 0 "Average
4130: 20 6e 6f 6e 2d 63 61 63 68 65 64 20 74 69 6d 65 non-cached time
4140: 20 20 20 22 0a 09 09 09 20 20 20 20 20 20 28 69 ".... (i
4150: 66 20 28 65 71 3f 20 2a 6e 75 6d 62 65 72 2d 6e f (eq? *number-n
4160: 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 73 on-write-queries
4170: 2a 20 30 29 0a 09 09 09 09 20 20 22 6e 2f 61 20 * 0)..... "n/a
4180: 28 6e 6f 20 71 75 65 72 69 65 73 29 22 0a 09 09 (no queries)"...
4190: 09 09 20 20 28 2f 20 2a 74 6f 74 61 6c 2d 6e 6f .. (/ *total-no
41a0: 6e 2d 77 72 69 74 65 2d 64 65 6c 61 79 2a 20 0a n-write-delay* .
41b0: 09 09 09 09 20 20 20 20 20 2a 6e 75 6d 62 65 72 .... *number
41c0: 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 -non-write-queri
41d0: 65 73 2a 29 29 0a 09 09 09 20 20 20 20 20 20 22 es*)).... "
41e0: 20 6d 73 22 29 0a 09 20 20 20 20 28 64 65 62 75 ms").. (debu
41f0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 g:print-info 0 "
4200: 53 65 72 76 65 72 20 73 68 75 74 64 6f 77 6e 20 Server shutdown
4210: 63 6f 6d 70 6c 65 74 65 2e 20 45 78 69 74 69 6e complete. Exitin
4220: 67 22 29 0a 09 20 20 20 20 28 74 61 73 6b 73 3a g").. (tasks:
4230: 73 65 72 76 65 72 2d 64 65 6c 65 74 65 2d 72 65 server-delete-re
4240: 63 6f 72 64 20 74 64 62 20 73 65 72 76 65 72 2d cord tdb server-
4250: 69 64 20 22 20 68 74 74 70 2d 74 72 61 6e 73 70 id " http-transp
4260: 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 ort:keep-running
4270: 22 29 0a 09 20 20 20 20 28 65 78 69 74 29 29 29 ").. (exit)))
4280: 29 29 29 0a 0a 3b 3b 20 61 6c 6c 20 72 6f 75 74 )))..;; all rout
4290: 65 73 20 74 68 6f 75 67 68 20 68 65 72 65 20 65 es though here e
42a0: 6e 64 20 69 6e 20 65 78 69 74 20 2e 2e 2e 0a 3b nd in exit ....;
42b0: 3b 0a 3b 3b 20 73 74 61 72 74 5f 73 65 72 76 65 ;.;; start_serve
42c0: 72 3f 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 r? .;;.(define (
42d0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6c http-transport:l
42e0: 61 75 6e 63 68 20 72 75 6e 2d 69 64 29 0a 20 20 aunch run-id).
42f0: 28 73 65 74 21 20 2a 72 75 6e 2d 69 64 2a 20 20 (set! *run-id*
4300: 20 72 75 6e 2d 69 64 29 0a 20 20 28 69 66 20 28 run-id). (if (
4310: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 64 args:get-arg "-d
4320: 61 65 6d 6f 6e 69 7a 65 22 29 0a 20 20 20 20 20 aemonize").
4330: 20 28 64 61 65 6d 6f 6e 3a 69 7a 65 29 29 0a 20 (daemon:ize)).
4340: 20 28 69 66 20 28 73 65 72 76 65 72 3a 63 68 65 (if (server:che
4350: 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 72 75 ck-if-running ru
4360: 6e 2d 69 64 29 0a 20 20 20 20 20 20 28 62 65 67 n-id). (beg
4370: 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 in..(debug:print
4380: 20 30 20 22 49 4e 46 4f 3a 20 53 65 72 76 65 72 0 "INFO: Server
4390: 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 20 72 75 for run-id " ru
43a0: 6e 2d 69 64 20 22 20 61 6c 72 65 61 64 79 20 72 n-id " already r
43b0: 75 6e 6e 69 6e 67 22 29 0a 09 28 65 78 69 74 20 unning")..(exit
43c0: 30 29 29 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 0))). (let loop
43d0: 20 28 28 73 65 72 76 65 72 2d 69 64 20 28 6f 70 ((server-id (op
43e0: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 en-run-close tas
43f0: 6b 73 3a 73 65 72 76 65 72 2d 6c 6f 63 6b 2d 73 ks:server-lock-s
4400: 6c 6f 74 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 lot tasks:open-d
4410: 62 20 72 75 6e 2d 69 64 29 29 0a 09 20 20 20 20 b run-id))..
4420: 20 28 72 65 6d 74 72 69 65 73 20 20 34 29 29 0a (remtries 4)).
4430: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 65 72 (if (not ser
4440: 76 65 72 2d 69 64 29 0a 09 28 69 66 20 28 3e 20 ver-id)..(if (>
4450: 72 65 6d 74 72 69 65 73 20 30 29 0a 09 20 20 20 remtries 0)..
4460: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
4470: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 thread-sleep! 2)
4480: 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 6f .. (loop (o
4490: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 pen-run-close ta
44a0: 73 6b 73 3a 73 65 72 76 65 72 2d 6c 6f 63 6b 2d sks:server-lock-
44b0: 73 6c 6f 74 20 74 61 73 6b 73 3a 6f 70 65 6e 2d slot tasks:open-
44c0: 64 62 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 20 db run-id)...
44d0: 20 28 2d 20 72 65 6d 74 72 69 65 73 20 31 29 29 (- remtries 1))
44e0: 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 ).. (begin..
44f0: 20 20 20 20 20 3b 3b 20 73 69 6e 63 65 20 77 65 ;; since we
4500: 20 64 69 64 6e 27 74 20 67 65 74 20 74 68 65 20 didn't get the
4510: 73 65 72 76 65 72 20 6c 6f 63 6b 20 77 65 20 61 server lock we a
4520: 72 65 20 67 6f 69 6e 67 20 74 6f 20 63 6c 65 61 re going to clea
4530: 6e 20 75 70 20 61 6e 64 20 62 61 69 6c 20 6f 75 n up and bail ou
4540: 74 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a t.. (debug:
4550: 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 49 4e print-info 2 "IN
4560: 46 4f 3a 20 73 65 72 76 65 72 20 70 69 64 3d 22 FO: server pid="
4570: 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
4580: 73 2d 69 64 29 20 22 2c 20 68 6f 73 74 6e 61 6d s-id) ", hostnam
4590: 65 3d 22 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 e=" (get-host-na
45a0: 6d 65 29 20 22 20 6e 6f 74 20 73 74 61 72 74 69 me) " not starti
45b0: 6e 67 20 64 75 65 20 74 6f 20 6f 74 68 65 72 20 ng due to other
45c0: 63 61 6e 64 69 64 61 74 65 73 20 61 68 65 61 64 candidates ahead
45d0: 20 69 6e 20 73 74 61 72 74 20 71 75 65 75 65 22 in start queue"
45e0: 29 0a 09 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 ).. (open-r
45f0: 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 un-close tasks:s
4600: 65 72 76 65 72 2d 64 65 6c 65 74 65 2d 72 65 63 erver-delete-rec
4610: 6f 72 64 73 2d 66 6f 72 2d 74 68 69 73 2d 70 69 ords-for-this-pi
4620: 64 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 d tasks:open-db
4630: 22 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 " http-transport
4640: 3a 6c 61 75 6e 63 68 22 29 0a 09 20 20 20 20 20 :launch")..
4650: 20 29 29 0a 09 28 6c 65 74 2a 20 28 28 74 68 32 ))..(let* ((th2
4660: 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c (make-thread (l
4670: 61 6d 62 64 61 20 28 29 0a 09 09 09 09 20 20 20 ambda ().....
4680: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
4690: 72 75 6e 20 0a 09 09 09 09 20 20 20 20 28 69 66 run ..... (if
46a0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
46b0: 2d 73 65 72 76 65 72 22 29 0a 09 09 09 09 09 28 -server")......(
46c0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 args:get-arg "-s
46d0: 65 72 76 65 72 22 29 0a 09 09 09 09 09 22 2d 22 erver")......"-"
46e0: 29 0a 09 09 09 09 20 20 20 20 72 75 6e 2d 69 64 )..... run-id
46f0: 0a 09 09 09 09 20 20 20 20 73 65 72 76 65 72 2d ..... server-
4700: 69 64 29 29 20 22 53 65 72 76 65 72 20 72 75 6e id)) "Server run
4710: 22 29 29 0a 09 20 20 20 20 20 20 20 28 74 68 33 ")).. (th3
4720: 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c (make-thread (l
4730: 61 6d 62 64 61 20 28 29 0a 09 09 09 09 20 20 20 ambda ().....
4740: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
4750: 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 73 65 72 keep-running ser
4760: 76 65 72 2d 69 64 29 29 0a 09 09 09 09 20 22 4b ver-id))..... "K
4770: 65 65 70 20 72 75 6e 6e 69 6e 67 22 29 29 29 0a eep running"))).
4780: 09 20 20 3b 3b 20 44 61 74 61 62 61 73 65 20 63 . ;; Database c
4790: 6f 6e 6e 65 63 74 69 6f 6e 0a 09 20 20 28 73 65 onnection.. (se
47a0: 74 21 20 2a 69 6e 6d 65 6d 64 62 2a 20 20 28 64 t! *inmemdb* (d
47b0: 62 3a 73 65 74 75 70 20 72 75 6e 2d 69 64 29 29 b:setup run-id))
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 32 29 0a 09 20 20 28 74 68 72 65 t! th2).. (thre
47e0: 61 64 2d 73 74 61 72 74 21 20 74 68 33 29 0a 09 ad-start! th3)..
47f0: 20 20 28 73 65 74 21 20 2a 64 69 64 73 6f 6d 65 (set! *didsome
4800: 74 68 69 6e 67 2a 20 23 74 29 0a 09 20 20 28 74 thing* #t).. (t
4810: 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 32 29 hread-join! th2)
4820: 0a 09 20 20 28 65 78 69 74 29 29 29 29 29 0a 0a .. (exit)))))..
4830: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
4840: 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 73 ansport:server-s
4850: 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 69 ignal-handler si
4860: 67 6e 75 6d 29 0a 20 20 28 68 61 6e 64 6c 65 2d gnum). (handle-
4870: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 exceptions. ex
4880: 6e 0a 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e n. (debug:prin
4890: 74 20 22 20 2e 2e 2e 20 65 78 69 74 69 6e 67 20 t " ... exiting
48a0: 2e 2e 2e 22 29 0a 20 20 20 28 6c 65 74 20 28 28 ..."). (let ((
48b0: 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 th1 (make-thread
48c0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ()....
48d0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
48e0: 70 21 20 31 29 29 0a 09 09 09 20 20 20 22 65 61 p! 1)).... "ea
48f0: 74 20 72 65 73 70 6f 6e 73 65 22 29 29 0a 09 20 t response"))..
4900: 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 61 (th2 (make-threa
4910: 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 d (lambda ()....
4920: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
4930: 74 20 30 20 22 45 52 52 4f 52 3a 20 52 65 63 65 t 0 "ERROR: Rece
4940: 69 76 65 64 20 5e 43 2c 20 61 74 74 65 6d 70 74 ived ^C, attempt
4950: 69 6e 67 20 63 6c 65 61 6e 20 65 78 69 74 2e 20 ing clean exit.
4960: 50 6c 65 61 73 65 20 62 65 20 70 61 74 69 65 6e Please be patien
4970: 74 20 61 6e 64 20 77 61 69 74 20 61 20 66 65 77 t and wait a few
4980: 20 73 65 63 6f 6e 64 73 20 62 65 66 6f 72 65 20 seconds before
4990: 68 69 74 74 69 6e 67 20 5e 43 20 61 67 61 69 6e hitting ^C again
49a0: 2e 22 29 0a 09 09 09 20 20 20 20 20 28 74 68 72 .").... (thr
49b0: 65 61 64 2d 73 6c 65 65 70 21 20 33 29 20 3b 3b ead-sleep! 3) ;;
49c0: 20 67 69 76 65 20 74 68 65 20 66 6c 75 73 68 20 give the flush
49d0: 74 68 72 65 65 20 73 65 63 6f 6e 64 73 20 74 6f three seconds to
49e0: 20 64 6f 20 69 74 27 73 20 73 74 75 66 66 0a 09 do it's stuff..
49f0: 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
4a00: 69 6e 74 20 30 20 22 20 20 20 20 20 20 20 44 6f int 0 " Do
4a10: 6e 65 2e 22 29 0a 09 09 09 20 20 20 20 20 28 65 ne.").... (e
4a20: 78 69 74 20 34 29 29 0a 09 09 09 20 20 20 22 65 xit 4)).... "e
4a30: 78 69 74 20 6f 6e 20 5e 43 20 74 69 6d 65 72 22 xit on ^C timer"
4a40: 29 29 29 0a 20 20 20 20 20 28 74 68 72 65 61 64 ))). (thread
4a50: 2d 73 74 61 72 74 21 20 74 68 32 29 0a 20 20 20 -start! th2).
4a60: 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 (thread-start!
4a70: 20 74 68 31 29 0a 20 20 20 20 20 28 74 68 72 65 th1). (thre
4a80: 61 64 2d 6a 6f 69 6e 21 20 74 68 32 29 29 29 29 ad-join! th2))))
4a90: 0a 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 77 65 ==========.;; we
4ae0: 62 20 70 61 67 65 73 0a 3b 3b 3d 3d 3d 3d 3d 3d b pages.;;======
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 3d 3d 3d 3d 3d 3d 3d ================
4b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4b30: 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ..(define (http-
4b40: 74 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 transport:main-p
4b50: 61 67 65 29 0a 20 20 28 6c 65 74 20 28 28 6c 69 age). (let ((li
4b60: 6e 6b 70 61 74 68 20 28 72 6f 6f 74 2d 70 61 74 nkpath (root-pat
4b70: 68 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 h))). (conc "
4b80: 3c 68 65 61 64 3e 3c 68 31 3e 22 20 28 70 61 74 <head><h1>" (pat
4b90: 68 6e 61 6d 65 2d 73 74 72 69 70 2d 64 69 72 65 hname-strip-dire
4ba0: 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 ctory *toppath*)
4bb0: 20 22 3c 2f 68 31 3e 3c 2f 68 65 61 64 3e 22 0a "</h1></head>".
4bc0: 09 20 20 22 3c 62 6f 64 79 3e 22 0a 09 20 20 22 . "<body>".. "
4bd0: 52 75 6e 20 61 72 65 61 3a 20 22 20 2a 74 6f 70 Run area: " *top
4be0: 70 61 74 68 2a 0a 09 20 20 22 3c 68 32 3e 53 65 path*.. "<h2>Se
4bf0: 72 76 65 72 20 53 74 61 74 73 3c 2f 68 32 3e 22 rver Stats</h2>"
4c00: 0a 09 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 .. (http-transp
4c10: 6f 72 74 3a 73 74 61 74 73 2d 74 61 62 6c 65 29 ort:stats-table)
4c20: 20 0a 09 20 20 22 3c 68 72 3e 22 0a 09 20 20 28 .. "<hr>".. (
4c30: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 http-transport:r
4c40: 75 6e 73 20 6c 69 6e 6b 70 61 74 68 29 0a 09 20 uns linkpath)..
4c50: 20 22 3c 68 72 3e 22 0a 09 20 20 28 68 74 74 70 "<hr>".. (http
4c60: 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 2d 73 -transport:run-s
4c70: 74 61 74 73 29 0a 09 20 20 22 3c 2f 62 6f 64 79 tats).. "</body
4c80: 3e 22 0a 09 20 20 29 29 29 0a 0a 28 64 65 66 69 >".. )))..(defi
4c90: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
4ca0: 72 74 3a 73 74 61 74 73 2d 74 61 62 6c 65 29 0a rt:stats-table).
4cb0: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
4cc0: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
4cd0: 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 0a ). (let ((res .
4ce0: 09 20 28 63 6f 6e 63 20 22 3c 74 61 62 6c 65 3e . (conc "<table>
4cf0: 22 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c ".. "<tr><
4d00: 74 64 3e 4d 61 78 20 63 61 63 68 65 64 20 71 75 td>Max cached qu
4d10: 65 72 69 65 73 3c 2f 74 64 3e 20 20 20 20 20 20 eries</td>
4d20: 20 20 3c 74 64 3e 22 20 2a 6d 61 78 2d 63 61 63 <td>" *max-cac
4d30: 68 65 2d 73 69 7a 65 2a 20 22 3c 2f 74 64 3e 3c he-size* "</td><
4d40: 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c /tr>".. "<
4d50: 74 72 3e 3c 74 64 3e 4e 75 6d 62 65 72 20 6f 66 tr><td>Number of
4d60: 20 63 61 63 68 65 64 20 77 72 69 74 65 73 3c 2f cached writes</
4d70: 74 64 3e 20 20 20 3c 74 64 3e 22 20 2a 6e 75 6d td> <td>" *num
4d80: 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a 20 22 ber-of-writes* "
4d90: 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 </td></tr>"..
4da0: 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 41 76 65 "<tr><td>Ave
4db0: 72 61 67 65 20 63 61 63 68 65 64 20 77 72 69 74 rage cached writ
4dc0: 65 20 74 69 6d 65 3c 2f 74 64 3e 20 3c 74 64 3e e time</td> <td>
4dd0: 22 20 28 69 66 20 28 65 71 3f 20 2a 6e 75 6d 62 " (if (eq? *numb
4de0: 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a 20 30 29 er-of-writes* 0)
4df0: 0a 09 09 09 09 09 09 09 09 20 22 6e 2f 61 20 28 ......... "n/a (
4e00: 6e 6f 20 77 72 69 74 65 73 29 22 0a 09 09 09 09 no writes)".....
4e10: 09 09 09 09 20 28 2f 20 2a 77 72 69 74 65 73 2d .... (/ *writes-
4e20: 74 6f 74 61 6c 2d 64 65 6c 61 79 2a 0a 09 09 09 total-delay*....
4e30: 09 09 09 09 09 20 20 20 20 2a 6e 75 6d 62 65 72 ..... *number
4e40: 2d 6f 66 2d 77 72 69 74 65 73 2a 29 29 0a 09 20 -of-writes*))..
4e50: 20 20 20 20 20 20 22 20 6d 73 3c 2f 74 64 3e 3c " ms</td><
4e60: 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c /tr>".. "<
4e70: 74 72 3e 3c 74 64 3e 4e 75 6d 62 65 72 20 6e 6f tr><td>Number no
4e80: 6e 2d 63 61 63 68 65 64 20 71 75 65 72 69 65 73 n-cached queries
4e90: 3c 2f 74 64 3e 20 3c 74 64 3e 22 20 20 2a 6e 75 </td> <td>" *nu
4ea0: 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 mber-non-write-q
4eb0: 75 65 72 69 65 73 2a 20 22 3c 2f 74 64 3e 3c 2f ueries* "</td></
4ec0: 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c 74 tr>".. "<t
4ed0: 72 3e 3c 74 64 3e 41 76 65 72 61 67 65 20 6e 6f r><td>Average no
4ee0: 6e 2d 63 61 63 68 65 64 20 74 69 6d 65 3c 2f 74 n-cached time</t
4ef0: 64 3e 20 20 20 3c 74 64 3e 22 20 28 69 66 20 28 d> <td>" (if (
4f00: 65 71 3f 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d eq? *number-non-
4f10: 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a 20 30 write-queries* 0
4f20: 29 0a 09 09 09 09 09 09 09 09 20 22 6e 2f 61 20 )......... "n/a
4f30: 28 6e 6f 20 71 75 65 72 69 65 73 29 22 0a 09 09 (no queries)"...
4f40: 09 09 09 09 09 09 20 28 2f 20 2a 74 6f 74 61 6c ...... (/ *total
4f50: 2d 6e 6f 6e 2d 77 72 69 74 65 2d 64 65 6c 61 79 -non-write-delay
4f60: 2a 20 0a 09 09 09 09 09 09 09 09 20 20 20 20 2a * ......... *
4f70: 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 number-non-write
4f80: 2d 71 75 65 72 69 65 73 2a 29 29 0a 09 20 20 20 -queries*))..
4f90: 20 20 20 20 22 20 6d 73 3c 2f 74 64 3e 3c 2f 74 " ms</td></t
4fa0: 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c 74 72 r>".. "<tr
4fb0: 3e 3c 74 64 3e 4c 61 73 74 20 61 63 63 65 73 73 ><td>Last access
4fc0: 3c 2f 74 64 3e 3c 74 64 3e 22 20 20 20 20 20 20 </td><td>"
4fd0: 20 20 20 20 20 20 20 20 28 73 65 63 6f 6e 64 73 (seconds
4fe0: 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 2a 6c ->time-string *l
4ff0: 61 73 74 2d 64 62 2d 61 63 63 65 73 73 2a 29 20 ast-db-access*)
5000: 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 "</td></tr>"..
5010: 20 20 20 20 20 22 3c 2f 74 61 62 6c 65 3e 22 29 "</table>")
5020: 29 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 6e )). (mutex-un
5030: 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 lock! *heartbeat
5040: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 72 65 73 -mutex*). res
5050: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 ))..(define (htt
5060: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 73 p-transport:runs
5070: 20 6c 69 6e 6b 70 61 74 68 29 0a 20 20 28 63 6f linkpath). (co
5080: 6e 63 20 22 3c 68 33 3e 52 75 6e 73 3c 2f 68 33 nc "<h3>Runs</h3
5090: 3e 22 0a 09 28 73 74 72 69 6e 67 2d 69 6e 74 65 >"..(string-inte
50a0: 72 73 70 65 72 73 65 0a 09 20 28 6c 65 74 20 28 rsperse.. (let (
50b0: 28 66 69 6c 65 73 20 28 6d 61 70 20 70 61 74 68 (files (map path
50c0: 6e 61 6d 65 2d 73 74 72 69 70 2d 64 69 72 65 63 name-strip-direc
50d0: 74 6f 72 79 20 28 67 6c 6f 62 20 28 63 6f 6e 63 tory (glob (conc
50e0: 20 6c 69 6e 6b 70 61 74 68 20 22 2f 2a 22 29 29 linkpath "/*"))
50f0: 29 29 29 0a 09 20 20 20 28 6d 61 70 20 28 6c 61 ))).. (map (la
5100: 6d 62 64 61 20 28 70 29 0a 09 09 20 20 28 63 6f mbda (p)... (co
5110: 6e 63 20 22 3c 61 20 68 72 65 66 3d 5c 22 22 20 nc "<a href=\""
5120: 70 20 22 5c 22 3e 22 20 70 20 22 3c 2f 61 3e 3c p "\">" p "</a><
5130: 62 72 3e 22 29 29 0a 09 09 66 69 6c 65 73 29 29 br>"))...files))
5140: 0a 09 20 22 20 22 29 29 29 0a 0a 28 64 65 66 69 .. " ")))..(defi
5150: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
5160: 72 74 3a 72 75 6e 2d 73 74 61 74 73 29 0a 20 20 rt:run-stats).
5170: 28 6c 65 74 20 28 28 73 74 61 74 73 20 28 6f 70 (let ((stats (op
5180: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a en-run-close db:
5190: 67 65 74 2d 72 75 6e 6e 69 6e 67 2d 73 74 61 74 get-running-stat
51a0: 73 20 23 66 29 29 29 0a 20 20 20 20 28 63 6f 6e s #f))). (con
51b0: 63 20 22 3c 74 61 62 6c 65 3e 22 0a 09 20 20 28 c "<table>".. (
51c0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
51d0: 73 65 0a 09 20 20 20 28 6d 61 70 20 28 6c 61 6d se.. (map (lam
51e0: 62 64 61 20 28 73 74 61 74 29 0a 09 09 20 20 28 bda (stat)... (
51f0: 63 6f 6e 63 20 22 3c 74 72 3e 3c 74 64 3e 22 20 conc "<tr><td>"
5200: 28 63 61 72 20 73 74 61 74 29 20 22 3c 2f 74 64 (car stat) "</td
5210: 3e 3c 74 64 3e 22 20 28 63 61 64 72 20 73 74 61 ><td>" (cadr sta
5220: 74 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 t) "</td></tr>")
5230: 29 0a 09 09 73 74 61 74 73 29 0a 09 20 20 20 22 )...stats).. "
5240: 20 22 29 0a 09 20 20 22 3c 2f 74 61 62 6c 65 3e ").. "</table>
5250: 22 29 29 29 0a "))).