Artifact
ac12c8febe2cfec810f6cc14de7fcd807e6376fc:
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: 4e 4f 54 45 3a 20 4c 61 72 67 65 20 62 6c 6f 63 NOTE: Large bloc
1cb0: 6b 20 6f 66 20 63 6f 64 65 20 66 72 6f 6d 20 33 k of code from 3
1cc0: 32 34 33 36 62 34 32 36 31 38 38 30 38 30 66 37 2436b426188080f7
1cd0: 32 66 63 65 62 36 38 39 34 61 66 35 34 31 66 62 2fceb6894af541fb
1ce0: 61 64 39 39 32 31 65 20 72 65 6d 6f 76 65 64 20 ad9921e removed
1cf0: 68 65 72 65 0a 3b 3b 20 20 20 20 20 20 20 49 27 here.;; I'
1d00: 6d 20 70 72 65 74 74 79 20 73 75 72 65 20 69 74 m pretty sure it
1d10: 20 69 73 20 64 65 66 75 6e 63 74 2e 0a 0a 3b 3b is defunct...;;
1d20: 20 54 68 69 73 20 6e 65 78 74 20 62 6c 6f 63 6b This next block
1d30: 20 61 6c 6c 20 69 6d 70 6f 72 74 65 64 20 65 6e all imported en
1d40: 2d 6d 61 73 73 20 66 72 6f 6d 20 74 68 65 20 61 -mass from the a
1d50: 70 69 20 62 72 61 6e 63 68 0a 28 64 65 66 69 6e pi branch.(defin
1d60: 65 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 e *http-requests
1d70: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 30 29 -in-progress* 0)
1d80: 0a 28 64 65 66 69 6e 65 20 2a 68 74 74 70 2d 63 .(define *http-c
1d90: 6f 6e 6e 65 63 74 69 6f 6e 73 2d 6e 65 78 74 2d onnections-next-
1da0: 63 6c 65 61 6e 75 70 2a 20 28 63 75 72 72 65 6e cleanup* (curren
1db0: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 0a 28 64 65 t-seconds))..(de
1dc0: 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
1dd0: 70 6f 72 74 3a 67 65 74 2d 74 69 6d 65 2d 74 6f port:get-time-to
1de0: 2d 63 6c 65 61 6e 75 70 29 0a 20 20 28 6c 65 74 -cleanup). (let
1df0: 20 28 28 72 65 73 20 23 66 29 29 0a 20 20 20 20 ((res #f)).
1e00: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 (mutex-lock! *ht
1e10: 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 28 tp-mutex*). (
1e20: 73 65 74 21 20 72 65 73 20 28 3e 20 28 63 75 72 set! res (> (cur
1e30: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 2a 68 rent-seconds) *h
1e40: 74 74 70 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 2d ttp-connections-
1e50: 6e 65 78 74 2d 63 6c 65 61 6e 75 70 2a 29 29 0a next-cleanup*)).
1e60: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
1e70: 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 k! *http-mutex*)
1e80: 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 . res))..(def
1e90: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
1ea0: 6f 72 74 3a 69 6e 63 2d 72 65 71 75 65 73 74 73 ort:inc-requests
1eb0: 2d 63 6f 75 6e 74 29 0a 20 20 28 6d 75 74 65 78 -count). (mutex
1ec0: 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 -lock! *http-mut
1ed0: 65 78 2a 29 0a 20 20 28 73 65 74 21 20 2a 68 74 ex*). (set! *ht
1ee0: 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 tp-requests-in-p
1ef0: 72 6f 67 72 65 73 73 2a 20 28 2b 20 31 20 2a 68 rogress* (+ 1 *h
1f00: 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d ttp-requests-in-
1f10: 70 72 6f 67 72 65 73 73 2a 29 29 0a 20 20 3b 3b progress*)). ;;
1f20: 20 55 73 65 20 74 68 69 73 20 6f 70 70 6f 72 74 Use this opport
1f30: 75 6e 69 74 79 20 74 6f 20 73 6c 6f 77 20 74 68 unity to slow th
1f40: 69 6e 67 73 20 64 6f 77 6e 20 69 66 66 20 74 68 ings down iff th
1f50: 65 72 65 20 61 72 65 20 74 6f 6f 20 6d 61 6e 79 ere are too many
1f60: 20 72 65 71 75 65 73 74 73 20 69 6e 20 66 6c 69 requests in fli
1f70: 67 68 74 0a 20 20 28 69 66 20 28 3e 20 2a 68 74 ght. (if (> *ht
1f80: 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 tp-requests-in-p
1f90: 72 6f 67 72 65 73 73 2a 20 35 29 0a 20 20 20 20 rogress* 5).
1fa0: 20 20 28 62 65 67 69 6e 0a 09 28 64 65 62 75 67 (begin..(debug
1fb0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 57 :print-info 0 "W
1fc0: 68 6f 61 20 74 68 65 72 65 20 62 75 64 64 79 2c hoa there buddy,
1fd0: 20 65 61 73 65 20 75 70 2e 2e 2e 22 29 0a 09 28 ease up...")..(
1fe0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
1ff0: 29 29 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f )). (mutex-unlo
2000: 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a ck! *http-mutex*
2010: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 ))..(define (htt
2020: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 64 65 63 2d p-transport:dec-
2030: 72 65 71 75 65 73 74 73 2d 63 6f 75 6e 74 20 70 requests-count p
2040: 72 6f 63 29 20 0a 20 20 28 6d 75 74 65 78 2d 6c roc) . (mutex-l
2050: 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 ock! *http-mutex
2060: 2a 29 0a 20 20 28 70 72 6f 63 29 0a 20 20 28 73 *). (proc). (s
2070: 65 74 21 20 2a 68 74 74 70 2d 72 65 71 75 65 73 et! *http-reques
2080: 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 ts-in-progress*
2090: 28 2d 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 (- *http-request
20a0: 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 31 s-in-progress* 1
20b0: 29 29 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f )). (mutex-unlo
20c0: 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a ck! *http-mutex*
20d0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 ))..(define (htt
20e0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 64 65 63 2d p-transport:dec-
20f0: 72 65 71 75 65 73 74 73 2d 63 6f 75 6e 74 2d 61 requests-count-a
2100: 6e 64 2d 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e nd-close-all-con
2110: 6e 65 63 74 69 6f 6e 73 29 0a 20 20 28 73 65 74 nections). (set
2120: 21 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 ! *http-requests
2130: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 28 2d -in-progress* (-
2140: 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d *http-requests-
2150: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 31 29 29 in-progress* 1))
2160: 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 65 . (let loop ((e
2170: 74 69 6d 65 20 28 2b 20 28 63 75 72 72 65 6e 74 time (+ (current
2180: 2d 73 65 63 6f 6e 64 73 29 20 35 29 29 29 20 3b -seconds) 5))) ;
2190: 3b 20 67 69 76 65 20 75 70 20 69 6e 20 66 69 76 ; give up in fiv
21a0: 65 20 73 65 63 6f 6e 64 73 0a 20 20 20 20 28 69 e seconds. (i
21b0: 66 20 28 3e 20 2a 68 74 74 70 2d 72 65 71 75 65 f (> *http-reque
21c0: 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a sts-in-progress*
21d0: 20 30 29 0a 09 28 69 66 20 28 3e 20 65 74 69 6d 0)..(if (> etim
21e0: 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e e (current-secon
21f0: 64 73 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e ds)).. (begin
2200: 0a 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d .. (thread-
2210: 73 6c 65 65 70 21 20 30 2e 30 35 29 0a 09 20 20 sleep! 0.05)..
2220: 20 20 20 20 28 6c 6f 6f 70 20 65 74 69 6d 65 29 (loop etime)
2230: 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
2240: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 72 65 int 0 "ERROR: re
2250: 71 75 65 73 74 73 20 73 74 69 6c 6c 20 69 6e 20 quests still in
2260: 70 72 6f 67 72 65 73 73 20 61 66 74 65 72 20 35 progress after 5
2270: 20 73 65 63 6f 6e 64 73 20 6f 66 20 77 61 69 74 seconds of wait
2280: 69 6e 67 2e 20 49 27 6d 20 67 6f 69 6e 67 20 74 ing. I'm going t
2290: 6f 20 70 61 73 73 20 6f 6e 20 63 6c 65 61 6e 69 o pass on cleani
22a0: 6e 67 20 75 70 20 68 74 74 70 20 63 6f 6e 6e 65 ng up http conne
22b0: 63 74 69 6f 6e 73 22 29 29 0a 09 28 63 6c 6f 73 ctions"))..(clos
22c0: 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e e-all-connection
22d0: 73 21 29 29 29 0a 20 20 28 73 65 74 21 20 2a 68 s!))). (set! *h
22e0: 74 74 70 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 2d ttp-connections-
22f0: 6e 65 78 74 2d 63 6c 65 61 6e 75 70 2a 20 28 2b next-cleanup* (+
2300: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
2310: 73 29 20 31 30 29 29 0a 20 20 28 6d 75 74 65 78 s) 10)). (mutex
2320: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d -unlock! *http-m
2330: 75 74 65 78 2a 29 29 0a 0a 28 64 65 66 69 6e 65 utex*))..(define
2340: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
2350: 3a 69 6e 63 2d 72 65 71 75 65 73 74 73 2d 61 6e :inc-requests-an
2360: 64 2d 70 72 65 70 2d 74 6f 2d 63 6c 6f 73 65 2d d-prep-to-close-
2370: 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 29 all-connections)
2380: 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 . (mutex-lock!
2390: 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 *http-mutex*).
23a0: 28 73 65 74 21 20 2a 68 74 74 70 2d 72 65 71 75 (set! *http-requ
23b0: 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 ests-in-progress
23c0: 2a 20 28 2b 20 31 20 2a 68 74 74 70 2d 72 65 71 * (+ 1 *http-req
23d0: 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 uests-in-progres
23e0: 73 2a 29 29 29 0a 0a 3b 3b 20 28 73 79 73 74 65 s*)))..;; (syste
23f0: 6d 20 22 6d 65 67 61 74 65 73 74 20 2d 6c 69 73 m "megatest -lis
2400: 74 2d 73 65 72 76 65 72 73 20 7c 20 67 72 65 70 t-servers | grep
2410: 20 61 6c 69 76 65 20 7c 7c 20 6d 65 67 61 74 65 alive || megate
2420: 73 74 20 2d 73 65 72 76 65 72 20 2d 20 2d 64 61 st -server - -da
2430: 65 6d 6f 6e 69 7a 65 20 26 26 20 73 6c 65 65 70 emonize && sleep
2440: 20 34 22 29 0a 0a 3b 3b 20 3c 68 74 6d 6c 3e 0a 4")..;; <html>.
2450: 3b 3b 20 3c 68 65 61 64 3e 3c 2f 68 65 61 64 3e ;; <head></head>
2460: 0a 3b 3b 20 3c 62 6f 64 79 3e 31 20 48 65 6c 6c .;; <body>1 Hell
2470: 6f 2c 20 77 6f 72 6c 64 21 20 47 6f 6f 64 62 79 o, world! Goodby
2480: 65 20 44 6f 6c 6c 79 3c 2f 62 6f 64 79 3e 3c 2f e Dolly</body></
2490: 68 74 6d 6c 3e 0a 3b 3b 20 53 65 6e 64 20 6d 73 html>.;; Send ms
24a0: 67 20 74 6f 20 73 65 72 76 65 72 64 61 74 20 61 g to serverdat a
24b0: 6e 64 20 72 65 63 65 69 76 65 20 72 65 73 75 6c nd receive resul
24c0: 74 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d t.(define (http-
24d0: 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 transport:client
24e0: 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 20 73 65 -send-receive se
24f0: 72 76 65 72 64 61 74 20 6d 73 67 20 23 21 6b 65 rverdat msg #!ke
2500: 79 20 28 6e 75 6d 72 65 74 72 69 65 73 20 33 30 y (numretries 30
2510: 29 29 0a 20 20 28 6c 65 74 2a 20 28 3b 3b 20 28 )). (let* (;; (
2520: 75 72 6c 20 20 20 20 20 20 20 20 28 68 74 74 70 url (http
2530: 2d 74 72 61 6e 73 70 6f 72 74 3a 6d 61 6b 65 2d -transport:make-
2540: 73 65 72 76 65 72 2d 75 72 6c 20 73 65 72 76 65 server-url serve
2550: 72 64 61 74 29 29 0a 09 20 28 66 75 6c 6c 75 72 rdat)).. (fullur
2560: 6c 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 l (if (list?
2570: 73 65 72 76 65 72 64 61 74 29 0a 09 09 09 20 28 serverdat).... (
2580: 63 61 64 64 72 20 73 65 72 76 65 72 64 61 74 29 caddr serverdat)
2590: 0a 09 09 09 20 28 62 65 67 69 6e 0a 09 09 09 20 .... (begin....
25a0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
25b0: 20 22 46 41 54 41 4c 20 45 52 52 4f 52 3a 20 68 "FATAL ERROR: h
25c0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c ttp-transport:cl
25d0: 69 65 6e 74 2d 73 65 6e 64 2d 72 65 63 65 69 76 ient-send-receiv
25e0: 65 20 63 61 6c 6c 65 64 20 77 69 74 68 20 6e 6f e called with no
25f0: 20 73 65 72 76 65 72 20 69 6e 66 6f 22 29 0a 09 server info")..
2600: 09 09 20 20 20 28 65 78 69 74 20 31 29 29 29 29 .. (exit 1))))
2610: 20 3b 3b 20 28 63 6f 6e 63 20 75 72 6c 20 22 2f ;; (conc url "/
2620: 63 74 72 6c 22 29 29 20 3b 3b 20 28 63 6f 6e 63 ctrl")) ;; (conc
2630: 20 75 72 6c 20 22 2f 3f 64 61 74 3d 22 20 6d 73 url "/?dat=" ms
2640: 67 29 29 29 0a 09 20 28 72 65 73 20 20 20 20 20 g))).. (res
2650: 20 20 20 23 66 29 29 0a 20 20 20 20 28 68 61 6e #f)). (han
2660: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 dle-exceptions.
2670: 20 20 20 20 65 78 6e 0a 20 20 20 20 20 28 62 65 exn. (be
2680: 67 69 6e 0a 20 20 20 20 20 20 20 28 70 72 69 6e gin. (prin
2690: 74 20 22 45 52 52 4f 52 20 49 4e 20 68 74 74 70 t "ERROR IN http
26a0: 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e -transport:clien
26b0: 74 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 20 22 t-send-receive "
26c0: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
26d0: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
26e0: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
26f0: 6e 29 29 0a 20 20 20 20 20 20 20 28 74 68 72 65 n)). (thre
2700: 61 64 2d 73 6c 65 65 70 21 20 32 29 0a 20 20 20 ad-sleep! 2).
2710: 20 20 20 20 28 69 66 20 28 3e 20 6e 75 6d 72 65 (if (> numre
2720: 74 72 69 65 73 20 30 29 0a 09 20 20 20 28 68 74 tries 0).. (ht
2730: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 tp-transport:cli
2740: 65 6e 74 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 ent-send-receive
2750: 20 73 65 72 76 65 72 64 61 74 20 6d 73 67 20 6e serverdat msg n
2760: 75 6d 72 65 74 72 69 65 73 3a 20 28 2d 20 6e 75 umretries: (- nu
2770: 6d 72 65 74 72 69 65 73 20 31 29 29 29 29 0a 20 mretries 1)))).
2780: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
2790: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
27a0: 6e 66 6f 20 31 31 20 22 66 75 6c 6c 75 72 6c 3d nfo 11 "fullurl=
27b0: 22 20 66 75 6c 6c 75 72 6c 20 22 5c 6e 22 29 0a " fullurl "\n").
27c0: 20 20 20 20 20 20 20 3b 3b 20 73 65 74 20 75 70 ;; set up
27d0: 20 74 68 65 20 68 74 74 70 2d 63 6c 69 65 6e 74 the http-client
27e0: 20 68 65 72 65 0a 20 20 20 20 20 20 20 28 6d 61 here. (ma
27f0: 78 2d 72 65 74 72 79 2d 61 74 74 65 6d 70 74 73 x-retry-attempts
2800: 20 35 29 0a 20 20 20 20 20 20 20 3b 3b 20 63 6f 5). ;; co
2810: 6e 73 69 64 65 72 20 61 6c 6c 20 72 65 71 75 65 nsider all reque
2820: 73 74 73 20 69 6e 64 65 6d 70 6f 74 65 6e 74 0a sts indempotent.
2830: 20 20 20 20 20 20 20 28 72 65 74 72 79 2d 72 65 (retry-re
2840: 71 75 65 73 74 3f 20 28 6c 61 6d 62 64 61 20 28 quest? (lambda (
2850: 72 65 71 75 65 73 74 29 0a 09 09 09 20 23 74 29 request).... #t)
2860: 29 20 20 20 3b 3b 20 20 09 09 20 28 74 68 72 65 ) ;; .. (thre
2870: 61 64 2d 73 6c 65 65 70 21 20 28 2f 20 28 69 66 ad-sleep! (/ (if
2880: 20 28 3e 20 6e 75 6d 72 65 74 72 69 65 73 20 31 (> numretries 1
2890: 30 30 29 20 31 30 30 20 6e 75 6d 72 65 74 72 69 00) 100 numretri
28a0: 65 73 29 20 31 30 29 29 0a 20 20 20 20 20 20 20 es) 10)).
28b0: 3b 3b 20 28 73 65 74 21 20 6e 75 6d 72 65 74 72 ;; (set! numretr
28c0: 69 65 73 20 28 2d 20 6e 75 6d 72 65 74 72 69 65 ies (- numretrie
28d0: 73 20 31 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 s 1)). ;;
28e0: 20 09 09 20 23 74 29 29 0a 20 20 20 20 20 20 20 .. #t)).
28f0: 3b 3b 20 73 65 6e 64 20 74 68 65 20 64 61 74 61 ;; send the data
2900: 20 61 6e 64 20 67 65 74 20 74 68 65 20 72 65 73 and get the res
2910: 70 6f 6e 73 65 0a 20 20 20 20 20 20 20 3b 3b 20 ponse. ;;
2920: 65 78 74 72 61 63 74 20 74 68 65 20 6e 65 65 64 extract the need
2930: 65 64 20 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 ed info from the
2940: 20 68 74 74 70 20 64 61 74 61 20 61 6e 64 20 0a http data and .
2950: 20 20 20 20 20 20 20 3b 3b 20 70 72 6f 63 65 73 ;; proces
2960: 73 20 61 6e 64 20 72 65 74 75 72 6e 20 69 74 2e s and return it.
2970: 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
2980: 73 65 6e 64 2d 72 65 63 69 65 76 65 20 28 6c 61 send-recieve (la
2990: 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 mbda ()....
29a0: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 (mutex-lock! *h
29b0: 74 74 70 2d 6d 75 74 65 78 2a 29 0a 09 09 09 20 ttp-mutex*)....
29c0: 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 28 (set! res (
29d0: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
29e0: 72 65 71 75 65 73 74 20 0a 09 09 09 09 09 20 66 request ...... f
29f0: 75 6c 6c 75 72 6c 20 0a 09 09 09 09 09 20 28 6c ullurl ...... (l
2a00: 69 73 74 20 28 63 6f 6e 73 20 27 64 61 74 20 6d ist (cons 'dat m
2a10: 73 67 29 29 20 0a 09 09 09 09 09 20 72 65 61 64 sg)) ...... read
2a20: 2d 73 74 72 69 6e 67 29 29 0a 09 09 09 20 20 20 -string))....
2a30: 20 20 20 28 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f (close-all-co
2a40: 6e 6e 65 63 74 69 6f 6e 73 21 29 20 0a 09 09 09 nnections!) ....
2a50: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
2a60: 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 ock! *http-mutex
2a70: 2a 29 29 29 0a 09 20 20 20 20 20 20 28 74 69 6d *))).. (tim
2a80: 65 2d 6f 75 74 20 20 20 20 20 28 6c 61 6d 62 64 e-out (lambd
2a90: 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 28 74 a ().... (t
2aa0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 34 35 29 hread-sleep! 45)
2ab0: 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 28 6e .... (if (n
2ac0: 6f 74 20 72 65 73 29 0a 09 09 09 09 20 20 28 62 ot res)..... (b
2ad0: 65 67 69 6e 0a 09 09 09 09 20 20 20 20 28 64 65 egin..... (de
2ae0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
2af0: 4e 49 4e 47 3a 20 63 6f 6d 6d 75 6e 69 63 61 74 NING: communicat
2b00: 69 6f 6e 20 77 69 74 68 20 74 68 65 20 73 65 72 ion with the ser
2b10: 76 65 72 20 74 69 6d 65 64 20 6f 75 74 2e 22 29 ver timed out.")
2b20: 0a 09 09 09 09 20 20 20 20 28 6d 75 74 65 78 2d ..... (mutex-
2b30: 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 unlock! *http-mu
2b40: 74 65 78 2a 29 0a 09 09 09 09 20 20 20 20 28 68 tex*)..... (h
2b50: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c ttp-transport:cl
2b60: 69 65 6e 74 2d 73 65 6e 64 2d 72 65 63 65 69 76 ient-send-receiv
2b70: 65 20 73 65 72 76 65 72 64 61 74 20 6d 73 67 20 e serverdat msg
2b80: 6e 75 6d 72 65 74 72 69 65 73 3a 20 28 2d 20 6e numretries: (- n
2b90: 75 6d 72 65 74 72 69 65 73 20 31 29 29 0a 09 09 umretries 1))...
2ba0: 09 09 20 20 20 20 28 69 66 20 28 3c 20 6e 75 6d .. (if (< num
2bb0: 72 65 74 72 69 65 73 20 33 29 20 3b 3b 20 6f 6e retries 3) ;; on
2bc0: 20 6c 61 73 74 20 74 72 79 20 6a 75 73 74 20 65 last try just e
2bd0: 78 69 74 0a 09 09 09 09 09 28 62 65 67 69 6e 0a xit......(begin.
2be0: 09 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 ..... (debug:pr
2bf0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 63 6f int 0 "ERROR: co
2c00: 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 77 69 74 68 mmunication with
2c10: 20 74 68 65 20 73 65 72 76 65 72 20 74 69 6d 65 the server time
2c20: 64 20 6f 75 74 2e 20 47 69 76 69 6e 67 20 75 70 d out. Giving up
2c30: 2e 22 29 0a 09 09 09 09 09 20 20 28 65 78 69 74 .")...... (exit
2c40: 20 31 29 29 29 29 29 29 29 0a 09 20 20 20 20 20 1)))))))..
2c50: 20 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 (th1 (make-thre
2c60: 61 64 20 73 65 6e 64 2d 72 65 63 69 65 76 65 20 ad send-recieve
2c70: 22 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d "with-input-from
2c80: 2d 72 65 71 75 65 73 74 22 29 29 0a 09 20 20 20 -request"))..
2c90: 20 20 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 (th2 (make-th
2ca0: 72 65 61 64 20 74 69 6d 65 2d 6f 75 74 20 20 20 read time-out
2cb0: 20 20 22 74 69 6d 65 20 6f 75 74 22 29 29 29 0a "time out"))).
2cc0: 09 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 . (thread-start!
2cd0: 20 74 68 31 29 0a 09 20 28 74 68 72 65 61 64 2d th1).. (thread-
2ce0: 73 74 61 72 74 21 20 74 68 32 29 0a 09 20 28 74 start! th2).. (t
2cf0: 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 29 hread-join! th1)
2d00: 0a 09 20 28 74 68 72 65 61 64 2d 74 65 72 6d 69 .. (thread-termi
2d10: 6e 61 74 65 21 20 74 68 32 29 0a 09 20 28 64 65 nate! th2).. (de
2d20: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
2d30: 31 20 22 67 6f 74 20 72 65 73 3d 22 20 72 65 73 1 "got res=" res
2d40: 29 0a 09 20 28 6c 65 74 20 28 28 6d 61 74 63 68 ).. (let ((match
2d50: 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 (string-search
2d60: 28 72 65 67 65 78 70 20 22 3c 62 6f 64 79 3e 28 (regexp "<body>(
2d70: 2e 2a 29 3c 2e 62 6f 64 79 3e 22 29 20 72 65 73 .*)<.body>") res
2d80: 29 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 ))).. (debug:p
2d90: 72 69 6e 74 2d 69 6e 66 6f 20 31 31 20 22 6d 61 rint-info 11 "ma
2da0: 74 63 68 3d 22 20 6d 61 74 63 68 29 0a 09 20 20 tch=" match)..
2db0: 20 28 6c 65 74 20 28 28 66 69 6e 61 6c 20 28 63 (let ((final (c
2dc0: 61 64 72 20 6d 61 74 63 68 29 29 29 0a 09 20 20 adr match)))..
2dd0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
2de0: 69 6e 66 6f 20 31 31 20 22 66 69 6e 61 6c 3d 22 info 11 "final="
2df0: 20 66 69 6e 61 6c 29 0a 09 20 20 20 20 20 66 69 final).. fi
2e00: 6e 61 6c 29 29 29 29 29 29 29 0a 0a 3b 3b 20 53 nal)))))))..;; S
2e10: 65 6e 64 20 22 63 6d 64 22 20 77 69 74 68 20 6a end "cmd" with j
2e20: 73 6f 6e 20 70 61 79 6c 6f 61 64 20 22 70 61 72 son payload "par
2e30: 61 6d 73 22 20 74 6f 20 73 65 72 76 65 72 64 61 ams" to serverda
2e40: 74 20 61 6e 64 20 72 65 63 65 69 76 65 20 72 65 t and receive re
2e50: 73 75 6c 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 sult.;;.(define
2e60: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
2e70: 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d client-api-send-
2e80: 72 65 63 65 69 76 65 20 73 65 72 76 65 72 64 61 receive serverda
2e90: 74 20 63 6d 64 20 70 61 72 61 6d 73 20 23 21 6b t cmd params #!k
2ea0: 65 79 20 28 6e 75 6d 72 65 74 72 69 65 73 20 33 ey (numretries 3
2eb0: 30 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 75 0)). (let* ((fu
2ec0: 6c 6c 75 72 6c 20 20 20 20 28 69 66 20 28 6c 69 llurl (if (li
2ed0: 73 74 3f 20 73 65 72 76 65 72 64 61 74 29 0a 09 st? serverdat)..
2ee0: 09 09 20 28 63 61 64 64 64 72 20 73 65 72 76 65 .. (cadddr serve
2ef0: 72 64 61 74 29 20 3b 3b 20 74 68 69 73 20 69 73 rdat) ;; this is
2f00: 20 74 68 65 20 75 72 69 20 66 6f 72 20 2f 61 70 the uri for /ap
2f10: 69 0a 09 09 09 20 28 62 65 67 69 6e 0a 09 09 09 i.... (begin....
2f20: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
2f30: 30 20 22 46 41 54 41 4c 20 45 52 52 4f 52 3a 20 0 "FATAL ERROR:
2f40: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 http-transport:c
2f50: 6c 69 65 6e 74 2d 73 65 6e 64 2d 72 65 63 65 69 lient-send-recei
2f60: 76 65 20 63 61 6c 6c 65 64 20 77 69 74 68 20 6e ve called with n
2f70: 6f 20 73 65 72 76 65 72 20 69 6e 66 6f 22 29 0a o server info").
2f80: 09 09 09 20 20 20 28 65 78 69 74 20 31 29 29 29 ... (exit 1)))
2f90: 29 0a 09 20 28 72 65 73 20 20 20 20 20 20 20 20 ).. (res
2fa0: 23 66 29 29 0a 20 20 20 20 28 68 61 6e 64 6c 65 #f)). (handle
2fb0: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 -exceptions.
2fc0: 20 65 78 6e 0a 20 20 20 20 20 28 62 65 67 69 6e exn. (begin
2fd0: 0a 20 20 20 20 20 20 20 3b 3b 20 54 4f 44 4f 3a . ;; TODO:
2fe0: 20 53 65 6e 64 20 74 68 69 73 20 6f 75 74 70 75 Send this outpu
2ff0: 74 20 74 6f 20 61 20 6c 6f 67 20 66 69 6c 65 20 t to a log file
3000: 73 6f 20 69 74 20 69 73 6e 27 74 20 6c 6f 73 74 so it isn't lost
3010: 20 77 68 65 6e 20 72 75 6e 6e 69 6e 67 20 61 73 when running as
3020: 20 64 61 65 6d 6f 6e 0a 20 20 20 20 20 20 20 28 daemon. (
3030: 70 72 69 6e 74 20 22 45 52 52 4f 52 20 49 4e 20 print "ERROR IN
3040: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 http-transport:c
3050: 6c 69 65 6e 74 2d 73 65 6e 64 2d 72 65 63 65 69 lient-send-recei
3060: 76 65 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e ve " ((condition
3070: 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
3080: 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
3090: 29 20 65 78 6e 29 29 0a 20 20 20 20 20 20 20 28 ) exn)). (
30a0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 thread-sleep! 2)
30b0: 0a 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 6e . (if (> n
30c0: 75 6d 72 65 74 72 69 65 73 20 30 29 0a 09 20 20 umretries 0)..
30d0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
30e0: 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 :client-api-send
30f0: 2d 72 65 63 65 69 76 65 20 73 65 72 76 65 72 64 -receive serverd
3100: 61 74 20 63 6d 64 20 70 61 72 61 6d 73 20 6e 75 at cmd params nu
3110: 6d 72 65 74 72 69 65 73 3a 20 28 2d 20 6e 75 6d mretries: (- num
3120: 72 65 74 72 69 65 73 20 31 29 29 29 29 0a 20 20 retries 1)))).
3130: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
3140: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
3150: 66 6f 20 31 31 20 22 66 75 6c 6c 75 72 6c 3d 22 fo 11 "fullurl="
3160: 20 66 75 6c 6c 75 72 6c 20 22 5c 6e 22 29 0a 20 fullurl "\n").
3170: 20 20 20 20 20 20 3b 3b 20 73 65 74 20 75 70 20 ;; set up
3180: 74 68 65 20 68 74 74 70 2d 63 6c 69 65 6e 74 20 the http-client
3190: 68 65 72 65 0a 20 20 20 20 20 20 20 28 6d 61 78 here. (max
31a0: 2d 72 65 74 72 79 2d 61 74 74 65 6d 70 74 73 20 -retry-attempts
31b0: 35 29 0a 20 20 20 20 20 20 20 3b 3b 20 63 6f 6e 5). ;; con
31c0: 73 69 64 65 72 20 61 6c 6c 20 72 65 71 75 65 73 sider all reques
31d0: 74 73 20 69 6e 64 65 6d 70 6f 74 65 6e 74 0a 20 ts indempotent.
31e0: 20 20 20 20 20 20 28 72 65 74 72 79 2d 72 65 71 (retry-req
31f0: 75 65 73 74 3f 20 28 6c 61 6d 62 64 61 20 28 72 uest? (lambda (r
3200: 65 71 75 65 73 74 29 0a 09 09 09 20 23 74 29 29 equest).... #t))
3210: 20 20 20 3b 3b 20 20 09 09 20 28 74 68 72 65 61 ;; .. (threa
3220: 64 2d 73 6c 65 65 70 21 20 28 2f 20 28 69 66 20 d-sleep! (/ (if
3230: 28 3e 20 6e 75 6d 72 65 74 72 69 65 73 20 31 30 (> numretries 10
3240: 30 29 20 31 30 30 20 6e 75 6d 72 65 74 72 69 65 0) 100 numretrie
3250: 73 29 20 31 30 29 29 0a 20 20 20 20 20 20 20 3b s) 10)). ;
3260: 3b 20 28 73 65 74 21 20 6e 75 6d 72 65 74 72 69 ; (set! numretri
3270: 65 73 20 28 2d 20 6e 75 6d 72 65 74 72 69 65 73 es (- numretries
3280: 20 31 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 20 1)). ;;
3290: 09 09 20 23 74 29 29 0a 20 20 20 20 20 20 20 3b .. #t)). ;
32a0: 3b 20 73 65 6e 64 20 74 68 65 20 64 61 74 61 20 ; send the data
32b0: 61 6e 64 20 67 65 74 20 74 68 65 20 72 65 73 70 and get the resp
32c0: 6f 6e 73 65 0a 20 20 20 20 20 20 20 3b 3b 20 65 onse. ;; e
32d0: 78 74 72 61 63 74 20 74 68 65 20 6e 65 65 64 65 xtract the neede
32e0: 64 20 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 20 d info from the
32f0: 68 74 74 70 20 64 61 74 61 20 61 6e 64 20 0a 20 http data and .
3300: 20 20 20 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 ;; process
3310: 20 61 6e 64 20 72 65 74 75 72 6e 20 69 74 2e 0a and return it..
3320: 0a 20 20 20 20 20 20 20 3b 3b 20 28 77 69 74 68 . ;; (with
3330: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 65 71 75 -input-from-requ
3340: 65 73 74 20 22 68 74 74 70 3a 2f 2f 6c 6f 63 61 est "http://loca
3350: 6c 68 6f 73 74 2f 65 63 68 6f 2d 73 65 72 76 69 lhost/echo-servi
3360: 63 65 22 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 ce". ;;
3370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 27 '
3380: 28 28 74 65 73 74 20 2e 20 22 76 61 6c 75 65 22 ((test . "value"
3390: 29 29 20 72 65 61 64 2d 73 74 72 69 6e 67 29 0a )) read-string).
33a0: 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
33b0: 73 65 6e 64 2d 72 65 63 69 65 76 65 20 28 6c 61 send-recieve (la
33c0: 6d 62 64 61 20 28 29 0a 09 09 09 3b 3b 20 20 20 mbda ()....;;
33d0: 20 20 20 20 28 6c 65 74 20 28 28 64 61 74 20 23 (let ((dat #
33e0: 66 29 0a 09 09 09 3b 3b 20 09 20 20 20 20 28 63 f)....;; . (c
33f0: 6c 65 61 6e 75 70 20 28 68 74 74 70 2d 74 72 61 leanup (http-tra
3400: 6e 73 70 6f 72 74 3a 67 65 74 2d 74 69 6d 65 2d nsport:get-time-
3410: 74 6f 2d 63 6c 65 61 6e 75 70 29 29 29 0a 09 09 to-cleanup)))...
3420: 09 3b 3b 20 09 28 69 66 20 63 6c 65 61 6e 75 70 .;; .(if cleanup
3430: 20 0a 09 09 09 3b 3b 20 09 20 20 20 20 28 68 74 ....;; . (ht
3440: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 69 6e 63 tp-transport:inc
3450: 2d 72 65 71 75 65 73 74 73 2d 61 6e 64 2d 70 72 -requests-and-pr
3460: 65 70 2d 74 6f 2d 63 6c 6f 73 65 2d 61 6c 6c 2d ep-to-close-all-
3470: 63 6f 6e 6e 65 63 74 69 6f 6e 73 29 0a 09 09 09 connections)....
3480: 3b 3b 20 09 20 20 20 20 28 68 74 74 70 2d 74 72 ;; . (http-tr
3490: 61 6e 73 70 6f 72 74 3a 69 6e 63 2d 72 65 71 75 ansport:inc-requ
34a0: 65 73 74 73 2d 63 6f 75 6e 74 29 29 0a 09 09 09 ests-count))....
34b0: 3b 3b 20 09 3b 3b 20 44 6f 20 74 68 65 20 61 63 ;; .;; Do the ac
34c0: 74 75 61 6c 20 64 61 74 61 20 74 72 61 6e 73 66 tual data transf
34d0: 65 72 20 4e 42 2f 2f 20 4b 45 50 50 20 54 48 49 er NB// KEPP THI
34e0: 53 20 49 4e 20 53 59 4e 43 20 57 49 54 48 20 68 S IN SYNC WITH h
34f0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c ttp-transport:cl
3500: 69 65 6e 74 2d 73 65 6e 64 2d 72 65 63 65 69 76 ient-send-receiv
3510: 65 0a 09 09 09 09 20 28 6d 75 74 65 78 2d 6c 6f e..... (mutex-lo
3520: 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a ck! *http-mutex*
3530: 29 0a 09 09 09 09 20 28 73 65 74 21 20 72 65 73 )..... (set! res
3540: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
3550: 6d 2d 72 65 71 75 65 73 74 20 3b 3b 20 77 61 73 m-request ;; was
3560: 20 64 61 74 0a 09 09 09 09 09 20 20 20 66 75 6c dat...... ful
3570: 6c 75 72 6c 20 0a 09 09 09 09 09 20 20 20 28 6c lurl ...... (l
3580: 69 73 74 20 28 63 6f 6e 73 20 27 6b 65 79 20 22 ist (cons 'key "
3590: 74 68 65 6b 65 79 22 29 0a 09 09 09 09 09 09 20 thekey").......
35a0: 28 63 6f 6e 73 20 27 63 6d 64 20 63 6d 64 29 0a (cons 'cmd cmd).
35b0: 09 09 09 09 09 09 20 28 63 6f 6e 73 20 27 70 61 ...... (cons 'pa
35c0: 72 61 6d 73 20 70 61 72 61 6d 73 29 29 0a 09 09 rams params))...
35d0: 09 09 09 20 20 20 72 65 61 64 2d 73 74 72 69 6e ... read-strin
35e0: 67 29 29 0a 09 09 09 09 20 3b 3b 20 53 68 6f 75 g))..... ;; Shou
35f0: 6c 64 6e 27 74 20 74 68 69 73 20 62 65 20 61 20 ldn't this be a
3600: 63 61 6c 6c 20 74 6f 20 74 68 65 20 6d 61 6e 61 call to the mana
3610: 67 65 64 20 63 61 6c 6c 2d 61 6c 6c 2d 63 6f 6e ged call-all-con
3620: 6e 65 63 74 69 6f 6e 73 20 73 74 75 66 66 20 61 nections stuff a
3630: 62 6f 76 65 3f 0a 09 09 09 09 28 63 6c 6f 73 65 bove?.....(close
3640: 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 -all-connections
3650: 21 29 0a 09 09 09 09 28 6d 75 74 65 78 2d 75 6e !).....(mutex-un
3660: 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 lock! *http-mute
3670: 78 2a 29 0a 09 09 09 09 29 29 0a 09 20 20 20 20 x*).....))..
3680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3690: 20 20 20 20 20 20 3b 3b 20 28 69 66 20 63 6c 65 ;; (if cle
36a0: 61 6e 75 70 0a 09 09 09 09 20 20 3b 3b 20 20 20 anup..... ;;
36b0: 3b 3b 20 6d 75 74 65 78 20 61 6c 72 65 61 64 79 ;; mutex already
36c0: 20 73 65 74 0a 09 09 09 09 20 20 3b 3b 20 20 20 set..... ;;
36d0: 28 62 65 67 69 6e 0a 09 09 09 09 20 20 3b 3b 20 (begin..... ;;
36e0: 20 20 20 20 28 73 65 74 21 20 72 65 73 20 64 61 (set! res da
36f0: 74 29 0a 09 09 09 09 20 20 3b 3b 20 20 20 20 20 t)..... ;;
3700: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
3710: 64 65 63 2d 72 65 71 75 65 73 74 73 2d 63 6f 75 dec-requests-cou
3720: 6e 74 2d 61 6e 64 2d 63 6c 6f 73 65 2d 61 6c 6c nt-and-close-all
3730: 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 29 29 0a 09 -connections))..
3740: 09 09 09 20 20 3b 3b 20 20 20 28 68 74 74 70 2d ... ;; (http-
3750: 74 72 61 6e 73 70 6f 72 74 3a 64 65 63 2d 72 65 transport:dec-re
3760: 71 75 65 73 74 73 2d 63 6f 75 6e 74 0a 09 09 09 quests-count....
3770: 09 20 20 3b 3b 20 20 20 20 28 6c 61 6d 62 64 61 . ;; (lambda
3780: 20 28 29 0a 09 09 09 09 20 20 3b 3b 20 20 20 20 ()..... ;;
3790: 20 20 28 73 65 74 21 20 72 65 73 20 64 61 74 29 (set! res dat)
37a0: 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 74 )))))).. (t
37b0: 69 6d 65 2d 6f 75 74 20 20 20 20 20 28 6c 61 6d ime-out (lam
37c0: 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 bda ()....
37d0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 34 (thread-sleep! 4
37e0: 35 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 5).... (if
37f0: 28 6e 6f 74 20 72 65 73 29 0a 09 09 09 09 20 20 (not res).....
3800: 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 20 28 (begin..... (
3810: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
3820: 41 52 4e 49 4e 47 3a 20 63 6f 6d 6d 75 6e 69 63 ARNING: communic
3830: 61 74 69 6f 6e 20 77 69 74 68 20 74 68 65 20 73 ation with the s
3840: 65 72 76 65 72 20 74 69 6d 65 64 20 6f 75 74 2e erver timed out.
3850: 22 29 0a 09 09 09 09 20 20 20 20 28 6d 75 74 65 ")..... (mute
3860: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d x-unlock! *http-
3870: 6d 75 74 65 78 2a 29 0a 09 09 09 09 20 20 20 20 mutex*).....
3880: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
3890: 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d client-api-send-
38a0: 72 65 63 65 69 76 65 20 73 65 72 76 65 72 64 61 receive serverda
38b0: 74 20 63 6d 64 20 70 61 72 61 6d 73 20 6e 75 6d t cmd params num
38c0: 72 65 74 72 69 65 73 3a 20 28 2d 20 6e 75 6d 72 retries: (- numr
38d0: 65 74 72 69 65 73 20 31 29 29 0a 09 09 09 09 20 etries 1)).....
38e0: 20 20 20 28 69 66 20 28 3c 20 6e 75 6d 72 65 74 (if (< numret
38f0: 72 69 65 73 20 33 29 20 3b 3b 20 6f 6e 20 6c 61 ries 3) ;; on la
3900: 73 74 20 74 72 79 20 6a 75 73 74 20 65 78 69 74 st try just exit
3910: 0a 09 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 ......(begin....
3920: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
3930: 20 30 20 22 45 52 52 4f 52 3a 20 63 6f 6d 6d 75 0 "ERROR: commu
3940: 6e 69 63 61 74 69 6f 6e 20 77 69 74 68 20 74 68 nication with th
3950: 65 20 73 65 72 76 65 72 20 74 69 6d 65 64 20 6f e server timed o
3960: 75 74 2e 20 47 69 76 69 6e 67 20 75 70 2e 22 29 ut. Giving up.")
3970: 0a 09 09 09 09 09 20 20 28 65 78 69 74 20 31 29 ...... (exit 1)
3980: 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 74 )))))).. (t
3990: 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 h1 (make-thread
39a0: 73 65 6e 64 2d 72 65 63 69 65 76 65 20 22 77 69 send-recieve "wi
39b0: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 65 th-input-from-re
39c0: 71 75 65 73 74 22 29 29 0a 09 20 20 20 20 20 20 quest"))..
39d0: 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 61 (th2 (make-threa
39e0: 64 20 74 69 6d 65 2d 6f 75 74 20 20 20 20 20 22 d time-out "
39f0: 74 69 6d 65 20 6f 75 74 22 29 29 29 0a 09 20 28 time out"))).. (
3a00: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th
3a10: 31 29 0a 09 20 28 74 68 72 65 61 64 2d 73 74 61 1).. (thread-sta
3a20: 72 74 21 20 74 68 32 29 0a 09 20 28 74 68 72 65 rt! th2).. (thre
3a30: 61 64 2d 6a 6f 69 6e 21 20 74 68 31 29 0a 09 20 ad-join! th1)..
3a40: 28 74 68 72 65 61 64 2d 74 65 72 6d 69 6e 61 74 (thread-terminat
3a50: 65 21 20 74 68 32 29 0a 09 20 28 64 65 62 75 67 e! th2).. (debug
3a60: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 31 20 22 :print-info 11 "
3a70: 67 6f 74 20 72 65 73 3d 22 20 72 65 73 29 0a 09 got res=" res)..
3a80: 20 72 65 73 29 29 29 29 29 0a 0a 28 64 65 66 69 res)))))..(defi
3a90: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
3aa0: 72 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 rt:client-connec
3ab0: 74 20 69 66 61 63 65 20 70 6f 72 74 29 0a 20 20 t iface port).
3ac0: 28 6c 65 74 2a 20 28 28 6c 6f 67 69 6e 2d 72 65 (let* ((login-re
3ad0: 73 20 20 20 23 66 29 0a 09 20 28 75 72 69 2d 64 s #f).. (uri-d
3ae0: 61 74 20 20 20 20 20 28 6d 61 6b 65 2d 72 65 71 at (make-req
3af0: 75 65 73 74 20 6d 65 74 68 6f 64 3a 20 27 50 4f uest method: 'PO
3b00: 53 54 20 75 72 69 3a 20 28 75 72 69 2d 72 65 66 ST uri: (uri-ref
3b10: 65 72 65 6e 63 65 20 28 63 6f 6e 63 20 22 68 74 erence (conc "ht
3b20: 74 70 3a 2f 2f 22 20 69 66 61 63 65 20 22 3a 22 tp://" iface ":"
3b30: 20 70 6f 72 74 20 22 2f 63 74 72 6c 22 29 29 29 port "/ctrl")))
3b40: 29 0a 09 20 28 75 72 69 2d 61 70 69 2d 64 61 74 ).. (uri-api-dat
3b50: 20 28 6d 61 6b 65 2d 72 65 71 75 65 73 74 20 6d (make-request m
3b60: 65 74 68 6f 64 3a 20 27 50 4f 53 54 20 75 72 69 ethod: 'POST uri
3b70: 3a 20 28 75 72 69 2d 72 65 66 65 72 65 6e 63 65 : (uri-reference
3b80: 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f 22 (conc "http://"
3b90: 20 69 66 61 63 65 20 22 3a 22 20 70 6f 72 74 20 iface ":" port
3ba0: 22 2f 61 70 69 22 29 29 29 29 0a 09 20 28 73 65 "/api")))).. (se
3bb0: 72 76 65 72 64 61 74 20 20 20 28 6c 69 73 74 20 rverdat (list
3bc0: 69 66 61 63 65 20 70 6f 72 74 20 75 72 69 2d 64 iface port uri-d
3bd0: 61 74 20 75 72 69 2d 61 70 69 2d 64 61 74 29 29 at uri-api-dat))
3be0: 29 0a 20 20 20 20 28 73 65 74 21 20 2a 72 75 6e ). (set! *run
3bf0: 72 65 6d 6f 74 65 2a 20 73 65 72 76 65 72 64 61 remote* serverda
3c00: 74 29 20 3b 3b 20 6d 61 79 20 6f 72 20 6d 61 79 t) ;; may or may
3c10: 20 6e 6f 74 20 62 65 20 67 6f 6f 64 20 2e 2e 2e not be good ...
3c20: 0a 20 20 20 20 28 73 65 74 21 20 6c 6f 67 69 6e . (set! login
3c30: 2d 72 65 73 20 28 72 6d 74 3a 6c 6f 67 69 6e 29 -res (rmt:login)
3c40: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 ). (if (and (
3c50: 6c 69 73 74 3f 20 6c 6f 67 69 6e 2d 72 65 73 29 list? login-res)
3c60: 0a 09 20 20 20 20 20 28 63 61 72 20 6c 6f 67 69 .. (car logi
3c70: 6e 2d 72 65 73 29 29 0a 09 28 62 65 67 69 6e 0a n-res))..(begin.
3c80: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
3c90: 69 6e 66 6f 20 32 20 22 4c 6f 67 67 65 64 20 69 info 2 "Logged i
3ca0: 6e 20 61 6e 64 20 63 6f 6e 6e 65 63 74 65 64 20 n and connected
3cb0: 74 6f 20 22 20 69 66 61 63 65 20 22 3a 22 20 70 to " iface ":" p
3cc0: 6f 72 74 29 0a 09 20 20 28 73 65 74 21 20 2a 72 ort).. (set! *r
3cd0: 75 6e 72 65 6d 6f 74 65 2a 20 73 65 72 76 65 72 unremote* server
3ce0: 64 61 74 29 0a 09 20 20 73 65 72 76 65 72 64 61 dat).. serverda
3cf0: 74 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 t)..(begin.. (d
3d00: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3d10: 30 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 0 "ERROR: Failed
3d20: 20 74 6f 20 6c 6f 67 69 6e 20 6f 72 20 63 6f 6e to login or con
3d30: 6e 65 63 74 20 74 6f 20 22 20 69 66 61 63 65 20 nect to " iface
3d40: 22 3a 22 20 70 6f 72 74 29 0a 09 20 20 28 65 78 ":" port).. (ex
3d50: 69 74 20 31 29 29 29 29 29 0a 3b 3b 20 09 20 20 it 1))))).;; .
3d60: 28 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 (set! *runremote
3d70: 2a 20 23 66 29 0a 3b 3b 20 09 20 20 28 73 65 74 * #f).;; . (set
3d80: 21 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 ! *transport-typ
3d90: 65 2a 20 27 66 73 29 0a 3b 3b 20 09 20 20 23 66 e* 'fs).;; . #f
3da0: 29 29 29 29 0a 0a 0a 3b 3b 20 72 75 6e 20 68 74 ))))...;; run ht
3db0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6b 65 65 tp-transport:kee
3dc0: 70 2d 72 75 6e 6e 69 6e 67 20 69 6e 20 61 20 70 p-running in a p
3dd0: 61 72 61 6c 6c 65 6c 20 74 68 72 65 61 64 20 74 arallel thread t
3de0: 6f 20 6d 6f 6e 69 74 6f 72 20 74 68 61 74 20 74 o monitor that t
3df0: 68 65 20 64 62 20 69 73 20 62 65 69 6e 67 20 0a he db is being .
3e00: 3b 3b 20 75 73 65 64 20 61 6e 64 20 74 6f 20 73 ;; used and to s
3e10: 68 75 74 64 6f 77 6e 20 61 66 74 65 72 20 73 6f hutdown after so
3e20: 6d 65 74 69 6d 65 20 69 66 20 69 74 20 69 73 20 metime if it is
3e30: 6e 6f 74 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 not..;;.(define
3e40: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
3e50: 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 29 0a 20 20 keep-running).
3e60: 3b 3b 20 69 66 20 6e 6f 6e 65 20 72 75 6e 6e 69 ;; if none runni
3e70: 6e 67 20 6f 72 20 69 66 20 3e 20 32 30 20 73 65 ng or if > 20 se
3e80: 63 6f 6e 64 73 20 73 69 6e 63 65 20 0a 20 20 3b conds since . ;
3e90: 3b 20 73 65 72 76 65 72 20 6c 61 73 74 20 75 73 ; server last us
3ea0: 65 64 20 74 68 65 6e 20 73 74 61 72 74 20 73 68 ed then start sh
3eb0: 75 74 64 6f 77 6e 0a 20 20 3b 3b 20 54 68 69 73 utdown. ;; This
3ec0: 20 74 68 72 65 61 64 20 77 61 69 74 73 20 66 6f thread waits fo
3ed0: 72 20 74 68 65 20 73 65 72 76 65 72 20 74 6f 20 r the server to
3ee0: 63 6f 6d 65 20 61 6c 69 76 65 0a 20 20 28 6c 65 come alive. (le
3ef0: 74 2a 20 28 28 73 65 72 76 65 72 2d 69 6e 66 6f t* ((server-info
3f00: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 20 20 (let loop ().
3f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3f20: 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 64 61 (let ((sda
3f30: 74 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 t #f)).
3f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3f50: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 (mutex-lock! *h
3f60: 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 eartbeat-mutex*)
3f70: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3f80: 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 (set!
3f90: 20 73 64 61 74 20 2a 72 75 6e 72 65 6d 6f 74 65 sdat *runremote
3fa0: 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 *).
3fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 75 (mu
3fc0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 tex-unlock! *hea
3fd0: 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 rtbeat-mutex*).
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 28 69 66 20 73 64 61 (if sda
4000: 74 0a 09 09 09 20 20 20 20 20 20 73 64 61 74 0a t.... sdat.
4010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
4030: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
4040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4050: 20 20 20 20 20 28 73 6c 65 65 70 20 34 29 0a 20 (sleep 4).
4060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4080: 6c 6f 6f 70 29 29 29 29 29 29 0a 20 20 20 20 20 loop)))))).
4090: 20 20 20 20 28 69 66 61 63 65 20 20 20 20 20 20 (iface
40a0: 20 28 63 61 72 20 73 65 72 76 65 72 2d 69 6e 66 (car server-inf
40b0: 6f 29 29 0a 20 20 20 20 20 20 20 20 20 28 70 6f o)). (po
40c0: 72 74 20 20 20 20 20 20 20 20 28 63 61 64 72 20 rt (cadr
40d0: 73 65 72 76 65 72 2d 69 6e 66 6f 29 29 0a 20 20 server-info)).
40e0: 20 20 20 20 20 20 20 28 6c 61 73 74 2d 61 63 63 (last-acc
40f0: 65 73 73 20 30 29 0a 09 20 28 74 64 62 20 20 20 ess 0).. (tdb
4100: 20 20 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 (tasks:ope
4110: 6e 2d 64 62 29 29 0a 09 20 28 73 70 69 64 20 20 n-db)).. (spid
4120: 20 20 20 20 20 20 3b 3b 28 6f 70 65 6e 2d 72 75 ;;(open-ru
4130: 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 n-close tasks:se
4140: 72 76 65 72 2d 67 65 74 2d 73 65 72 76 65 72 2d rver-get-server-
4150: 69 64 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 id tasks:open-db
4160: 20 23 66 20 69 66 61 63 65 20 70 6f 72 74 20 23 #f iface port #
4170: 66 29 29 0a 09 20 20 20 28 74 61 73 6b 73 3a 73 f)).. (tasks:s
4180: 65 72 76 65 72 2d 67 65 74 2d 73 65 72 76 65 72 erver-get-server
4190: 2d 69 64 20 74 64 62 20 23 66 20 69 66 61 63 65 -id tdb #f iface
41a0: 20 70 6f 72 74 20 23 66 29 29 0a 09 20 28 73 65 port #f)).. (se
41b0: 72 76 65 72 2d 74 69 6d 65 6f 75 74 20 28 6c 65 rver-timeout (le
41c0: 74 20 28 28 74 6d 6f 20 28 63 6f 6e 66 69 67 2d t ((tmo (config-
41d0: 6c 6f 6f 6b 75 70 20 20 2a 63 6f 6e 66 69 67 64 lookup *configd
41e0: 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 74 69 at* "server" "ti
41f0: 6d 65 6f 75 74 22 29 29 29 0a 09 09 09 20 20 20 meout")))....
4200: 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (if (and (string
4210: 3f 20 74 6d 6f 29 0a 09 09 09 09 20 20 20 20 28 ? tmo)..... (
4220: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 74 string->number t
4230: 6d 6f 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 mo)).... (
4240: 2a 20 36 30 20 36 30 20 28 73 74 72 69 6e 67 2d * 60 60 (string-
4250: 3e 6e 75 6d 62 65 72 20 74 6d 6f 29 29 0a 09 09 >number tmo))...
4260: 09 20 20 20 20 20 20 20 3b 3b 20 64 65 66 61 75 . ;; defau
4270: 6c 74 20 74 6f 20 74 68 72 65 65 20 64 61 79 73 lt to three days
4280: 0a 09 09 09 20 20 20 20 20 20 20 28 2a 20 33 20 .... (* 3
4290: 32 34 20 36 30 20 36 30 29 29 29 29 29 0a 20 20 24 60 60))))).
42a0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
42b0: 6e 66 6f 20 32 20 22 73 65 72 76 65 72 2d 74 69 nfo 2 "server-ti
42c0: 6d 65 6f 75 74 3a 20 22 20 73 65 72 76 65 72 2d meout: " server-
42d0: 74 69 6d 65 6f 75 74 20 22 2c 20 73 65 72 76 65 timeout ", serve
42e0: 72 20 70 69 64 3a 20 22 20 73 70 69 64 20 22 20 r pid: " spid "
42f0: 6f 6e 20 22 20 69 66 61 63 65 20 22 3a 22 20 70 on " iface ":" p
4300: 6f 72 74 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f ort). (let lo
4310: 6f 70 20 28 28 63 6f 75 6e 74 20 30 29 29 0a 20 op ((count 0)).
4320: 20 20 20 20 20 3b 3b 20 55 73 65 20 74 68 69 73 ;; Use this
4330: 20 6f 70 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 opportunity to
4340: 73 79 6e 63 20 74 68 65 20 69 6e 6d 65 6d 64 62 sync the inmemdb
4350: 20 74 6f 20 64 62 0a 20 20 20 20 20 20 28 6c 65 to db. (le
4360: 74 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 28 t ((start-time (
4370: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
4380: 6f 6e 64 73 29 29 0a 09 20 20 20 20 28 73 79 6e onds)).. (syn
4390: 63 2d 74 69 6d 65 20 20 23 66 29 0a 09 20 20 20 c-time #f)..
43a0: 20 28 72 65 6d 2d 74 69 6d 65 20 20 20 23 66 29 (rem-time #f)
43b0: 29 0a 09 28 69 66 20 2a 69 6e 6d 65 6d 64 62 2a )..(if *inmemdb*
43c0: 20 28 64 62 3a 73 79 6e 63 2d 74 6f 75 63 68 65 (db:sync-touche
43d0: 64 20 2a 69 6e 6d 65 6d 64 62 2a 20 66 6f 72 63 d *inmemdb* forc
43e0: 65 2d 73 79 6e 63 3a 20 23 74 29 29 0a 09 28 73 e-sync: #t))..(s
43f0: 65 74 21 20 73 79 6e 63 2d 74 69 6d 65 20 20 28 et! sync-time (
4400: 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 - (current-milli
4410: 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d 74 seconds) start-t
4420: 69 6d 65 29 29 0a 09 28 73 65 74 21 20 72 65 6d ime))..(set! rem
4430: 2d 74 69 6d 65 20 28 71 75 6f 74 69 65 6e 74 20 -time (quotient
4440: 28 2d 20 34 30 30 30 20 73 79 6e 63 2d 74 69 6d (- 4000 sync-tim
4450: 65 29 20 31 30 30 30 29 29 0a 09 28 64 65 62 75 e) 1000))..(debu
4460: 67 3a 70 72 69 6e 74 20 30 20 22 53 59 4e 43 3a g:print 0 "SYNC:
4470: 20 74 69 6d 65 3d 20 22 20 73 79 6e 63 2d 74 69 time= " sync-ti
4480: 6d 65 20 22 2c 20 72 65 6d 2d 74 69 6d 65 3d 22 me ", rem-time="
4490: 20 72 65 6d 2d 74 69 6d 65 29 0a 09 28 69 66 20 rem-time)..(if
44a0: 28 61 6e 64 20 28 3c 3d 20 72 65 6d 2d 74 69 6d (and (<= rem-tim
44b0: 65 20 34 29 0a 09 09 20 28 3e 20 72 65 6d 2d 74 e 4)... (> rem-t
44c0: 69 6d 65 20 30 29 29 0a 09 20 20 20 20 28 74 68 ime 0)).. (th
44d0: 72 65 61 64 2d 73 6c 65 65 70 21 20 72 65 6d 2d read-sleep! rem-
44e0: 74 69 6d 65 29 0a 09 20 20 20 20 28 74 68 72 65 time).. (thre
44f0: 61 64 2d 73 6c 65 65 70 21 20 34 29 29 29 20 3b ad-sleep! 4))) ;
4500: 3b 20 66 61 6c 6c 62 61 63 6b 20 66 6f 72 20 69 ; fallback for i
4510: 66 20 74 68 65 20 6d 61 74 68 20 69 73 20 63 68 f the math is ch
4520: 61 6e 67 65 64 20 2e 2e 2e 0a 0a 20 20 20 20 20 anged .....
4530: 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 ;; (thread-slee
4540: 70 21 20 34 29 20 3b 3b 20 6e 6f 20 6e 65 65 64 p! 4) ;; no need
4550: 20 74 6f 20 64 6f 20 74 68 69 73 20 76 65 72 79 to do this very
4560: 20 6f 66 74 65 6e 0a 0a 20 20 20 20 20 20 28 69 often.. (i
4570: 66 20 28 3c 20 63 6f 75 6e 74 20 31 29 20 3b 3b f (< count 1) ;;
4580: 20 33 78 33 20 3d 20 39 20 73 65 63 73 20 61 70 3x3 = 9 secs ap
4590: 72 6f 78 0a 09 20 20 28 6c 6f 6f 70 20 28 2b 20 rox.. (loop (+
45a0: 63 6f 75 6e 74 20 31 29 29 29 0a 20 20 20 20 20 count 1))).
45b0: 20 0a 20 20 20 20 20 20 3b 3b 20 43 68 65 63 6b . ;; Check
45c0: 20 74 68 61 74 20 69 66 61 63 65 20 61 6e 64 20 that iface and
45d0: 70 6f 72 74 20 68 61 76 65 20 6e 6f 74 20 63 68 port have not ch
45e0: 61 6e 67 65 64 20 28 63 61 6e 20 68 61 70 70 65 anged (can happe
45f0: 6e 20 69 66 20 73 65 72 76 65 72 20 70 6f 72 74 n if server port
4600: 20 63 6f 6c 6c 69 64 65 73 29 0a 20 20 20 20 20 collides).
4610: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 (mutex-lock! *h
4620: 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 eartbeat-mutex*)
4630: 0a 20 20 20 20 20 20 28 73 65 74 21 20 73 64 61 . (set! sda
4640: 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 0a 20 t *runremote*).
4650: 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f (mutex-unlo
4660: 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
4670: 75 74 65 78 2a 29 0a 20 20 20 20 20 20 0a 20 20 utex*). .
4680: 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 (if (or (not
4690: 20 28 65 71 75 61 6c 3f 20 73 64 61 74 20 28 6c (equal? sdat (l
46a0: 69 73 74 20 69 66 61 63 65 20 70 6f 72 74 29 29 ist iface port))
46b0: 29 0a 09 20 20 20 20 20 20 28 6e 6f 74 20 73 70 ).. (not sp
46c0: 69 64 29 29 0a 09 20 20 28 62 65 67 69 6e 20 0a id)).. (begin .
46d0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
46e0: 74 2d 69 6e 66 6f 20 30 20 22 69 6e 74 65 72 66 t-info 0 "interf
46f0: 61 63 65 20 63 68 61 6e 67 65 64 2c 20 72 65 66 ace changed, ref
4700: 72 65 73 68 69 6e 67 20 69 66 61 63 65 20 61 6e reshing iface an
4710: 64 20 70 6f 72 74 20 69 6e 66 6f 22 29 0a 09 20 d port info")..
4720: 20 20 20 28 73 65 74 21 20 69 66 61 63 65 20 28 (set! iface (
4730: 63 61 72 20 73 64 61 74 29 29 0a 09 20 20 20 20 car sdat))..
4740: 28 73 65 74 21 20 70 6f 72 74 20 20 28 63 61 64 (set! port (cad
4750: 72 20 73 64 61 74 29 29 0a 09 20 20 20 20 28 73 r sdat)).. (s
4760: 65 74 21 20 73 70 69 64 20 20 28 74 61 73 6b 73 et! spid (tasks
4770: 3a 73 65 72 76 65 72 2d 67 65 74 2d 73 65 72 76 :server-get-serv
4780: 65 72 2d 69 64 20 74 64 62 20 23 66 20 69 66 61 er-id tdb #f ifa
4790: 63 65 20 70 6f 72 74 20 23 66 29 29 29 29 0a 20 ce port #f)))).
47a0: 20 20 20 20 20 0a 20 20 20 20 20 20 3b 3b 20 4e . ;; N
47b0: 4f 54 45 3a 20 47 65 74 20 72 69 64 20 6f 66 20 OTE: Get rid of
47c0: 74 68 69 73 20 6d 65 63 68 61 6e 69 73 6d 21 20 this mechanism!
47d0: 49 74 20 72 65 61 6c 6c 79 20 69 73 20 6e 6f 74 It really is not
47e0: 20 6e 65 65 64 65 64 2e 2e 2e 0a 20 20 20 20 20 needed....
47f0: 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c ;; (open-run-cl
4800: 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 76 65 72 ose tasks:server
4810: 2d 75 70 64 61 74 65 2d 68 65 61 72 74 62 65 61 -update-heartbea
4820: 74 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 t tasks:open-db
4830: 73 70 69 64 29 0a 20 20 20 20 20 20 28 74 61 73 spid). (tas
4840: 6b 73 3a 73 65 72 76 65 72 2d 75 70 64 61 74 65 ks:server-update
4850: 2d 68 65 61 72 74 62 65 61 74 20 74 64 62 20 73 -heartbeat tdb s
4860: 70 69 64 29 0a 20 20 20 20 20 20 0a 20 20 20 20 pid). .
4870: 20 20 3b 3b 20 28 69 66 20 3b 3b 20 28 6f 72 20 ;; (if ;; (or
4880: 28 3e 20 6e 75 6d 72 75 6e 6e 69 6e 67 20 30 29 (> numrunning 0)
4890: 20 3b 3b 20 73 74 61 79 20 61 6c 69 76 65 20 66 ;; stay alive f
48a0: 6f 72 20 74 77 6f 20 64 61 79 73 20 61 66 74 65 or two days afte
48b0: 72 20 6c 61 73 74 20 61 63 63 65 73 73 0a 0a 20 r last access..
48c0: 20 20 20 20 20 3b 3b 20 54 72 61 6e 73 66 65 72 ;; Transfer
48d0: 20 2a 6c 61 73 74 2d 64 62 2d 61 63 63 65 73 73 *last-db-access
48e0: 2a 20 74 6f 20 6c 61 73 74 2d 61 63 63 65 73 73 * to last-access
48f0: 20 74 6f 20 75 73 65 20 69 6e 20 63 68 65 63 6b to use in check
4900: 69 6e 67 20 74 68 61 74 20 77 65 20 61 72 65 20 ing that we are
4910: 73 74 69 6c 6c 20 61 6c 69 76 65 0a 20 20 20 20 still alive.
4920: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
4930: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
4940: 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 6c 61 ). (set! la
4950: 73 74 2d 61 63 63 65 73 73 20 2a 6c 61 73 74 2d st-access *last-
4960: 64 62 2d 61 63 63 65 73 73 2a 29 0a 20 20 20 20 db-access*).
4970: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
4980: 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 *heartbeat-mute
4990: 78 2a 29 0a 0a 20 20 20 20 20 20 3b 3b 20 28 64 x*).. ;; (d
49a0: 65 62 75 67 3a 70 72 69 6e 74 20 31 31 20 22 6c ebug:print 11 "l
49b0: 61 73 74 2d 61 63 63 65 73 73 3d 22 20 6c 61 73 ast-access=" las
49c0: 74 2d 61 63 63 65 73 73 20 22 2c 20 73 65 72 76 t-access ", serv
49d0: 65 72 2d 74 69 6d 65 6f 75 74 3d 22 20 73 65 72 er-timeout=" ser
49e0: 76 65 72 2d 74 69 6d 65 6f 75 74 29 0a 20 20 20 ver-timeout).
49f0: 20 20 20 28 69 66 20 28 61 6e 64 20 2a 73 65 72 (if (and *ser
4a00: 76 65 72 2d 72 75 6e 2a 0a 09 20 20 20 20 20 20 ver-run*..
4a10: 20 28 3e 20 28 2b 20 6c 61 73 74 2d 61 63 63 65 (> (+ last-acce
4a20: 73 73 20 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 ss server-timeou
4a30: 74 29 0a 09 09 20 20 28 63 75 72 72 65 6e 74 2d t)... (current-
4a40: 73 65 63 6f 6e 64 73 29 29 29 0a 09 20 20 28 62 seconds))).. (b
4a50: 65 67 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 egin.. (debug
4a60: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 53 :print-info 0 "S
4a70: 65 72 76 65 72 20 63 6f 6e 74 69 6e 75 69 6e 67 erver continuing
4a80: 2c 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 , seconds since
4a90: 6c 61 73 74 20 64 62 20 61 63 63 65 73 73 3a 20 last db access:
4aa0: 22 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 " (- (current-se
4ab0: 63 6f 6e 64 73 29 20 6c 61 73 74 2d 61 63 63 65 conds) last-acce
4ac0: 73 73 29 29 0a 09 20 20 20 20 28 6c 6f 6f 70 20 ss)).. (loop
4ad0: 30 29 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 0)).. (begin..
4ae0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
4af0: 69 6e 66 6f 20 30 20 22 53 74 61 72 74 69 6e 67 info 0 "Starting
4b00: 20 74 6f 20 73 68 75 74 64 6f 77 6e 20 74 68 65 to shutdown the
4b10: 20 73 65 72 76 65 72 2e 22 29 0a 09 20 20 20 20 server.")..
4b20: 3b 3b 20 6e 65 65 64 20 74 6f 20 64 65 6c 65 74 ;; need to delet
4b30: 65 20 6f 6e 6c 79 20 2a 6d 79 2a 20 73 65 72 76 e only *my* serv
4b40: 65 72 20 65 6e 74 72 79 20 28 66 75 74 75 72 65 er entry (future
4b50: 20 75 73 65 29 0a 09 20 20 20 20 28 73 65 74 21 use).. (set!
4b60: 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 *time-to-exit*
4b70: 23 74 29 0a 09 20 20 20 20 28 69 66 20 2a 69 6e #t).. (if *in
4b80: 6d 65 6d 64 62 2a 20 28 64 62 3a 73 79 6e 63 2d memdb* (db:sync-
4b90: 74 6f 75 63 68 65 64 20 2a 69 6e 6d 65 6d 64 62 touched *inmemdb
4ba0: 2a 20 66 6f 72 63 65 2d 73 79 6e 63 3a 20 23 74 * force-sync: #t
4bb0: 29 29 0a 09 20 20 20 20 28 6f 70 65 6e 2d 72 75 )).. (open-ru
4bc0: 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 n-close tasks:se
4bd0: 72 76 65 72 2d 64 65 72 65 67 69 73 74 65 72 2d rver-deregister-
4be0: 73 65 6c 66 20 74 61 73 6b 73 3a 6f 70 65 6e 2d self tasks:open-
4bf0: 64 62 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d db (get-host-nam
4c00: 65 29 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 e)).. (thread
4c10: 2d 73 6c 65 65 70 21 20 31 29 0a 09 20 20 20 20 -sleep! 1)..
4c20: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
4c30: 6f 20 30 20 22 4d 61 78 20 63 61 63 68 65 64 20 o 0 "Max cached
4c40: 71 75 65 72 69 65 73 20 77 61 73 20 20 20 20 22 queries was "
4c50: 20 2a 6d 61 78 2d 63 61 63 68 65 2d 73 69 7a 65 *max-cache-size
4c60: 2a 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 *).. (debug:p
4c70: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 4e 75 6d rint-info 0 "Num
4c80: 62 65 72 20 6f 66 20 63 61 63 68 65 64 20 77 72 ber of cached wr
4c90: 69 74 65 73 20 20 20 22 20 2a 6e 75 6d 62 65 72 ites " *number
4ca0: 2d 6f 66 2d 77 72 69 74 65 73 2a 29 0a 09 20 20 -of-writes*)..
4cb0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
4cc0: 6e 66 6f 20 30 20 22 41 76 65 72 61 67 65 20 63 nfo 0 "Average c
4cd0: 61 63 68 65 64 20 77 72 69 74 65 20 74 69 6d 65 ached write time
4ce0: 20 22 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 ".... (if
4cf0: 28 65 71 3f 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d (eq? *number-of-
4d00: 77 72 69 74 65 73 2a 20 30 29 0a 09 09 09 09 20 writes* 0).....
4d10: 20 22 6e 2f 61 20 28 6e 6f 20 77 72 69 74 65 73 "n/a (no writes
4d20: 29 22 0a 09 09 09 09 20 20 28 2f 20 2a 77 72 69 )"..... (/ *wri
4d30: 74 65 73 2d 74 6f 74 61 6c 2d 64 65 6c 61 79 2a tes-total-delay*
4d40: 0a 09 09 09 09 20 20 20 20 20 2a 6e 75 6d 62 65 ..... *numbe
4d50: 72 2d 6f 66 2d 77 72 69 74 65 73 2a 29 29 0a 09 r-of-writes*))..
4d60: 09 09 20 20 20 20 20 20 22 20 6d 73 22 29 0a 09 .. " ms")..
4d70: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4d80: 2d 69 6e 66 6f 20 30 20 22 4e 75 6d 62 65 72 20 -info 0 "Number
4d90: 6e 6f 6e 2d 63 61 63 68 65 64 20 71 75 65 72 69 non-cached queri
4da0: 65 73 20 22 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f es " *number-no
4db0: 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a n-write-queries*
4dc0: 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
4dd0: 69 6e 74 2d 69 6e 66 6f 20 30 20 22 41 76 65 72 int-info 0 "Aver
4de0: 61 67 65 20 6e 6f 6e 2d 63 61 63 68 65 64 20 74 age non-cached t
4df0: 69 6d 65 20 20 20 22 0a 09 09 09 20 20 20 20 20 ime "....
4e00: 20 28 69 66 20 28 65 71 3f 20 2a 6e 75 6d 62 65 (if (eq? *numbe
4e10: 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 r-non-write-quer
4e20: 69 65 73 2a 20 30 29 0a 09 09 09 09 20 20 22 6e ies* 0)..... "n
4e30: 2f 61 20 28 6e 6f 20 71 75 65 72 69 65 73 29 22 /a (no queries)"
4e40: 0a 09 09 09 09 20 20 28 2f 20 2a 74 6f 74 61 6c ..... (/ *total
4e50: 2d 6e 6f 6e 2d 77 72 69 74 65 2d 64 65 6c 61 79 -non-write-delay
4e60: 2a 20 0a 09 09 09 09 20 20 20 20 20 2a 6e 75 6d * ..... *num
4e70: 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 ber-non-write-qu
4e80: 65 72 69 65 73 2a 29 29 0a 09 09 09 20 20 20 20 eries*))....
4e90: 20 20 22 20 6d 73 22 29 0a 09 20 20 20 20 28 64 " ms").. (d
4ea0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
4eb0: 30 20 22 53 65 72 76 65 72 20 73 68 75 74 64 6f 0 "Server shutdo
4ec0: 77 6e 20 63 6f 6d 70 6c 65 74 65 2e 20 45 78 69 wn complete. Exi
4ed0: 74 69 6e 67 22 29 0a 09 20 20 20 20 28 65 78 69 ting").. (exi
4ee0: 74 29 29 29 29 29 29 0a 0a 3b 3b 20 61 6c 6c 20 t))))))..;; all
4ef0: 72 6f 75 74 65 73 20 74 68 6f 75 67 68 20 68 65 routes though he
4f00: 72 65 20 65 6e 64 20 69 6e 20 65 78 69 74 20 2e re end in exit .
4f10: 2e 2e 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 ...(define (http
4f20: 2d 74 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 -transport:launc
4f30: 68 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 2a 74 h). (if (not *t
4f40: 6f 70 70 61 74 68 2a 29 0a 20 20 20 20 20 20 28 oppath*). (
4f50: 69 66 20 28 6e 6f 74 20 28 73 65 74 75 70 2d 66 if (not (setup-f
4f60: 6f 72 2d 72 75 6e 29 29 0a 09 20 20 28 62 65 67 or-run)).. (beg
4f70: 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 in.. (debug:p
4f80: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 63 rint 0 "ERROR: c
4f90: 61 6e 6e 6f 74 20 66 69 6e 64 20 6d 65 67 61 74 annot find megat
4fa0: 65 73 74 2e 63 6f 6e 66 69 67 2c 20 65 78 69 74 est.config, exit
4fb0: 69 6e 67 22 29 0a 09 20 20 20 20 28 65 78 69 74 ing").. (exit
4fc0: 29 29 29 29 0a 20 20 28 64 65 62 75 67 3a 70 72 )))). (debug:pr
4fd0: 69 6e 74 2d 69 6e 66 6f 20 32 20 22 53 74 61 72 int-info 2 "Star
4fe0: 74 69 6e 67 20 74 68 65 20 73 74 61 6e 64 61 6c ting the standal
4ff0: 6f 6e 65 20 73 65 72 76 65 72 22 29 0a 20 20 28 one server"). (
5000: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
5010: 20 22 2d 64 61 65 6d 6f 6e 69 7a 65 22 29 0a 20 "-daemonize").
5020: 20 20 20 20 20 28 64 61 65 6d 6f 6e 3a 69 7a 65 (daemon:ize
5030: 29 29 0a 20 20 28 6c 65 74 20 28 28 68 6f 73 74 )). (let ((host
5040: 69 6e 66 6f 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 info (open-run-c
5050: 6c 6f 73 65 20 74 61 73 6b 73 3a 67 65 74 2d 62 lose tasks:get-b
5060: 65 73 74 2d 73 65 72 76 65 72 20 74 61 73 6b 73 est-server tasks
5070: 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 20 20 20 :open-db))).
5080: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 31 20 (debug:print 11
5090: 22 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a "http-transport:
50a0: 6c 61 75 6e 63 68 20 68 6f 73 74 69 6e 66 6f 3d launch hostinfo=
50b0: 22 20 68 6f 73 74 69 6e 66 6f 29 0a 20 20 20 20 " hostinfo).
50c0: 3b 3b 20 23 28 31 20 22 31 34 33 2e 31 38 32 2e ;; #(1 "143.182.
50d0: 32 30 37 2e 32 34 22 20 35 37 33 36 20 2d 31 20 207.24" 5736 -1
50e0: 22 68 74 74 70 22 20 32 32 37 37 31 20 22 68 6f "http" 22771 "ho
50f0: 73 74 6e 61 6d 65 22 29 0a 20 20 20 20 28 69 66 stname"). (if
5100: 20 68 6f 73 74 69 6e 66 6f 0a 09 28 64 65 62 75 hostinfo..(debu
5110: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 g:print-info 2 "
5120: 4e 4f 54 20 73 74 61 72 74 69 6e 67 20 6e 65 77 NOT starting new
5130: 20 73 65 72 76 65 72 2c 20 6f 6e 65 20 69 73 20 server, one is
5140: 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 20 already running
5150: 6f 6e 20 22 20 28 76 65 63 74 6f 72 2d 72 65 66 on " (vector-ref
5160: 20 68 6f 73 74 69 6e 66 6f 20 31 29 20 22 3a 22 hostinfo 1) ":"
5170: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 68 6f 73 (vector-ref hos
5180: 74 69 6e 66 6f 20 32 29 29 0a 09 28 69 66 20 2a tinfo 2))..(if *
5190: 74 6f 70 70 61 74 68 2a 20 0a 09 20 20 20 20 28 toppath* .. (
51a0: 6c 65 74 2a 20 28 28 74 68 32 20 28 6d 61 6b 65 let* ((th2 (make
51b0: 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 -thread (lambda
51c0: 28 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 68 ()..... (h
51d0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 ttp-transport:ru
51e0: 6e 20 0a 09 09 09 09 09 28 69 66 20 28 61 72 67 n ......(if (arg
51f0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 s:get-arg "-serv
5200: 65 72 22 29 0a 09 09 09 09 09 20 20 20 20 28 61 er")...... (a
5210: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 rgs:get-arg "-se
5220: 72 76 65 72 22 29 0a 09 09 09 09 09 20 20 20 20 rver")......
5230: 22 2d 22 29 29 29 20 22 53 65 72 76 65 72 20 72 "-"))) "Server r
5240: 75 6e 22 29 29 0a 09 09 20 20 20 28 74 68 33 20 un"))... (th3
5250: 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 68 74 74 (make-thread htt
5260: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6b 65 65 70 p-transport:keep
5270: 2d 72 75 6e 6e 69 6e 67 20 22 4b 65 65 70 20 72 -running "Keep r
5280: 75 6e 6e 69 6e 67 22 29 29 29 0a 09 20 20 20 20 unning")))..
5290: 20 20 3b 3b 20 44 61 74 61 62 61 73 65 20 63 6f ;; Database co
52a0: 6e 6e 65 63 74 69 6f 6e 0a 09 20 20 20 20 20 20 nnection..
52b0: 28 73 65 74 21 20 2a 69 6e 6d 65 6d 64 62 2a 20 (set! *inmemdb*
52c0: 20 28 64 62 3a 73 65 74 75 70 29 29 0a 09 20 20 (db:setup))..
52d0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 (thread-star
52e0: 74 21 20 74 68 32 29 0a 09 20 20 20 20 20 20 28 t! th2).. (
52f0: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th
5300: 33 29 0a 09 20 20 20 20 20 20 28 73 65 74 21 20 3).. (set!
5310: 2a 64 69 64 73 6f 6d 65 74 68 69 6e 67 2a 20 23 *didsomething* #
5320: 74 29 0a 09 20 20 20 20 20 20 28 74 68 72 65 61 t).. (threa
5330: 64 2d 6a 6f 69 6e 21 20 74 68 32 29 29 0a 09 20 d-join! th2))..
5340: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
5350: 30 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 0 "ERROR: Failed
5360: 20 74 6f 20 73 65 74 75 70 20 66 6f 72 20 6d 65 to setup for me
5370: 67 61 74 65 73 74 22 29 29 29 0a 20 20 20 20 3b gatest"))). ;
5380: 3b 20 28 73 64 62 3a 71 72 79 20 27 66 69 6e 61 ; (sdb:qry 'fina
5390: 6c 69 7a 65 29 0a 20 20 20 20 28 65 78 69 74 29 lize). (exit)
53a0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 ))..(define (htt
53b0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 p-transport:serv
53c0: 65 72 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 er-signal-handle
53d0: 72 20 73 69 67 6e 75 6d 29 0a 20 20 28 68 61 6e r signum). (han
53e0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 dle-exceptions.
53f0: 20 20 65 78 6e 0a 20 20 20 28 64 65 62 75 67 3a exn. (debug:
5400: 70 72 69 6e 74 20 22 20 2e 2e 2e 20 65 78 69 74 print " ... exit
5410: 69 6e 67 20 2e 2e 2e 22 29 0a 20 20 20 28 6c 65 ing ..."). (le
5420: 74 20 28 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 t ((th1 (make-th
5430: 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a read (lambda ().
5440: 09 09 09 20 20 20 20 20 28 74 68 72 65 61 64 2d ... (thread-
5450: 73 6c 65 65 70 21 20 31 29 29 0a 09 09 09 20 20 sleep! 1))....
5460: 20 22 65 61 74 20 72 65 73 70 6f 6e 73 65 22 29 "eat response")
5470: 29 0a 09 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 ).. (th2 (make-t
5480: 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 hread (lambda ()
5490: 0a 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a .... (debug:
54a0: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
54b0: 52 65 63 65 69 76 65 64 20 5e 43 2c 20 61 74 74 Received ^C, att
54c0: 65 6d 70 74 69 6e 67 20 63 6c 65 61 6e 20 65 78 empting clean ex
54d0: 69 74 2e 20 50 6c 65 61 73 65 20 62 65 20 70 61 it. Please be pa
54e0: 74 69 65 6e 74 20 61 6e 64 20 77 61 69 74 20 61 tient and wait a
54f0: 20 66 65 77 20 73 65 63 6f 6e 64 73 20 62 65 66 few seconds bef
5500: 6f 72 65 20 68 69 74 74 69 6e 67 20 5e 43 20 61 ore hitting ^C a
5510: 67 61 69 6e 2e 22 29 0a 09 09 09 20 20 20 20 20 gain.")....
5520: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 33 (thread-sleep! 3
5530: 29 20 3b 3b 20 67 69 76 65 20 74 68 65 20 66 6c ) ;; give the fl
5540: 75 73 68 20 74 68 72 65 65 20 73 65 63 6f 6e 64 ush three second
5550: 73 20 74 6f 20 64 6f 20 69 74 27 73 20 73 74 75 s to do it's stu
5560: 66 66 0a 09 09 09 20 20 20 20 20 28 64 65 62 75 ff.... (debu
5570: 67 3a 70 72 69 6e 74 20 30 20 22 20 20 20 20 20 g:print 0 "
5580: 20 20 44 6f 6e 65 2e 22 29 0a 09 09 09 20 20 20 Done.")....
5590: 20 20 28 65 78 69 74 20 34 29 29 0a 09 09 09 20 (exit 4))....
55a0: 20 20 22 65 78 69 74 20 6f 6e 20 5e 43 20 74 69 "exit on ^C ti
55b0: 6d 65 72 22 29 29 29 0a 20 20 20 20 20 28 74 68 mer"))). (th
55c0: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 read-start! th2)
55d0: 0a 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 . (thread-st
55e0: 61 72 74 21 20 74 68 31 29 0a 20 20 20 20 20 28 art! th1). (
55f0: 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 32 thread-join! th2
5600: 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
5610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
5650: 3b 20 77 65 62 20 70 61 67 65 73 0a 3b 3b 3d 3d ; web pages.;;==
5660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
56a0: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 68 ====..(define (h
56b0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6d 61 ttp-transport:ma
56c0: 69 6e 2d 70 61 67 65 29 0a 20 20 28 6c 65 74 20 in-page). (let
56d0: 28 28 6c 69 6e 6b 70 61 74 68 20 28 72 6f 6f 74 ((linkpath (root
56e0: 2d 70 61 74 68 29 29 29 0a 20 20 20 20 28 63 6f -path))). (co
56f0: 6e 63 20 22 3c 68 65 61 64 3e 3c 68 31 3e 22 20 nc "<head><h1>"
5700: 28 70 61 74 68 6e 61 6d 65 2d 73 74 72 69 70 2d (pathname-strip-
5710: 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 directory *toppa
5720: 74 68 2a 29 20 22 3c 2f 68 31 3e 3c 2f 68 65 61 th*) "</h1></hea
5730: 64 3e 22 0a 09 20 20 22 3c 62 6f 64 79 3e 22 0a d>".. "<body>".
5740: 09 20 20 22 52 75 6e 20 61 72 65 61 3a 20 22 20 . "Run area: "
5750: 2a 74 6f 70 70 61 74 68 2a 0a 09 20 20 22 3c 68 *toppath*.. "<h
5760: 32 3e 53 65 72 76 65 72 20 53 74 61 74 73 3c 2f 2>Server Stats</
5770: 68 32 3e 22 0a 09 20 20 28 68 74 74 70 2d 74 72 h2>".. (http-tr
5780: 61 6e 73 70 6f 72 74 3a 73 74 61 74 73 2d 74 61 ansport:stats-ta
5790: 62 6c 65 29 20 0a 09 20 20 22 3c 68 72 3e 22 0a ble) .. "<hr>".
57a0: 09 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f . (http-transpo
57b0: 72 74 3a 72 75 6e 73 20 6c 69 6e 6b 70 61 74 68 rt:runs linkpath
57c0: 29 0a 09 20 20 22 3c 68 72 3e 22 0a 09 20 20 28 ).. "<hr>".. (
57d0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 http-transport:r
57e0: 75 6e 2d 73 74 61 74 73 29 0a 09 20 20 22 3c 2f un-stats).. "</
57f0: 62 6f 64 79 3e 22 0a 09 20 20 29 29 29 0a 0a 28 body>".. )))..(
5800: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
5810: 6e 73 70 6f 72 74 3a 73 74 61 74 73 2d 74 61 62 nsport:stats-tab
5820: 6c 65 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 le). (mutex-loc
5830: 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 k! *heartbeat-mu
5840: 74 65 78 2a 29 0a 20 20 28 6c 65 74 20 28 28 72 tex*). (let ((r
5850: 65 73 20 0a 09 20 28 63 6f 6e 63 20 22 3c 74 61 es .. (conc "<ta
5860: 62 6c 65 3e 22 0a 09 20 20 20 20 20 20 20 22 3c ble>".. "<
5870: 74 72 3e 3c 74 64 3e 4d 61 78 20 63 61 63 68 65 tr><td>Max cache
5880: 64 20 71 75 65 72 69 65 73 3c 2f 74 64 3e 20 20 d queries</td>
5890: 20 20 20 20 20 20 3c 74 64 3e 22 20 2a 6d 61 78 <td>" *max
58a0: 2d 63 61 63 68 65 2d 73 69 7a 65 2a 20 22 3c 2f -cache-size* "</
58b0: 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 td></tr>"..
58c0: 20 20 22 3c 74 72 3e 3c 74 64 3e 4e 75 6d 62 65 "<tr><td>Numbe
58d0: 72 20 6f 66 20 63 61 63 68 65 64 20 77 72 69 74 r of cached writ
58e0: 65 73 3c 2f 74 64 3e 20 20 20 3c 74 64 3e 22 20 es</td> <td>"
58f0: 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 *number-of-write
5900: 73 2a 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a s* "</td></tr>".
5910: 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 . "<tr><td
5920: 3e 41 76 65 72 61 67 65 20 63 61 63 68 65 64 20 >Average cached
5930: 77 72 69 74 65 20 74 69 6d 65 3c 2f 74 64 3e 20 write time</td>
5940: 3c 74 64 3e 22 20 28 69 66 20 28 65 71 3f 20 2a <td>" (if (eq? *
5950: 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 number-of-writes
5960: 2a 20 30 29 0a 09 09 09 09 09 09 09 09 20 22 6e * 0)......... "n
5970: 2f 61 20 28 6e 6f 20 77 72 69 74 65 73 29 22 0a /a (no writes)".
5980: 09 09 09 09 09 09 09 09 20 28 2f 20 2a 77 72 69 ........ (/ *wri
5990: 74 65 73 2d 74 6f 74 61 6c 2d 64 65 6c 61 79 2a tes-total-delay*
59a0: 0a 09 09 09 09 09 09 09 09 20 20 20 20 2a 6e 75 ......... *nu
59b0: 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a 29 mber-of-writes*)
59c0: 29 0a 09 20 20 20 20 20 20 20 22 20 6d 73 3c 2f ).. " ms</
59d0: 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 td></tr>"..
59e0: 20 20 22 3c 74 72 3e 3c 74 64 3e 4e 75 6d 62 65 "<tr><td>Numbe
59f0: 72 20 6e 6f 6e 2d 63 61 63 68 65 64 20 71 75 65 r non-cached que
5a00: 72 69 65 73 3c 2f 74 64 3e 20 3c 74 64 3e 22 20 ries</td> <td>"
5a10: 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 *number-non-wri
5a20: 74 65 2d 71 75 65 72 69 65 73 2a 20 22 3c 2f 74 te-queries* "</t
5a30: 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 d></tr>"..
5a40: 20 22 3c 74 72 3e 3c 74 64 3e 41 76 65 72 61 67 "<tr><td>Averag
5a50: 65 20 6e 6f 6e 2d 63 61 63 68 65 64 20 74 69 6d e non-cached tim
5a60: 65 3c 2f 74 64 3e 20 20 20 3c 74 64 3e 22 20 28 e</td> <td>" (
5a70: 69 66 20 28 65 71 3f 20 2a 6e 75 6d 62 65 72 2d if (eq? *number-
5a80: 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 non-write-querie
5a90: 73 2a 20 30 29 0a 09 09 09 09 09 09 09 09 20 22 s* 0)......... "
5aa0: 6e 2f 61 20 28 6e 6f 20 71 75 65 72 69 65 73 29 n/a (no queries)
5ab0: 22 0a 09 09 09 09 09 09 09 09 20 28 2f 20 2a 74 "......... (/ *t
5ac0: 6f 74 61 6c 2d 6e 6f 6e 2d 77 72 69 74 65 2d 64 otal-non-write-d
5ad0: 65 6c 61 79 2a 20 0a 09 09 09 09 09 09 09 09 20 elay* .........
5ae0: 20 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 *number-non-w
5af0: 72 69 74 65 2d 71 75 65 72 69 65 73 2a 29 29 0a rite-queries*)).
5b00: 09 20 20 20 20 20 20 20 22 20 6d 73 3c 2f 74 64 . " ms</td
5b10: 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 20 ></tr>"..
5b20: 22 3c 74 72 3e 3c 74 64 3e 4c 61 73 74 20 61 63 "<tr><td>Last ac
5b30: 63 65 73 73 3c 2f 74 64 3e 3c 74 64 3e 22 20 20 cess</td><td>"
5b40: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 63 (sec
5b50: 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e onds->time-strin
5b60: 67 20 2a 6c 61 73 74 2d 64 62 2d 61 63 63 65 73 g *last-db-acces
5b70: 73 2a 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 s*) "</td></tr>"
5b80: 0a 09 20 20 20 20 20 20 20 22 3c 2f 74 61 62 6c .. "</tabl
5b90: 65 3e 22 29 29 29 0a 20 20 20 20 28 6d 75 74 65 e>"))). (mute
5ba0: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 x-unlock! *heart
5bb0: 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 beat-mutex*).
5bc0: 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 res))..(define
5bd0: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
5be0: 72 75 6e 73 20 6c 69 6e 6b 70 61 74 68 29 0a 20 runs linkpath).
5bf0: 20 28 63 6f 6e 63 20 22 3c 68 33 3e 52 75 6e 73 (conc "<h3>Runs
5c00: 3c 2f 68 33 3e 22 0a 09 28 73 74 72 69 6e 67 2d </h3>"..(string-
5c10: 69 6e 74 65 72 73 70 65 72 73 65 0a 09 20 28 6c intersperse.. (l
5c20: 65 74 20 28 28 66 69 6c 65 73 20 28 6d 61 70 20 et ((files (map
5c30: 70 61 74 68 6e 61 6d 65 2d 73 74 72 69 70 2d 64 pathname-strip-d
5c40: 69 72 65 63 74 6f 72 79 20 28 67 6c 6f 62 20 28 irectory (glob (
5c50: 63 6f 6e 63 20 6c 69 6e 6b 70 61 74 68 20 22 2f conc linkpath "/
5c60: 2a 22 29 29 29 29 29 0a 09 20 20 20 28 6d 61 70 *"))))).. (map
5c70: 20 28 6c 61 6d 62 64 61 20 28 70 29 0a 09 09 20 (lambda (p)...
5c80: 20 28 63 6f 6e 63 20 22 3c 61 20 68 72 65 66 3d (conc "<a href=
5c90: 5c 22 22 20 70 20 22 5c 22 3e 22 20 70 20 22 3c \"" p "\">" p "<
5ca0: 2f 61 3e 3c 62 72 3e 22 29 29 0a 09 09 66 69 6c /a><br>"))...fil
5cb0: 65 73 29 29 0a 09 20 22 20 22 29 29 29 0a 0a 28 es)).. " ")))..(
5cc0: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
5cd0: 6e 73 70 6f 72 74 3a 72 75 6e 2d 73 74 61 74 73 nsport:run-stats
5ce0: 29 0a 20 20 28 6c 65 74 20 28 28 73 74 61 74 73 ). (let ((stats
5cf0: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
5d00: 20 64 62 3a 67 65 74 2d 72 75 6e 6e 69 6e 67 2d db:get-running-
5d10: 73 74 61 74 73 20 23 66 29 29 29 0a 20 20 20 20 stats #f))).
5d20: 28 63 6f 6e 63 20 22 3c 74 61 62 6c 65 3e 22 0a (conc "<table>".
5d30: 09 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 . (string-inter
5d40: 73 70 65 72 73 65 0a 09 20 20 20 28 6d 61 70 20 sperse.. (map
5d50: 28 6c 61 6d 62 64 61 20 28 73 74 61 74 29 0a 09 (lambda (stat)..
5d60: 09 20 20 28 63 6f 6e 63 20 22 3c 74 72 3e 3c 74 . (conc "<tr><t
5d70: 64 3e 22 20 28 63 61 72 20 73 74 61 74 29 20 22 d>" (car stat) "
5d80: 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 63 61 64 72 </td><td>" (cadr
5d90: 20 73 74 61 74 29 20 22 3c 2f 74 64 3e 3c 2f 74 stat) "</td></t
5da0: 72 3e 22 29 29 0a 09 09 73 74 61 74 73 29 0a 09 r>"))...stats)..
5db0: 20 20 20 22 20 22 29 0a 09 20 20 22 3c 2f 74 61 " ").. "</ta
5dc0: 62 6c 65 3e 22 29 29 29 ble>")))