Artifact
bedbeec6ccc29cfdca051db39e552eaf20b5a57a:
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 29 0a 20 20 28 64 65 62 75 n hostn). (debu
0740: 67 3a 70 72 69 6e 74 20 32 20 22 41 74 74 65 6d g:print 2 "Attem
0750: 70 74 69 6e 67 20 74 6f 20 73 74 61 72 74 20 74 pting to start t
0760: 68 65 20 73 65 72 76 65 72 20 2e 2e 2e 22 29 0a he server ...").
0770: 20 20 28 69 66 20 28 6e 6f 74 20 2a 74 6f 70 70 (if (not *topp
0780: 61 74 68 2a 29 0a 20 20 20 20 20 20 28 69 66 20 ath*). (if
0790: 28 6e 6f 74 20 28 73 65 74 75 70 2d 66 6f 72 2d (not (setup-for-
07a0: 72 75 6e 29 29 0a 09 20 20 28 62 65 67 69 6e 0a run)).. (begin.
07b0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
07c0: 74 20 30 20 22 45 52 52 4f 52 3a 20 63 61 6e 6e t 0 "ERROR: cann
07d0: 6f 74 20 66 69 6e 64 20 6d 65 67 61 74 65 73 74 ot find megatest
07e0: 2e 63 6f 6e 66 69 67 2c 20 63 61 6e 6e 6f 74 20 .config, cannot
07f0: 73 74 61 72 74 20 73 65 72 76 65 72 2c 20 65 78 start server, ex
0800: 69 74 69 6e 67 22 29 0a 09 20 20 20 20 28 65 78 iting").. (ex
0810: 69 74 29 29 29 29 0a 20 20 28 6c 65 74 2a 20 28 it)))). (let* (
0820: 3b 3b 20 28 69 66 61 63 65 20 20 20 20 20 20 20 ;; (iface
0830: 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d (if (string=
0840: 3f 20 22 2d 22 20 68 6f 73 74 6e 29 0a 09 20 3b ? "-" hostn).. ;
0850: 3b 20 20 20 20 20 20 20 20 09 20 20 20 20 20 20 ; .
0860: 23 66 20 3b 3b 20 28 67 65 74 2d 68 6f 73 74 2d #f ;; (get-host-
0870: 6e 61 6d 65 29 20 0a 09 20 3b 3b 20 20 20 20 20 name) .. ;;
0880: 20 20 20 09 20 20 20 20 20 20 68 6f 73 74 6e 29 . hostn)
0890: 29 0a 09 20 28 64 62 20 20 20 20 20 20 20 20 20 ).. (db
08a0: 20 20 20 20 20 23 66 29 20 3b 3b 20 20 20 20 20 #f) ;;
08b0: 20 20 20 28 6f 70 65 6e 2d 64 62 29 29 20 3b 3b (open-db)) ;;
08c0: 20 77 65 20 64 6f 6e 27 74 20 77 61 6e 74 20 74 we don't want t
08d0: 68 65 20 73 65 72 76 65 72 20 74 6f 20 62 65 20 he server to be
08e0: 6f 70 65 6e 69 6e 67 20 61 6e 64 20 63 6c 6f 73 opening and clos
08f0: 69 6e 67 20 74 68 65 20 64 62 20 75 6e 6e 65 63 ing the db unnec
0900: 65 73 61 72 69 6c 79 0a 09 20 28 68 6f 73 74 6e esarily.. (hostn
0910: 61 6d 65 20 20 20 20 20 20 20 20 28 67 65 74 2d ame (get-
0920: 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 69 host-name)).. (i
0930: 70 61 64 64 72 73 74 72 20 20 20 20 20 20 20 28 paddrstr (
0940: 6c 65 74 20 28 28 69 70 73 74 72 20 28 69 66 20 let ((ipstr (if
0950: 28 73 74 72 69 6e 67 3d 3f 20 22 2d 22 20 68 6f (string=? "-" ho
0960: 73 74 6e 29 0a 09 09 09 09 09 20 20 20 3b 3b 20 stn)...... ;;
0970: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
0980: 72 73 65 20 28 6d 61 70 20 6e 75 6d 62 65 72 2d rse (map number-
0990: 3e 73 74 72 69 6e 67 20 28 75 38 76 65 63 74 6f >string (u8vecto
09a0: 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 6e 61 6d r->list (hostnam
09b0: 65 2d 3e 69 70 20 68 6f 73 74 6e 61 6d 65 29 29 e->ip hostname))
09c0: 29 20 22 2e 22 29 0a 09 09 09 09 09 20 20 20 28 ) ".")...... (
09d0: 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d server:get-best-
09e0: 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f guess-address ho
09f0: 73 74 6e 61 6d 65 29 0a 09 09 09 09 09 20 20 20 stname)......
0a00: 23 66 29 29 29 0a 09 09 09 20 20 20 20 28 69 66 #f))).... (if
0a10: 20 69 70 73 74 72 20 69 70 73 74 72 20 68 6f 73 ipstr ipstr hos
0a20: 74 6e 29 29 29 20 3b 3b 20 68 6f 73 74 6e 61 6d tn))) ;; hostnam
0a30: 65 29 29 29 20 0a 09 20 28 73 74 61 72 74 2d 70 e))) .. (start-p
0a40: 6f 72 74 20 20 20 20 28 69 66 20 28 61 6e 64 20 ort (if (and
0a50: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
0a60: 70 6f 72 74 22 29 0a 09 09 09 09 20 28 73 74 72 port")..... (str
0a70: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 61 72 67 ing->number (arg
0a80: 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 6f 72 74 s:get-arg "-port
0a90: 22 29 29 29 0a 09 09 09 20 20 20 20 28 73 74 72 "))).... (str
0aa0: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 61 72 67 ing->number (arg
0ab0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 6f 72 74 s:get-arg "-port
0ac0: 22 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 ")).... (if (
0ad0: 61 6e 64 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b and (config-look
0ae0: 75 70 20 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 up *configdat*
0af0: 22 73 65 72 76 65 72 22 20 22 70 6f 72 74 22 29 "server" "port")
0b00: 0a 09 09 09 09 20 20 20 20 20 28 73 74 72 69 6e ..... (strin
0b10: 67 2d 3e 6e 75 6d 62 65 72 20 28 63 6f 6e 66 69 g->number (confi
0b20: 67 2d 6c 6f 6f 6b 75 70 20 20 2a 63 6f 6e 66 69 g-lookup *confi
0b30: 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 gdat* "server" "
0b40: 70 6f 72 74 22 29 29 29 0a 09 09 09 09 28 73 74 port"))).....(st
0b50: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 6f ring->number (co
0b60: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 20 2a 63 6f nfig-lookup *co
0b70: 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 nfigdat* "server
0b80: 22 20 22 70 6f 72 74 22 29 29 0a 09 09 09 09 28 " "port")).....(
0b90: 2b 20 35 30 30 30 20 28 72 61 6e 64 6f 6d 20 31 + 5000 (random 1
0ba0: 30 30 31 29 29 29 29 29 0a 09 20 28 6c 69 6e 6b 001))))).. (link
0bb0: 2d 74 72 65 65 2d 70 61 74 68 20 28 63 6f 6e 66 -tree-path (conf
0bc0: 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 ig-lookup *confi
0bd0: 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 6c gdat* "setup" "l
0be0: 69 6e 6b 74 72 65 65 22 29 29 29 0a 20 20 20 20 inktree"))).
0bf0: 28 73 65 74 21 20 64 62 20 2a 69 6e 6d 65 6d 64 (set! db *inmemd
0c00: 62 2a 29 0a 20 20 20 20 28 72 6f 6f 74 2d 70 61 b*). (root-pa
0c10: 74 68 20 20 20 20 20 28 69 66 20 6c 69 6e 6b 2d th (if link-
0c20: 74 72 65 65 2d 70 61 74 68 20 0a 09 09 20 20 20 tree-path ...
0c30: 20 20 20 20 6c 69 6e 6b 2d 74 72 65 65 2d 70 61 link-tree-pa
0c40: 74 68 0a 09 09 20 20 20 20 20 20 20 28 63 75 72 th... (cur
0c50: 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 rent-directory))
0c60: 29 20 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 53 45 ) ;; WARNING: SE
0c70: 43 55 52 49 54 59 20 48 4f 4c 45 2e 20 46 49 58 CURITY HOLE. FIX
0c80: 20 41 53 41 50 21 0a 20 20 20 20 28 68 61 6e 64 ASAP!. (hand
0c90: 6c 65 2d 64 69 72 65 63 74 6f 72 79 20 73 70 69 le-directory spi
0ca0: 66 66 79 2d 64 69 72 65 63 74 6f 72 79 2d 6c 69 ffy-directory-li
0cb0: 73 74 69 6e 67 29 0a 20 20 20 20 3b 3b 20 68 74 sting). ;; ht
0cc0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 68 61 6e tp-transport:han
0cd0: 64 6c 65 2d 64 69 72 65 63 74 6f 72 79 29 20 3b dle-directory) ;
0ce0: 3b 20 73 69 6d 70 6c 65 2d 64 69 72 65 63 74 6f ; simple-directo
0cf0: 72 79 2d 68 61 6e 64 6c 65 72 29 0a 20 20 20 20 ry-handler).
0d00: 3b 3b 20 53 65 74 75 70 20 74 68 65 20 77 65 62 ;; Setup the web
0d10: 20 73 65 72 76 65 72 20 61 6e 64 20 61 20 2f 63 server and a /c
0d20: 74 72 6c 20 69 6e 74 65 72 66 61 63 65 0a 20 20 trl interface.
0d30: 20 20 3b 3b 0a 20 20 20 20 28 76 68 6f 73 74 2d ;;. (vhost-
0d40: 6d 61 70 20 60 28 28 28 2a 20 61 6e 79 29 20 2e map `(((* any) .
0d50: 20 2c 28 6c 61 6d 62 64 61 20 28 63 6f 6e 74 69 ,(lambda (conti
0d60: 6e 75 65 29 0a 09 09 09 20 20 20 20 20 20 20 3b nue).... ;
0d70: 3b 20 6f 70 65 6e 20 74 68 65 20 64 62 20 6f 6e ; open the db on
0d80: 20 74 68 65 20 66 69 72 73 74 20 63 61 6c 6c 20 the first call
0d90: 0a 09 09 09 09 20 3b 3b 20 54 68 69 73 20 69 73 ..... ;; This is
0da0: 20 77 65 72 65 20 77 65 20 73 65 74 20 75 70 20 were we set up
0db0: 74 68 65 20 64 61 74 61 62 61 73 65 20 63 6f 6e the database con
0dc0: 6e 65 63 74 69 6f 6e 73 0a 09 09 09 20 20 20 20 nections....
0dd0: 20 20 20 28 6c 65 74 2a 20 28 28 24 20 20 20 28 (let* (($ (
0de0: 72 65 71 75 65 73 74 2d 76 61 72 73 20 73 6f 75 request-vars sou
0df0: 72 63 65 3a 20 27 62 6f 74 68 29 29 0a 09 09 09 rce: 'both))....
0e00: 09 20 20 20 20 20 20 28 64 61 74 20 28 24 20 27 . (dat ($ '
0e10: 64 61 74 29 29 0a 09 09 09 09 20 20 20 20 20 20 dat)).....
0e20: 28 72 65 73 20 23 66 29 29 0a 09 09 09 09 20 28 (res #f))..... (
0e30: 63 6f 6e 64 0a 09 09 09 09 20 20 28 28 65 71 75 cond..... ((equ
0e40: 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 al? (uri-path (r
0e50: 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 equest-uri (curr
0e60: 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 0a 09 ent-request)))..
0e70: 09 09 09 09 20 20 20 27 28 2f 20 22 61 70 69 22 .... '(/ "api"
0e80: 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e 64 2d ))..... (send-
0e90: 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 20 response body:
0ea0: 20 20 28 61 70 69 3a 70 72 6f 63 65 73 73 2d 72 (api:process-r
0eb0: 65 71 75 65 73 74 20 64 62 20 24 29 20 3b 3b 20 equest db $) ;;
0ec0: 74 68 65 20 24 20 69 73 20 74 68 65 20 72 65 71 the $ is the req
0ed0: 75 65 73 74 20 76 61 72 73 20 70 72 6f 63 0a 09 uest vars proc..
0ee0: 09 09 09 09 09 20 20 68 65 61 64 65 72 73 3a 20 ..... headers:
0ef0: 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 '((content-type
0f00: 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 0a 09 09 text/plain)))...
0f10: 09 09 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b .. (mutex-lock
0f20: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
0f30: 65 78 2a 29 0a 09 09 09 09 20 20 20 28 73 65 74 ex*)..... (set
0f40: 21 20 2a 6c 61 73 74 2d 64 62 2d 61 63 63 65 73 ! *last-db-acces
0f50: 73 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f s* (current-seco
0f60: 6e 64 73 29 29 0a 09 09 09 09 20 20 20 28 6d 75 nds))..... (mu
0f70: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 tex-unlock! *hea
0f80: 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 29 0a rtbeat-mutex*)).
0f90: 09 09 09 09 20 20 3b 3b 20 54 68 69 73 20 69 73 .... ;; This is
0fa0: 20 74 68 65 20 2f 63 74 72 6c 20 70 61 74 68 20 the /ctrl path
0fb0: 77 68 65 72 65 20 64 61 74 61 20 69 73 20 68 61 where data is ha
0fc0: 6e 64 65 64 20 74 6f 20 74 68 65 20 73 65 72 76 nded to the serv
0fd0: 65 72 20 61 6e 64 0a 09 09 09 09 20 20 3b 3b 20 er and..... ;;
0fe0: 72 65 73 70 6f 6e 73 65 73 20 0a 09 09 09 09 20 responses .....
0ff0: 20 28 28 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 ((equal? (uri-p
1000: 61 74 68 20 28 72 65 71 75 65 73 74 2d 75 72 69 ath (request-uri
1010: 20 28 63 75 72 72 65 6e 74 2d 72 65 71 75 65 73 (current-reques
1020: 74 29 29 29 0a 09 09 09 09 09 20 20 20 27 28 2f t)))...... '(/
1030: 20 22 63 74 72 6c 22 29 29 0a 09 09 09 09 20 20 "ctrl")).....
1040: 20 28 6c 65 74 2a 20 28 28 70 61 63 6b 65 74 20 (let* ((packet
1050: 28 64 62 3a 73 74 72 69 6e 67 2d 3e 6f 62 6a 20 (db:string->obj
1060: 64 61 74 29 29 0a 09 09 09 09 09 20 20 28 71 74 dat))...... (qt
1070: 79 70 65 20 20 28 63 64 62 3a 70 61 63 6b 65 74 ype (cdb:packet
1080: 2d 67 65 74 2d 71 74 79 70 65 20 70 61 63 6b 65 -get-qtype packe
1090: 74 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 64 t)))..... (d
10a0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
10b0: 31 32 20 22 73 65 72 76 65 72 3d 3e 20 72 65 63 12 "server=> rec
10c0: 65 69 76 65 64 20 70 61 63 6b 65 74 3d 22 20 70 eived packet=" p
10d0: 61 63 6b 65 74 29 0a 09 09 09 09 20 20 20 20 20 acket).....
10e0: 28 69 66 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 (if (not (member
10f0: 20 71 74 79 70 65 20 27 28 73 79 6e 63 20 70 69 qtype '(sync pi
1100: 6e 67 29 29 29 0a 09 09 09 09 09 20 28 62 65 67 ng)))...... (beg
1110: 69 6e 0a 09 09 09 09 09 20 20 20 28 6d 75 74 65 in...... (mute
1120: 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 x-lock! *heartbe
1130: 61 74 2d 6d 75 74 65 78 2a 29 0a 09 09 09 09 09 at-mutex*)......
1140: 20 20 20 28 73 65 74 21 20 2a 6c 61 73 74 2d 64 (set! *last-d
1150: 62 2d 61 63 63 65 73 73 2a 20 28 63 75 72 72 65 b-access* (curre
1160: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 09 nt-seconds))....
1170: 09 09 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f .. (mutex-unlo
1180: 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
1190: 75 74 65 78 2a 29 29 29 0a 09 09 09 09 20 20 20 utex*))).....
11a0: 20 20 3b 3b 20 28 6d 75 74 65 78 2d 6c 6f 63 6b ;; (mutex-lock
11b0: 21 20 2a 64 62 3a 70 72 6f 63 65 73 73 2d 71 75 ! *db:process-qu
11c0: 65 75 65 2d 6d 75 74 65 78 2a 29 20 3b 3b 20 74 eue-mutex*) ;; t
11d0: 72 79 69 6e 67 20 61 20 6d 75 74 65 78 0a 09 09 rying a mutex...
11e0: 09 09 20 20 20 20 20 3b 3b 20 28 73 65 74 21 20 .. ;; (set!
11f0: 72 65 73 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c res (open-run-cl
1200: 6f 73 65 20 64 62 3a 70 72 6f 63 65 73 73 2d 71 ose db:process-q
1210: 75 65 75 65 2d 69 74 65 6d 20 6f 70 65 6e 2d 64 ueue-item open-d
1220: 62 20 70 61 63 6b 65 74 29 29 0a 09 09 09 09 20 b packet)).....
1230: 20 20 20 20 28 73 65 74 21 20 72 65 73 20 28 64 (set! res (d
1240: 62 3a 70 72 6f 63 65 73 73 2d 71 75 65 75 65 2d b:process-queue-
1250: 69 74 65 6d 20 64 62 20 70 61 63 6b 65 74 29 29 item db packet))
1260: 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 28 6d 75 ..... ;; (mu
1270: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 3a tex-unlock! *db:
1280: 70 72 6f 63 65 73 73 2d 71 75 65 75 65 2d 6d 75 process-queue-mu
1290: 74 65 78 2a 29 0a 09 09 09 09 20 20 20 20 20 28 tex*)..... (
12a0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
12b0: 20 31 31 20 22 52 65 74 75 72 6e 20 76 61 6c 75 11 "Return valu
12c0: 65 20 66 72 6f 6d 20 64 62 3a 70 72 6f 63 65 73 e from db:proces
12d0: 73 2d 71 75 65 75 65 2d 69 74 65 6d 20 69 73 20 s-queue-item is
12e0: 22 20 72 65 73 29 0a 09 09 09 09 20 20 20 20 20 " res).....
12f0: 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 (send-response b
1300: 6f 64 79 3a 20 28 63 6f 6e 63 20 22 3c 68 65 61 ody: (conc "<hea
1310: 64 3e 63 74 72 6c 20 64 61 74 61 3c 2f 68 65 61 d>ctrl data</hea
1320: 64 3e 5c 6e 3c 62 6f 64 79 3e 22 0a 09 09 09 09 d>\n<body>".....
1330: 09 09 09 09 72 65 73 0a 09 09 09 09 09 09 09 09 ....res.........
1340: 22 3c 2f 62 6f 64 79 3e 22 29 0a 09 09 09 09 09 "</body>")......
1350: 09 20 20 20 20 68 65 61 64 65 72 73 3a 20 27 28 . headers: '(
1360: 28 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 65 (content-type te
1370: 78 74 2f 70 6c 61 69 6e 29 29 29 29 29 0a 09 09 xt/plain)))))...
1380: 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 .. ((equal? (ur
1390: 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 2d i-path (request-
13a0: 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 uri (current-req
13b0: 75 65 73 74 29 29 29 20 0a 09 09 09 09 09 20 20 uest))) ......
13c0: 20 27 28 2f 20 22 22 29 29 0a 09 09 09 09 20 20 '(/ "")).....
13d0: 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 (send-response
13e0: 62 6f 64 79 3a 20 28 68 74 74 70 2d 74 72 61 6e body: (http-tran
13f0: 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 61 67 65 29 sport:main-page)
1400: 29 29 0a 09 09 09 09 20 20 28 28 65 71 75 61 6c ))..... ((equal
1410: 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 ? (uri-path (req
1420: 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e uest-uri (curren
1430: 74 2d 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 t-request))) ...
1440: 09 09 09 20 20 20 27 28 2f 20 22 72 75 6e 73 22 ... '(/ "runs"
1450: 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e 64 2d ))..... (send-
1460: 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 28 response body: (
1470: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6d http-transport:m
1480: 61 69 6e 2d 70 61 67 65 29 29 29 0a 09 09 09 09 ain-page))).....
1490: 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 69 2d ((equal? (uri-
14a0: 70 61 74 68 20 28 72 65 71 75 65 73 74 2d 75 72 path (request-ur
14b0: 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 75 65 i (current-reque
14c0: 73 74 29 29 29 20 0a 09 09 09 09 09 20 20 20 27 st))) ...... '
14d0: 28 2f 20 61 6e 79 29 29 0a 09 09 09 09 20 20 20 (/ any)).....
14e0: 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 (send-response b
14f0: 6f 64 79 3a 20 22 68 65 79 20 74 68 65 72 65 21 ody: "hey there!
1500: 5c 6e 22 0a 09 09 09 09 09 09 20 20 68 65 61 64 \n"....... head
1510: 65 72 73 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d ers: '((content-
1520: 74 79 70 65 20 74 65 78 74 2f 70 6c 61 69 6e 29 type text/plain)
1530: 29 29 29 0a 09 09 09 09 20 20 28 28 65 71 75 61 )))..... ((equa
1540: 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 l? (uri-path (re
1550: 71 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 quest-uri (curre
1560: 6e 74 2d 72 65 71 75 65 73 74 29 29 29 20 0a 09 nt-request))) ..
1570: 09 09 09 09 20 20 20 27 28 2f 20 22 68 65 79 22 .... '(/ "hey"
1580: 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e 64 2d ))..... (send-
1590: 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 22 response body: "
15a0: 68 65 79 20 74 68 65 72 65 21 5c 6e 22 0a 09 09 hey there!\n"...
15b0: 09 09 09 09 20 20 68 65 61 64 65 72 73 3a 20 27 .... headers: '
15c0: 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 ((content-type t
15d0: 65 78 74 2f 70 6c 61 69 6e 29 29 29 29 0a 09 09 ext/plain))))...
15e0: 09 09 20 20 28 65 6c 73 65 20 28 63 6f 6e 74 69 .. (else (conti
15f0: 6e 75 65 29 29 29 29 29 29 29 29 0a 20 20 20 20 nue)))))))).
1600: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
1610: 74 72 79 2d 73 74 61 72 74 2d 73 65 72 76 65 72 try-start-server
1620: 20 69 70 61 64 64 72 73 74 72 20 73 74 61 72 74 ipaddrstr start
1630: 2d 70 6f 72 74 29 29 29 0a 0a 3b 3b 20 54 68 69 -port)))..;; Thi
1640: 73 20 69 73 20 72 65 63 75 72 73 69 76 65 6c 79 s is recursively
1650: 20 72 75 6e 20 62 79 20 68 74 74 70 2d 74 72 61 run by http-tra
1660: 6e 73 70 6f 72 74 3a 72 75 6e 20 75 6e 74 69 6c nsport:run until
1670: 20 73 75 63 65 73 73 66 75 6c 0a 3b 3b 0a 28 64 sucessful.;;.(d
1680: 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e efine (http-tran
1690: 73 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 74 2d sport:try-start-
16a0: 73 65 72 76 65 72 20 69 70 61 64 64 72 73 74 72 server ipaddrstr
16b0: 20 70 6f 72 74 6e 75 6d 29 0a 20 20 28 68 61 6e portnum). (han
16c0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 dle-exceptions.
16d0: 20 20 65 78 6e 0a 20 20 20 28 62 65 67 69 6e 0a exn. (begin.
16e0: 20 20 20 20 20 28 70 72 69 6e 74 2d 65 72 72 6f (print-erro
16f0: 72 2d 6d 65 73 73 61 67 65 20 65 78 6e 29 0a 20 r-message exn).
1700: 20 20 20 20 28 69 66 20 28 3c 20 70 6f 72 74 6e (if (< portn
1710: 75 6d 20 39 30 30 30 29 0a 09 20 28 62 65 67 69 um 9000).. (begi
1720: 6e 20 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 n .. (debug:pr
1730: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
1740: 66 61 69 6c 65 64 20 74 6f 20 73 74 61 72 74 20 failed to start
1750: 6f 6e 20 70 6f 72 74 6e 75 6d 3a 20 22 20 70 6f on portnum: " po
1760: 72 74 6e 75 6d 20 22 2c 20 74 72 79 69 6e 67 20 rtnum ", trying
1770: 6e 65 78 74 20 70 6f 72 74 22 29 0a 09 20 20 20 next port")..
1780: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
1790: 2e 31 29 0a 09 20 20 20 3b 3b 20 28 6f 70 65 6e .1).. ;; (open
17a0: 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 -run-close tasks
17b0: 3a 72 65 6d 6f 76 65 2d 73 65 72 76 65 72 2d 72 :remove-server-r
17c0: 65 63 6f 72 64 73 20 74 61 73 6b 73 3a 6f 70 65 ecords tasks:ope
17d0: 6e 2d 64 62 29 0a 09 20 20 20 28 6f 70 65 6e 2d n-db).. (open-
17e0: 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a run-close tasks:
17f0: 73 65 72 76 65 72 2d 64 65 6c 65 74 65 20 74 61 server-delete ta
1800: 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 69 70 61 64 sks:open-db ipad
1810: 64 72 73 74 72 20 70 6f 72 74 6e 75 6d 29 0a 09 drstr portnum)..
1820: 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f (http-transpo
1830: 72 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 rt:try-start-ser
1840: 76 65 72 20 69 70 61 64 64 72 73 74 72 20 28 2b ver ipaddrstr (+
1850: 20 70 6f 72 74 6e 75 6d 20 31 29 29 29 0a 09 20 portnum 1)))..
1860: 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 54 (print "ERROR: T
1870: 72 69 65 64 20 61 6e 64 20 74 72 69 65 64 20 62 ried and tried b
1880: 75 74 20 63 6f 75 6c 64 20 6e 6f 74 20 73 74 61 ut could not sta
1890: 72 74 20 74 68 65 20 73 65 72 76 65 72 22 29 29 rt the server"))
18a0: 29 0a 20 20 20 3b 3b 20 61 6e 79 20 65 72 72 6f ). ;; any erro
18b0: 72 20 69 6e 20 66 6f 6c 6c 6f 77 69 6e 67 20 73 r in following s
18c0: 74 65 70 73 20 77 69 6c 6c 20 72 65 73 75 6c 74 teps will result
18d0: 20 69 6e 20 61 20 72 65 74 72 79 0a 20 20 20 28 in a retry. (
18e0: 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a set! *runremote*
18f0: 20 28 6c 69 73 74 20 69 70 61 64 64 72 73 74 72 (list ipaddrstr
1900: 20 70 6f 72 74 6e 75 6d 29 29 0a 20 20 20 3b 3b portnum)). ;;
1910: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
1920: 20 74 61 73 6b 73 3a 72 65 6d 6f 76 65 2d 73 65 tasks:remove-se
1930: 72 76 65 72 2d 72 65 63 6f 72 64 73 20 74 61 73 rver-records tas
1940: 6b 73 3a 6f 70 65 6e 2d 64 62 29 0a 20 20 20 28 ks:open-db). (
1950: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 open-run-close t
1960: 61 73 6b 73 3a 73 65 72 76 65 72 2d 72 65 67 69 asks:server-regi
1970: 73 74 65 72 20 0a 09 09 20 20 20 74 61 73 6b 73 ster ... tasks
1980: 3a 6f 70 65 6e 2d 64 62 20 0a 09 09 20 20 20 28 :open-db ... (
1990: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
19a0: 69 64 29 0a 09 09 20 20 20 69 70 61 64 64 72 73 id)... ipaddrs
19b0: 74 72 20 70 6f 72 74 6e 75 6d 20 30 20 27 73 74 tr portnum 0 'st
19c0: 61 72 74 75 70 20 27 68 74 74 70 29 0a 20 20 20 artup 'http).
19d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
19e0: 49 4e 46 4f 3a 20 54 72 79 69 6e 67 20 74 6f 20 INFO: Trying to
19f0: 73 74 61 72 74 20 73 65 72 76 65 72 20 6f 6e 20 start server on
1a00: 22 20 69 70 61 64 64 72 73 74 72 20 22 3a 22 20 " ipaddrstr ":"
1a10: 70 6f 72 74 6e 75 6d 29 0a 20 20 20 3b 3b 20 54 portnum). ;; T
1a20: 68 69 73 20 73 74 61 72 74 73 20 74 68 65 20 73 his starts the s
1a30: 70 69 66 66 79 20 73 65 72 76 65 72 0a 20 20 20 piffy server.
1a40: 3b 3b 20 4e 45 45 44 20 57 41 59 20 54 4f 20 53 ;; NEED WAY TO S
1a50: 45 54 20 49 50 20 54 4f 20 23 66 20 54 4f 20 42 ET IP TO #f TO B
1a60: 49 4e 44 20 41 4c 4c 0a 20 20 20 28 73 74 61 72 IND ALL. (star
1a70: 74 2d 73 65 72 76 65 72 20 62 69 6e 64 2d 61 64 t-server bind-ad
1a80: 64 72 65 73 73 3a 20 69 70 61 64 64 72 73 74 72 dress: ipaddrstr
1a90: 20 70 6f 72 74 3a 20 70 6f 72 74 6e 75 6d 29 0a port: portnum).
1aa0: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
1ab0: 73 65 20 74 61 73 6b 73 3a 73 65 72 76 65 72 2d se tasks:server-
1ac0: 64 65 6c 65 74 65 20 74 61 73 6b 73 3a 6f 70 65 delete tasks:ope
1ad0: 6e 2d 64 62 20 69 70 61 64 64 72 73 74 72 20 70 n-db ipaddrstr p
1ae0: 6f 72 74 6e 75 6d 29 0a 20 20 20 28 64 65 62 75 ortnum). (debu
1af0: 67 3a 70 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a g:print 1 "INFO:
1b00: 20 73 65 72 76 65 72 20 68 61 73 20 62 65 65 6e server has been
1b10: 20 73 74 6f 70 70 65 64 22 29 29 29 0a 0a 3b 3b stopped")))..;;
1b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b60: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 20 ======.;; S E R
1b70: 56 20 45 20 52 20 20 20 55 20 54 20 49 20 4c 20 V E R U T I L
1b80: 49 20 54 20 49 20 45 20 53 20 0a 3b 3b 3d 3d 3d I T I E S .;;===
1b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1bb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1bd0: 3d 3d 3d 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ===..;;=========
1be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
1c20: 20 43 20 4c 20 49 20 45 20 4e 20 54 20 53 0a 3b C L I E N T S.;
1c30: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
1c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1c70: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
1c80: 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 20 28 6d *http-mutex* (m
1c90: 61 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 3b 3b 20 ake-mutex))..;;
1ca0: 54 68 69 73 20 6e 65 78 74 20 62 6c 6f 63 6b 20 This next block
1cb0: 61 6c 6c 20 69 6d 70 6f 72 74 65 64 20 65 6e 2d all imported en-
1cc0: 6d 61 73 73 20 66 72 6f 6d 20 74 68 65 20 61 70 mass from the ap
1cd0: 69 20 62 72 61 6e 63 68 0a 28 64 65 66 69 6e 65 i branch.(define
1ce0: 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d *http-requests-
1cf0: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 30 29 0a in-progress* 0).
1d00: 28 64 65 66 69 6e 65 20 2a 68 74 74 70 2d 63 6f (define *http-co
1d10: 6e 6e 65 63 74 69 6f 6e 73 2d 6e 65 78 74 2d 63 nnections-next-c
1d20: 6c 65 61 6e 75 70 2a 20 28 63 75 72 72 65 6e 74 leanup* (current
1d30: 2d 73 65 63 6f 6e 64 73 29 29 0a 0a 28 64 65 66 -seconds))..(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 67 65 74 2d 74 69 6d 65 2d 74 6f 2d ort:get-time-to-
1d60: 63 6c 65 61 6e 75 70 29 0a 20 20 28 6c 65 74 20 cleanup). (let
1d70: 28 28 72 65 73 20 23 66 29 29 0a 20 20 20 20 28 ((res #f)). (
1d80: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 mutex-lock! *htt
1d90: 70 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 28 73 p-mutex*). (s
1da0: 65 74 21 20 72 65 73 20 28 3e 20 28 63 75 72 72 et! res (> (curr
1db0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 2a 68 74 ent-seconds) *ht
1dc0: 74 70 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 2d 6e tp-connections-n
1dd0: 65 78 74 2d 63 6c 65 61 6e 75 70 2a 29 29 0a 20 ext-cleanup*)).
1de0: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
1df0: 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a ! *http-mutex*).
1e00: 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 res))..(defi
1e10: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
1e20: 72 74 3a 69 6e 63 2d 72 65 71 75 65 73 74 73 2d rt:inc-requests-
1e30: 63 6f 75 6e 74 29 0a 20 20 28 6d 75 74 65 78 2d count). (mutex-
1e40: 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 lock! *http-mute
1e50: 78 2a 29 0a 20 20 28 73 65 74 21 20 2a 68 74 74 x*). (set! *htt
1e60: 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 p-requests-in-pr
1e70: 6f 67 72 65 73 73 2a 20 28 2b 20 31 20 2a 68 74 ogress* (+ 1 *ht
1e80: 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 tp-requests-in-p
1e90: 72 6f 67 72 65 73 73 2a 29 29 0a 20 20 3b 3b 20 rogress*)). ;;
1ea0: 55 73 65 20 74 68 69 73 20 6f 70 70 6f 72 74 75 Use this opportu
1eb0: 6e 69 74 79 20 74 6f 20 73 6c 6f 77 20 74 68 69 nity to slow thi
1ec0: 6e 67 73 20 64 6f 77 6e 20 69 66 66 20 74 68 65 ngs down iff the
1ed0: 72 65 20 61 72 65 20 74 6f 6f 20 6d 61 6e 79 20 re are too many
1ee0: 72 65 71 75 65 73 74 73 20 69 6e 20 66 6c 69 67 requests in flig
1ef0: 68 74 0a 20 20 28 69 66 20 28 3e 20 2a 68 74 74 ht. (if (> *htt
1f00: 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 p-requests-in-pr
1f10: 6f 67 72 65 73 73 2a 20 35 29 0a 20 20 20 20 20 ogress* 5).
1f20: 20 28 62 65 67 69 6e 0a 09 28 64 65 62 75 67 3a (begin..(debug:
1f30: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 57 68 print-info 0 "Wh
1f40: 6f 61 20 74 68 65 72 65 20 62 75 64 64 79 2c 20 oa there buddy,
1f50: 65 61 73 65 20 75 70 2e 2e 2e 22 29 0a 09 28 74 ease up...")..(t
1f60: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 29 hread-sleep! 1))
1f70: 29 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 ). (mutex-unloc
1f80: 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 k! *http-mutex*)
1f90: 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 )..(define (http
1fa0: 2d 74 72 61 6e 73 70 6f 72 74 3a 64 65 63 2d 72 -transport:dec-r
1fb0: 65 71 75 65 73 74 73 2d 63 6f 75 6e 74 20 70 72 equests-count pr
1fc0: 6f 63 29 20 0a 20 20 28 6d 75 74 65 78 2d 6c 6f oc) . (mutex-lo
1fd0: 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a ck! *http-mutex*
1fe0: 29 0a 20 20 28 70 72 6f 63 29 0a 20 20 28 73 65 ). (proc). (se
1ff0: 74 21 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 t! *http-request
2000: 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 28 s-in-progress* (
2010: 2d 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 - *http-requests
2020: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 31 29 -in-progress* 1)
2030: 29 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 ). (mutex-unloc
2040: 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 k! *http-mutex*)
2050: 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 )..(define (http
2060: 2d 74 72 61 6e 73 70 6f 72 74 3a 64 65 63 2d 72 -transport:dec-r
2070: 65 71 75 65 73 74 73 2d 63 6f 75 6e 74 2d 61 6e equests-count-an
2080: 64 2d 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e d-close-all-conn
2090: 65 63 74 69 6f 6e 73 29 0a 20 20 28 73 65 74 21 ections). (set!
20a0: 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d *http-requests-
20b0: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 28 2d 20 in-progress* (-
20c0: 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 *http-requests-i
20d0: 6e 2d 70 72 6f 67 72 65 73 73 2a 20 31 29 29 0a n-progress* 1)).
20e0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 65 74 (let loop ((et
20f0: 69 6d 65 20 28 2b 20 28 63 75 72 72 65 6e 74 2d ime (+ (current-
2100: 73 65 63 6f 6e 64 73 29 20 35 29 29 29 20 3b 3b seconds) 5))) ;;
2110: 20 67 69 76 65 20 75 70 20 69 6e 20 66 69 76 65 give up in five
2120: 20 73 65 63 6f 6e 64 73 0a 20 20 20 20 28 69 66 seconds. (if
2130: 20 28 3e 20 2a 68 74 74 70 2d 72 65 71 75 65 73 (> *http-reques
2140: 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 ts-in-progress*
2150: 30 29 0a 09 28 69 66 20 28 3e 20 65 74 69 6d 65 0)..(if (> etime
2160: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
2170: 73 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a s)).. (begin.
2180: 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
2190: 6c 65 65 70 21 20 30 2e 30 35 29 0a 09 20 20 20 leep! 0.05)..
21a0: 20 20 20 28 6c 6f 6f 70 20 65 74 69 6d 65 29 29 (loop etime))
21b0: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
21c0: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 72 65 71 nt 0 "ERROR: req
21d0: 75 65 73 74 73 20 73 74 69 6c 6c 20 69 6e 20 70 uests still in p
21e0: 72 6f 67 72 65 73 73 20 61 66 74 65 72 20 35 20 rogress after 5
21f0: 73 65 63 6f 6e 64 73 20 6f 66 20 77 61 69 74 69 seconds of waiti
2200: 6e 67 2e 20 49 27 6d 20 67 6f 69 6e 67 20 74 6f ng. I'm going to
2210: 20 70 61 73 73 20 6f 6e 20 63 6c 65 61 6e 69 6e pass on cleanin
2220: 67 20 75 70 20 68 74 74 70 20 63 6f 6e 6e 65 63 g up http connec
2230: 74 69 6f 6e 73 22 29 29 0a 09 28 63 6c 6f 73 65 tions"))..(close
2240: 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 -all-connections
2250: 21 29 29 29 0a 20 20 28 73 65 74 21 20 2a 68 74 !))). (set! *ht
2260: 74 70 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 2d 6e tp-connections-n
2270: 65 78 74 2d 63 6c 65 61 6e 75 70 2a 20 28 2b 20 ext-cleanup* (+
2280: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
2290: 29 20 31 30 29 29 0a 20 20 28 6d 75 74 65 78 2d ) 10)). (mutex-
22a0: 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 unlock! *http-mu
22b0: 74 65 78 2a 29 29 0a 0a 28 64 65 66 69 6e 65 20 tex*))..(define
22c0: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
22d0: 69 6e 63 2d 72 65 71 75 65 73 74 73 2d 61 6e 64 inc-requests-and
22e0: 2d 70 72 65 70 2d 74 6f 2d 63 6c 6f 73 65 2d 61 -prep-to-close-a
22f0: 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 29 0a ll-connections).
2300: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
2310: 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 28 http-mutex*). (
2320: 73 65 74 21 20 2a 68 74 74 70 2d 72 65 71 75 65 set! *http-reque
2330: 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a sts-in-progress*
2340: 20 28 2b 20 31 20 2a 68 74 74 70 2d 72 65 71 75 (+ 1 *http-requ
2350: 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 ests-in-progress
2360: 2a 29 29 29 0a 0a 3b 3b 20 28 73 79 73 74 65 6d *)))..;; (system
2370: 20 22 6d 65 67 61 74 65 73 74 20 2d 6c 69 73 74 "megatest -list
2380: 2d 73 65 72 76 65 72 73 20 7c 20 67 72 65 70 20 -servers | grep
2390: 61 6c 69 76 65 20 7c 7c 20 6d 65 67 61 74 65 73 alive || megates
23a0: 74 20 2d 73 65 72 76 65 72 20 2d 20 2d 64 61 65 t -server - -dae
23b0: 6d 6f 6e 69 7a 65 20 26 26 20 73 6c 65 65 70 20 monize && sleep
23c0: 34 22 29 0a 0a 3b 3b 20 3c 68 74 6d 6c 3e 0a 3b 4")..;; <html>.;
23d0: 3b 20 3c 68 65 61 64 3e 3c 2f 68 65 61 64 3e 0a ; <head></head>.
23e0: 3b 3b 20 3c 62 6f 64 79 3e 31 20 48 65 6c 6c 6f ;; <body>1 Hello
23f0: 2c 20 77 6f 72 6c 64 21 20 47 6f 6f 64 62 79 65 , world! Goodbye
2400: 20 44 6f 6c 6c 79 3c 2f 62 6f 64 79 3e 3c 2f 68 Dolly</body></h
2410: 74 6d 6c 3e 0a 3b 3b 20 53 65 6e 64 20 6d 73 67 tml>.;; Send msg
2420: 20 74 6f 20 73 65 72 76 65 72 64 61 74 20 61 6e to serverdat an
2430: 64 20 72 65 63 65 69 76 65 20 72 65 73 75 6c 74 d receive result
2440: 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 .(define (http-t
2450: 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d ransport:client-
2460: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 73 65 72 send-receive ser
2470: 76 65 72 64 61 74 20 6d 73 67 20 23 21 6b 65 79 verdat msg #!key
2480: 20 28 6e 75 6d 72 65 74 72 69 65 73 20 33 30 29 (numretries 30)
2490: 29 0a 20 20 28 6c 65 74 2a 20 28 3b 3b 20 28 75 ). (let* (;; (u
24a0: 72 6c 20 20 20 20 20 20 20 20 28 68 74 74 70 2d rl (http-
24b0: 74 72 61 6e 73 70 6f 72 74 3a 6d 61 6b 65 2d 73 transport:make-s
24c0: 65 72 76 65 72 2d 75 72 6c 20 73 65 72 76 65 72 erver-url server
24d0: 64 61 74 29 29 0a 09 20 28 66 75 6c 6c 75 72 6c dat)).. (fullurl
24e0: 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 73 (if (list? s
24f0: 65 72 76 65 72 64 61 74 29 0a 09 09 09 20 28 63 erverdat).... (c
2500: 61 64 64 72 20 73 65 72 76 65 72 64 61 74 29 0a addr serverdat).
2510: 09 09 09 20 28 62 65 67 69 6e 0a 09 09 09 20 20 ... (begin....
2520: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
2530: 22 46 41 54 41 4c 20 45 52 52 4f 52 3a 20 68 74 "FATAL ERROR: ht
2540: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 tp-transport:cli
2550: 65 6e 74 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 ent-send-receive
2560: 20 63 61 6c 6c 65 64 20 77 69 74 68 20 6e 6f 20 called with no
2570: 73 65 72 76 65 72 20 69 6e 66 6f 22 29 0a 09 09 server info")...
2580: 09 20 20 20 28 65 78 69 74 20 31 29 29 29 29 20 . (exit 1))))
2590: 3b 3b 20 28 63 6f 6e 63 20 75 72 6c 20 22 2f 63 ;; (conc url "/c
25a0: 74 72 6c 22 29 29 20 3b 3b 20 28 63 6f 6e 63 20 trl")) ;; (conc
25b0: 75 72 6c 20 22 2f 3f 64 61 74 3d 22 20 6d 73 67 url "/?dat=" msg
25c0: 29 29 29 0a 09 20 28 72 65 73 20 20 20 20 20 20 ))).. (res
25d0: 20 20 23 66 29 29 0a 20 20 20 20 28 68 61 6e 64 #f)). (hand
25e0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 le-exceptions.
25f0: 20 20 20 65 78 6e 0a 20 20 20 20 20 28 62 65 67 exn. (beg
2600: 69 6e 0a 20 20 20 20 20 20 20 28 70 72 69 6e 74 in. (print
2610: 20 22 45 52 52 4f 52 20 49 4e 20 68 74 74 70 2d "ERROR IN http-
2620: 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 transport:client
2630: 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 20 22 20 -send-receive "
2640: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
2650: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
2660: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
2670: 29 29 0a 20 20 20 20 20 20 20 28 74 68 72 65 61 )). (threa
2680: 64 2d 73 6c 65 65 70 21 20 32 29 0a 20 20 20 20 d-sleep! 2).
2690: 20 20 20 28 69 66 20 28 3e 20 6e 75 6d 72 65 74 (if (> numret
26a0: 72 69 65 73 20 30 29 0a 09 20 20 20 28 68 74 74 ries 0).. (htt
26b0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 p-transport:clie
26c0: 6e 74 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 20 nt-send-receive
26d0: 73 65 72 76 65 72 64 61 74 20 6d 73 67 20 6e 75 serverdat msg nu
26e0: 6d 72 65 74 72 69 65 73 3a 20 28 2d 20 6e 75 6d mretries: (- num
26f0: 72 65 74 72 69 65 73 20 31 29 29 29 29 0a 20 20 retries 1)))).
2700: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
2710: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2720: 66 6f 20 31 31 20 22 66 75 6c 6c 75 72 6c 3d 22 fo 11 "fullurl="
2730: 20 66 75 6c 6c 75 72 6c 20 22 5c 6e 22 29 0a 20 fullurl "\n").
2740: 20 20 20 20 20 20 3b 3b 20 73 65 74 20 75 70 20 ;; set up
2750: 74 68 65 20 68 74 74 70 2d 63 6c 69 65 6e 74 20 the http-client
2760: 68 65 72 65 0a 20 20 20 20 20 20 20 28 6d 61 78 here. (max
2770: 2d 72 65 74 72 79 2d 61 74 74 65 6d 70 74 73 20 -retry-attempts
2780: 35 29 0a 20 20 20 20 20 20 20 3b 3b 20 63 6f 6e 5). ;; con
2790: 73 69 64 65 72 20 61 6c 6c 20 72 65 71 75 65 73 sider all reques
27a0: 74 73 20 69 6e 64 65 6d 70 6f 74 65 6e 74 0a 20 ts indempotent.
27b0: 20 20 20 20 20 20 28 72 65 74 72 79 2d 72 65 71 (retry-req
27c0: 75 65 73 74 3f 20 28 6c 61 6d 62 64 61 20 28 72 uest? (lambda (r
27d0: 65 71 75 65 73 74 29 0a 09 09 09 20 23 74 29 29 equest).... #t))
27e0: 20 20 20 3b 3b 20 20 09 09 20 28 74 68 72 65 61 ;; .. (threa
27f0: 64 2d 73 6c 65 65 70 21 20 28 2f 20 28 69 66 20 d-sleep! (/ (if
2800: 28 3e 20 6e 75 6d 72 65 74 72 69 65 73 20 31 30 (> numretries 10
2810: 30 29 20 31 30 30 20 6e 75 6d 72 65 74 72 69 65 0) 100 numretrie
2820: 73 29 20 31 30 29 29 0a 20 20 20 20 20 20 20 3b s) 10)). ;
2830: 3b 20 28 73 65 74 21 20 6e 75 6d 72 65 74 72 69 ; (set! numretri
2840: 65 73 20 28 2d 20 6e 75 6d 72 65 74 72 69 65 73 es (- numretries
2850: 20 31 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 1)). ;;
2860: 09 09 20 23 74 29 29 0a 20 20 20 20 20 20 20 3b .. #t)). ;
2870: 3b 20 73 65 6e 64 20 74 68 65 20 64 61 74 61 20 ; send the data
2880: 61 6e 64 20 67 65 74 20 74 68 65 20 72 65 73 70 and get the resp
2890: 6f 6e 73 65 0a 20 20 20 20 20 20 20 3b 3b 20 65 onse. ;; e
28a0: 78 74 72 61 63 74 20 74 68 65 20 6e 65 65 64 65 xtract the neede
28b0: 64 20 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 20 d info from the
28c0: 68 74 74 70 20 64 61 74 61 20 61 6e 64 20 0a 20 http data and .
28d0: 20 20 20 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 ;; process
28e0: 20 61 6e 64 20 72 65 74 75 72 6e 20 69 74 2e 0a and return it..
28f0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 (let* ((s
2900: 65 6e 64 2d 72 65 63 69 65 76 65 20 28 6c 61 6d end-recieve (lam
2910: 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 bda ()....
2920: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 (mutex-lock! *ht
2930: 74 70 2d 6d 75 74 65 78 2a 29 0a 09 09 09 20 20 tp-mutex*)....
2940: 20 20 20 20 28 73 65 74 21 20 72 65 73 20 28 77 (set! res (w
2950: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 ith-input-from-r
2960: 65 71 75 65 73 74 20 0a 09 09 09 09 09 20 66 75 equest ...... fu
2970: 6c 6c 75 72 6c 20 0a 09 09 09 09 09 20 28 6c 69 llurl ...... (li
2980: 73 74 20 28 63 6f 6e 73 20 27 64 61 74 20 6d 73 st (cons 'dat ms
2990: 67 29 29 20 0a 09 09 09 09 09 20 72 65 61 64 2d g)) ...... read-
29a0: 73 74 72 69 6e 67 29 29 0a 09 09 09 20 20 20 20 string))....
29b0: 20 20 28 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e (close-all-con
29c0: 6e 65 63 74 69 6f 6e 73 21 29 20 0a 09 09 09 20 nections!) ....
29d0: 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f (mutex-unlo
29e0: 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a ck! *http-mutex*
29f0: 29 29 29 0a 09 20 20 20 20 20 20 28 74 69 6d 65 ))).. (time
2a00: 2d 6f 75 74 20 20 20 20 20 28 6c 61 6d 62 64 61 -out (lambda
2a10: 20 28 29 0a 09 09 09 20 20 20 20 20 20 28 74 68 ().... (th
2a20: 72 65 61 64 2d 73 6c 65 65 70 21 20 34 35 29 0a read-sleep! 45).
2a30: 09 09 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f ... (if (no
2a40: 74 20 72 65 73 29 0a 09 09 09 09 20 20 28 62 65 t res)..... (be
2a50: 67 69 6e 0a 09 09 09 09 20 20 20 20 28 64 65 62 gin..... (deb
2a60: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
2a70: 49 4e 47 3a 20 63 6f 6d 6d 75 6e 69 63 61 74 69 ING: communicati
2a80: 6f 6e 20 77 69 74 68 20 74 68 65 20 73 65 72 76 on with the serv
2a90: 65 72 20 74 69 6d 65 64 20 6f 75 74 2e 22 29 0a er timed out.").
2aa0: 09 09 09 09 20 20 20 20 28 6d 75 74 65 78 2d 75 .... (mutex-u
2ab0: 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 nlock! *http-mut
2ac0: 65 78 2a 29 0a 09 09 09 09 20 20 20 20 28 68 74 ex*)..... (ht
2ad0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 tp-transport:cli
2ae0: 65 6e 74 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 ent-send-receive
2af0: 20 73 65 72 76 65 72 64 61 74 20 6d 73 67 20 6e serverdat msg n
2b00: 75 6d 72 65 74 72 69 65 73 3a 20 28 2d 20 6e 75 umretries: (- nu
2b10: 6d 72 65 74 72 69 65 73 20 31 29 29 0a 09 09 09 mretries 1))....
2b20: 09 20 20 20 20 28 69 66 20 28 3c 20 6e 75 6d 72 . (if (< numr
2b30: 65 74 72 69 65 73 20 33 29 20 3b 3b 20 6f 6e 20 etries 3) ;; on
2b40: 6c 61 73 74 20 74 72 79 20 6a 75 73 74 20 65 78 last try just ex
2b50: 69 74 0a 09 09 09 09 09 28 62 65 67 69 6e 0a 09 it......(begin..
2b60: 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 .... (debug:pri
2b70: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 63 6f 6d nt 0 "ERROR: com
2b80: 6d 75 6e 69 63 61 74 69 6f 6e 20 77 69 74 68 20 munication with
2b90: 74 68 65 20 73 65 72 76 65 72 20 74 69 6d 65 64 the server timed
2ba0: 20 6f 75 74 2e 20 47 69 76 69 6e 67 20 75 70 2e out. Giving up.
2bb0: 22 29 0a 09 09 09 09 09 20 20 28 65 78 69 74 20 ")...... (exit
2bc0: 31 29 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 1)))))))..
2bd0: 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 (th1 (make-threa
2be0: 64 20 73 65 6e 64 2d 72 65 63 69 65 76 65 20 22 d send-recieve "
2bf0: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
2c00: 72 65 71 75 65 73 74 22 29 29 0a 09 20 20 20 20 request"))..
2c10: 20 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 (th2 (make-thr
2c20: 65 61 64 20 74 69 6d 65 2d 6f 75 74 20 20 20 20 ead time-out
2c30: 20 22 74 69 6d 65 20 6f 75 74 22 29 29 29 0a 09 "time out")))..
2c40: 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 (thread-start!
2c50: 74 68 31 29 0a 09 20 28 74 68 72 65 61 64 2d 73 th1).. (thread-s
2c60: 74 61 72 74 21 20 74 68 32 29 0a 09 20 28 74 68 tart! th2).. (th
2c70: 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 29 0a read-join! th1).
2c80: 09 20 28 74 68 72 65 61 64 2d 74 65 72 6d 69 6e . (thread-termin
2c90: 61 74 65 21 20 74 68 32 29 0a 09 20 28 64 65 62 ate! th2).. (deb
2ca0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 31 ug:print-info 11
2cb0: 20 22 67 6f 74 20 72 65 73 3d 22 20 72 65 73 29 "got res=" res)
2cc0: 0a 09 20 28 6c 65 74 20 28 28 6d 61 74 63 68 20 .. (let ((match
2cd0: 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 28 (string-search (
2ce0: 72 65 67 65 78 70 20 22 3c 62 6f 64 79 3e 28 2e regexp "<body>(.
2cf0: 2a 29 3c 2e 62 6f 64 79 3e 22 29 20 72 65 73 29 *)<.body>") res)
2d00: 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 )).. (debug:pr
2d10: 69 6e 74 2d 69 6e 66 6f 20 31 31 20 22 6d 61 74 int-info 11 "mat
2d20: 63 68 3d 22 20 6d 61 74 63 68 29 0a 09 20 20 20 ch=" match)..
2d30: 28 6c 65 74 20 28 28 66 69 6e 61 6c 20 28 63 61 (let ((final (ca
2d40: 64 72 20 6d 61 74 63 68 29 29 29 0a 09 20 20 20 dr match)))..
2d50: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
2d60: 6e 66 6f 20 31 31 20 22 66 69 6e 61 6c 3d 22 20 nfo 11 "final="
2d70: 66 69 6e 61 6c 29 0a 09 20 20 20 20 20 66 69 6e final).. fin
2d80: 61 6c 29 29 29 29 29 29 29 0a 0a 3b 3b 20 53 65 al)))))))..;; Se
2d90: 6e 64 20 22 63 6d 64 22 20 77 69 74 68 20 6a 73 nd "cmd" with js
2da0: 6f 6e 20 70 61 79 6c 6f 61 64 20 22 70 61 72 61 on payload "para
2db0: 6d 73 22 20 74 6f 20 73 65 72 76 65 72 64 61 74 ms" to serverdat
2dc0: 20 61 6e 64 20 72 65 63 65 69 76 65 20 72 65 73 and receive res
2dd0: 75 6c 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ult.;;.(define (
2de0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 http-transport:c
2df0: 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 lient-api-send-r
2e00: 65 63 65 69 76 65 20 73 65 72 76 65 72 64 61 74 eceive serverdat
2e10: 20 63 6d 64 20 70 61 72 61 6d 73 20 23 21 6b 65 cmd params #!ke
2e20: 79 20 28 6e 75 6d 72 65 74 72 69 65 73 20 33 30 y (numretries 30
2e30: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 75 6c )). (let* ((ful
2e40: 6c 75 72 6c 20 20 20 20 28 69 66 20 28 6c 69 73 lurl (if (lis
2e50: 74 3f 20 73 65 72 76 65 72 64 61 74 29 0a 09 09 t? serverdat)...
2e60: 09 20 28 63 61 64 64 64 72 20 73 65 72 76 65 72 . (cadddr server
2e70: 64 61 74 29 20 3b 3b 20 74 68 69 73 20 69 73 20 dat) ;; this is
2e80: 74 68 65 20 75 72 69 20 66 6f 72 20 2f 61 70 69 the uri for /api
2e90: 0a 09 09 09 20 28 62 65 67 69 6e 0a 09 09 09 20 .... (begin....
2ea0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
2eb0: 20 22 46 41 54 41 4c 20 45 52 52 4f 52 3a 20 68 "FATAL ERROR: h
2ec0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c ttp-transport:cl
2ed0: 69 65 6e 74 2d 73 65 6e 64 2d 72 65 63 65 69 76 ient-send-receiv
2ee0: 65 20 63 61 6c 6c 65 64 20 77 69 74 68 20 6e 6f e called with no
2ef0: 20 73 65 72 76 65 72 20 69 6e 66 6f 22 29 0a 09 server info")..
2f00: 09 09 20 20 20 28 65 78 69 74 20 31 29 29 29 29 .. (exit 1))))
2f10: 0a 09 20 28 72 65 73 20 20 20 20 20 20 20 20 23 .. (res #
2f20: 66 29 29 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d f)). (handle-
2f30: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 exceptions.
2f40: 65 78 6e 0a 20 20 20 20 20 28 62 65 67 69 6e 0a exn. (begin.
2f50: 20 20 20 20 20 20 20 3b 3b 20 54 4f 44 4f 3a 20 ;; TODO:
2f60: 53 65 6e 64 20 74 68 69 73 20 6f 75 74 70 75 74 Send this output
2f70: 20 74 6f 20 61 20 6c 6f 67 20 66 69 6c 65 20 73 to a log file s
2f80: 6f 20 69 74 20 69 73 6e 27 74 20 6c 6f 73 74 20 o it isn't lost
2f90: 77 68 65 6e 20 72 75 6e 6e 69 6e 67 20 61 73 20 when running as
2fa0: 64 61 65 6d 6f 6e 0a 20 20 20 20 20 20 20 28 70 daemon. (p
2fb0: 72 69 6e 74 20 22 45 52 52 4f 52 20 49 4e 20 68 rint "ERROR IN h
2fc0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c ttp-transport:cl
2fd0: 69 65 6e 74 2d 73 65 6e 64 2d 72 65 63 65 69 76 ient-send-receiv
2fe0: 65 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d e " ((condition-
2ff0: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
3000: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
3010: 20 65 78 6e 29 29 0a 20 20 20 20 20 20 20 28 74 exn)). (t
3020: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a hread-sleep! 2).
3030: 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 6e 75 (if (> nu
3040: 6d 72 65 74 72 69 65 73 20 30 29 0a 09 20 20 20 mretries 0)..
3050: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
3060: 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d client-api-send-
3070: 72 65 63 65 69 76 65 20 73 65 72 76 65 72 64 61 receive serverda
3080: 74 20 63 6d 64 20 70 61 72 61 6d 73 20 6e 75 6d t cmd params num
3090: 72 65 74 72 69 65 73 3a 20 28 2d 20 6e 75 6d 72 retries: (- numr
30a0: 65 74 72 69 65 73 20 31 29 29 29 29 0a 20 20 20 etries 1)))).
30b0: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
30c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
30d0: 6f 20 31 31 20 22 66 75 6c 6c 75 72 6c 3d 22 20 o 11 "fullurl="
30e0: 66 75 6c 6c 75 72 6c 20 22 5c 6e 22 29 0a 20 20 fullurl "\n").
30f0: 20 20 20 20 20 3b 3b 20 73 65 74 20 75 70 20 74 ;; set up t
3100: 68 65 20 68 74 74 70 2d 63 6c 69 65 6e 74 20 68 he http-client h
3110: 65 72 65 0a 20 20 20 20 20 20 20 28 6d 61 78 2d ere. (max-
3120: 72 65 74 72 79 2d 61 74 74 65 6d 70 74 73 20 35 retry-attempts 5
3130: 29 0a 20 20 20 20 20 20 20 3b 3b 20 63 6f 6e 73 ). ;; cons
3140: 69 64 65 72 20 61 6c 6c 20 72 65 71 75 65 73 74 ider all request
3150: 73 20 69 6e 64 65 6d 70 6f 74 65 6e 74 0a 20 20 s indempotent.
3160: 20 20 20 20 20 28 72 65 74 72 79 2d 72 65 71 75 (retry-requ
3170: 65 73 74 3f 20 28 6c 61 6d 62 64 61 20 28 72 65 est? (lambda (re
3180: 71 75 65 73 74 29 0a 09 09 09 20 23 74 29 29 20 quest).... #t))
3190: 20 20 3b 3b 20 20 09 09 20 28 74 68 72 65 61 64 ;; .. (thread
31a0: 2d 73 6c 65 65 70 21 20 28 2f 20 28 69 66 20 28 -sleep! (/ (if (
31b0: 3e 20 6e 75 6d 72 65 74 72 69 65 73 20 31 30 30 > numretries 100
31c0: 29 20 31 30 30 20 6e 75 6d 72 65 74 72 69 65 73 ) 100 numretries
31d0: 29 20 31 30 29 29 0a 20 20 20 20 20 20 20 3b 3b ) 10)). ;;
31e0: 20 28 73 65 74 21 20 6e 75 6d 72 65 74 72 69 65 (set! numretrie
31f0: 73 20 28 2d 20 6e 75 6d 72 65 74 72 69 65 73 20 s (- numretries
3200: 31 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 09 1)). ;; .
3210: 09 20 23 74 29 29 0a 20 20 20 20 20 20 20 3b 3b . #t)). ;;
3220: 20 73 65 6e 64 20 74 68 65 20 64 61 74 61 20 61 send the data a
3230: 6e 64 20 67 65 74 20 74 68 65 20 72 65 73 70 6f nd get the respo
3240: 6e 73 65 0a 20 20 20 20 20 20 20 3b 3b 20 65 78 nse. ;; ex
3250: 74 72 61 63 74 20 74 68 65 20 6e 65 65 64 65 64 tract the needed
3260: 20 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 20 68 info from the h
3270: 74 74 70 20 64 61 74 61 20 61 6e 64 20 0a 20 20 ttp data and .
3280: 20 20 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 20 ;; process
3290: 61 6e 64 20 72 65 74 75 72 6e 20 69 74 2e 0a 0a and return it...
32a0: 20 20 20 20 20 20 20 3b 3b 20 28 77 69 74 68 2d ;; (with-
32b0: 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 65 71 75 65 input-from-reque
32c0: 73 74 20 22 68 74 74 70 3a 2f 2f 6c 6f 63 61 6c st "http://local
32d0: 68 6f 73 74 2f 65 63 68 6f 2d 73 65 72 76 69 63 host/echo-servic
32e0: 65 22 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 e". ;;
32f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 27 28 '(
3300: 28 74 65 73 74 20 2e 20 22 76 61 6c 75 65 22 29 (test . "value")
3310: 29 20 72 65 61 64 2d 73 74 72 69 6e 67 29 0a 0a ) read-string)..
3320: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 (let* ((s
3330: 65 6e 64 2d 72 65 63 69 65 76 65 20 28 6c 61 6d end-recieve (lam
3340: 62 64 61 20 28 29 0a 09 09 09 3b 3b 20 20 20 20 bda ()....;;
3350: 20 20 20 28 6c 65 74 20 28 28 64 61 74 20 23 66 (let ((dat #f
3360: 29 0a 09 09 09 3b 3b 20 09 20 20 20 20 28 63 6c )....;; . (cl
3370: 65 61 6e 75 70 20 28 68 74 74 70 2d 74 72 61 6e eanup (http-tran
3380: 73 70 6f 72 74 3a 67 65 74 2d 74 69 6d 65 2d 74 sport:get-time-t
3390: 6f 2d 63 6c 65 61 6e 75 70 29 29 29 0a 09 09 09 o-cleanup)))....
33a0: 3b 3b 20 09 28 69 66 20 63 6c 65 61 6e 75 70 20 ;; .(if cleanup
33b0: 0a 09 09 09 3b 3b 20 09 20 20 20 20 28 68 74 74 ....;; . (htt
33c0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 69 6e 63 2d p-transport:inc-
33d0: 72 65 71 75 65 73 74 73 2d 61 6e 64 2d 70 72 65 requests-and-pre
33e0: 70 2d 74 6f 2d 63 6c 6f 73 65 2d 61 6c 6c 2d 63 p-to-close-all-c
33f0: 6f 6e 6e 65 63 74 69 6f 6e 73 29 0a 09 09 09 3b onnections)....;
3400: 3b 20 09 20 20 20 20 28 68 74 74 70 2d 74 72 61 ; . (http-tra
3410: 6e 73 70 6f 72 74 3a 69 6e 63 2d 72 65 71 75 65 nsport:inc-reque
3420: 73 74 73 2d 63 6f 75 6e 74 29 29 0a 09 09 09 3b sts-count))....;
3430: 3b 20 09 3b 3b 20 44 6f 20 74 68 65 20 61 63 74 ; .;; Do the act
3440: 75 61 6c 20 64 61 74 61 20 74 72 61 6e 73 66 65 ual data transfe
3450: 72 20 4e 42 2f 2f 20 4b 45 50 50 20 54 48 49 53 r NB// KEPP THIS
3460: 20 49 4e 20 53 59 4e 43 20 57 49 54 48 20 68 74 IN SYNC WITH ht
3470: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 tp-transport:cli
3480: 65 6e 74 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 ent-send-receive
3490: 0a 09 09 09 09 20 28 6d 75 74 65 78 2d 6c 6f 63 ..... (mutex-loc
34a0: 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 k! *http-mutex*)
34b0: 0a 09 09 09 09 20 28 73 65 74 21 20 72 65 73 20 ..... (set! res
34c0: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
34d0: 2d 72 65 71 75 65 73 74 20 3b 3b 20 77 61 73 20 -request ;; was
34e0: 64 61 74 0a 09 09 09 09 09 20 20 20 66 75 6c 6c dat...... full
34f0: 75 72 6c 20 0a 09 09 09 09 09 20 20 20 28 6c 69 url ...... (li
3500: 73 74 20 28 63 6f 6e 73 20 27 6b 65 79 20 22 74 st (cons 'key "t
3510: 68 65 6b 65 79 22 29 0a 09 09 09 09 09 09 20 28 hekey")....... (
3520: 63 6f 6e 73 20 27 63 6d 64 20 63 6d 64 29 0a 09 cons 'cmd cmd)..
3530: 09 09 09 09 09 20 28 63 6f 6e 73 20 27 70 61 72 ..... (cons 'par
3540: 61 6d 73 20 70 61 72 61 6d 73 29 29 0a 09 09 09 ams params))....
3550: 09 09 20 20 20 72 65 61 64 2d 73 74 72 69 6e 67 .. read-string
3560: 29 29 0a 09 09 09 09 20 3b 3b 20 53 68 6f 75 6c ))..... ;; Shoul
3570: 64 6e 27 74 20 74 68 69 73 20 62 65 20 61 20 63 dn't this be a c
3580: 61 6c 6c 20 74 6f 20 74 68 65 20 6d 61 6e 61 67 all to the manag
3590: 65 64 20 63 61 6c 6c 2d 61 6c 6c 2d 63 6f 6e 6e ed call-all-conn
35a0: 65 63 74 69 6f 6e 73 20 73 74 75 66 66 20 61 62 ections stuff ab
35b0: 6f 76 65 3f 0a 09 09 09 09 28 63 6c 6f 73 65 2d ove?.....(close-
35c0: 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 all-connections!
35d0: 29 0a 09 09 09 09 28 6d 75 74 65 78 2d 75 6e 6c ).....(mutex-unl
35e0: 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 ock! *http-mutex
35f0: 2a 29 0a 09 09 09 09 29 29 0a 09 20 20 20 20 20 *).....))..
3600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3610: 20 20 20 20 20 3b 3b 20 28 69 66 20 63 6c 65 61 ;; (if clea
3620: 6e 75 70 0a 09 09 09 09 20 20 3b 3b 20 20 20 3b nup..... ;; ;
3630: 3b 20 6d 75 74 65 78 20 61 6c 72 65 61 64 79 20 ; mutex already
3640: 73 65 74 0a 09 09 09 09 20 20 3b 3b 20 20 20 28 set..... ;; (
3650: 62 65 67 69 6e 0a 09 09 09 09 20 20 3b 3b 20 20 begin..... ;;
3660: 20 20 20 28 73 65 74 21 20 72 65 73 20 64 61 74 (set! res dat
3670: 29 0a 09 09 09 09 20 20 3b 3b 20 20 20 20 20 28 )..... ;; (
3680: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 64 http-transport:d
3690: 65 63 2d 72 65 71 75 65 73 74 73 2d 63 6f 75 6e ec-requests-coun
36a0: 74 2d 61 6e 64 2d 63 6c 6f 73 65 2d 61 6c 6c 2d t-and-close-all-
36b0: 63 6f 6e 6e 65 63 74 69 6f 6e 73 29 29 0a 09 09 connections))...
36c0: 09 09 20 20 3b 3b 20 20 20 28 68 74 74 70 2d 74 .. ;; (http-t
36d0: 72 61 6e 73 70 6f 72 74 3a 64 65 63 2d 72 65 71 ransport:dec-req
36e0: 75 65 73 74 73 2d 63 6f 75 6e 74 0a 09 09 09 09 uests-count.....
36f0: 20 20 3b 3b 20 20 20 20 28 6c 61 6d 62 64 61 20 ;; (lambda
3700: 28 29 0a 09 09 09 09 20 20 3b 3b 20 20 20 20 20 ()..... ;;
3710: 20 28 73 65 74 21 20 72 65 73 20 64 61 74 29 29 (set! res dat))
3720: 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 74 69 ))))).. (ti
3730: 6d 65 2d 6f 75 74 20 20 20 20 20 28 6c 61 6d 62 me-out (lamb
3740: 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 28 da ().... (
3750: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 34 35 thread-sleep! 45
3760: 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 28 ).... (if (
3770: 6e 6f 74 20 72 65 73 29 0a 09 09 09 09 20 20 28 not res)..... (
3780: 62 65 67 69 6e 0a 09 09 09 09 20 20 20 20 28 64 begin..... (d
3790: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
37a0: 52 4e 49 4e 47 3a 20 63 6f 6d 6d 75 6e 69 63 61 RNING: communica
37b0: 74 69 6f 6e 20 77 69 74 68 20 74 68 65 20 73 65 tion with the se
37c0: 72 76 65 72 20 74 69 6d 65 64 20 6f 75 74 2e 22 rver timed out."
37d0: 29 0a 09 09 09 09 20 20 20 20 28 6d 75 74 65 78 )..... (mutex
37e0: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d -unlock! *http-m
37f0: 75 74 65 78 2a 29 0a 09 09 09 09 20 20 20 20 28 utex*)..... (
3800: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 http-transport:c
3810: 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 lient-api-send-r
3820: 65 63 65 69 76 65 20 73 65 72 76 65 72 64 61 74 eceive serverdat
3830: 20 63 6d 64 20 70 61 72 61 6d 73 20 6e 75 6d 72 cmd params numr
3840: 65 74 72 69 65 73 3a 20 28 2d 20 6e 75 6d 72 65 etries: (- numre
3850: 74 72 69 65 73 20 31 29 29 0a 09 09 09 09 20 20 tries 1)).....
3860: 20 20 28 69 66 20 28 3c 20 6e 75 6d 72 65 74 72 (if (< numretr
3870: 69 65 73 20 33 29 20 3b 3b 20 6f 6e 20 6c 61 73 ies 3) ;; on las
3880: 74 20 74 72 79 20 6a 75 73 74 20 65 78 69 74 0a t try just exit.
3890: 09 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 .....(begin.....
38a0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
38b0: 30 20 22 45 52 52 4f 52 3a 20 63 6f 6d 6d 75 6e 0 "ERROR: commun
38c0: 69 63 61 74 69 6f 6e 20 77 69 74 68 20 74 68 65 ication with the
38d0: 20 73 65 72 76 65 72 20 74 69 6d 65 64 20 6f 75 server timed ou
38e0: 74 2e 20 47 69 76 69 6e 67 20 75 70 2e 22 29 0a t. Giving up.").
38f0: 09 09 09 09 09 20 20 28 65 78 69 74 20 31 29 29 ..... (exit 1))
3900: 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 74 68 ))))).. (th
3910: 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 73 1 (make-thread s
3920: 65 6e 64 2d 72 65 63 69 65 76 65 20 22 77 69 74 end-recieve "wit
3930: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 65 71 h-input-from-req
3940: 75 65 73 74 22 29 29 0a 09 20 20 20 20 20 20 28 uest")).. (
3950: 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 th2 (make-thread
3960: 20 74 69 6d 65 2d 6f 75 74 20 20 20 20 20 22 74 time-out "t
3970: 69 6d 65 20 6f 75 74 22 29 29 29 0a 09 20 28 74 ime out"))).. (t
3980: 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 hread-start! th1
3990: 29 0a 09 20 28 74 68 72 65 61 64 2d 73 74 61 72 ).. (thread-star
39a0: 74 21 20 74 68 32 29 0a 09 20 28 74 68 72 65 61 t! th2).. (threa
39b0: 64 2d 6a 6f 69 6e 21 20 74 68 31 29 0a 09 20 28 d-join! th1).. (
39c0: 74 68 72 65 61 64 2d 74 65 72 6d 69 6e 61 74 65 thread-terminate
39d0: 21 20 74 68 32 29 0a 09 20 28 64 65 62 75 67 3a ! th2).. (debug:
39e0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 31 20 22 67 print-info 11 "g
39f0: 6f 74 20 72 65 73 3d 22 20 72 65 73 29 0a 09 20 ot res=" res)..
3a00: 72 65 73 29 29 29 29 29 0a 0a 28 64 65 66 69 6e res)))))..(defin
3a10: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
3a20: 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 t:client-connect
3a30: 20 69 66 61 63 65 20 70 6f 72 74 29 0a 20 20 28 iface port). (
3a40: 6c 65 74 2a 20 28 28 6c 6f 67 69 6e 2d 72 65 73 let* ((login-res
3a50: 20 20 20 23 66 29 0a 09 20 28 75 72 69 2d 64 61 #f).. (uri-da
3a60: 74 20 20 20 20 20 28 6d 61 6b 65 2d 72 65 71 75 t (make-requ
3a70: 65 73 74 20 6d 65 74 68 6f 64 3a 20 27 50 4f 53 est method: 'POS
3a80: 54 20 75 72 69 3a 20 28 75 72 69 2d 72 65 66 65 T uri: (uri-refe
3a90: 72 65 6e 63 65 20 28 63 6f 6e 63 20 22 68 74 74 rence (conc "htt
3aa0: 70 3a 2f 2f 22 20 69 66 61 63 65 20 22 3a 22 20 p://" iface ":"
3ab0: 70 6f 72 74 20 22 2f 63 74 72 6c 22 29 29 29 29 port "/ctrl"))))
3ac0: 0a 09 20 28 75 72 69 2d 61 70 69 2d 64 61 74 20 .. (uri-api-dat
3ad0: 28 6d 61 6b 65 2d 72 65 71 75 65 73 74 20 6d 65 (make-request me
3ae0: 74 68 6f 64 3a 20 27 50 4f 53 54 20 75 72 69 3a thod: 'POST uri:
3af0: 20 28 75 72 69 2d 72 65 66 65 72 65 6e 63 65 20 (uri-reference
3b00: 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f 22 20 (conc "http://"
3b10: 69 66 61 63 65 20 22 3a 22 20 70 6f 72 74 20 22 iface ":" port "
3b20: 2f 61 70 69 22 29 29 29 29 0a 09 20 28 73 65 72 /api")))).. (ser
3b30: 76 65 72 64 61 74 20 20 20 28 6c 69 73 74 20 69 verdat (list i
3b40: 66 61 63 65 20 70 6f 72 74 20 75 72 69 2d 64 61 face port uri-da
3b50: 74 20 75 72 69 2d 61 70 69 2d 64 61 74 29 29 29 t uri-api-dat)))
3b60: 0a 20 20 20 20 28 73 65 74 21 20 2a 72 75 6e 72 . (set! *runr
3b70: 65 6d 6f 74 65 2a 20 73 65 72 76 65 72 64 61 74 emote* serverdat
3b80: 29 20 3b 3b 20 6d 61 79 20 6f 72 20 6d 61 79 20 ) ;; may or may
3b90: 6e 6f 74 20 62 65 20 67 6f 6f 64 20 2e 2e 2e 0a not be good ....
3ba0: 20 20 20 20 28 73 65 74 21 20 6c 6f 67 69 6e 2d (set! login-
3bb0: 72 65 73 20 28 72 6d 74 3a 6c 6f 67 69 6e 29 29 res (rmt:login))
3bc0: 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6c . (if (and (l
3bd0: 69 73 74 3f 20 6c 6f 67 69 6e 2d 72 65 73 29 0a ist? login-res).
3be0: 09 20 20 20 20 20 28 63 61 72 20 6c 6f 67 69 6e . (car login
3bf0: 2d 72 65 73 29 29 0a 09 28 62 65 67 69 6e 0a 09 -res))..(begin..
3c00: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
3c10: 6e 66 6f 20 32 20 22 4c 6f 67 67 65 64 20 69 6e nfo 2 "Logged in
3c20: 20 61 6e 64 20 63 6f 6e 6e 65 63 74 65 64 20 74 and connected t
3c30: 6f 20 22 20 69 66 61 63 65 20 22 3a 22 20 70 6f o " iface ":" po
3c40: 72 74 29 0a 09 20 20 28 73 65 74 21 20 2a 72 75 rt).. (set! *ru
3c50: 6e 72 65 6d 6f 74 65 2a 20 73 65 72 76 65 72 64 nremote* serverd
3c60: 61 74 29 0a 09 20 20 73 65 72 76 65 72 64 61 74 at).. serverdat
3c70: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 )..(begin.. (de
3c80: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
3c90: 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 "ERROR: Failed
3ca0: 74 6f 20 6c 6f 67 69 6e 20 6f 72 20 63 6f 6e 6e to login or conn
3cb0: 65 63 74 20 74 6f 20 22 20 69 66 61 63 65 20 22 ect to " iface "
3cc0: 3a 22 20 70 6f 72 74 29 0a 09 20 20 28 65 78 69 :" port).. (exi
3cd0: 74 20 31 29 29 29 29 29 0a 3b 3b 20 09 20 20 28 t 1))))).;; . (
3ce0: 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a set! *runremote*
3cf0: 20 23 66 29 0a 3b 3b 20 09 20 20 28 73 65 74 21 #f).;; . (set!
3d00: 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 *transport-type
3d10: 2a 20 27 66 73 29 0a 3b 3b 20 09 20 20 23 66 29 * 'fs).;; . #f)
3d20: 29 29 29 0a 0a 0a 3b 3b 20 72 75 6e 20 68 74 74 )))...;; run htt
3d30: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6b 65 65 70 p-transport:keep
3d40: 2d 72 75 6e 6e 69 6e 67 20 69 6e 20 61 20 70 61 -running in a pa
3d50: 72 61 6c 6c 65 6c 20 74 68 72 65 61 64 20 74 6f rallel thread to
3d60: 20 6d 6f 6e 69 74 6f 72 20 74 68 61 74 20 74 68 monitor that th
3d70: 65 20 64 62 20 69 73 20 62 65 69 6e 67 20 0a 3b e db is being .;
3d80: 3b 20 75 73 65 64 20 61 6e 64 20 74 6f 20 73 68 ; used and to sh
3d90: 75 74 64 6f 77 6e 20 61 66 74 65 72 20 73 6f 6d utdown after som
3da0: 65 74 69 6d 65 20 69 66 20 69 74 20 69 73 20 6e etime if it is n
3db0: 6f 74 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ot..;;.(define (
3dc0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6b http-transport:k
3dd0: 65 65 70 2d 72 75 6e 6e 69 6e 67 29 0a 20 20 3b eep-running). ;
3de0: 3b 20 69 66 20 6e 6f 6e 65 20 72 75 6e 6e 69 6e ; if none runnin
3df0: 67 20 6f 72 20 69 66 20 3e 20 32 30 20 73 65 63 g or if > 20 sec
3e00: 6f 6e 64 73 20 73 69 6e 63 65 20 0a 20 20 3b 3b onds since . ;;
3e10: 20 73 65 72 76 65 72 20 6c 61 73 74 20 75 73 65 server last use
3e20: 64 20 74 68 65 6e 20 73 74 61 72 74 20 73 68 75 d then start shu
3e30: 74 64 6f 77 6e 0a 20 20 3b 3b 20 54 68 69 73 20 tdown. ;; This
3e40: 74 68 72 65 61 64 20 77 61 69 74 73 20 66 6f 72 thread waits for
3e50: 20 74 68 65 20 73 65 72 76 65 72 20 74 6f 20 63 the server to c
3e60: 6f 6d 65 20 61 6c 69 76 65 0a 20 20 28 6c 65 74 ome alive. (let
3e70: 2a 20 28 28 73 65 72 76 65 72 2d 69 6e 66 6f 20 * ((server-info
3e80: 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 20 20 20 (let loop ().
3e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ea0: 20 20 20 20 20 28 6c 65 74 20 28 28 73 64 61 74 (let ((sdat
3eb0: 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 #f)).
3ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ed0: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 (mutex-lock! *he
3ee0: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
3ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3f00: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
3f10: 73 64 61 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a sdat *runremote*
3f20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3f30: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 75 74 (mut
3f40: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 ex-unlock! *hear
3f50: 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 tbeat-mutex*).
3f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3f70: 20 20 20 20 20 20 20 20 28 69 66 20 73 64 61 74 (if sdat
3f80: 0a 09 09 09 20 20 20 20 20 20 73 64 61 74 0a 20 .... sdat.
3f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 (be
3fb0: 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 gin.
3fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3fd0: 20 20 20 20 28 73 6c 65 65 70 20 34 29 0a 20 20 (sleep 4).
3fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
4000: 6f 6f 70 29 29 29 29 29 29 0a 20 20 20 20 20 20 oop)))))).
4010: 20 20 20 28 69 66 61 63 65 20 20 20 20 20 20 20 (iface
4020: 28 63 61 72 20 73 65 72 76 65 72 2d 69 6e 66 6f (car server-info
4030: 29 29 0a 20 20 20 20 20 20 20 20 20 28 70 6f 72 )). (por
4040: 74 20 20 20 20 20 20 20 20 28 63 61 64 72 20 73 t (cadr s
4050: 65 72 76 65 72 2d 69 6e 66 6f 29 29 0a 20 20 20 erver-info)).
4060: 20 20 20 20 20 20 28 6c 61 73 74 2d 61 63 63 65 (last-acce
4070: 73 73 20 30 29 0a 09 20 28 74 64 62 20 20 20 20 ss 0).. (tdb
4080: 20 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 6e (tasks:open
4090: 2d 64 62 29 29 0a 09 20 28 73 70 69 64 20 20 20 -db)).. (spid
40a0: 20 20 20 20 20 3b 3b 28 6f 70 65 6e 2d 72 75 6e ;;(open-run
40b0: 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 -close tasks:ser
40c0: 76 65 72 2d 67 65 74 2d 73 65 72 76 65 72 2d 69 ver-get-server-i
40d0: 64 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 d tasks:open-db
40e0: 23 66 20 69 66 61 63 65 20 70 6f 72 74 20 23 66 #f iface port #f
40f0: 29 29 0a 09 20 20 20 28 74 61 73 6b 73 3a 73 65 )).. (tasks:se
4100: 72 76 65 72 2d 67 65 74 2d 73 65 72 76 65 72 2d rver-get-server-
4110: 69 64 20 74 64 62 20 23 66 20 69 66 61 63 65 20 id tdb #f iface
4120: 70 6f 72 74 20 23 66 29 29 0a 09 20 28 73 65 72 port #f)).. (ser
4130: 76 65 72 2d 74 69 6d 65 6f 75 74 20 28 6c 65 74 ver-timeout (let
4140: 20 28 28 74 6d 6f 20 28 63 6f 6e 66 69 67 2d 6c ((tmo (config-l
4150: 6f 6f 6b 75 70 20 20 2a 63 6f 6e 66 69 67 64 61 ookup *configda
4160: 74 2a 20 22 73 65 72 76 65 72 22 20 22 74 69 6d t* "server" "tim
4170: 65 6f 75 74 22 29 29 29 0a 09 09 09 20 20 20 28 eout"))).... (
4180: 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f if (and (string?
4190: 20 74 6d 6f 29 0a 09 09 09 09 20 20 20 20 28 73 tmo)..... (s
41a0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 74 6d tring->number tm
41b0: 6f 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 2a o)).... (*
41c0: 20 36 30 20 36 30 20 28 73 74 72 69 6e 67 2d 3e 60 60 (string->
41d0: 6e 75 6d 62 65 72 20 74 6d 6f 29 29 0a 09 09 09 number tmo))....
41e0: 20 20 20 20 20 20 20 3b 3b 20 64 65 66 61 75 6c ;; defaul
41f0: 74 20 74 6f 20 74 68 72 65 65 20 64 61 79 73 0a t to three days.
4200: 09 09 09 20 20 20 20 20 20 20 28 2a 20 33 20 32 ... (* 3 2
4210: 34 20 36 30 20 36 30 29 29 29 29 29 0a 20 20 20 4 60 60))))).
4220: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
4230: 66 6f 20 32 20 22 73 65 72 76 65 72 2d 74 69 6d fo 2 "server-tim
4240: 65 6f 75 74 3a 20 22 20 73 65 72 76 65 72 2d 74 eout: " server-t
4250: 69 6d 65 6f 75 74 20 22 2c 20 73 65 72 76 65 72 imeout ", server
4260: 20 70 69 64 3a 20 22 20 73 70 69 64 20 22 20 6f pid: " spid " o
4270: 6e 20 22 20 69 66 61 63 65 20 22 3a 22 20 70 6f n " iface ":" po
4280: 72 74 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f rt). (let loo
4290: 70 20 28 28 63 6f 75 6e 74 20 30 29 29 0a 20 20 p ((count 0)).
42a0: 20 20 20 20 3b 3b 20 55 73 65 20 74 68 69 73 20 ;; Use this
42b0: 6f 70 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 73 opportunity to s
42c0: 79 6e 63 20 74 68 65 20 69 6e 6d 65 6d 64 62 20 ync the inmemdb
42d0: 74 6f 20 64 62 0a 20 20 20 20 20 20 28 6c 65 74 to db. (let
42e0: 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 28 63 ((start-time (c
42f0: 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f urrent-milliseco
4300: 6e 64 73 29 29 0a 09 20 20 20 20 28 73 79 6e 63 nds)).. (sync
4310: 2d 74 69 6d 65 20 20 23 66 29 0a 09 20 20 20 20 -time #f)..
4320: 28 72 65 6d 2d 74 69 6d 65 20 20 20 23 66 29 29 (rem-time #f))
4330: 0a 09 28 69 66 20 2a 69 6e 6d 65 6d 64 62 2a 20 ..(if *inmemdb*
4340: 28 64 62 3a 73 79 6e 63 2d 74 61 62 6c 65 73 20 (db:sync-tables
4350: 28 64 62 3a 74 62 6c 73 20 2a 69 6e 6d 65 6d 64 (db:tbls *inmemd
4360: 62 2a 29 20 2a 69 6e 6d 65 6d 64 62 2a 20 2a 64 b*) *inmemdb* *d
4370: 62 2a 29 29 20 3b 3b 20 28 64 62 3a 73 79 6e 63 b*)) ;; (db:sync
4380: 2d 74 6f 20 2a 69 6e 6d 65 6d 64 62 2a 20 2a 64 -to *inmemdb* *d
4390: 62 2a 29 29 0a 09 28 73 65 74 21 20 73 79 6e 63 b*))..(set! sync
43a0: 2d 74 69 6d 65 20 20 28 2d 20 28 63 75 72 72 65 -time (- (curre
43b0: 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
43c0: 20 73 74 61 72 74 2d 74 69 6d 65 29 29 0a 09 28 start-time))..(
43d0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 53 debug:print 0 "S
43e0: 59 4e 43 3a 20 74 69 6d 65 3d 20 22 20 73 79 6e YNC: time= " syn
43f0: 63 2d 74 69 6d 65 29 0a 09 28 73 65 74 21 20 72 c-time)..(set! r
4400: 65 6d 2d 74 69 6d 65 20 28 71 75 6f 74 69 65 6e em-time (quotien
4410: 74 20 28 2d 20 34 30 30 30 20 73 79 6e 63 2d 74 t (- 4000 sync-t
4420: 69 6d 65 29 20 31 30 30 30 29 29 0a 09 28 69 66 ime) 1000))..(if
4430: 20 28 61 6e 64 20 28 3c 20 72 65 6d 2d 74 69 6d (and (< rem-tim
4440: 65 20 34 29 0a 09 09 20 28 3e 20 72 65 6d 2d 74 e 4)... (> rem-t
4450: 69 6d 65 20 30 29 29 0a 09 20 20 20 20 28 74 68 ime 0)).. (th
4460: 72 65 61 64 2d 73 6c 65 65 70 21 20 72 65 6d 2d read-sleep! rem-
4470: 74 69 6d 65 29 29 29 0a 0a 20 20 20 20 20 20 3b time))).. ;
4480: 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 ; (thread-sleep!
4490: 20 34 29 20 3b 3b 20 6e 6f 20 6e 65 65 64 20 74 4) ;; no need t
44a0: 6f 20 64 6f 20 74 68 69 73 20 76 65 72 79 20 6f o do this very o
44b0: 66 74 65 6e 0a 0a 20 20 20 20 20 20 28 69 66 20 ften.. (if
44c0: 28 3c 20 63 6f 75 6e 74 20 31 29 20 3b 3b 20 33 (< count 1) ;; 3
44d0: 78 33 20 3d 20 39 20 73 65 63 73 20 61 70 72 6f x3 = 9 secs apro
44e0: 78 0a 09 20 20 28 6c 6f 6f 70 20 28 2b 20 63 6f x.. (loop (+ co
44f0: 75 6e 74 20 31 29 29 29 0a 20 20 20 20 20 20 0a unt 1))). .
4500: 20 20 20 20 20 20 3b 3b 20 43 68 65 63 6b 20 74 ;; Check t
4510: 68 61 74 20 69 66 61 63 65 20 61 6e 64 20 70 6f hat iface and po
4520: 72 74 20 68 61 76 65 20 6e 6f 74 20 63 68 61 6e rt have not chan
4530: 67 65 64 20 28 63 61 6e 20 68 61 70 70 65 6e 20 ged (can happen
4540: 69 66 20 73 65 72 76 65 72 20 70 6f 72 74 20 63 if server port c
4550: 6f 6c 6c 69 64 65 73 29 0a 20 20 20 20 20 20 28 ollides). (
4560: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 mutex-lock! *hea
4570: 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 rtbeat-mutex*).
4580: 20 20 20 20 20 28 73 65 74 21 20 73 64 61 74 20 (set! sdat
4590: 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 0a 20 20 20 *runremote*).
45a0: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
45b0: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
45c0: 65 78 2a 29 0a 20 20 20 20 20 20 0a 20 20 20 20 ex*). .
45d0: 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 (if (or (not (
45e0: 65 71 75 61 6c 3f 20 73 64 61 74 20 28 6c 69 73 equal? sdat (lis
45f0: 74 20 69 66 61 63 65 20 70 6f 72 74 29 29 29 0a t iface port))).
4600: 09 20 20 20 20 20 20 28 6e 6f 74 20 73 70 69 64 . (not spid
4610: 29 29 0a 09 20 20 28 62 65 67 69 6e 20 0a 09 20 )).. (begin ..
4620: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
4630: 69 6e 66 6f 20 30 20 22 69 6e 74 65 72 66 61 63 info 0 "interfac
4640: 65 20 63 68 61 6e 67 65 64 2c 20 72 65 66 72 65 e changed, refre
4650: 73 68 69 6e 67 20 69 66 61 63 65 20 61 6e 64 20 shing iface and
4660: 70 6f 72 74 20 69 6e 66 6f 22 29 0a 09 20 20 20 port info")..
4670: 20 28 73 65 74 21 20 69 66 61 63 65 20 28 63 61 (set! iface (ca
4680: 72 20 73 64 61 74 29 29 0a 09 20 20 20 20 28 73 r sdat)).. (s
4690: 65 74 21 20 70 6f 72 74 20 20 28 63 61 64 72 20 et! port (cadr
46a0: 73 64 61 74 29 29 0a 09 20 20 20 20 28 73 65 74 sdat)).. (set
46b0: 21 20 73 70 69 64 20 20 28 74 61 73 6b 73 3a 73 ! spid (tasks:s
46c0: 65 72 76 65 72 2d 67 65 74 2d 73 65 72 76 65 72 erver-get-server
46d0: 2d 69 64 20 74 64 62 20 23 66 20 69 66 61 63 65 -id tdb #f iface
46e0: 20 70 6f 72 74 20 23 66 29 29 29 29 0a 20 20 20 port #f)))).
46f0: 20 20 20 0a 20 20 20 20 20 20 3b 3b 20 4e 4f 54 . ;; NOT
4700: 45 3a 20 47 65 74 20 72 69 64 20 6f 66 20 74 68 E: Get rid of th
4710: 69 73 20 6d 65 63 68 61 6e 69 73 6d 21 20 49 74 is mechanism! It
4720: 20 72 65 61 6c 6c 79 20 69 73 20 6e 6f 74 20 6e really is not n
4730: 65 65 64 65 64 2e 2e 2e 0a 20 20 20 20 20 20 3b eeded.... ;
4740: 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 ; (open-run-clos
4750: 65 20 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 75 e tasks:server-u
4760: 70 64 61 74 65 2d 68 65 61 72 74 62 65 61 74 20 pdate-heartbeat
4770: 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 73 70 tasks:open-db sp
4780: 69 64 29 0a 20 20 20 20 20 20 28 74 61 73 6b 73 id). (tasks
4790: 3a 73 65 72 76 65 72 2d 75 70 64 61 74 65 2d 68 :server-update-h
47a0: 65 61 72 74 62 65 61 74 20 74 64 62 20 73 70 69 eartbeat tdb spi
47b0: 64 29 0a 20 20 20 20 20 20 0a 20 20 20 20 20 20 d). .
47c0: 3b 3b 20 28 69 66 20 3b 3b 20 28 6f 72 20 28 3e ;; (if ;; (or (>
47d0: 20 6e 75 6d 72 75 6e 6e 69 6e 67 20 30 29 20 3b numrunning 0) ;
47e0: 3b 20 73 74 61 79 20 61 6c 69 76 65 20 66 6f 72 ; stay alive for
47f0: 20 74 77 6f 20 64 61 79 73 20 61 66 74 65 72 20 two days after
4800: 6c 61 73 74 20 61 63 63 65 73 73 0a 20 20 20 20 last access.
4810: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
4820: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
4830: 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 6c 61 ). (set! la
4840: 73 74 2d 61 63 63 65 73 73 20 2a 6c 61 73 74 2d st-access *last-
4850: 64 62 2d 61 63 63 65 73 73 2a 29 0a 20 20 20 20 db-access*).
4860: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
4870: 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 *heartbeat-mute
4880: 78 2a 29 0a 20 20 20 20 20 20 3b 3b 20 28 64 65 x*). ;; (de
4890: 62 75 67 3a 70 72 69 6e 74 20 31 31 20 22 6c 61 bug:print 11 "la
48a0: 73 74 2d 61 63 63 65 73 73 3d 22 20 6c 61 73 74 st-access=" last
48b0: 2d 61 63 63 65 73 73 20 22 2c 20 73 65 72 76 65 -access ", serve
48c0: 72 2d 74 69 6d 65 6f 75 74 3d 22 20 73 65 72 76 r-timeout=" serv
48d0: 65 72 2d 74 69 6d 65 6f 75 74 29 0a 20 20 20 20 er-timeout).
48e0: 20 20 28 69 66 20 28 61 6e 64 20 2a 73 65 72 76 (if (and *serv
48f0: 65 72 2d 72 75 6e 2a 0a 09 20 20 20 20 20 20 20 er-run*..
4900: 28 3e 20 28 2b 20 6c 61 73 74 2d 61 63 63 65 73 (> (+ last-acces
4910: 73 20 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 s server-timeout
4920: 29 0a 09 09 20 20 28 63 75 72 72 65 6e 74 2d 73 )... (current-s
4930: 65 63 6f 6e 64 73 29 29 29 0a 09 20 20 28 62 65 econds))).. (be
4940: 67 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a gin.. (debug:
4950: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 53 65 print-info 0 "Se
4960: 72 76 65 72 20 63 6f 6e 74 69 6e 75 69 6e 67 2c rver continuing,
4970: 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 6c seconds since l
4980: 61 73 74 20 64 62 20 61 63 63 65 73 73 3a 20 22 ast db access: "
4990: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
49a0: 6f 6e 64 73 29 20 6c 61 73 74 2d 61 63 63 65 73 onds) last-acces
49b0: 73 29 29 0a 09 20 20 20 20 28 6c 6f 6f 70 20 30 s)).. (loop 0
49c0: 29 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 )).. (begin..
49d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
49e0: 6e 66 6f 20 30 20 22 53 74 61 72 74 69 6e 67 20 nfo 0 "Starting
49f0: 74 6f 20 73 68 75 74 64 6f 77 6e 20 74 68 65 20 to shutdown the
4a00: 73 65 72 76 65 72 2e 22 29 0a 09 20 20 20 20 3b server.").. ;
4a10: 3b 20 6e 65 65 64 20 74 6f 20 64 65 6c 65 74 65 ; need to delete
4a20: 20 6f 6e 6c 79 20 2a 6d 79 2a 20 73 65 72 76 65 only *my* serve
4a30: 72 20 65 6e 74 72 79 20 28 66 75 74 75 72 65 20 r entry (future
4a40: 75 73 65 29 0a 09 20 20 20 20 28 73 65 74 21 20 use).. (set!
4a50: 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 *time-to-exit* #
4a60: 74 29 0a 09 20 20 20 20 28 69 66 20 2a 69 6e 6d t).. (if *inm
4a70: 65 6d 64 62 2a 20 28 64 62 3a 73 79 6e 63 2d 74 emdb* (db:sync-t
4a80: 61 62 6c 65 73 20 28 64 62 3a 74 62 6c 73 20 2a ables (db:tbls *
4a90: 69 6e 6d 65 6d 64 62 2a 29 20 2a 69 6e 6d 65 6d inmemdb*) *inmem
4aa0: 64 62 2a 20 2a 64 62 2a 29 29 20 3b 3b 20 28 64 db* *db*)) ;; (d
4ab0: 62 3a 73 79 6e 63 2d 74 6f 20 2a 69 6e 6d 65 6d b:sync-to *inmem
4ac0: 64 62 2a 20 2a 64 62 2a 29 29 0a 09 20 20 20 20 db* *db*))..
4ad0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
4ae0: 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 64 65 72 tasks:server-der
4af0: 65 67 69 73 74 65 72 2d 73 65 6c 66 20 74 61 73 egister-self tas
4b00: 6b 73 3a 6f 70 65 6e 2d 64 62 20 28 67 65 74 2d ks:open-db (get-
4b10: 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 20 20 host-name))..
4b20: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
4b30: 31 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 1).. (debug:p
4b40: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 4d 61 78 rint-info 0 "Max
4b50: 20 63 61 63 68 65 64 20 71 75 65 72 69 65 73 20 cached queries
4b60: 77 61 73 20 20 20 20 22 20 2a 6d 61 78 2d 63 61 was " *max-ca
4b70: 63 68 65 2d 73 69 7a 65 2a 29 0a 09 20 20 20 20 che-size*)..
4b80: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
4b90: 6f 20 30 20 22 4e 75 6d 62 65 72 20 6f 66 20 63 o 0 "Number of c
4ba0: 61 63 68 65 64 20 77 72 69 74 65 73 20 20 20 22 ached writes "
4bb0: 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 *number-of-writ
4bc0: 65 73 2a 29 0a 09 20 20 20 20 28 64 65 62 75 67 es*).. (debug
4bd0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 41 :print-info 0 "A
4be0: 76 65 72 61 67 65 20 63 61 63 68 65 64 20 77 72 verage cached wr
4bf0: 69 74 65 20 74 69 6d 65 20 22 0a 09 09 09 20 20 ite time "....
4c00: 20 20 20 20 28 69 66 20 28 65 71 3f 20 2a 6e 75 (if (eq? *nu
4c10: 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a 20 mber-of-writes*
4c20: 30 29 0a 09 09 09 09 20 20 22 6e 2f 61 20 28 6e 0)..... "n/a (n
4c30: 6f 20 77 72 69 74 65 73 29 22 0a 09 09 09 09 20 o writes)".....
4c40: 20 28 2f 20 2a 77 72 69 74 65 73 2d 74 6f 74 61 (/ *writes-tota
4c50: 6c 2d 64 65 6c 61 79 2a 0a 09 09 09 09 20 20 20 l-delay*.....
4c60: 20 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 *number-of-wri
4c70: 74 65 73 2a 29 29 0a 09 09 09 20 20 20 20 20 20 tes*))....
4c80: 22 20 6d 73 22 29 0a 09 20 20 20 20 28 64 65 62 " ms").. (deb
4c90: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
4ca0: 22 4e 75 6d 62 65 72 20 6e 6f 6e 2d 63 61 63 68 "Number non-cach
4cb0: 65 64 20 71 75 65 72 69 65 73 20 22 20 20 2a 6e ed queries " *n
4cc0: 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d umber-non-write-
4cd0: 71 75 65 72 69 65 73 2a 29 0a 09 20 20 20 20 28 queries*).. (
4ce0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
4cf0: 20 30 20 22 41 76 65 72 61 67 65 20 6e 6f 6e 2d 0 "Average non-
4d00: 63 61 63 68 65 64 20 74 69 6d 65 20 20 20 22 0a cached time ".
4d10: 09 09 09 20 20 20 20 20 20 28 69 66 20 28 65 71 ... (if (eq
4d20: 3f 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 ? *number-non-wr
4d30: 69 74 65 2d 71 75 65 72 69 65 73 2a 20 30 29 0a ite-queries* 0).
4d40: 09 09 09 09 20 20 22 6e 2f 61 20 28 6e 6f 20 71 .... "n/a (no q
4d50: 75 65 72 69 65 73 29 22 0a 09 09 09 09 20 20 28 ueries)"..... (
4d60: 2f 20 2a 74 6f 74 61 6c 2d 6e 6f 6e 2d 77 72 69 / *total-non-wri
4d70: 74 65 2d 64 65 6c 61 79 2a 20 0a 09 09 09 09 20 te-delay* .....
4d80: 20 20 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d *number-non-
4d90: 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a 29 29 write-queries*))
4da0: 0a 09 09 09 20 20 20 20 20 20 22 20 6d 73 22 29 .... " ms")
4db0: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
4dc0: 6e 74 2d 69 6e 66 6f 20 30 20 22 53 65 72 76 65 nt-info 0 "Serve
4dd0: 72 20 73 68 75 74 64 6f 77 6e 20 63 6f 6d 70 6c r shutdown compl
4de0: 65 74 65 2e 20 45 78 69 74 69 6e 67 22 29 0a 09 ete. Exiting")..
4df0: 20 20 20 20 28 65 78 69 74 29 29 29 29 29 29 0a (exit)))))).
4e00: 0a 3b 3b 20 61 6c 6c 20 72 6f 75 74 65 73 20 74 .;; all routes t
4e10: 68 6f 75 67 68 20 68 65 72 65 20 65 6e 64 20 69 hough here end i
4e20: 6e 20 65 78 69 74 20 2e 2e 2e 0a 28 64 65 66 69 n exit ....(defi
4e30: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
4e40: 72 74 3a 6c 61 75 6e 63 68 29 0a 20 20 28 69 66 rt:launch). (if
4e50: 20 28 6e 6f 74 20 2a 74 6f 70 70 61 74 68 2a 29 (not *toppath*)
4e60: 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 . (if (not
4e70: 28 73 65 74 75 70 2d 66 6f 72 2d 72 75 6e 29 29 (setup-for-run))
4e80: 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 .. (begin..
4e90: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
4ea0: 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 66 69 ERROR: cannot fi
4eb0: 6e 64 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 nd megatest.conf
4ec0: 69 67 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 ig, exiting")..
4ed0: 20 20 20 28 65 78 69 74 29 29 29 29 0a 20 20 28 (exit)))). (
4ee0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
4ef0: 20 32 20 22 53 74 61 72 74 69 6e 67 20 74 68 65 2 "Starting the
4f00: 20 73 74 61 6e 64 61 6c 6f 6e 65 20 73 65 72 76 standalone serv
4f10: 65 72 22 29 0a 20 20 28 69 66 20 28 61 72 67 73 er"). (if (args
4f20: 3a 67 65 74 2d 61 72 67 20 22 2d 64 61 65 6d 6f :get-arg "-daemo
4f30: 6e 69 7a 65 22 29 0a 20 20 20 20 20 20 28 64 61 nize"). (da
4f40: 65 6d 6f 6e 3a 69 7a 65 29 29 0a 20 20 28 6c 65 emon:ize)). (le
4f50: 74 20 28 28 68 6f 73 74 69 6e 66 6f 20 28 6f 70 t ((hostinfo (op
4f60: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 en-run-close tas
4f70: 6b 73 3a 67 65 74 2d 62 65 73 74 2d 73 65 72 76 ks:get-best-serv
4f80: 65 72 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 er tasks:open-db
4f90: 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 ))). (debug:p
4fa0: 72 69 6e 74 20 31 31 20 22 68 74 74 70 2d 74 72 rint 11 "http-tr
4fb0: 61 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 20 68 ansport:launch h
4fc0: 6f 73 74 69 6e 66 6f 3d 22 20 68 6f 73 74 69 6e ostinfo=" hostin
4fd0: 66 6f 29 0a 20 20 20 20 3b 3b 20 23 28 31 20 22 fo). ;; #(1 "
4fe0: 31 34 33 2e 31 38 32 2e 32 30 37 2e 32 34 22 20 143.182.207.24"
4ff0: 35 37 33 36 20 2d 31 20 22 68 74 74 70 22 20 32 5736 -1 "http" 2
5000: 32 37 37 31 20 22 68 6f 73 74 6e 61 6d 65 22 29 2771 "hostname")
5010: 0a 20 20 20 20 28 69 66 20 68 6f 73 74 69 6e 66 . (if hostinf
5020: 6f 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d o..(debug:print-
5030: 69 6e 66 6f 20 32 20 22 4e 4f 54 20 73 74 61 72 info 2 "NOT star
5040: 74 69 6e 67 20 6e 65 77 20 73 65 72 76 65 72 2c ting new server,
5050: 20 6f 6e 65 20 69 73 20 61 6c 72 65 61 64 79 20 one is already
5060: 72 75 6e 6e 69 6e 67 20 6f 6e 20 22 20 28 76 65 running on " (ve
5070: 63 74 6f 72 2d 72 65 66 20 68 6f 73 74 69 6e 66 ctor-ref hostinf
5080: 6f 20 31 29 20 22 3a 22 20 28 76 65 63 74 6f 72 o 1) ":" (vector
5090: 2d 72 65 66 20 68 6f 73 74 69 6e 66 6f 20 32 29 -ref hostinfo 2)
50a0: 29 0a 09 28 69 66 20 2a 74 6f 70 70 61 74 68 2a )..(if *toppath*
50b0: 20 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 74 .. (let* ((t
50c0: 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 h2 (make-thread
50d0: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 20 (lambda ().....
50e0: 20 20 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e (http-tran
50f0: 73 70 6f 72 74 3a 72 75 6e 20 0a 09 09 09 09 09 sport:run ......
5100: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
5110: 67 20 22 2d 73 65 72 76 65 72 22 29 0a 09 09 09 g "-server")....
5120: 09 09 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d .. (args:get-
5130: 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a 09 arg "-server")..
5140: 09 09 09 09 20 20 20 20 22 2d 22 29 29 29 20 22 .... "-"))) "
5150: 53 65 72 76 65 72 20 72 75 6e 22 29 29 0a 09 09 Server run"))...
5160: 20 20 20 28 74 68 33 20 28 6d 61 6b 65 2d 74 68 (th3 (make-th
5170: 72 65 61 64 20 68 74 74 70 2d 74 72 61 6e 73 70 read http-transp
5180: 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 ort:keep-running
5190: 20 22 4b 65 65 70 20 72 75 6e 6e 69 6e 67 22 29 "Keep running")
51a0: 29 29 0a 3b 3b 09 09 20 20 20 28 74 68 31 20 28 )).;;.. (th1 (
51b0: 6d 61 6b 65 2d 74 68 72 65 61 64 20 73 65 72 76 make-thread serv
51c0: 65 72 3a 77 72 69 74 65 2d 71 75 65 75 65 2d 68 er:write-queue-h
51d0: 61 6e 64 6c 65 72 20 20 22 77 72 69 74 65 20 71 andler "write q
51e0: 75 65 75 65 22 29 29 29 0a 09 20 20 20 20 20 20 ueue")))..
51f0: 28 73 65 74 21 20 2a 63 61 63 68 65 2d 6f 6e 2a (set! *cache-on*
5200: 20 23 74 29 0a 09 20 20 20 20 20 20 28 73 65 74 #t).. (set
5210: 21 20 2a 64 62 2a 20 20 20 20 20 20 20 28 6f 70 ! *db* (op
5220: 65 6e 2d 64 62 29 29 0a 09 20 20 20 20 20 20 28 en-db)).. (
5230: 73 65 74 21 20 2a 69 6e 6d 65 6d 64 62 2a 20 20 set! *inmemdb*
5240: 28 6f 70 65 6e 2d 69 6e 2d 6d 65 6d 2d 64 62 29 (open-in-mem-db)
5250: 29 0a 09 20 20 20 20 20 20 28 64 62 3a 73 79 6e ).. (db:syn
5260: 63 2d 74 61 62 6c 65 73 20 28 64 62 3a 74 62 6c c-tables (db:tbl
5270: 73 20 2a 64 62 2a 29 20 2a 64 62 2a 20 2a 69 6e s *db*) *db* *in
5280: 6d 65 6d 64 62 2a 29 20 3b 3b 20 28 64 62 3a 73 memdb*) ;; (db:s
5290: 79 6e 63 2d 74 6f 20 2a 64 62 2a 20 2a 69 6e 6d ync-to *db* *inm
52a0: 65 6d 64 62 2a 29 0a 0a 09 20 20 20 20 20 20 28 emdb*)... (
52b0: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th
52c0: 32 29 0a 09 20 20 20 20 20 20 28 74 68 72 65 61 2).. (threa
52d0: 64 2d 73 74 61 72 74 21 20 74 68 33 29 0a 09 20 d-start! th3)..
52e0: 20 20 20 20 20 3b 3b 20 28 74 68 72 65 61 64 2d ;; (thread-
52f0: 73 74 61 72 74 21 20 74 68 31 29 0a 09 20 20 20 start! th1)..
5300: 20 20 20 28 73 65 74 21 20 2a 64 69 64 73 6f 6d (set! *didsom
5310: 65 74 68 69 6e 67 2a 20 23 74 29 0a 09 20 20 20 ething* #t)..
5320: 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 (thread-join!
5330: 20 74 68 32 29 29 0a 09 20 20 20 20 28 64 65 62 th2)).. (deb
5340: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
5350: 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 73 65 74 R: Failed to set
5360: 75 70 20 66 6f 72 20 6d 65 67 61 74 65 73 74 22 up for megatest"
5370: 29 29 29 0a 20 20 20 20 28 65 78 69 74 29 29 29 ))). (exit)))
5380: 0a 0a 3b 3b 20 28 75 73 65 20 74 72 61 63 65 29 ..;; (use trace)
5390: 0a 3b 3b 20 28 74 72 61 63 65 20 68 74 74 70 2d .;; (trace http-
53a0: 74 72 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 transport:keep-r
53b0: 75 6e 6e 69 6e 67 20 0a 3b 3b 20 20 20 20 20 20 unning .;;
53c0: 20 20 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 75 tasks:server-u
53d0: 70 64 61 74 65 2d 68 65 61 72 74 62 65 61 74 0a pdate-heartbeat.
53e0: 3b 3b 20 20 20 20 20 20 20 20 74 61 73 6b 73 3a ;; tasks:
53f0: 73 65 72 76 65 72 2d 67 65 74 2d 73 65 72 76 65 server-get-serve
5400: 72 2d 69 64 29 0a 3b 3b 20 20 20 20 20 20 20 20 r-id).;;
5410: 74 61 73 6b 73 3a 67 65 74 2d 62 65 73 74 2d 73 tasks:get-best-s
5420: 65 72 76 65 72 0a 3b 3b 20 20 20 20 20 20 20 20 erver.;;
5430: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 http-transport:r
5440: 75 6e 0a 3b 3b 20 20 20 20 20 20 20 20 68 74 74 un.;; htt
5450: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e p-transport:laun
5460: 63 68 0a 3b 3b 20 20 20 20 20 20 20 20 68 74 74 ch.;; htt
5470: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d p-transport:try-
5480: 73 74 61 72 74 2d 73 65 72 76 65 72 0a 3b 3b 20 start-server.;;
5490: 20 20 20 20 20 20 20 68 74 74 70 2d 74 72 61 6e http-tran
54a0: 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 73 65 6e sport:client-sen
54b0: 64 2d 72 65 63 65 69 76 65 0a 3b 3b 20 20 20 20 d-receive.;;
54c0: 20 20 20 20 68 74 74 70 2d 74 72 61 6e 73 70 6f http-transpo
54d0: 72 74 3a 6d 61 6b 65 2d 73 65 72 76 65 72 2d 75 rt:make-server-u
54e0: 72 6c 0a 3b 3b 20 20 20 20 20 20 20 20 74 61 73 rl.;; tas
54f0: 6b 73 3a 73 65 72 76 65 72 2d 72 65 67 69 73 74 ks:server-regist
5500: 65 72 0a 3b 3b 20 20 20 20 20 20 20 20 74 61 73 er.;; tas
5510: 6b 73 3a 73 65 72 76 65 72 2d 64 65 6c 65 74 65 ks:server-delete
5520: 0a 3b 3b 20 20 20 20 20 20 20 20 73 74 61 72 74 .;; start
5530: 2d 73 65 72 76 65 72 0a 3b 3b 20 20 20 20 20 20 -server.;;
5540: 20 20 68 6f 73 74 6e 61 6d 65 2d 3e 69 70 0a 3b hostname->ip.;
5550: 3b 20 20 20 20 20 20 20 20 77 69 74 68 2d 69 6e ; with-in
5560: 70 75 74 2d 66 72 6f 6d 2d 72 65 71 75 65 73 74 put-from-request
5570: 0a 3b 3b 20 20 20 20 20 20 20 20 74 61 73 6b 73 .;; tasks
5580: 3a 73 65 72 76 65 72 2d 64 65 72 65 67 69 73 74 :server-deregist
5590: 65 72 2d 73 65 6c 66 29 0a 0a 28 64 65 66 69 6e er-self)..(defin
55a0: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
55b0: 74 3a 73 65 72 76 65 72 2d 73 69 67 6e 61 6c 2d t:server-signal-
55c0: 68 61 6e 64 6c 65 72 20 73 69 67 6e 75 6d 29 0a handler signum).
55d0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
55e0: 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 ions. exn. (
55f0: 64 65 62 75 67 3a 70 72 69 6e 74 20 22 20 2e 2e debug:print " ..
5600: 2e 20 65 78 69 74 69 6e 67 20 2e 2e 2e 22 29 0a . exiting ...").
5610: 20 20 20 28 6c 65 74 20 28 28 74 68 31 20 28 6d (let ((th1 (m
5620: 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 ake-thread (lamb
5630: 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 74 da ().... (t
5640: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 29 hread-sleep! 1))
5650: 0a 09 09 09 20 20 20 20 20 3b 3b 20 28 69 66 20 .... ;; (if
5660: 28 6e 6f 74 20 2a 72 65 63 65 69 76 65 64 2d 72 (not *received-r
5670: 65 73 70 6f 6e 73 65 2a 29 0a 09 09 09 20 20 20 esponse*)....
5680: 20 20 3b 3b 09 20 28 72 65 63 65 69 76 65 2d 6d ;;. (receive-m
5690: 65 73 73 61 67 65 2a 20 2a 72 75 6e 72 65 6d 6f essage* *runremo
56a0: 74 65 2a 29 29 29 20 3b 3b 20 66 6c 75 73 68 20 te*))) ;; flush
56b0: 6f 75 74 20 6c 61 73 74 20 63 61 6c 6c 20 69 66 out last call if
56c0: 20 61 70 70 6c 69 63 61 62 6c 65 0a 09 09 09 20 applicable....
56d0: 20 20 22 65 61 74 20 72 65 73 70 6f 6e 73 65 22 "eat response"
56e0: 29 29 0a 09 20 28 74 68 32 20 28 6d 61 6b 65 2d )).. (th2 (make-
56f0: 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 thread (lambda (
5700: 29 0a 09 09 09 20 20 20 20 20 28 64 65 62 75 67 ).... (debug
5710: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
5720: 20 52 65 63 65 69 76 65 64 20 5e 43 2c 20 61 74 Received ^C, at
5730: 74 65 6d 70 74 69 6e 67 20 63 6c 65 61 6e 20 65 tempting clean e
5740: 78 69 74 2e 20 50 6c 65 61 73 65 20 62 65 20 70 xit. Please be p
5750: 61 74 69 65 6e 74 20 61 6e 64 20 77 61 69 74 20 atient and wait
5760: 61 20 66 65 77 20 73 65 63 6f 6e 64 73 20 62 65 a few seconds be
5770: 66 6f 72 65 20 68 69 74 74 69 6e 67 20 5e 43 20 fore hitting ^C
5780: 61 67 61 69 6e 2e 22 29 0a 09 09 09 20 20 20 20 again.")....
5790: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
57a0: 33 29 20 3b 3b 20 67 69 76 65 20 74 68 65 20 66 3) ;; give the f
57b0: 6c 75 73 68 20 74 68 72 65 65 20 73 65 63 6f 6e lush three secon
57c0: 64 73 20 74 6f 20 64 6f 20 69 74 27 73 20 73 74 ds to do it's st
57d0: 75 66 66 0a 09 09 09 20 20 20 20 20 28 64 65 62 uff.... (deb
57e0: 75 67 3a 70 72 69 6e 74 20 30 20 22 20 20 20 20 ug:print 0 "
57f0: 20 20 20 44 6f 6e 65 2e 22 29 0a 09 09 09 20 20 Done.")....
5800: 20 20 20 28 65 78 69 74 20 34 29 29 0a 09 09 09 (exit 4))....
5810: 20 20 20 22 65 78 69 74 20 6f 6e 20 5e 43 20 74 "exit on ^C t
5820: 69 6d 65 72 22 29 29 29 0a 20 20 20 20 20 28 74 imer"))). (t
5830: 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 hread-start! th2
5840: 29 0a 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 ). (thread-s
5850: 74 61 72 74 21 20 74 68 31 29 0a 20 20 20 20 20 tart! th1).
5860: 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 (thread-join! th
5870: 32 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 2))))..;;=======
5880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
58c0: 3b 3b 20 77 65 62 20 70 61 67 65 73 0a 3b 3b 3d ;; web pages.;;=
58d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5910: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 =====..(define (
5920: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6d http-transport:m
5930: 61 69 6e 2d 70 61 67 65 29 0a 20 20 28 6c 65 74 ain-page). (let
5940: 20 28 28 6c 69 6e 6b 70 61 74 68 20 28 72 6f 6f ((linkpath (roo
5950: 74 2d 70 61 74 68 29 29 29 0a 20 20 20 20 28 63 t-path))). (c
5960: 6f 6e 63 20 22 3c 68 65 61 64 3e 3c 68 31 3e 22 onc "<head><h1>"
5970: 20 28 70 61 74 68 6e 61 6d 65 2d 73 74 72 69 70 (pathname-strip
5980: 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 -directory *topp
5990: 61 74 68 2a 29 20 22 3c 2f 68 31 3e 3c 2f 68 65 ath*) "</h1></he
59a0: 61 64 3e 22 0a 09 20 20 22 3c 62 6f 64 79 3e 22 ad>".. "<body>"
59b0: 0a 09 20 20 22 52 75 6e 20 61 72 65 61 3a 20 22 .. "Run area: "
59c0: 20 2a 74 6f 70 70 61 74 68 2a 0a 09 20 20 22 3c *toppath*.. "<
59d0: 68 32 3e 53 65 72 76 65 72 20 53 74 61 74 73 3c h2>Server Stats<
59e0: 2f 68 32 3e 22 0a 09 20 20 28 68 74 74 70 2d 74 /h2>".. (http-t
59f0: 72 61 6e 73 70 6f 72 74 3a 73 74 61 74 73 2d 74 ransport:stats-t
5a00: 61 62 6c 65 29 20 0a 09 20 20 22 3c 68 72 3e 22 able) .. "<hr>"
5a10: 0a 09 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 .. (http-transp
5a20: 6f 72 74 3a 72 75 6e 73 20 6c 69 6e 6b 70 61 74 ort:runs linkpat
5a30: 68 29 0a 09 20 20 22 3c 68 72 3e 22 0a 09 20 20 h).. "<hr>"..
5a40: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
5a50: 72 75 6e 2d 73 74 61 74 73 29 0a 09 20 20 22 3c run-stats).. "<
5a60: 2f 62 6f 64 79 3e 22 0a 09 20 20 29 29 29 0a 0a /body>".. )))..
5a70: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
5a80: 61 6e 73 70 6f 72 74 3a 73 74 61 74 73 2d 74 61 ansport:stats-ta
5a90: 62 6c 65 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f ble). (mutex-lo
5aa0: 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
5ab0: 75 74 65 78 2a 29 0a 20 20 28 6c 65 74 20 28 28 utex*). (let ((
5ac0: 72 65 73 20 0a 09 20 28 63 6f 6e 63 20 22 3c 74 res .. (conc "<t
5ad0: 61 62 6c 65 3e 22 0a 09 20 20 20 20 20 20 20 22 able>".. "
5ae0: 3c 74 72 3e 3c 74 64 3e 4d 61 78 20 63 61 63 68 <tr><td>Max cach
5af0: 65 64 20 71 75 65 72 69 65 73 3c 2f 74 64 3e 20 ed queries</td>
5b00: 20 20 20 20 20 20 20 3c 74 64 3e 22 20 2a 6d 61 <td>" *ma
5b10: 78 2d 63 61 63 68 65 2d 73 69 7a 65 2a 20 22 3c x-cache-size* "<
5b20: 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 /td></tr>"..
5b30: 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4e 75 6d 62 "<tr><td>Numb
5b40: 65 72 20 6f 66 20 63 61 63 68 65 64 20 77 72 69 er of cached wri
5b50: 74 65 73 3c 2f 74 64 3e 20 20 20 3c 74 64 3e 22 tes</td> <td>"
5b60: 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 *number-of-writ
5b70: 65 73 2a 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 es* "</td></tr>"
5b80: 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 .. "<tr><t
5b90: 64 3e 41 76 65 72 61 67 65 20 63 61 63 68 65 64 d>Average cached
5ba0: 20 77 72 69 74 65 20 74 69 6d 65 3c 2f 74 64 3e write time</td>
5bb0: 20 3c 74 64 3e 22 20 28 69 66 20 28 65 71 3f 20 <td>" (if (eq?
5bc0: 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 *number-of-write
5bd0: 73 2a 20 30 29 0a 09 09 09 09 09 09 09 09 20 22 s* 0)......... "
5be0: 6e 2f 61 20 28 6e 6f 20 77 72 69 74 65 73 29 22 n/a (no writes)"
5bf0: 0a 09 09 09 09 09 09 09 09 20 28 2f 20 2a 77 72 ......... (/ *wr
5c00: 69 74 65 73 2d 74 6f 74 61 6c 2d 64 65 6c 61 79 ites-total-delay
5c10: 2a 0a 09 09 09 09 09 09 09 09 20 20 20 20 2a 6e *......... *n
5c20: 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a umber-of-writes*
5c30: 29 29 0a 09 20 20 20 20 20 20 20 22 20 6d 73 3c )).. " ms<
5c40: 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 /td></tr>"..
5c50: 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4e 75 6d 62 "<tr><td>Numb
5c60: 65 72 20 6e 6f 6e 2d 63 61 63 68 65 64 20 71 75 er non-cached qu
5c70: 65 72 69 65 73 3c 2f 74 64 3e 20 3c 74 64 3e 22 eries</td> <td>"
5c80: 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 *number-non-wr
5c90: 69 74 65 2d 71 75 65 72 69 65 73 2a 20 22 3c 2f ite-queries* "</
5ca0: 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 td></tr>"..
5cb0: 20 20 22 3c 74 72 3e 3c 74 64 3e 41 76 65 72 61 "<tr><td>Avera
5cc0: 67 65 20 6e 6f 6e 2d 63 61 63 68 65 64 20 74 69 ge non-cached ti
5cd0: 6d 65 3c 2f 74 64 3e 20 20 20 3c 74 64 3e 22 20 me</td> <td>"
5ce0: 28 69 66 20 28 65 71 3f 20 2a 6e 75 6d 62 65 72 (if (eq? *number
5cf0: 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 -non-write-queri
5d00: 65 73 2a 20 30 29 0a 09 09 09 09 09 09 09 09 20 es* 0).........
5d10: 22 6e 2f 61 20 28 6e 6f 20 71 75 65 72 69 65 73 "n/a (no queries
5d20: 29 22 0a 09 09 09 09 09 09 09 09 20 28 2f 20 2a )"......... (/ *
5d30: 74 6f 74 61 6c 2d 6e 6f 6e 2d 77 72 69 74 65 2d total-non-write-
5d40: 64 65 6c 61 79 2a 20 0a 09 09 09 09 09 09 09 09 delay* .........
5d50: 20 20 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d *number-non-
5d60: 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a 29 29 write-queries*))
5d70: 0a 09 20 20 20 20 20 20 20 22 20 6d 73 3c 2f 74 .. " ms</t
5d80: 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 d></tr>"..
5d90: 20 22 3c 74 72 3e 3c 74 64 3e 4c 61 73 74 20 61 "<tr><td>Last a
5da0: 63 63 65 73 73 3c 2f 74 64 3e 3c 74 64 3e 22 20 ccess</td><td>"
5db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 (se
5dc0: 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 conds->time-stri
5dd0: 6e 67 20 2a 6c 61 73 74 2d 64 62 2d 61 63 63 65 ng *last-db-acce
5de0: 73 73 2a 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e ss*) "</td></tr>
5df0: 22 0a 09 20 20 20 20 20 20 20 22 3c 2f 74 61 62 ".. "</tab
5e00: 6c 65 3e 22 29 29 29 0a 20 20 20 20 28 6d 75 74 le>"))). (mut
5e10: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 ex-unlock! *hear
5e20: 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 tbeat-mutex*).
5e30: 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 res))..(define
5e40: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
5e50: 3a 72 75 6e 73 20 6c 69 6e 6b 70 61 74 68 29 0a :runs linkpath).
5e60: 20 20 28 63 6f 6e 63 20 22 3c 68 33 3e 52 75 6e (conc "<h3>Run
5e70: 73 3c 2f 68 33 3e 22 0a 09 28 73 74 72 69 6e 67 s</h3>"..(string
5e80: 2d 69 6e 74 65 72 73 70 65 72 73 65 0a 09 20 28 -intersperse.. (
5e90: 6c 65 74 20 28 28 66 69 6c 65 73 20 28 6d 61 70 let ((files (map
5ea0: 20 70 61 74 68 6e 61 6d 65 2d 73 74 72 69 70 2d pathname-strip-
5eb0: 64 69 72 65 63 74 6f 72 79 20 28 67 6c 6f 62 20 directory (glob
5ec0: 28 63 6f 6e 63 20 6c 69 6e 6b 70 61 74 68 20 22 (conc linkpath "
5ed0: 2f 2a 22 29 29 29 29 29 0a 09 20 20 20 28 6d 61 /*"))))).. (ma
5ee0: 70 20 28 6c 61 6d 62 64 61 20 28 70 29 0a 09 09 p (lambda (p)...
5ef0: 20 20 28 63 6f 6e 63 20 22 3c 61 20 68 72 65 66 (conc "<a href
5f00: 3d 5c 22 22 20 70 20 22 5c 22 3e 22 20 70 20 22 =\"" p "\">" p "
5f10: 3c 2f 61 3e 3c 62 72 3e 22 29 29 0a 09 09 66 69 </a><br>"))...fi
5f20: 6c 65 73 29 29 0a 09 20 22 20 22 29 29 29 0a 0a les)).. " ")))..
5f30: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
5f40: 61 6e 73 70 6f 72 74 3a 72 75 6e 2d 73 74 61 74 ansport:run-stat
5f50: 73 29 0a 20 20 28 6c 65 74 20 28 28 73 74 61 74 s). (let ((stat
5f60: 73 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 s (open-run-clos
5f70: 65 20 64 62 3a 67 65 74 2d 72 75 6e 6e 69 6e 67 e db:get-running
5f80: 2d 73 74 61 74 73 20 23 66 29 29 29 0a 20 20 20 -stats #f))).
5f90: 20 28 63 6f 6e 63 20 22 3c 74 61 62 6c 65 3e 22 (conc "<table>"
5fa0: 0a 09 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 .. (string-inte
5fb0: 72 73 70 65 72 73 65 0a 09 20 20 20 28 6d 61 70 rsperse.. (map
5fc0: 20 28 6c 61 6d 62 64 61 20 28 73 74 61 74 29 0a (lambda (stat).
5fd0: 09 09 20 20 28 63 6f 6e 63 20 22 3c 74 72 3e 3c .. (conc "<tr><
5fe0: 74 64 3e 22 20 28 63 61 72 20 73 74 61 74 29 20 td>" (car stat)
5ff0: 22 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 63 61 64 "</td><td>" (cad
6000: 72 20 73 74 61 74 29 20 22 3c 2f 74 64 3e 3c 2f r stat) "</td></
6010: 74 72 3e 22 29 29 0a 09 09 73 74 61 74 73 29 0a tr>"))...stats).
6020: 09 20 20 20 22 20 22 29 0a 09 20 20 22 3c 2f 74 . " ").. "</t
6030: 61 62 6c 65 3e 22 29 29 29 able>")))