Artifact
eebbc561d6bfb4556a3cd801d28d7f12381163dd:
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 20 cp s11n)..(use
0180: 73 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 67 srfi-1 posix reg
0190: 65 78 20 72 65 67 65 78 2d 63 61 73 65 20 73 72 ex regex-case sr
01a0: 66 69 2d 36 39 20 68 6f 73 74 69 6e 66 6f 20 6d fi-69 hostinfo m
01b0: 64 35 20 6d 65 73 73 61 67 65 2d 64 69 67 65 73 d5 message-diges
01c0: 74 20 70 6f 73 69 78 2d 65 78 74 72 61 73 29 20 t posix-extras)
01d0: 3b 3b 20 73 71 6c 69 74 65 33 0a 3b 3b 20 28 69 ;; sqlite3.;; (i
01e0: 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 73 71 mport (prefix sq
01f0: 6c 69 74 65 33 20 73 71 6c 69 74 65 33 3a 29 29 lite3 sqlite3:))
0200: 0a 0a 28 75 73 65 20 73 70 69 66 66 79 20 75 72 ..(use spiffy ur
0210: 69 2d 63 6f 6d 6d 6f 6e 20 69 6e 74 61 72 77 65 i-common intarwe
0220: 62 20 68 74 74 70 2d 63 6c 69 65 6e 74 20 73 70 b http-client sp
0230: 69 66 66 79 2d 72 65 71 75 65 73 74 2d 76 61 72 iffy-request-var
0240: 73 20 69 6e 74 61 72 77 65 62 20 73 70 69 66 66 s intarweb spiff
0250: 79 2d 64 69 72 65 63 74 6f 72 79 2d 6c 69 73 74 y-directory-list
0260: 69 6e 67 29 0a 0a 3b 3b 20 43 6f 6e 66 69 67 75 ing)..;; Configu
0270: 72 61 74 69 6f 6e 73 20 66 6f 72 20 73 65 72 76 rations for serv
0280: 65 72 0a 28 74 63 70 2d 62 75 66 66 65 72 2d 73 er.(tcp-buffer-s
0290: 69 7a 65 20 32 30 34 38 29 0a 28 6d 61 78 2d 63 ize 2048).(max-c
02a0: 6f 6e 6e 65 63 74 69 6f 6e 73 20 32 30 34 38 29 onnections 2048)
02b0: 20 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 6e 69 ..(declare (uni
02c0: 74 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 t http-transport
02d0: 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 73 ))..(declare (us
02e0: 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 63 es common)).(dec
02f0: 6c 61 72 65 20 28 75 73 65 73 20 64 62 29 29 0a lare (uses db)).
0300: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 (declare (uses t
0310: 65 73 74 73 29 29 0a 28 64 65 63 6c 61 72 65 20 ests)).(declare
0320: 28 75 73 65 73 20 74 61 73 6b 73 29 29 20 3b 3b (uses tasks)) ;;
0330: 20 74 61 73 6b 73 20 61 72 65 20 77 68 65 72 65 tasks are where
0340: 20 73 74 75 66 66 20 69 73 20 6d 61 69 6e 74 61 stuff is mainta
0350: 69 6e 65 64 20 61 62 6f 75 74 20 77 68 61 74 20 ined about what
0360: 69 73 20 72 75 6e 6e 69 6e 67 2e 0a 28 64 65 63 is running..(dec
0370: 6c 61 72 65 20 28 75 73 65 73 20 73 65 72 76 65 lare (uses serve
0380: 72 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 r)).(declare (us
0390: 65 73 20 64 61 65 6d 6f 6e 29 29 0a 28 64 65 63 es daemon)).(dec
03a0: 6c 61 72 65 20 28 75 73 65 73 20 70 6f 72 74 6c lare (uses portl
03b0: 6f 67 67 65 72 29 29 0a 28 64 65 63 6c 61 72 65 ogger)).(declare
03c0: 20 28 75 73 65 73 20 72 6d 74 29 29 0a 0a 28 69 (uses rmt))..(i
03d0: 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 nclude "common_r
03e0: 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e ecords.scm").(in
03f0: 63 6c 75 64 65 20 22 64 62 5f 72 65 63 6f 72 64 clude "db_record
0400: 73 2e 73 63 6d 22 29 0a 0a 28 64 65 66 69 6e 65 s.scm")..(define
0410: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
0420: 3a 6d 61 6b 65 2d 73 65 72 76 65 72 2d 75 72 6c :make-server-url
0430: 20 68 6f 73 74 70 6f 72 74 29 0a 20 20 28 69 66 hostport). (if
0440: 20 28 6e 6f 74 20 68 6f 73 74 70 6f 72 74 29 0a (not hostport).
0450: 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 #f. (
0460: 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f 22 20 28 conc "http://" (
0470: 63 61 72 20 68 6f 73 74 70 6f 72 74 29 20 22 3a car hostport) ":
0480: 22 20 28 63 61 64 72 20 68 6f 73 74 70 6f 72 74 " (cadr hostport
0490: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 73 ))))..(define *s
04a0: 65 72 76 65 72 2d 6c 6f 6f 70 2d 68 65 61 72 74 erver-loop-heart
04b0: 2d 62 65 61 74 2a 20 28 63 75 72 72 65 6e 74 2d -beat* (current-
04c0: 73 65 63 6f 6e 64 73 29 29 0a 0a 3b 3b 3d 3d 3d seconds))..;;===
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0510: 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 20 56 20 45 ===.;; S E R V E
0520: 20 52 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d R.;;===========
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 3d 3d ================
0550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
0570: 43 61 6c 6c 20 74 68 69 73 20 74 6f 20 73 74 61 Call this to sta
0580: 72 74 20 74 68 65 20 61 63 74 75 61 6c 20 73 65 rt the actual se
0590: 72 76 65 72 0a 3b 3b 0a 0a 28 64 65 66 69 6e 65 rver.;;..(define
05a0: 20 2a 64 62 3a 70 72 6f 63 65 73 73 2d 71 75 65 *db:process-que
05b0: 75 65 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d ue-mutex* (make-
05c0: 6d 75 74 65 78 29 29 0a 0a 28 64 65 66 69 6e 65 mutex))..(define
05d0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
05e0: 3a 72 75 6e 20 68 6f 73 74 6e 29 0a 20 20 28 64 :run hostn). (d
05f0: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 ebug:print 2 *de
0600: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
0610: 22 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 73 "Attempting to s
0620: 74 61 72 74 20 74 68 65 20 73 65 72 76 65 72 20 tart the server
0630: 2e 2e 2e 22 29 0a 20 20 28 6c 65 74 2a 20 28 28 ..."). (let* ((
0640: 64 62 20 20 20 20 20 20 20 20 20 20 20 20 20 20 db
0650: 23 66 29 20 3b 3b 20 20 20 20 20 20 20 20 28 6f #f) ;; (o
0660: 70 65 6e 2d 64 62 29 29 20 3b 3b 20 77 65 20 64 pen-db)) ;; we d
0670: 6f 6e 27 74 20 77 61 6e 74 20 74 68 65 20 73 65 on't want the se
0680: 72 76 65 72 20 74 6f 20 62 65 20 6f 70 65 6e 69 rver to be openi
0690: 6e 67 20 61 6e 64 20 63 6c 6f 73 69 6e 67 20 74 ng and closing t
06a0: 68 65 20 64 62 20 75 6e 6e 65 63 65 73 61 72 69 he db unnecesari
06b0: 6c 79 0a 09 20 28 68 6f 73 74 6e 61 6d 65 20 20 ly.. (hostname
06c0: 20 20 20 20 20 20 28 67 65 74 2d 68 6f 73 74 2d (get-host-
06d0: 6e 61 6d 65 29 29 0a 09 20 28 69 70 61 64 64 72 name)).. (ipaddr
06e0: 73 74 72 20 20 20 20 20 20 20 28 6c 65 74 20 28 str (let (
06f0: 28 69 70 73 74 72 20 28 69 66 20 28 73 74 72 69 (ipstr (if (stri
0700: 6e 67 3d 3f 20 22 2d 22 20 68 6f 73 74 6e 29 0a ng=? "-" hostn).
0710: 09 09 09 09 09 20 20 20 3b 3b 20 28 73 74 72 69 ..... ;; (stri
0720: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
0730: 6d 61 70 20 6e 75 6d 62 65 72 2d 3e 73 74 72 69 map number->stri
0740: 6e 67 20 28 75 38 76 65 63 74 6f 72 2d 3e 6c 69 ng (u8vector->li
0750: 73 74 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 69 70 st (hostname->ip
0760: 20 68 6f 73 74 6e 61 6d 65 29 29 29 20 22 2e 22 hostname))) "."
0770: 29 0a 09 09 09 09 09 20 20 20 28 73 65 72 76 65 )...... (serve
0780: 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 r:get-best-guess
0790: 2d 61 64 64 72 65 73 73 20 68 6f 73 74 6e 61 6d -address hostnam
07a0: 65 29 0a 09 09 09 09 09 20 20 20 23 66 29 29 29 e)...... #f)))
07b0: 0a 09 09 09 20 20 20 20 28 69 66 20 69 70 73 74 .... (if ipst
07c0: 72 20 69 70 73 74 72 20 68 6f 73 74 6e 29 29 29 r ipstr hostn)))
07d0: 20 3b 3b 20 68 6f 73 74 6e 61 6d 65 29 29 29 20 ;; hostname)))
07e0: 0a 09 20 28 73 74 61 72 74 2d 70 6f 72 74 20 20 .. (start-port
07f0: 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a (portlogger:
0800: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 open-run-close p
0810: 6f 72 74 6c 6f 67 67 65 72 3a 66 69 6e 64 2d 70 ortlogger:find-p
0820: 6f 72 74 29 29 0a 09 20 28 6c 69 6e 6b 2d 74 72 ort)).. (link-tr
0830: 65 65 2d 70 61 74 68 20 20 28 63 6f 6d 6d 6f 6e ee-path (common
0840: 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 29 0a :get-linktree)).
0850: 09 20 28 74 6d 70 2d 61 72 65 61 20 20 20 20 20 . (tmp-area
0860: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 (common:get-d
0870: 62 2d 74 6d 70 2d 61 72 65 61 29 29 0a 09 20 28 b-tmp-area)).. (
0880: 73 74 61 72 74 2d 66 69 6c 65 20 20 20 20 20 20 start-file
0890: 28 63 6f 6e 63 20 74 6d 70 2d 61 72 65 61 20 22 (conc tmp-area "
08a0: 2f 2e 73 65 72 76 65 72 2d 73 74 61 72 74 22 29 /.server-start")
08b0: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
08c0: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
08d0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 ult-log-port* "p
08e0: 6f 72 74 6c 6f 67 67 65 72 20 72 65 63 6f 6d 6d ortlogger recomm
08f0: 65 6e 64 65 64 20 70 6f 72 74 3a 20 22 20 73 74 ended port: " st
0900: 61 72 74 2d 70 6f 72 74 29 0a 20 20 20 20 3b 3b art-port). ;;
0910: 20 73 65 74 20 73 6f 6d 65 20 70 61 72 61 6d 65 set some parame
0920: 74 65 72 73 20 66 6f 72 20 74 68 65 20 73 65 72 ters for the ser
0930: 76 65 72 0a 20 20 20 20 28 72 6f 6f 74 2d 70 61 ver. (root-pa
0940: 74 68 20 20 20 20 20 28 69 66 20 6c 69 6e 6b 2d th (if link-
0950: 74 72 65 65 2d 70 61 74 68 20 0a 09 09 20 20 20 tree-path ...
0960: 20 20 20 20 6c 69 6e 6b 2d 74 72 65 65 2d 70 61 link-tree-pa
0970: 74 68 0a 09 09 20 20 20 20 20 20 20 28 63 75 72 th... (cur
0980: 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 rent-directory))
0990: 29 20 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 53 45 ) ;; WARNING: SE
09a0: 43 55 52 49 54 59 20 48 4f 4c 45 2e 20 46 49 58 CURITY HOLE. FIX
09b0: 20 41 53 41 50 21 0a 20 20 20 20 28 68 61 6e 64 ASAP!. (hand
09c0: 6c 65 2d 64 69 72 65 63 74 6f 72 79 20 73 70 69 le-directory spi
09d0: 66 66 79 2d 64 69 72 65 63 74 6f 72 79 2d 6c 69 ffy-directory-li
09e0: 73 74 69 6e 67 29 0a 20 20 20 20 28 68 61 6e 64 sting). (hand
09f0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 20 28 6c 61 le-exception (la
0a00: 6d 62 64 61 20 28 65 78 6e 20 63 68 61 69 6e 29 mbda (exn chain)
0a10: 0a 09 09 09 28 73 69 67 6e 61 6c 20 28 6d 61 6b ....(signal (mak
0a20: 65 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 6f 6e 64 e-composite-cond
0a30: 69 74 69 6f 6e 0a 09 09 09 09 20 28 6d 61 6b 65 ition..... (make
0a40: 2d 70 72 6f 70 65 72 74 79 2d 63 6f 6e 64 69 74 -property-condit
0a50: 69 6f 6e 20 0a 09 09 09 09 20 20 27 73 65 72 76 ion ..... 'serv
0a60: 65 72 0a 09 09 09 09 20 20 27 6d 65 73 73 61 67 er..... 'messag
0a70: 65 20 22 73 65 72 76 65 72 20 65 72 72 6f 72 22 e "server error"
0a80: 29 29 29 29 29 0a 0a 20 20 20 20 3b 3b 20 68 74 ))))).. ;; ht
0a90: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 68 61 6e tp-transport:han
0aa0: 64 6c 65 2d 64 69 72 65 63 74 6f 72 79 29 20 3b dle-directory) ;
0ab0: 3b 20 73 69 6d 70 6c 65 2d 64 69 72 65 63 74 6f ; simple-directo
0ac0: 72 79 2d 68 61 6e 64 6c 65 72 29 0a 20 20 20 20 ry-handler).
0ad0: 3b 3b 20 53 65 74 75 70 20 74 68 65 20 77 65 62 ;; Setup the web
0ae0: 20 73 65 72 76 65 72 20 61 6e 64 20 61 20 2f 63 server and a /c
0af0: 74 72 6c 20 69 6e 74 65 72 66 61 63 65 0a 20 20 trl interface.
0b00: 20 20 3b 3b 0a 20 20 20 20 28 76 68 6f 73 74 2d ;;. (vhost-
0b10: 6d 61 70 20 60 28 28 28 2a 20 61 6e 79 29 20 2e map `(((* any) .
0b20: 20 2c 28 6c 61 6d 62 64 61 20 28 63 6f 6e 74 69 ,(lambda (conti
0b30: 6e 75 65 29 0a 09 09 09 20 20 20 20 20 20 20 3b nue).... ;
0b40: 3b 20 6f 70 65 6e 20 74 68 65 20 64 62 20 6f 6e ; open the db on
0b50: 20 74 68 65 20 66 69 72 73 74 20 63 61 6c 6c 20 the first call
0b60: 0a 09 09 09 09 20 3b 3b 20 54 68 69 73 20 69 73 ..... ;; This is
0b70: 20 77 65 72 65 20 77 65 20 73 65 74 20 75 70 20 were we set up
0b80: 74 68 65 20 64 61 74 61 62 61 73 65 20 63 6f 6e the database con
0b90: 6e 65 63 74 69 6f 6e 73 0a 09 09 09 20 20 20 20 nections....
0ba0: 20 20 20 28 6c 65 74 2a 20 28 28 24 20 20 20 28 (let* (($ (
0bb0: 72 65 71 75 65 73 74 2d 76 61 72 73 20 73 6f 75 request-vars sou
0bc0: 72 63 65 3a 20 27 62 6f 74 68 29 29 0a 09 09 09 rce: 'both))....
0bd0: 09 20 20 20 20 20 20 28 64 61 74 20 28 24 20 27 . (dat ($ '
0be0: 64 61 74 29 29 0a 09 09 09 09 20 20 20 20 20 20 dat)).....
0bf0: 28 72 65 73 20 23 66 29 29 0a 09 09 09 09 20 28 (res #f))..... (
0c00: 63 6f 6e 64 0a 09 09 09 09 20 20 28 28 65 71 75 cond..... ((equ
0c10: 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 al? (uri-path (r
0c20: 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 equest-uri (curr
0c30: 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 0a 09 ent-request)))..
0c40: 09 09 09 09 20 20 20 27 28 2f 20 22 61 70 69 22 .... '(/ "api"
0c50: 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e 64 2d ))..... (send-
0c60: 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 20 response body:
0c70: 20 20 28 61 70 69 3a 70 72 6f 63 65 73 73 2d 72 (api:process-r
0c80: 65 71 75 65 73 74 20 2a 64 62 73 74 72 75 63 74 equest *dbstruct
0c90: 2d 64 62 2a 20 24 29 20 3b 3b 20 74 68 65 20 24 -db* $) ;; the $
0ca0: 20 69 73 20 74 68 65 20 72 65 71 75 65 73 74 20 is the request
0cb0: 76 61 72 73 20 70 72 6f 63 0a 09 09 09 09 09 09 vars proc.......
0cc0: 20 20 68 65 61 64 65 72 73 3a 20 27 28 28 63 6f headers: '((co
0cd0: 6e 74 65 6e 74 2d 74 79 70 65 20 74 65 78 74 2f ntent-type text/
0ce0: 70 6c 61 69 6e 29 29 29 0a 09 09 09 09 20 20 20 plain))).....
0cf0: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 (mutex-lock! *he
0d00: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
0d10: 09 09 09 09 20 20 20 28 73 65 74 21 20 2a 64 62 .... (set! *db
0d20: 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 28 63 -last-access* (c
0d30: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
0d40: 0a 09 09 09 09 20 20 20 28 6d 75 74 65 78 2d 75 ..... (mutex-u
0d50: 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 nlock! *heartbea
0d60: 74 2d 6d 75 74 65 78 2a 29 29 0a 09 09 09 09 20 t-mutex*)).....
0d70: 20 28 28 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 ((equal? (uri-p
0d80: 61 74 68 20 28 72 65 71 75 65 73 74 2d 75 72 69 ath (request-uri
0d90: 20 28 63 75 72 72 65 6e 74 2d 72 65 71 75 65 73 (current-reques
0da0: 74 29 29 29 20 0a 09 09 09 09 09 20 20 20 27 28 t))) ...... '(
0db0: 2f 20 22 22 29 29 0a 09 09 09 09 20 20 20 28 73 / ""))..... (s
0dc0: 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 end-response bod
0dd0: 79 3a 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f y: (http-transpo
0de0: 72 74 3a 6d 61 69 6e 2d 70 61 67 65 29 29 29 0a rt:main-page))).
0df0: 09 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 .... ((equal? (
0e00: 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 uri-path (reques
0e10: 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 t-uri (current-r
0e20: 65 71 75 65 73 74 29 29 29 20 0a 09 09 09 09 09 equest))) ......
0e30: 20 20 20 27 28 2f 20 22 6a 73 6f 6e 5f 61 70 69 '(/ "json_api
0e40: 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e 64 "))..... (send
0e50: 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 -response body:
0e60: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
0e70: 6d 61 69 6e 2d 70 61 67 65 29 29 29 0a 09 09 09 main-page)))....
0e80: 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 69 . ((equal? (uri
0e90: 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 2d 75 -path (request-u
0ea0: 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 75 ri (current-requ
0eb0: 65 73 74 29 29 29 20 0a 09 09 09 09 09 20 20 20 est))) ......
0ec0: 27 28 2f 20 22 72 75 6e 73 22 29 29 0a 09 09 09 '(/ "runs"))....
0ed0: 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e . (send-respon
0ee0: 73 65 20 62 6f 64 79 3a 20 28 68 74 74 70 2d 74 se body: (http-t
0ef0: 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 61 ransport:main-pa
0f00: 67 65 29 29 29 0a 09 09 09 09 20 20 28 28 65 71 ge)))..... ((eq
0f10: 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 28 ual? (uri-path (
0f20: 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 72 request-uri (cur
0f30: 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 20 rent-request)))
0f40: 0a 09 09 09 09 09 20 20 20 27 28 2f 20 61 6e 79 ...... '(/ any
0f50: 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e 64 2d ))..... (send-
0f60: 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 22 response body: "
0f70: 68 65 79 20 74 68 65 72 65 21 5c 6e 22 0a 09 09 hey there!\n"...
0f80: 09 09 09 09 20 20 68 65 61 64 65 72 73 3a 20 27 .... headers: '
0f90: 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 ((content-type t
0fa0: 65 78 74 2f 70 6c 61 69 6e 29 29 29 29 0a 09 09 ext/plain))))...
0fb0: 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 .. ((equal? (ur
0fc0: 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 2d i-path (request-
0fd0: 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 uri (current-req
0fe0: 75 65 73 74 29 29 29 20 0a 09 09 09 09 09 20 20 uest))) ......
0ff0: 20 27 28 2f 20 22 68 65 79 22 29 29 0a 09 09 09 '(/ "hey"))....
1000: 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e . (send-respon
1010: 73 65 20 62 6f 64 79 3a 20 22 68 65 79 20 74 68 se body: "hey th
1020: 65 72 65 21 5c 6e 22 0a 09 09 09 09 09 09 20 20 ere!\n".......
1030: 68 65 61 64 65 72 73 3a 20 27 28 28 63 6f 6e 74 headers: '((cont
1040: 65 6e 74 2d 74 79 70 65 20 74 65 78 74 2f 70 6c ent-type text/pl
1050: 61 69 6e 29 29 29 29 0a 09 09 09 09 20 20 28 65 ain))))..... (e
1060: 6c 73 65 20 28 63 6f 6e 74 69 6e 75 65 29 29 29 lse (continue)))
1070: 29 29 29 29 29 0a 20 20 20 20 28 77 69 74 68 2d ))))). (with-
1080: 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 73 output-to-file s
1090: 74 61 72 74 2d 66 69 6c 65 20 28 6c 61 6d 62 64 tart-file (lambd
10a0: 61 20 28 29 28 70 72 69 6e 74 20 28 63 75 72 72 a ()(print (curr
10b0: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 ent-process-id))
10c0: 29 29 0a 20 20 20 20 28 68 74 74 70 2d 74 72 61 )). (http-tra
10d0: 6e 73 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 74 nsport:try-start
10e0: 2d 73 65 72 76 65 72 20 69 70 61 64 64 72 73 74 -server ipaddrst
10f0: 72 20 73 74 61 72 74 2d 70 6f 72 74 29 29 29 0a r start-port))).
1100: 0a 3b 3b 20 54 68 69 73 20 69 73 20 72 65 63 75 .;; This is recu
1110: 72 73 69 76 65 6c 79 20 72 75 6e 20 62 79 20 68 rsively run by h
1120: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 ttp-transport:ru
1130: 6e 20 75 6e 74 69 6c 20 73 75 63 65 73 73 66 75 n until sucessfu
1140: 6c 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 l.;;.(define (ht
1150: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 tp-transport:try
1160: 2d 73 74 61 72 74 2d 73 65 72 76 65 72 20 69 70 -start-server ip
1170: 61 64 64 72 73 74 72 20 70 6f 72 74 6e 75 6d 29 addrstr portnum)
1180: 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 66 69 67 . (let ((config
1190: 2d 68 6f 73 74 6e 61 6d 65 20 28 63 6f 6e 66 69 -hostname (confi
11a0: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
11b0: 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 gdat* "server" "
11c0: 68 6f 73 74 6e 61 6d 65 22 29 29 0a 09 28 63 6f hostname"))..(co
11d0: 6e 66 69 67 2d 75 73 65 2d 70 72 6f 78 79 20 28 nfig-use-proxy (
11e0: 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 3a equal? (configf:
11f0: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
1200: 74 2a 20 22 63 6c 69 65 6e 74 22 20 22 75 73 65 t* "client" "use
1210: 2d 68 74 74 70 5f 70 72 6f 78 79 22 29 20 22 79 -http_proxy") "y
1220: 65 73 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 es"))). (if (
1230: 6e 6f 74 20 63 6f 6e 66 69 67 2d 75 73 65 2d 70 not config-use-p
1240: 72 6f 78 79 29 0a 09 28 64 65 74 65 72 6d 69 6e roxy)..(determin
1250: 65 2d 70 72 6f 78 79 20 28 63 6f 6e 73 74 61 6e e-proxy (constan
1260: 74 6c 79 20 23 66 29 29 29 0a 20 20 20 20 28 64 tly #f))). (d
1270: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
1280: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
1290: 6f 72 74 2a 20 22 68 74 74 70 2d 74 72 61 6e 73 ort* "http-trans
12a0: 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 port:try-start-s
12b0: 65 72 76 65 72 20 74 69 6d 65 3d 22 20 28 73 65 erver time=" (se
12c0: 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 conds->time-stri
12d0: 6e 67 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f ng (current-seco
12e0: 6e 64 73 29 29 20 22 20 69 70 61 64 64 72 73 73 nds)) " ipaddrss
12f0: 74 72 3d 22 20 69 70 61 64 64 72 73 74 72 20 22 tr=" ipaddrstr "
1300: 20 70 6f 72 74 6e 75 6d 3d 22 20 70 6f 72 74 6e portnum=" portn
1310: 75 6d 20 22 20 63 6f 6e 66 69 67 2d 68 6f 73 74 um " config-host
1320: 6e 61 6d 65 3d 22 20 63 6f 6e 66 69 67 2d 68 6f name=" config-ho
1330: 73 74 6e 61 6d 65 29 0a 20 20 20 20 28 68 61 6e stname). (han
1340: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
1350: 65 78 6e 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 exn..(begin.. (
1360: 70 72 69 6e 74 2d 65 72 72 6f 72 2d 6d 65 73 73 print-error-mess
1370: 61 67 65 20 65 78 6e 29 0a 09 20 20 28 69 66 20 age exn).. (if
1380: 28 3c 20 70 6f 72 74 6e 75 6d 20 36 34 30 30 30 (< portnum 64000
1390: 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 20 ).. (begin
13a0: 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
13b0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
13c0: 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 61 ort* "WARNING: a
13d0: 74 74 65 6d 70 74 20 74 6f 20 73 74 61 72 74 20 ttempt to start
13e0: 73 65 72 76 65 72 20 66 61 69 6c 65 64 2e 20 54 server failed. T
13f0: 72 79 69 6e 67 20 61 67 61 69 6e 20 2e 2e 2e 22 rying again ..."
1400: 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 )...(debug:print
1410: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
1420: 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 65 3a port* " message:
1430: 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
1440: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
1450: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
1460: 65 78 6e 29 29 0a 09 09 28 64 65 62 75 67 3a 70 exn))...(debug:p
1470: 72 69 6e 74 20 35 20 2a 64 65 66 61 75 6c 74 2d rint 5 *default-
1480: 6c 6f 67 2d 70 6f 72 74 2a 20 22 65 78 6e 3d 22 log-port* "exn="
1490: 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 (condition->lis
14a0: 74 20 65 78 6e 29 29 0a 09 09 28 70 6f 72 74 6c t exn))...(portl
14b0: 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 ogger:open-run-c
14c0: 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a lose portlogger:
14d0: 73 65 74 2d 66 61 69 6c 65 64 20 70 6f 72 74 6e set-failed portn
14e0: 75 6d 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 um)...(debug:pri
14f0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
1500: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
1510: 3a 20 66 61 69 6c 65 64 20 74 6f 20 73 74 61 72 : failed to star
1520: 74 20 6f 6e 20 70 6f 72 74 6e 75 6d 3a 20 22 20 t on portnum: "
1530: 70 6f 72 74 6e 75 6d 20 22 2c 20 74 72 79 69 6e portnum ", tryin
1540: 67 20 6e 65 78 74 20 70 6f 72 74 22 29 0a 09 09 g next port")...
1550: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
1560: 2e 31 29 0a 09 09 0a 09 09 3b 3b 20 67 65 74 5f .1)......;; get_
1570: 6e 65 78 74 5f 70 6f 72 74 20 67 6f 65 73 20 68 next_port goes h
1580: 65 72 65 0a 09 09 28 68 74 74 70 2d 74 72 61 6e ere...(http-tran
1590: 73 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 74 2d sport:try-start-
15a0: 73 65 72 76 65 72 20 69 70 61 64 64 72 73 74 72 server ipaddrstr
15b0: 0a 09 09 09 09 09 09 20 28 70 6f 72 74 6c 6f 67 ....... (portlog
15c0: 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f ger:open-run-clo
15d0: 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 66 69 se portlogger:fi
15e0: 6e 64 2d 70 6f 72 74 29 29 29 0a 09 20 20 20 20 nd-port)))..
15f0: 20 20 28 62 65 67 69 6e 0a 09 09 28 70 72 69 6e (begin...(prin
1600: 74 20 22 45 52 52 4f 52 3a 20 54 72 69 65 64 20 t "ERROR: Tried
1610: 61 6e 64 20 74 72 69 65 64 20 62 75 74 20 63 6f and tried but co
1620: 75 6c 64 20 6e 6f 74 20 73 74 61 72 74 20 74 68 uld not start th
1630: 65 20 73 65 72 76 65 72 22 29 29 29 29 0a 20 20 e server")))).
1640: 20 20 20 20 3b 3b 20 61 6e 79 20 65 72 72 6f 72 ;; any error
1650: 20 69 6e 20 66 6f 6c 6c 6f 77 69 6e 67 20 73 74 in following st
1660: 65 70 73 20 77 69 6c 6c 20 72 65 73 75 6c 74 20 eps will result
1670: 69 6e 20 61 20 72 65 74 72 79 0a 20 20 20 20 20 in a retry.
1680: 20 28 73 65 74 21 20 2a 73 65 72 76 65 72 2d 69 (set! *server-i
1690: 6e 66 6f 2a 20 28 6c 69 73 74 20 69 70 61 64 64 nfo* (list ipadd
16a0: 72 73 74 72 20 70 6f 72 74 6e 75 6d 29 29 0a 20 rstr portnum)).
16b0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
16c0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
16d0: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 54 72 -port* "INFO: Tr
16e0: 79 69 6e 67 20 74 6f 20 73 74 61 72 74 20 73 65 ying to start se
16f0: 72 76 65 72 20 6f 6e 20 22 20 69 70 61 64 64 72 rver on " ipaddr
1700: 73 74 72 20 22 3a 22 20 70 6f 72 74 6e 75 6d 29 str ":" portnum)
1710: 0a 20 20 20 20 20 20 3b 3b 20 54 68 69 73 20 73 . ;; This s
1720: 74 61 72 74 73 20 74 68 65 20 73 70 69 66 66 79 tarts the spiffy
1730: 20 73 65 72 76 65 72 0a 20 20 20 20 20 20 3b 3b server. ;;
1740: 20 4e 45 45 44 20 57 41 59 20 54 4f 20 53 45 54 NEED WAY TO SET
1750: 20 49 50 20 54 4f 20 23 66 20 54 4f 20 42 49 4e IP TO #f TO BIN
1760: 44 20 41 4c 4c 0a 20 20 20 20 20 20 3b 3b 20 28 D ALL. ;; (
1770: 73 74 61 72 74 2d 73 65 72 76 65 72 20 62 69 6e start-server bin
1780: 64 2d 61 64 64 72 65 73 73 3a 20 69 70 61 64 64 d-address: ipadd
1790: 72 73 74 72 20 70 6f 72 74 3a 20 70 6f 72 74 6e rstr port: portn
17a0: 75 6d 29 0a 20 20 20 20 20 20 28 69 66 20 63 6f um). (if co
17b0: 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 20 3b 3b nfig-hostname ;;
17c0: 20 74 68 69 73 20 69 73 20 61 20 68 69 6e 74 20 this is a hint
17d0: 74 6f 20 62 69 6e 64 20 64 69 72 65 63 74 6c 79 to bind directly
17e0: 0a 09 20 20 28 73 74 61 72 74 2d 73 65 72 76 65 .. (start-serve
17f0: 72 20 70 6f 72 74 3a 20 70 6f 72 74 6e 75 6d 20 r port: portnum
1800: 62 69 6e 64 2d 61 64 64 72 65 73 73 3a 20 28 69 bind-address: (i
1810: 66 20 28 65 71 75 61 6c 3f 20 63 6f 6e 66 69 67 f (equal? config
1820: 2d 68 6f 73 74 6e 61 6d 65 20 22 2d 22 29 0a 09 -hostname "-")..
1830: 09 09 09 09 09 09 69 70 61 64 64 72 73 74 72 0a ......ipaddrstr.
1840: 09 09 09 09 09 09 09 63 6f 6e 66 69 67 2d 68 6f .......config-ho
1850: 73 74 6e 61 6d 65 29 29 0a 09 20 20 28 73 74 61 stname)).. (sta
1860: 72 74 2d 73 65 72 76 65 72 20 70 6f 72 74 3a 20 rt-server port:
1870: 70 6f 72 74 6e 75 6d 29 29 0a 20 20 20 20 20 20 portnum)).
1880: 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 6e (portlogger:open
1890: 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 6c -run-close portl
18a0: 6f 67 67 65 72 3a 73 65 74 2d 70 6f 72 74 20 70 ogger:set-port p
18b0: 6f 72 74 6e 75 6d 20 22 72 65 6c 65 61 73 65 64 ortnum "released
18c0: 22 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a "). (debug:
18d0: 70 72 69 6e 74 20 31 20 2a 64 65 66 61 75 6c 74 print 1 *default
18e0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f -log-port* "INFO
18f0: 3a 20 73 65 72 76 65 72 20 68 61 73 20 62 65 65 : server has bee
1900: 6e 20 73 74 6f 70 70 65 64 22 29 29 29 29 0a 0a n stopped"))))..
1910: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
1920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1950: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 ========.;; S E
1960: 52 20 56 20 45 20 52 20 20 20 55 20 54 20 49 20 R V E R U T I
1970: 4c 20 49 20 54 20 49 20 45 20 53 20 0a 3b 3b 3d L I T I E S .;;=
1980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19c0: 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d =====..;;=======
19d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
1a10: 3b 3b 20 43 20 4c 20 49 20 45 20 4e 20 54 20 53 ;; C L I E N T S
1a20: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
1a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
1a70: 6e 65 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 20 ne *http-mutex*
1a80: 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 3b (make-mutex))..;
1a90: 3b 20 4e 4f 54 45 3a 20 4c 61 72 67 65 20 62 6c ; NOTE: Large bl
1aa0: 6f 63 6b 20 6f 66 20 63 6f 64 65 20 66 72 6f 6d ock of code from
1ab0: 20 33 32 34 33 36 62 34 32 36 31 38 38 30 38 30 32436b426188080
1ac0: 66 37 32 66 63 65 62 36 38 39 34 61 66 35 34 31 f72fceb6894af541
1ad0: 66 62 61 64 39 39 32 31 65 20 72 65 6d 6f 76 65 fbad9921e remove
1ae0: 64 20 68 65 72 65 0a 3b 3b 20 20 20 20 20 20 20 d here.;;
1af0: 49 27 6d 20 70 72 65 74 74 79 20 73 75 72 65 20 I'm pretty sure
1b00: 69 74 20 69 73 20 64 65 66 75 6e 63 74 2e 0a 0a it is defunct...
1b10: 3b 3b 20 54 68 69 73 20 6e 65 78 74 20 62 6c 6f ;; This next blo
1b20: 63 6b 20 61 6c 6c 20 69 6d 70 6f 72 74 65 64 20 ck all imported
1b30: 65 6e 2d 6d 61 73 73 20 66 72 6f 6d 20 74 68 65 en-mass from the
1b40: 20 61 70 69 20 62 72 61 6e 63 68 0a 28 64 65 66 api branch.(def
1b50: 69 6e 65 20 2a 68 74 74 70 2d 72 65 71 75 65 73 ine *http-reques
1b60: 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 ts-in-progress*
1b70: 30 29 0a 28 64 65 66 69 6e 65 20 2a 68 74 74 70 0).(define *http
1b80: 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 2d 6e 65 78 -connections-nex
1b90: 74 2d 63 6c 65 61 6e 75 70 2a 20 28 63 75 72 72 t-cleanup* (curr
1ba0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 0a 28 ent-seconds))..(
1bb0: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
1bc0: 6e 73 70 6f 72 74 3a 67 65 74 2d 74 69 6d 65 2d nsport:get-time-
1bd0: 74 6f 2d 63 6c 65 61 6e 75 70 29 0a 20 20 28 6c to-cleanup). (l
1be0: 65 74 20 28 28 72 65 73 20 23 66 29 29 0a 20 20 et ((res #f)).
1bf0: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
1c00: 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 20 http-mutex*).
1c10: 20 28 73 65 74 21 20 72 65 73 20 28 3e 20 28 63 (set! res (> (c
1c20: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
1c30: 2a 68 74 74 70 2d 63 6f 6e 6e 65 63 74 69 6f 6e *http-connection
1c40: 73 2d 6e 65 78 74 2d 63 6c 65 61 6e 75 70 2a 29 s-next-cleanup*)
1c50: 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c ). (mutex-unl
1c60: 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 ock! *http-mutex
1c70: 2a 29 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 64 *). res))..(d
1c80: 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e efine (http-tran
1c90: 73 70 6f 72 74 3a 69 6e 63 2d 72 65 71 75 65 73 sport:inc-reques
1ca0: 74 73 2d 63 6f 75 6e 74 29 0a 20 20 28 6d 75 74 ts-count). (mut
1cb0: 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d ex-lock! *http-m
1cc0: 75 74 65 78 2a 29 0a 20 20 28 73 65 74 21 20 2a utex*). (set! *
1cd0: 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e http-requests-in
1ce0: 2d 70 72 6f 67 72 65 73 73 2a 20 28 2b 20 31 20 -progress* (+ 1
1cf0: 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 *http-requests-i
1d00: 6e 2d 70 72 6f 67 72 65 73 73 2a 29 29 0a 20 20 n-progress*)).
1d10: 3b 3b 20 55 73 65 20 74 68 69 73 20 6f 70 70 6f ;; Use this oppo
1d20: 72 74 75 6e 69 74 79 20 74 6f 20 73 6c 6f 77 20 rtunity to slow
1d30: 74 68 69 6e 67 73 20 64 6f 77 6e 20 69 66 66 20 things down iff
1d40: 74 68 65 72 65 20 61 72 65 20 74 6f 6f 20 6d 61 there are too ma
1d50: 6e 79 20 72 65 71 75 65 73 74 73 20 69 6e 20 66 ny requests in f
1d60: 6c 69 67 68 74 0a 20 20 28 69 66 20 28 3e 20 2a light. (if (> *
1d70: 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e http-requests-in
1d80: 2d 70 72 6f 67 72 65 73 73 2a 20 35 29 0a 20 20 -progress* 5).
1d90: 20 20 20 20 28 62 65 67 69 6e 0a 09 28 64 65 62 (begin..(deb
1da0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
1db0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
1dc0: 74 2a 20 22 57 68 6f 61 20 74 68 65 72 65 20 62 t* "Whoa there b
1dd0: 75 64 64 79 2c 20 65 61 73 65 20 75 70 2e 2e 2e uddy, ease up...
1de0: 22 29 0a 09 28 74 68 72 65 61 64 2d 73 6c 65 65 ")..(thread-slee
1df0: 70 21 20 31 29 29 29 0a 20 20 28 6d 75 74 65 78 p! 1))). (mutex
1e00: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d -unlock! *http-m
1e10: 75 74 65 78 2a 29 29 0a 0a 28 64 65 66 69 6e 65 utex*))..(define
1e20: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
1e30: 3a 64 65 63 2d 72 65 71 75 65 73 74 73 2d 63 6f :dec-requests-co
1e40: 75 6e 74 20 70 72 6f 63 29 20 0a 20 20 28 6d 75 unt proc) . (mu
1e50: 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 2d tex-lock! *http-
1e60: 6d 75 74 65 78 2a 29 0a 20 20 28 70 72 6f 63 29 mutex*). (proc)
1e70: 0a 20 20 28 73 65 74 21 20 2a 68 74 74 70 2d 72 . (set! *http-r
1e80: 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 equests-in-progr
1e90: 65 73 73 2a 20 28 2d 20 2a 68 74 74 70 2d 72 65 ess* (- *http-re
1ea0: 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 quests-in-progre
1eb0: 73 73 2a 20 31 29 29 0a 20 20 28 6d 75 74 65 78 ss* 1)). (mutex
1ec0: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d -unlock! *http-m
1ed0: 75 74 65 78 2a 29 29 0a 0a 28 64 65 66 69 6e 65 utex*))..(define
1ee0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
1ef0: 3a 64 65 63 2d 72 65 71 75 65 73 74 73 2d 63 6f :dec-requests-co
1f00: 75 6e 74 2d 61 6e 64 2d 63 6c 6f 73 65 2d 61 6c unt-and-close-al
1f10: 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 29 0a 20 l-connections).
1f20: 20 28 73 65 74 21 20 2a 68 74 74 70 2d 72 65 71 (set! *http-req
1f30: 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 uests-in-progres
1f40: 73 2a 20 28 2d 20 2a 68 74 74 70 2d 72 65 71 75 s* (- *http-requ
1f50: 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 ests-in-progress
1f60: 2a 20 31 29 29 0a 20 20 28 6c 65 74 20 6c 6f 6f * 1)). (let loo
1f70: 70 20 28 28 65 74 69 6d 65 20 28 2b 20 28 63 75 p ((etime (+ (cu
1f80: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 35 rrent-seconds) 5
1f90: 29 29 29 20 3b 3b 20 67 69 76 65 20 75 70 20 69 ))) ;; give up i
1fa0: 6e 20 66 69 76 65 20 73 65 63 6f 6e 64 73 0a 20 n five seconds.
1fb0: 20 20 20 28 69 66 20 28 3e 20 2a 68 74 74 70 2d (if (> *http-
1fc0: 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 requests-in-prog
1fd0: 72 65 73 73 2a 20 30 29 0a 09 28 69 66 20 28 3e ress* 0)..(if (>
1fe0: 20 65 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d etime (current-
1ff0: 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 20 20 28 seconds)).. (
2000: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 74 68 begin.. (th
2010: 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 30 35 read-sleep! 0.05
2020: 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 65 ).. (loop e
2030: 74 69 6d 65 29 29 0a 09 20 20 20 20 28 64 65 62 time)).. (deb
2040: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
2050: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
2060: 72 74 2a 20 22 72 65 71 75 65 73 74 73 20 73 74 rt* "requests st
2070: 69 6c 6c 20 69 6e 20 70 72 6f 67 72 65 73 73 20 ill in progress
2080: 61 66 74 65 72 20 35 20 73 65 63 6f 6e 64 73 20 after 5 seconds
2090: 6f 66 20 77 61 69 74 69 6e 67 2e 20 49 27 6d 20 of waiting. I'm
20a0: 67 6f 69 6e 67 20 74 6f 20 70 61 73 73 20 6f 6e going to pass on
20b0: 20 63 6c 65 61 6e 69 6e 67 20 75 70 20 68 74 74 cleaning up htt
20c0: 70 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 22 29 29 p connections"))
20d0: 0a 09 28 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e ..(close-all-con
20e0: 6e 65 63 74 69 6f 6e 73 21 29 29 29 0a 20 20 28 nections!))). (
20f0: 73 65 74 21 20 2a 68 74 74 70 2d 63 6f 6e 6e 65 set! *http-conne
2100: 63 74 69 6f 6e 73 2d 6e 65 78 74 2d 63 6c 65 61 ctions-next-clea
2110: 6e 75 70 2a 20 28 2b 20 28 63 75 72 72 65 6e 74 nup* (+ (current
2120: 2d 73 65 63 6f 6e 64 73 29 20 31 30 29 29 0a 20 -seconds) 10)).
2130: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
2140: 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 29 0a 0a *http-mutex*))..
2150: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
2160: 61 6e 73 70 6f 72 74 3a 69 6e 63 2d 72 65 71 75 ansport:inc-requ
2170: 65 73 74 73 2d 61 6e 64 2d 70 72 65 70 2d 74 6f ests-and-prep-to
2180: 2d 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 -close-all-conne
2190: 63 74 69 6f 6e 73 29 0a 20 20 28 6d 75 74 65 78 ctions). (mutex
21a0: 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 -lock! *http-mut
21b0: 65 78 2a 29 0a 20 20 28 73 65 74 21 20 2a 68 74 ex*). (set! *ht
21c0: 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 tp-requests-in-p
21d0: 72 6f 67 72 65 73 73 2a 20 28 2b 20 31 20 2a 68 rogress* (+ 1 *h
21e0: 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d ttp-requests-in-
21f0: 70 72 6f 67 72 65 73 73 2a 29 29 29 0a 0a 3b 3b progress*)))..;;
2200: 20 53 65 6e 64 20 22 63 6d 64 22 20 77 69 74 68 Send "cmd" with
2210: 20 6a 73 6f 6e 20 70 61 79 6c 6f 61 64 20 22 70 json payload "p
2220: 61 72 61 6d 73 22 20 74 6f 20 73 65 72 76 65 72 arams" to server
2230: 64 61 74 20 61 6e 64 20 72 65 63 65 69 76 65 20 dat and receive
2240: 72 65 73 75 6c 74 0a 3b 3b 0a 28 64 65 66 69 6e result.;;.(defin
2250: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
2260: 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e t:client-api-sen
2270: 64 2d 72 65 63 65 69 76 65 20 72 75 6e 2d 69 64 d-receive run-id
2280: 20 73 65 72 76 65 72 64 61 74 20 63 6d 64 20 70 serverdat cmd p
2290: 61 72 61 6d 73 20 23 21 6b 65 79 20 28 6e 75 6d arams #!key (num
22a0: 72 65 74 72 69 65 73 20 33 29 28 61 72 65 61 2d retries 3)(area-
22b0: 64 61 74 20 23 66 29 29 0a 20 20 28 6c 65 74 2a dat #f)). (let*
22c0: 20 28 28 66 75 6c 6c 75 72 6c 20 20 20 20 28 69 ((fullurl (i
22d0: 66 20 28 76 65 63 74 6f 72 3f 20 73 65 72 76 65 f (vector? serve
22e0: 72 64 61 74 29 0a 09 09 09 20 28 68 74 74 70 2d rdat).... (http-
22f0: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
2300: 2d 64 61 74 2d 67 65 74 2d 61 70 69 2d 72 65 71 -dat-get-api-req
2310: 20 73 65 72 76 65 72 64 61 74 29 0a 09 09 09 20 serverdat)....
2320: 28 62 65 67 69 6e 0a 09 09 09 20 20 20 28 64 65 (begin.... (de
2330: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
2340: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
2350: 46 41 54 41 4c 20 45 52 52 4f 52 3a 20 68 74 74 FATAL ERROR: htt
2360: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 p-transport:clie
2370: 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 nt-api-send-rece
2380: 69 76 65 20 63 61 6c 6c 65 64 20 77 69 74 68 20 ive called with
2390: 6e 6f 20 73 65 72 76 65 72 20 69 6e 66 6f 22 29 no server info")
23a0: 0a 09 09 09 20 20 20 28 65 78 69 74 20 31 29 29 .... (exit 1))
23b0: 29 29 0a 09 20 28 72 65 73 20 20 20 20 20 20 20 )).. (res
23c0: 20 28 76 65 63 74 6f 72 20 23 66 20 22 75 6e 69 (vector #f "uni
23d0: 6e 69 74 69 61 6c 69 7a 65 64 22 29 29 0a 09 20 nitialized"))..
23e0: 28 73 75 63 63 65 73 73 20 20 20 20 23 74 29 0a (success #t).
23f0: 09 20 28 73 70 61 72 61 6d 73 20 20 20 20 28 64 . (sparams (d
2400: 62 3a 6f 62 6a 2d 3e 73 74 72 69 6e 67 20 70 61 b:obj->string pa
2410: 72 61 6d 73 20 74 72 61 6e 73 70 6f 72 74 3a 20 rams transport:
2420: 27 68 74 74 70 29 29 0a 09 20 28 72 75 6e 72 65 'http)).. (runre
2430: 6d 6f 74 65 20 20 28 6f 72 20 61 72 65 61 2d 64 mote (or area-d
2440: 61 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 29 at *runremote*))
2450: 29 0a 20 20 20 20 20 20 20 28 64 65 62 75 67 3a ). (debug:
2460: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 31 20 2a 64 print-info 11 *d
2470: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2480: 20 22 66 75 6c 6c 75 72 6c 3d 22 20 66 75 6c 6c "fullurl=" full
2490: 75 72 6c 20 22 2c 20 63 6d 64 3d 22 20 63 6d 64 url ", cmd=" cmd
24a0: 20 22 2c 20 70 61 72 61 6d 73 3d 22 20 70 61 72 ", params=" par
24b0: 61 6d 73 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 ams ", run-id="
24c0: 72 75 6e 2d 69 64 20 22 5c 6e 22 29 0a 20 20 20 run-id "\n").
24d0: 20 20 20 20 3b 3b 20 73 65 74 20 75 70 20 74 68 ;; set up th
24e0: 65 20 68 74 74 70 2d 63 6c 69 65 6e 74 20 68 65 e http-client he
24f0: 72 65 0a 20 20 20 20 20 20 20 28 6d 61 78 2d 72 re. (max-r
2500: 65 74 72 79 2d 61 74 74 65 6d 70 74 73 20 31 29 etry-attempts 1)
2510: 0a 20 20 20 20 20 20 20 3b 3b 20 63 6f 6e 73 69 . ;; consi
2520: 64 65 72 20 61 6c 6c 20 72 65 71 75 65 73 74 73 der all requests
2530: 20 69 6e 64 65 6d 70 6f 74 65 6e 74 0a 20 20 20 indempotent.
2540: 20 20 20 20 28 72 65 74 72 79 2d 72 65 71 75 65 (retry-reque
2550: 73 74 3f 20 28 6c 61 6d 62 64 61 20 28 72 65 71 st? (lambda (req
2560: 75 65 73 74 29 0a 09 09 09 20 23 66 29 29 0a 20 uest).... #f)).
2570: 20 20 20 20 20 20 3b 3b 20 73 65 6e 64 20 74 68 ;; send th
2580: 65 20 64 61 74 61 20 61 6e 64 20 67 65 74 20 74 e data and get t
2590: 68 65 20 72 65 73 70 6f 6e 73 65 0a 20 20 20 20 he response.
25a0: 20 20 20 3b 3b 20 65 78 74 72 61 63 74 20 74 68 ;; extract th
25b0: 65 20 6e 65 65 64 65 64 20 69 6e 66 6f 20 66 72 e needed info fr
25c0: 6f 6d 20 74 68 65 20 68 74 74 70 20 64 61 74 61 om the http data
25d0: 20 61 6e 64 20 0a 20 20 20 20 20 20 20 3b 3b 20 and . ;;
25e0: 70 72 6f 63 65 73 73 20 61 6e 64 20 72 65 74 75 process and retu
25f0: 72 6e 20 69 74 2e 0a 20 20 20 20 20 20 20 28 6c rn it.. (l
2600: 65 74 2a 20 28 28 73 65 6e 64 2d 72 65 63 69 65 et* ((send-recie
2610: 76 65 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 ve (lambda ()...
2620: 09 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f . (mutex-lo
2630: 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a ck! *http-mutex*
2640: 29 0a 09 09 09 20 20 20 20 20 20 3b 3b 20 28 63 ).... ;; (c
2650: 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 20 28 77 ondition-case (w
2660: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 ith-input-from-r
2670: 65 71 75 65 73 74 20 22 68 74 74 70 3a 2f 2f 6c equest "http://l
2680: 6f 63 61 6c 68 6f 73 74 22 3b 20 23 66 20 72 65 ocalhost"; #f re
2690: 61 64 2d 6c 69 6e 65 73 29 0a 09 09 09 20 20 20 ad-lines)....
26a0: 20 20 20 3b 3b 09 09 09 09 09 20 20 20 20 20 20 ;;.....
26b0: 20 28 28 65 78 6e 20 68 74 74 70 20 63 6c 69 65 ((exn http clie
26c0: 6e 74 2d 65 72 72 6f 72 29 20 65 20 28 70 72 69 nt-error) e (pri
26d0: 6e 74 20 65 29 29 29 0a 09 09 09 20 20 20 20 20 nt e)))....
26e0: 20 28 73 65 74 21 20 72 65 73 20 28 76 65 63 74 (set! res (vect
26f0: 6f 72 20 20 20 20 20 20 20 20 20 20 20 20 20 20 or
2700: 20 20 3b 3b 3b 20 44 4f 4e 27 54 20 46 4f 52 47 ;;; DON'T FORG
2710: 45 54 20 2d 20 54 48 49 53 20 49 53 20 54 48 45 ET - THIS IS THE
2720: 20 43 4c 49 45 4e 54 20 53 49 44 45 21 20 4e 4f CLIENT SIDE! NO
2730: 54 45 3a 20 63 6f 6e 73 69 64 65 72 20 6d 6f 76 TE: consider mov
2740: 69 6e 67 20 74 68 69 73 20 74 6f 20 63 6c 69 65 ing this to clie
2750: 6e 74 2e 73 63 6d 20 73 69 6e 63 65 20 77 65 20 nt.scm since we
2760: 61 72 65 20 6f 6e 6c 79 20 73 75 70 70 6f 72 74 are only support
2770: 69 6e 67 20 68 74 74 70 20 74 72 61 6e 73 70 6f ing http transpo
2780: 72 74 20 61 74 20 74 68 69 73 20 74 69 6d 65 2e rt at this time.
2790: 0a 09 09 09 09 09 20 73 75 63 63 65 73 73 0a 09 ...... success..
27a0: 09 09 09 09 20 28 64 62 3a 73 74 72 69 6e 67 2d .... (db:string-
27b0: 3e 6f 62 6a 20 0a 09 09 09 09 09 20 20 28 68 61 >obj ...... (ha
27c0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
27d0: 09 09 09 09 09 20 20 20 20 20 20 65 78 6e 0a 09 ..... exn..
27e0: 09 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 .... (let (
27f0: 28 63 61 6c 6c 2d 63 68 61 69 6e 20 28 67 65 74 (call-chain (get
2800: 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 29 0a 09 09 -call-chain))...
2810: 09 09 09 09 20 20 20 20 28 6d 73 67 20 20 20 20 .... (msg
2820: 20 20 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d ((condition-
2830: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
2840: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
2850: 20 65 78 6e 29 29 29 0a 09 09 09 09 09 09 28 73 exn))).......(s
2860: 65 74 21 20 73 75 63 63 65 73 73 20 23 66 29 0a et! success #f).
2870: 09 09 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 ......(debug:pri
2880: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
2890: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
28a0: 3a 20 66 61 69 6c 75 72 65 20 69 6e 20 77 69 74 : failure in wit
28b0: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 65 71 h-input-from-req
28c0: 75 65 73 74 20 74 6f 20 22 20 66 75 6c 6c 75 72 uest to " fullur
28d0: 6c 20 22 2e 22 29 0a 09 09 09 09 09 09 28 64 65 l ".").......(de
28e0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
28f0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
2900: 20 6d 65 73 73 61 67 65 3a 20 22 20 6d 73 67 29 message: " msg)
2910: 0a 09 09 09 09 09 09 28 64 65 62 75 67 3a 70 72 .......(debug:pr
2920: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
2930: 6f 67 2d 70 6f 72 74 2a 20 22 20 63 6d 64 3a 20 og-port* " cmd:
2940: 22 20 63 6d 64 20 22 20 70 61 72 61 6d 73 3a 20 " cmd " params:
2950: 22 20 70 61 72 61 6d 73 29 0a 20 20 20 20 20 20 " params).
2960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2980: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
2990: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
29a0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 63 61 t-log-port* " ca
29b0: 6c 6c 2d 63 68 61 69 6e 3a 20 22 20 63 61 6c 6c ll-chain: " call
29c0: 2d 63 68 61 69 6e 29 0a 09 09 09 09 09 09 28 69 -chain).......(i
29d0: 66 20 72 75 6e 72 65 6d 6f 74 65 0a 09 09 09 09 f runremote.....
29e0: 09 09 20 20 20 20 28 72 65 6d 6f 74 65 2d 63 6f .. (remote-co
29f0: 6e 6e 64 61 74 2d 73 65 74 21 20 72 75 6e 72 65 nndat-set! runre
2a00: 6d 6f 74 65 20 23 66 29 29 0a 09 09 09 09 09 09 mote #f)).......
2a10: 3b 3b 20 4b 69 6c 6c 69 6e 67 20 61 73 73 6f 63 ;; Killing assoc
2a20: 69 61 74 65 64 20 73 65 72 76 65 72 20 74 6f 20 iated server to
2a30: 61 6c 6c 6f 77 20 63 6c 65 61 6e 20 72 65 74 72 allow clean retr
2a40: 79 2e 22 29 0a 09 09 09 09 09 09 3b 3b 20 28 74 y.").......;; (t
2a50: 61 73 6b 73 3a 6b 69 6c 6c 2d 73 65 72 76 65 72 asks:kill-server
2a60: 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 29 20 -run-id run-id)
2a70: 20 3b 3b 20 62 65 74 74 65 72 20 74 6f 20 6b 69 ;; better to ki
2a80: 6c 6c 20 74 68 65 20 73 65 72 76 65 72 20 69 6e ll the server in
2a90: 20 74 68 65 20 6c 6f 67 69 63 20 74 68 61 74 20 the logic that
2aa0: 63 61 6c 6c 65 64 20 74 68 69 73 20 72 6f 75 74 called this rout
2ab0: 69 6e 65 3f 0a 09 09 09 09 09 09 28 6d 75 74 65 ine?.......(mute
2ac0: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d x-unlock! *http-
2ad0: 6d 75 74 65 78 2a 29 0a 09 09 09 09 09 20 20 20 mutex*)......
2ae0: 20 20 3b 3b 3b 20 28 73 69 67 6e 61 6c 20 28 6d ;;; (signal (m
2af0: 61 6b 65 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 6f ake-composite-co
2b00: 6e 64 69 74 69 6f 6e 0a 09 09 09 09 09 20 20 20 ndition......
2b10: 20 20 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 28 ;;; (
2b20: 6d 61 6b 65 2d 70 72 6f 70 65 72 74 79 2d 63 6f make-property-co
2b30: 6e 64 69 74 69 6f 6e 20 27 63 6f 6d 6d 66 61 69 ndition 'commfai
2b40: 6c 20 27 6d 65 73 73 61 67 65 20 22 66 61 69 6c l 'message "fail
2b50: 65 64 20 74 6f 20 63 6f 6e 6e 65 63 74 20 74 6f ed to connect to
2b60: 20 73 65 72 76 65 72 22 29 29 29 0a 09 09 09 09 server"))).....
2b70: 09 20 20 20 20 20 3b 3b 3b 20 22 63 6f 6d 6d 75 . ;;; "commu
2b80: 6e 69 63 61 74 69 6f 6e 73 20 66 61 69 6c 65 64 nications failed
2b90: 22 0a 09 09 09 09 09 09 28 64 62 3a 6f 62 6a 2d ".......(db:obj-
2ba0: 3e 73 74 72 69 6e 67 20 23 66 29 29 0a 09 09 09 >string #f))....
2bb0: 09 09 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 .. (with-inpu
2bc0: 74 2d 66 72 6f 6d 2d 72 65 71 75 65 73 74 20 3b t-from-request ;
2bd0: 3b 20 77 61 73 20 64 61 74 0a 09 09 09 09 09 20 ; was dat......
2be0: 20 20 20 20 66 75 6c 6c 75 72 6c 20 0a 09 09 09 fullurl ....
2bf0: 09 09 20 20 20 20 20 28 6c 69 73 74 20 28 63 6f .. (list (co
2c00: 6e 73 20 27 6b 65 79 20 28 6f 72 20 2a 73 65 72 ns 'key (or *ser
2c10: 76 65 72 2d 69 64 2a 20 22 74 68 65 6b 65 79 22 ver-id* "thekey"
2c20: 29 29 0a 09 09 09 09 09 09 20 20 20 28 63 6f 6e ))....... (con
2c30: 73 20 27 63 6d 64 20 63 6d 64 29 0a 09 09 09 09 s 'cmd cmd).....
2c40: 09 09 20 20 20 28 63 6f 6e 73 20 27 70 61 72 61 .. (cons 'para
2c50: 6d 73 20 73 70 61 72 61 6d 73 29 29 0a 09 09 09 ms sparams))....
2c60: 09 09 20 20 20 20 20 72 65 61 64 2d 73 74 72 69 .. read-stri
2c70: 6e 67 29 29 0a 09 09 09 09 09 20 20 74 72 61 6e ng))...... tran
2c80: 73 70 6f 72 74 3a 20 27 68 74 74 70 29 0a 20 20 sport: 'http).
2c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cb0: 20 20 20 20 20 20 20 30 29 29 20 3b 3b 20 61 64 0)) ;; ad
2cc0: 64 65 64 20 74 68 69 73 20 73 70 65 63 75 6c 61 ded this specula
2cd0: 74 69 76 65 6c 79 0a 09 09 09 20 20 20 20 20 20 tively....
2ce0: 3b 3b 20 53 68 6f 75 6c 64 6e 27 74 20 74 68 69 ;; Shouldn't thi
2cf0: 73 20 62 65 20 61 20 63 61 6c 6c 20 74 6f 20 74 s be a call to t
2d00: 68 65 20 6d 61 6e 61 67 65 64 20 63 61 6c 6c 2d he managed call-
2d10: 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 all-connections
2d20: 73 74 75 66 66 20 61 62 6f 76 65 3f 0a 09 09 09 stuff above?....
2d30: 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 61 6c 6c (close-all
2d40: 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 0a 09 -connections!)..
2d50: 09 09 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 .. (mutex-u
2d60: 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 nlock! *http-mut
2d70: 65 78 2a 29 0a 09 09 09 20 20 20 20 20 20 29 29 ex*).... ))
2d80: 0a 09 20 20 20 20 20 20 28 74 69 6d 65 2d 6f 75 .. (time-ou
2d90: 74 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 t (lambda ()
2da0: 0a 09 09 09 20 20 20 20 20 20 28 74 68 72 65 61 .... (threa
2db0: 64 2d 73 6c 65 65 70 21 20 34 35 29 0a 09 09 09 d-sleep! 45)....
2dc0: 20 20 20 20 20 20 23 66 29 29 0a 09 20 20 20 20 #f))..
2dd0: 20 20 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 (th1 (make-thr
2de0: 65 61 64 20 73 65 6e 64 2d 72 65 63 69 65 76 65 ead send-recieve
2df0: 20 22 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f "with-input-fro
2e00: 6d 2d 72 65 71 75 65 73 74 22 29 29 0a 09 20 20 m-request"))..
2e10: 20 20 20 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 (th2 (make-t
2e20: 68 72 65 61 64 20 74 69 6d 65 2d 6f 75 74 20 20 hread time-out
2e30: 20 20 20 22 74 69 6d 65 20 6f 75 74 22 29 29 29 "time out")))
2e40: 0a 09 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 .. (thread-start
2e50: 21 20 74 68 31 29 0a 09 20 28 74 68 72 65 61 64 ! th1).. (thread
2e60: 2d 73 74 61 72 74 21 20 74 68 32 29 0a 09 20 28 -start! th2).. (
2e70: 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 thread-join! th1
2e80: 29 0a 09 20 28 74 68 72 65 61 64 2d 74 65 72 6d ).. (thread-term
2e90: 69 6e 61 74 65 21 20 74 68 32 29 0a 09 20 28 64 inate! th2).. (d
2ea0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
2eb0: 31 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 11 *default-log-
2ec0: 70 6f 72 74 2a 20 22 67 6f 74 20 72 65 73 3d 22 port* "got res="
2ed0: 20 72 65 73 29 0a 09 20 28 69 66 20 28 76 65 63 res).. (if (vec
2ee0: 74 6f 72 3f 20 72 65 73 29 0a 09 20 20 20 20 20 tor? res)..
2ef0: 28 69 66 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (if (vector-ref
2f00: 72 65 73 20 30 29 20 3b 3b 20 74 68 69 73 20 69 res 0) ;; this i
2f10: 73 20 74 68 65 20 66 69 72 73 74 20 66 6c 61 67 s the first flag
2f20: 20 6f 72 20 74 68 65 20 73 65 63 6f 6e 64 20 66 or the second f
2f30: 6c 61 67 3f 0a 09 09 20 72 65 73 20 3b 3b 20 74 lag?... res ;; t
2f40: 68 69 73 20 69 73 20 74 68 65 20 2a 69 6e 6e 65 his is the *inne
2f50: 72 2a 20 76 65 63 74 6f 72 3f 20 73 65 72 69 6f r* vector? serio
2f60: 75 73 6c 79 3f 20 77 68 79 3f 0a 20 20 20 20 20 usly? why?.
2f70: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
2f80: 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 (debug:debug-mod
2f90: 65 20 31 31 29 0a 20 20 20 20 20 20 20 20 20 20 e 11).
2fa0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
2fb0: 28 28 63 61 6c 6c 2d 63 68 61 69 6e 20 28 67 65 ((call-chain (ge
2fc0: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 29 29 20 t-call-chain)))
2fd0: 3b 3b 20 6e 6f 74 65 3a 20 74 68 69 73 20 63 6f ;; note: this co
2fe0: 64 65 20 61 6c 73 6f 20 63 61 6c 6c 65 64 20 69 de also called i
2ff0: 6e 20 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 n nmsg-transport
3000: 20 2d 20 63 6f 6e 73 69 64 65 72 20 63 6f 6e 73 - consider cons
3010: 6f 6c 69 64 61 74 69 6e 67 20 69 74 0a 20 20 20 olidating it.
3020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3030: 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d (print-call-
3040: 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 chain (current-e
3050: 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 20 20 rror-port)).
3060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3070: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
3080: 65 72 72 6f 72 20 31 31 20 2a 64 65 66 61 75 6c error 11 *defaul
3090: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 65 72 72 t-log-port* "err
30a0: 6f 72 20 61 62 6f 76 65 20 6f 63 63 75 72 65 64 or above occured
30b0: 20 61 74 20 73 65 72 76 65 72 2c 20 72 65 73 3d at server, res=
30c0: 22 20 72 65 73 20 22 20 6d 65 73 73 61 67 65 3a " res " message:
30d0: 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
30e0: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
30f0: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
3100: 65 78 6e 29 29 0a 20 20 20 20 20 20 20 20 20 20 exn)).
3110: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
3120: 62 75 67 3a 70 72 69 6e 74 20 31 31 20 2a 64 65 bug:print 11 *de
3130: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
3140: 22 20 73 65 72 76 65 72 20 63 61 6c 6c 20 63 68 " server call ch
3150: 61 69 6e 3a 22 29 0a 20 20 20 20 20 20 20 20 20 ain:").
3160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
3170: 70 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 p (vector-ref re
3180: 73 20 31 29 20 28 63 75 72 72 65 6e 74 2d 65 72 s 1) (current-er
3190: 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 20 20 20 ror-port)).
31a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
31b0: 20 20 28 73 69 67 6e 61 6c 20 28 76 65 63 74 6f (signal (vecto
31c0: 72 2d 72 65 66 20 72 65 73 20 30 29 29 29 0a 20 r-ref res 0))).
31d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
31e0: 20 20 20 20 72 65 73 29 29 0a 09 20 20 20 20 20 res))..
31f0: 28 73 69 67 6e 61 6c 20 28 6d 61 6b 65 2d 63 6f (signal (make-co
3200: 6d 70 6f 73 69 74 65 2d 63 6f 6e 64 69 74 69 6f mposite-conditio
3210: 6e 0a 09 09 20 20 20 20 20 20 28 6d 61 6b 65 2d n... (make-
3220: 70 72 6f 70 65 72 74 79 2d 63 6f 6e 64 69 74 69 property-conditi
3230: 6f 6e 20 0a 09 09 20 20 20 20 20 20 20 27 74 69 on ... 'ti
3240: 6d 65 6f 75 74 0a 09 09 20 20 20 20 20 20 20 27 meout... '
3250: 6d 65 73 73 61 67 65 20 22 6e 6d 73 67 2d 74 72 message "nmsg-tr
3260: 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 ansport:client-a
3270: 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 2d pi-send-receive-
3280: 72 61 77 20 74 69 6d 65 64 20 6f 75 74 20 74 61 raw timed out ta
3290: 6c 6b 69 6e 67 20 74 6f 20 73 65 72 76 65 72 22 lking to server"
32a0: 29 29 29 29 29 29 29 0a 0a 3b 3b 20 63 61 72 65 )))))))..;; care
32b0: 66 75 6c 20 63 6c 6f 73 69 6e 67 20 6f 66 20 63 ful closing of c
32c0: 6f 6e 6e 65 63 74 69 6f 6e 73 20 73 74 6f 72 65 onnections store
32d0: 64 20 69 6e 20 2a 72 75 6e 72 65 6d 6f 74 65 2a d in *runremote*
32e0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 74 .;;.(define (htt
32f0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 6f 73 p-transport:clos
3300: 65 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 23 21 e-connections #!
3310: 6b 65 79 20 28 61 72 65 61 2d 64 61 74 20 23 66 key (area-dat #f
3320: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 75 6e )). (let* ((run
3330: 72 65 6d 6f 74 65 20 20 28 6f 72 20 61 72 65 61 remote (or area
3340: 2d 64 61 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a -dat *runremote*
3350: 29 29 0a 09 20 28 73 65 72 76 65 72 2d 64 61 74 )).. (server-dat
3360: 20 28 69 66 20 72 75 6e 72 65 6d 6f 74 65 0a 20 (if runremote.
3370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3380: 20 20 20 20 20 20 20 20 28 72 65 6d 6f 74 65 2d (remote-
3390: 63 6f 6e 6e 64 61 74 20 72 75 6e 72 65 6d 6f 74 conndat runremot
33a0: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
33b0: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 29 #f))
33c0: 29 20 3b 3b 20 28 68 61 73 68 2d 74 61 62 6c 65 ) ;; (hash-table
33d0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 72 75 -ref/default *ru
33e0: 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 nremote* run-id
33f0: 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 76 #f))). (if (v
3400: 65 63 74 6f 72 3f 20 73 65 72 76 65 72 2d 64 61 ector? server-da
3410: 74 29 0a 09 28 6c 65 74 20 28 28 61 70 69 2d 64 t)..(let ((api-d
3420: 61 74 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f at (http-transpo
3430: 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 rt:server-dat-ge
3440: 74 2d 61 70 69 2d 75 72 69 20 73 65 72 76 65 72 t-api-uri server
3450: 2d 64 61 74 29 29 29 0a 09 20 20 28 68 61 6e 64 -dat))).. (hand
3460: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 le-exceptions..
3470: 20 20 20 65 78 6e 0a 09 20 20 20 20 28 62 65 67 exn.. (beg
3480: 69 6e 0a 09 20 20 20 20 20 20 28 70 72 69 6e 74 in.. (print
3490: 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 2a 64 65 66 -call-chain *def
34a0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 29 0a ault-log-port*).
34b0: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
34c0: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
34d0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
34e0: 20 63 6c 6f 73 69 6e 67 20 63 6f 6e 6e 65 63 74 closing connect
34f0: 69 6f 6e 20 66 61 69 6c 65 64 20 77 69 74 68 20 ion failed with
3500: 65 72 72 6f 72 3a 20 22 20 28 28 63 6f 6e 64 69 error: " ((condi
3510: 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 tion-property-ac
3520: 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 cessor 'exn 'mes
3530: 73 61 67 65 29 20 65 78 6e 29 29 29 0a 09 20 20 sage) exn)))..
3540: 20 20 28 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 (close-connect
3550: 69 6f 6e 21 20 61 70 69 2d 64 61 74 29 0a 20 20 ion! api-dat).
3560: 20 20 20 20 20 20 20 20 20 20 3b 3b 28 63 6c 6f ;;(clo
3570: 73 65 2d 69 64 6c 65 2d 63 6f 6e 6e 65 63 74 69 se-idle-connecti
3580: 6f 6e 73 21 29 0a 09 20 20 20 20 23 74 29 29 0a ons!).. #t)).
3590: 09 23 66 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 .#f)))...(define
35a0: 20 28 6d 61 6b 65 2d 68 74 74 70 2d 74 72 61 6e (make-http-tran
35b0: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 sport:server-dat
35c0: 29 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 36 29 )(make-vector 6)
35d0: 29 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ).(define (http-
35e0: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
35f0: 2d 64 61 74 2d 67 65 74 2d 69 66 61 63 65 20 20 -dat-get-iface
3600: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
3610: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
3620: 30 29 29 0a 28 64 65 66 69 6e 65 20 28 68 74 74 0)).(define (htt
3630: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 p-transport:serv
3640: 65 72 2d 64 61 74 2d 67 65 74 2d 70 6f 72 74 20 er-dat-get-port
3650: 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 vec)
3660: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
3670: 63 20 31 29 29 0a 28 64 65 66 69 6e 65 20 28 68 c 1)).(define (h
3680: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 ttp-transport:se
3690: 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 61 70 69 rver-dat-get-api
36a0: 2d 75 72 69 20 20 20 20 20 20 20 76 65 63 29 20 -uri vec)
36b0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
36c0: 76 65 63 20 32 29 29 0a 28 64 65 66 69 6e 65 20 vec 2)).(define
36d0: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
36e0: 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 61 server-dat-get-a
36f0: 70 69 2d 75 72 6c 20 20 20 20 20 20 20 76 65 63 pi-url vec
3700: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
3710: 20 20 76 65 63 20 33 29 29 0a 28 64 65 66 69 6e vec 3)).(defin
3720: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
3730: 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 t:server-dat-get
3740: 2d 61 70 69 2d 72 65 71 20 20 20 20 20 20 20 76 -api-req v
3750: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
3760: 65 66 20 20 76 65 63 20 34 29 29 0a 28 64 65 66 ef vec 4)).(def
3770: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
3780: 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 ort:server-dat-g
3790: 65 74 2d 6c 61 73 74 2d 61 63 63 65 73 73 20 20 et-last-access
37a0: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
37b0: 2d 72 65 66 20 20 76 65 63 20 35 29 29 0a 28 64 -ref vec 5)).(d
37c0: 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e efine (http-tran
37d0: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 sport:server-dat
37e0: 2d 67 65 74 2d 73 6f 63 6b 65 74 20 20 20 20 20 -get-socket
37f0: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
3800: 6f 72 2d 72 65 66 20 20 76 65 63 20 36 29 29 0a or-ref vec 6)).
3810: 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 .(define (http-t
3820: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
3830: 64 61 74 2d 6d 61 6b 65 2d 75 72 6c 20 76 65 63 dat-make-url vec
3840: 29 0a 20 20 28 69 66 20 28 61 6e 64 20 28 68 74 ). (if (and (ht
3850: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
3860: 76 65 72 2d 64 61 74 2d 67 65 74 2d 69 66 61 63 ver-dat-get-ifac
3870: 65 20 76 65 63 29 0a 09 20 20 20 28 68 74 74 70 e vec).. (http
3880: 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 -transport:serve
3890: 72 2d 64 61 74 2d 67 65 74 2d 70 6f 72 74 20 20 r-dat-get-port
38a0: 76 65 63 29 29 0a 20 20 20 20 20 20 28 63 6f 6e vec)). (con
38b0: 63 20 22 68 74 74 70 3a 2f 2f 22 20 0a 09 20 20 c "http://" ..
38c0: 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 (http-transpor
38d0: 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 t:server-dat-get
38e0: 2d 69 66 61 63 65 20 76 65 63 29 0a 09 20 20 20 -iface vec)..
38f0: 20 22 3a 22 0a 09 20 20 20 20 28 68 74 74 70 2d ":".. (http-
3900: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
3910: 2d 64 61 74 2d 67 65 74 2d 70 6f 72 74 20 20 76 -dat-get-port v
3920: 65 63 29 29 0a 20 20 20 20 20 20 23 66 29 29 0a ec)). #f)).
3930: 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 .(define (http-t
3940: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
3950: 64 61 74 2d 75 70 64 61 74 65 2d 6c 61 73 74 2d dat-update-last-
3960: 61 63 63 65 73 73 20 76 65 63 29 0a 20 20 28 69 access vec). (i
3970: 66 20 28 76 65 63 74 6f 72 3f 20 76 65 63 29 0a f (vector? vec).
3980: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 (vector-se
3990: 74 21 20 76 65 63 20 35 20 28 63 75 72 72 65 6e t! vec 5 (curren
39a0: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 20 20 20 20 t-seconds)).
39b0: 20 20 28 62 65 67 69 6e 0a 09 28 70 72 69 6e 74 (begin..(print
39c0: 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 -call-chain (cur
39d0: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
39e0: 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d )..(debug:print-
39f0: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
3a00: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 6c 6c -log-port* "call
3a10: 20 74 6f 20 68 74 74 70 2d 74 72 61 6e 73 70 6f to http-transpo
3a20: 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 75 70 rt:server-dat-up
3a30: 64 61 74 65 2d 6c 61 73 74 2d 61 63 63 65 73 73 date-last-access
3a40: 20 77 69 74 68 20 6e 6f 6e 2d 76 65 63 74 6f 72 with non-vector
3a50: 21 21 22 29 29 29 29 0a 0a 3b 3b 0a 3b 3b 20 63 !!"))))..;;.;; c
3a60: 6f 6e 6e 65 63 74 0a 3b 3b 0a 28 64 65 66 69 6e onnect.;;.(defin
3a70: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
3a80: 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 t:client-connect
3a90: 20 69 66 61 63 65 20 70 6f 72 74 29 0a 20 20 28 iface port). (
3aa0: 6c 65 74 2a 20 28 28 61 70 69 2d 75 72 6c 20 20 let* ((api-url
3ab0: 20 20 20 20 28 63 6f 6e 63 20 22 68 74 74 70 3a (conc "http:
3ac0: 2f 2f 22 20 69 66 61 63 65 20 22 3a 22 20 70 6f //" iface ":" po
3ad0: 72 74 20 22 2f 61 70 69 22 29 29 0a 09 20 28 61 rt "/api")).. (a
3ae0: 70 69 2d 75 72 69 20 20 20 20 20 20 28 75 72 69 pi-uri (uri
3af0: 2d 72 65 66 65 72 65 6e 63 65 20 28 63 6f 6e 63 -reference (conc
3b00: 20 22 68 74 74 70 3a 2f 2f 22 20 69 66 61 63 65 "http://" iface
3b10: 20 22 3a 22 20 70 6f 72 74 20 22 2f 61 70 69 22 ":" port "/api"
3b20: 29 29 29 0a 09 20 28 61 70 69 2d 72 65 71 20 20 ))).. (api-req
3b30: 20 20 20 20 28 6d 61 6b 65 2d 72 65 71 75 65 73 (make-reques
3b40: 74 20 6d 65 74 68 6f 64 3a 20 27 50 4f 53 54 20 t method: 'POST
3b50: 75 72 69 3a 20 61 70 69 2d 75 72 69 29 29 0a 09 uri: api-uri))..
3b60: 20 28 73 65 72 76 65 72 2d 64 61 74 20 20 20 28 (server-dat (
3b70: 76 65 63 74 6f 72 20 69 66 61 63 65 20 70 6f 72 vector iface por
3b80: 74 20 61 70 69 2d 75 72 69 20 61 70 69 2d 75 72 t api-uri api-ur
3b90: 6c 20 61 70 69 2d 72 65 71 20 28 63 75 72 72 65 l api-req (curre
3ba0: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a 20 nt-seconds)))).
3bb0: 20 20 20 73 65 72 76 65 72 2d 64 61 74 29 29 0a server-dat)).
3bc0: 0a 3b 3b 20 72 75 6e 20 68 74 74 70 2d 74 72 61 .;; run http-tra
3bd0: 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e nsport:keep-runn
3be0: 69 6e 67 20 69 6e 20 61 20 70 61 72 61 6c 6c 65 ing in a paralle
3bf0: 6c 20 74 68 72 65 61 64 20 74 6f 20 6d 6f 6e 69 l thread to moni
3c00: 74 6f 72 20 74 68 61 74 20 74 68 65 20 64 62 20 tor that the db
3c10: 69 73 20 62 65 69 6e 67 20 0a 3b 3b 20 75 73 65 is being .;; use
3c20: 64 20 61 6e 64 20 74 6f 20 73 68 75 74 64 6f 77 d and to shutdow
3c30: 6e 20 61 66 74 65 72 20 73 6f 6d 65 74 69 6d 65 n after sometime
3c40: 20 69 66 20 69 74 20 69 73 20 6e 6f 74 2e 0a 3b if it is not..;
3c50: 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ;.(define (http-
3c60: 74 72 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 transport:keep-r
3c70: 75 6e 6e 69 6e 67 29 20 0a 20 20 3b 3b 20 69 66 unning) . ;; if
3c80: 20 6e 6f 6e 65 20 72 75 6e 6e 69 6e 67 20 6f 72 none running or
3c90: 20 69 66 20 3e 20 32 30 20 73 65 63 6f 6e 64 73 if > 20 seconds
3ca0: 20 73 69 6e 63 65 20 0a 20 20 3b 3b 20 73 65 72 since . ;; ser
3cb0: 76 65 72 20 6c 61 73 74 20 75 73 65 64 20 74 68 ver last used th
3cc0: 65 6e 20 73 74 61 72 74 20 73 68 75 74 64 6f 77 en start shutdow
3cd0: 6e 0a 20 20 3b 3b 20 54 68 69 73 20 74 68 72 65 n. ;; This thre
3ce0: 61 64 20 77 61 69 74 73 20 66 6f 72 20 74 68 65 ad waits for the
3cf0: 20 73 65 72 76 65 72 20 74 6f 20 63 6f 6d 65 20 server to come
3d00: 61 6c 69 76 65 0a 20 20 28 64 65 62 75 67 3a 70 alive. (debug:p
3d10: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
3d20: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
3d30: 53 74 61 72 74 69 6e 67 20 74 68 65 20 73 79 6e Starting the syn
3d40: 63 2d 62 61 63 6b 2c 20 6b 65 65 70 20 61 6c 69 c-back, keep ali
3d50: 76 65 20 74 68 72 65 61 64 20 69 6e 20 73 65 72 ve thread in ser
3d60: 76 65 72 22 29 0a 20 20 28 6c 65 74 2a 20 28 28 ver"). (let* ((
3d70: 74 6d 70 2d 61 72 65 61 20 20 20 20 20 20 20 20 tmp-area
3d80: 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 62 (common:get-db
3d90: 2d 74 6d 70 2d 61 72 65 61 29 29 0a 09 20 28 73 -tmp-area)).. (s
3da0: 74 61 72 74 65 64 2d 66 69 6c 65 20 20 20 20 20 tarted-file
3db0: 20 28 63 6f 6e 63 20 74 6d 70 2d 61 72 65 61 20 (conc tmp-area
3dc0: 22 2f 2e 73 65 72 76 65 72 2d 73 74 61 72 74 65 "/.server-starte
3dd0: 64 22 29 29 0a 09 20 28 73 65 72 76 65 72 2d 73 d")).. (server-s
3de0: 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 tart-time (curre
3df0: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 28 nt-seconds)).. (
3e00: 73 65 72 76 65 72 2d 69 6e 66 6f 20 28 6c 65 74 server-info (let
3e10: 20 6c 6f 6f 70 20 28 28 73 74 61 72 74 2d 74 69 loop ((start-ti
3e20: 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f me (current-seco
3e30: 6e 64 73 29 29 0a 09 09 09 09 20 28 63 68 61 6e nds))..... (chan
3e40: 67 65 64 20 20 20 20 23 74 29 0a 09 09 09 09 20 ged #t).....
3e50: 28 6c 61 73 74 2d 73 64 61 74 20 20 22 6e 6f 74 (last-sdat "not
3e60: 20 74 68 69 73 22 29 29 0a 20 20 20 20 20 20 20 this")).
3e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3e80: 20 28 6c 65 74 20 28 28 73 64 61 74 20 23 66 29 (let ((sdat #f)
3e90: 29 0a 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 ).... (thread-s
3ea0: 6c 65 65 70 21 20 30 2e 30 31 29 0a 09 09 09 20 leep! 0.01)....
3eb0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
3ec0: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
3ed0: 67 2d 70 6f 72 74 2a 20 22 57 61 69 74 69 6e 67 g-port* "Waiting
3ee0: 20 66 6f 72 20 73 65 72 76 65 72 20 61 6c 69 76 for server aliv
3ef0: 65 20 73 69 67 6e 61 74 75 72 65 22 29 0a 20 20 e signature").
3f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3f10: 20 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c (mutex-l
3f20: 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d ock! *heartbeat-
3f30: 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 20 20 mutex*).
3f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3f50: 20 20 28 73 65 74 21 20 73 64 61 74 20 2a 73 65 (set! sdat *se
3f60: 72 76 65 72 2d 69 6e 66 6f 2a 29 0a 20 20 20 20 rver-info*).
3f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3f80: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
3f90: 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d ock! *heartbeat-
3fa0: 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 20 20 mutex*).
3fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3fc0: 20 20 28 69 66 20 28 61 6e 64 20 73 64 61 74 0a (if (and sdat.
3fd0: 09 09 09 09 20 20 20 28 6e 6f 74 20 63 68 61 6e .... (not chan
3fe0: 67 65 64 29 0a 09 09 09 09 20 20 20 28 3e 20 28 ged)..... (> (
3ff0: 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
4000: 64 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 20 ds) start-time)
4010: 32 29 29 0a 09 09 09 20 20 20 20 20 20 28 62 65 2)).... (be
4020: 67 69 6e 0a 09 09 09 09 28 64 65 62 75 67 3a 70 gin.....(debug:p
4030: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
4040: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4050: 52 65 63 65 69 76 65 64 20 73 65 72 76 65 72 20 Received server
4060: 61 6c 69 76 65 20 73 69 67 6e 61 74 75 72 65 22 alive signature"
4070: 29 0a 09 09 09 09 73 64 61 74 29 0a 20 20 20 20 ).....sdat).
4080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4090: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
40a0: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
40b0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
40c0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 74 69 t-log-port* "Sti
40d0: 6c 6c 20 77 61 69 74 69 6e 67 2c 20 6c 61 73 74 ll waiting, last
40e0: 2d 73 64 61 74 3d 22 20 6c 61 73 74 2d 73 64 61 -sdat=" last-sda
40f0: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
4100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4110: 20 20 20 28 73 6c 65 65 70 20 34 29 0a 09 09 09 (sleep 4)....
4120: 09 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 .(if (> (- (curr
4130: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 74 61 ent-seconds) sta
4140: 72 74 2d 74 69 6d 65 29 20 31 32 30 29 20 3b 3b rt-time) 120) ;;
4150: 20 62 65 65 6e 20 77 61 69 74 69 6e 67 20 66 6f been waiting fo
4160: 72 20 74 77 6f 20 6d 69 6e 75 74 65 73 0a 09 09 r two minutes...
4170: 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 .. (begin....
4180: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
4190: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
41a0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
41b0: 74 72 61 6e 73 70 6f 72 74 20 61 70 70 65 61 72 transport appear
41c0: 73 20 74 6f 20 68 61 76 65 20 64 69 65 64 2c 20 s to have died,
41d0: 65 78 69 74 69 6e 67 20 73 65 72 76 65 72 22 29 exiting server")
41e0: 0a 09 09 09 09 20 20 20 20 20 20 28 65 78 69 74 ..... (exit
41f0: 29 29 0a 09 09 09 09 20 20 20 20 28 6c 6f 6f 70 ))..... (loop
4200: 20 73 74 61 72 74 2d 74 69 6d 65 0a 09 09 09 09 start-time.....
4210: 09 20 20 28 65 71 75 61 6c 3f 20 73 64 61 74 20 . (equal? sdat
4220: 6c 61 73 74 2d 73 64 61 74 29 0a 09 09 09 09 09 last-sdat)......
4230: 20 20 73 64 61 74 29 29 29 29 29 29 29 0a 20 20 sdat))))))).
4240: 20 20 20 20 20 20 20 28 69 66 61 63 65 20 20 20 (iface
4250: 20 20 20 20 28 63 61 72 20 73 65 72 76 65 72 2d (car server-
4260: 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 info)).
4270: 28 70 6f 72 74 20 20 20 20 20 20 20 20 28 63 61 (port (ca
4280: 64 72 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 29 dr server-info))
4290: 0a 20 20 20 20 20 20 20 20 20 28 6c 61 73 74 2d . (last-
42a0: 61 63 63 65 73 73 20 30 29 0a 09 20 28 73 65 72 access 0).. (ser
42b0: 76 65 72 2d 74 69 6d 65 6f 75 74 20 28 73 65 72 ver-timeout (ser
42c0: 76 65 72 3a 65 78 70 69 72 61 74 69 6f 6e 2d 74 ver:expiration-t
42d0: 69 6d 65 6f 75 74 29 29 0a 09 20 28 73 65 72 76 imeout)).. (serv
42e0: 65 72 2d 67 6f 69 6e 67 20 20 23 66 29 0a 09 20 er-going #f)..
42f0: 28 73 65 72 76 65 72 2d 6c 6f 67 2d 66 69 6c 65 (server-log-file
4300: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
4310: 2d 6c 6f 67 22 29 29 29 20 3b 3b 20 61 6c 77 61 -log"))) ;; alwa
4320: 79 73 20 73 65 74 20 77 68 65 6e 20 77 65 20 61 ys set when we a
4330: 72 65 20 61 20 73 65 72 76 65 72 0a 0a 20 20 20 re a server..
4340: 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
4350: 2d 66 69 6c 65 20 73 74 61 72 74 65 64 2d 66 69 -file started-fi
4360: 6c 65 20 28 6c 61 6d 62 64 61 20 28 29 28 70 72 le (lambda ()(pr
4370: 69 6e 74 20 28 63 75 72 72 65 6e 74 2d 70 72 6f int (current-pro
4380: 63 65 73 73 2d 69 64 29 29 29 29 0a 0a 20 20 20 cess-id))))..
4390: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 63 6f 75 (let loop ((cou
43a0: 6e 74 20 20 20 20 20 20 20 20 20 30 29 0a 09 20 nt 0)..
43b0: 20 20 20 20 20 20 28 73 65 72 76 65 72 2d 73 74 (server-st
43c0: 61 74 65 20 27 61 76 61 69 6c 61 62 6c 65 29 0a ate 'available).
43d0: 09 20 20 20 20 20 20 20 28 62 61 64 2d 73 79 6e . (bad-syn
43e0: 63 2d 63 6f 75 6e 74 20 30 29 0a 09 20 20 20 20 c-count 0)..
43f0: 20 20 20 28 73 74 61 72 74 2d 74 69 6d 65 20 20 (start-time
4400: 20 20 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c (current-mill
4410: 69 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 iseconds))).
4420: 20 20 3b 3b 20 55 73 65 20 74 68 69 73 20 6f 70 ;; Use this op
4430: 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 73 79 6e portunity to syn
4440: 63 20 74 68 65 20 74 6d 70 20 64 62 20 74 6f 20 c the tmp db to
4450: 6d 65 67 61 74 65 73 74 2e 64 62 0a 20 20 20 20 megatest.db.
4460: 20 20 28 69 66 20 28 6e 6f 74 20 73 65 72 76 65 (if (not serve
4470: 72 2d 67 6f 69 6e 67 29 20 3b 3b 20 2a 64 62 73 r-going) ;; *dbs
4480: 74 72 75 63 74 2d 64 62 2a 20 0a 09 20 20 28 62 truct-db* .. (b
4490: 65 67 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 egin.. (debug
44a0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
44b0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 45 52 t-log-port* "SER
44c0: 56 45 52 3a 20 64 62 70 72 65 70 22 29 0a 09 20 VER: dbprep")..
44d0: 20 20 20 28 73 65 74 21 20 2a 64 62 73 74 72 75 (set! *dbstru
44e0: 63 74 2d 64 62 2a 20 20 28 64 62 3a 73 65 74 75 ct-db* (db:setu
44f0: 70 20 23 74 29 29 20 3b 3b 20 20 72 75 6e 2d 69 p #t)) ;; run-i
4500: 64 29 29 0a 09 20 20 20 20 28 73 65 74 21 20 73 d)).. (set! s
4510: 65 72 76 65 72 2d 67 6f 69 6e 67 20 23 74 29 0a erver-going #t).
4520: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
4530: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
4540: 2d 70 6f 72 74 2a 20 22 53 45 52 56 45 52 3a 20 -port* "SERVER:
4550: 72 75 6e 6e 69 6e 67 2c 20 6d 65 67 61 74 65 73 running, megates
4560: 74 20 76 65 72 73 69 6f 6e 3a 20 22 20 28 63 6f t version: " (co
4570: 6d 6d 6f 6e 3a 67 65 74 2d 66 75 6c 6c 2d 76 65 mmon:get-full-ve
4580: 72 73 69 6f 6e 29 29 20 3b 3b 20 4e 4f 54 45 3a rsion)) ;; NOTE:
4590: 20 74 68 65 20 73 65 72 76 65 72 20 69 73 20 4e the server is N
45a0: 4f 54 20 79 65 74 20 6d 61 72 6b 65 64 20 61 73 OT yet marked as
45b0: 20 72 75 6e 6e 69 6e 67 20 69 6e 20 74 68 65 20 running in the
45c0: 6c 6f 67 2e 20 57 65 20 64 6f 20 74 68 61 74 20 log. We do that
45d0: 69 6e 20 74 68 65 20 6b 65 65 70 2d 72 75 6e 6e in the keep-runn
45e0: 69 6e 67 20 72 6f 75 74 69 6e 65 2e 0a 09 20 20 ing routine...
45f0: 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 (thread-start!
4600: 20 2a 77 61 74 63 68 64 6f 67 2a 29 29 29 0a 20 *watchdog*))).
4610: 20 20 20 20 20 0a 20 20 20 20 20 20 3b 3b 20 77 . ;; w
4620: 68 65 6e 20 74 68 69 6e 67 73 20 67 6f 20 77 72 hen things go wr
4630: 6f 6e 67 20 77 65 20 64 6f 6e 27 74 20 77 61 6e ong we don't wan
4640: 74 20 74 6f 20 62 65 20 64 6f 69 6e 67 20 74 68 t to be doing th
4650: 65 20 76 61 72 69 6f 75 73 20 71 75 65 72 69 65 e various querie
4660: 73 20 74 6f 6f 20 6f 66 74 65 6e 0a 20 20 20 20 s too often.
4670: 20 20 3b 3b 20 73 6f 20 77 65 20 73 74 72 69 76 ;; so we striv
4680: 65 20 74 6f 20 72 75 6e 20 74 68 69 73 20 73 74 e to run this st
4690: 75 66 66 20 6f 6e 6c 79 20 65 76 65 72 79 20 66 uff only every f
46a0: 6f 75 72 20 73 65 63 6f 6e 64 73 20 6f 72 20 73 our seconds or s
46b0: 6f 2e 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 o.. (let* (
46c0: 28 73 79 6e 63 2d 74 69 6d 65 20 28 2d 20 28 63 (sync-time (- (c
46d0: 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f urrent-milliseco
46e0: 6e 64 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 nds) start-time)
46f0: 29 0a 09 20 20 20 20 28 72 65 6d 2d 74 69 6d 65 ).. (rem-time
4700: 20 20 28 71 75 6f 74 69 65 6e 74 20 28 2d 20 34 (quotient (- 4
4710: 30 30 30 20 73 79 6e 63 2d 74 69 6d 65 29 20 31 000 sync-time) 1
4720: 30 30 30 29 29 29 0a 09 28 69 66 20 28 61 6e 64 000)))..(if (and
4730: 20 28 3c 3d 20 72 65 6d 2d 74 69 6d 65 20 34 29 (<= rem-time 4)
4740: 0a 09 09 20 28 3e 20 20 72 65 6d 2d 74 69 6d 65 ... (> rem-time
4750: 20 30 29 29 0a 09 20 20 20 20 28 74 68 72 65 61 0)).. (threa
4760: 64 2d 73 6c 65 65 70 21 20 72 65 6d 2d 74 69 6d d-sleep! rem-tim
4770: 65 29 29 29 0a 20 20 20 20 20 20 0a 20 20 20 20 e))). .
4780: 20 20 28 69 66 20 28 3c 20 63 6f 75 6e 74 20 31 (if (< count 1
4790: 29 20 3b 3b 20 33 78 33 20 3d 20 39 20 73 65 63 ) ;; 3x3 = 9 sec
47a0: 73 20 61 70 72 6f 78 0a 09 20 20 28 6c 6f 6f 70 s aprox.. (loop
47b0: 20 28 2b 20 63 6f 75 6e 74 20 31 29 20 27 72 75 (+ count 1) 'ru
47c0: 6e 6e 69 6e 67 20 62 61 64 2d 73 79 6e 63 2d 63 nning bad-sync-c
47d0: 6f 75 6e 74 20 28 63 75 72 72 65 6e 74 2d 6d 69 ount (current-mi
47e0: 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 lliseconds))).
47f0: 20 20 20 20 0a 20 20 20 20 20 20 3b 3b 20 43 68 . ;; Ch
4800: 65 63 6b 20 74 68 61 74 20 69 66 61 63 65 20 61 eck that iface a
4810: 6e 64 20 70 6f 72 74 20 68 61 76 65 20 6e 6f 74 nd port have not
4820: 20 63 68 61 6e 67 65 64 20 28 63 61 6e 20 68 61 changed (can ha
4830: 70 70 65 6e 20 69 66 20 73 65 72 76 65 72 20 70 ppen if server p
4840: 6f 72 74 20 63 6f 6c 6c 69 64 65 73 29 0a 20 20 ort collides).
4850: 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 (mutex-lock!
4860: 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 *heartbeat-mute
4870: 78 2a 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 x*). (set!
4880: 73 64 61 74 20 2a 73 65 72 76 65 72 2d 69 6e 66 sdat *server-inf
4890: 6f 2a 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 o*). (mutex
48a0: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 -unlock! *heartb
48b0: 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 eat-mutex*).
48c0: 20 20 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f . (if (no
48d0: 74 20 28 65 71 75 61 6c 3f 20 73 64 61 74 20 28 t (equal? sdat (
48e0: 6c 69 73 74 20 69 66 61 63 65 20 70 6f 72 74 29 list iface port)
48f0: 29 29 0a 09 20 20 28 6c 65 74 20 28 28 6e 65 77 )).. (let ((new
4900: 2d 69 66 61 63 65 20 28 63 61 72 20 73 64 61 74 -iface (car sdat
4910: 29 29 0a 09 09 28 6e 65 77 2d 70 6f 72 74 20 20 ))...(new-port
4920: 28 63 61 64 72 20 73 64 61 74 29 29 29 0a 09 20 (cadr sdat)))..
4930: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
4940: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
4950: 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 log-port* "WARNI
4960: 4e 47 3a 20 69 6e 74 65 72 66 61 63 65 20 63 68 NG: interface ch
4970: 61 6e 67 65 64 2c 20 72 65 66 72 65 73 68 69 6e anged, refreshin
4980: 67 20 69 66 61 63 65 20 61 6e 64 20 70 6f 72 74 g iface and port
4990: 20 69 6e 66 6f 22 29 0a 09 20 20 20 20 28 73 65 info").. (se
49a0: 74 21 20 69 66 61 63 65 20 6e 65 77 2d 69 66 61 t! iface new-ifa
49b0: 63 65 29 0a 09 20 20 20 20 28 73 65 74 21 20 70 ce).. (set! p
49c0: 6f 72 74 20 20 6e 65 77 2d 70 6f 72 74 29 0a 09 ort new-port)..
49d0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
49e0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
49f0: 70 6f 72 74 2a 20 22 53 45 52 56 45 52 20 53 54 port* "SERVER ST
4a00: 41 52 54 45 44 3a 20 22 20 69 66 61 63 65 20 22 ARTED: " iface "
4a10: 3a 22 20 70 6f 72 74 20 22 20 41 54 20 22 20 28 :" port " AT " (
4a20: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
4a30: 29 0a 09 20 20 20 20 28 66 6c 75 73 68 2d 6f 75 ).. (flush-ou
4a40: 74 70 75 74 20 2a 64 65 66 61 75 6c 74 2d 6c 6f tput *default-lo
4a50: 67 2d 70 6f 72 74 2a 29 29 29 0a 20 20 20 20 20 g-port*))).
4a60: 20 0a 20 20 20 20 20 20 3b 3b 20 54 72 61 6e 73 . ;; Trans
4a70: 66 65 72 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 fer *db-last-acc
4a80: 65 73 73 2a 20 74 6f 20 6c 61 73 74 2d 61 63 63 ess* to last-acc
4a90: 65 73 73 20 74 6f 20 75 73 65 20 69 6e 20 63 68 ess to use in ch
4aa0: 65 63 6b 69 6e 67 20 74 68 61 74 20 77 65 20 61 ecking that we a
4ab0: 72 65 20 73 74 69 6c 6c 20 61 6c 69 76 65 0a 20 re still alive.
4ac0: 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b (mutex-lock
4ad0: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
4ae0: 65 78 2a 29 0a 20 20 20 20 20 20 28 73 65 74 21 ex*). (set!
4af0: 20 6c 61 73 74 2d 61 63 63 65 73 73 20 2a 64 62 last-access *db
4b00: 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a 29 0a 20 -last-access*).
4b10: 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f (mutex-unlo
4b20: 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
4b30: 75 74 65 78 2a 29 0a 20 20 20 20 20 20 0a 20 20 utex*). .
4b40: 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a (if (common:
4b50: 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 low-noise-print
4b60: 31 32 30 20 28 63 6f 6e 63 20 22 73 65 72 76 65 120 (conc "serve
4b70: 72 20 72 75 6e 6e 69 6e 67 20 6f 6e 20 22 20 69 r running on " i
4b80: 66 61 63 65 20 22 3a 22 20 70 6f 72 74 29 29 0a face ":" port)).
4b90: 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 . (begin.. (
4ba0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
4bb0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
4bc0: 20 22 53 45 52 56 45 52 20 53 54 41 52 54 45 44 "SERVER STARTED
4bd0: 3a 20 22 20 69 66 61 63 65 20 22 3a 22 20 70 6f : " iface ":" po
4be0: 72 74 20 22 20 41 54 20 22 20 28 63 75 72 72 65 rt " AT " (curre
4bf0: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 nt-seconds))..
4c00: 20 20 28 66 6c 75 73 68 2d 6f 75 74 70 75 74 20 (flush-output
4c10: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
4c20: 74 2a 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 t*))). (if
4c30: 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 (common:low-nois
4c40: 65 2d 70 72 69 6e 74 20 36 30 20 22 64 62 73 74 e-print 60 "dbst
4c50: 61 74 73 22 29 0a 09 20 20 28 62 65 67 69 6e 0a ats").. (begin.
4c60: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
4c70: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
4c80: 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 72 20 73 -port* "Server s
4c90: 74 61 74 73 3a 22 29 0a 09 20 20 20 20 28 64 62 tats:").. (db
4ca0: 3a 70 72 69 6e 74 2d 63 75 72 72 65 6e 74 2d 71 :print-current-q
4cb0: 75 65 72 79 2d 73 74 61 74 73 29 29 29 0a 20 20 uery-stats))).
4cc0: 20 20 20 20 28 6c 65 74 2a 20 28 28 68 72 73 2d (let* ((hrs-
4cd0: 73 69 6e 63 65 2d 73 74 61 72 74 20 20 28 2f 20 since-start (/
4ce0: 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
4cf0: 6e 64 73 29 20 73 65 72 76 65 72 2d 73 74 61 72 nds) server-star
4d00: 74 2d 74 69 6d 65 29 20 33 36 30 30 29 29 29 0a t-time) 3600))).
4d10: 09 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 .(cond.
4d20: 28 28 61 6e 64 20 2a 73 65 72 76 65 72 2d 72 75 ((and *server-ru
4d30: 6e 2a 0a 09 20 20 20 20 20 20 20 28 3e 20 28 2b n*.. (> (+
4d40: 20 6c 61 73 74 2d 61 63 63 65 73 73 20 73 65 72 last-access ser
4d50: 76 65 72 2d 74 69 6d 65 6f 75 74 29 0a 09 09 20 ver-timeout)...
4d60: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
4d70: 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 s))). (
4d80: 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e if (common:low-n
4d90: 6f 69 73 65 2d 70 72 69 6e 74 20 31 32 30 20 22 oise-print 120 "
4da0: 73 65 72 76 65 72 20 63 6f 6e 74 69 6e 75 69 6e server continuin
4db0: 67 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 g").
4dc0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
4dd0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
4de0: 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 72 og-port* "Server
4df0: 20 63 6f 6e 74 69 6e 75 69 6e 67 2c 20 73 65 63 continuing, sec
4e00: 6f 6e 64 73 20 73 69 6e 63 65 20 6c 61 73 74 20 onds since last
4e10: 64 62 20 61 63 63 65 73 73 3a 20 22 20 28 2d 20 db access: " (-
4e20: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
4e30: 29 20 6c 61 73 74 2d 61 63 63 65 73 73 29 29 0a ) last-access)).
4e40: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 75 . (let ((cu
4e50: 72 72 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 rr-time (current
4e60: 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 09 28 68 -seconds)))...(h
4e70: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
4e80: 0a 09 09 20 20 20 20 65 78 6e 0a 09 09 20 20 20 ... exn...
4e90: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
4ea0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
4eb0: 74 2a 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 t* "ERROR: Faile
4ec0: 64 20 74 6f 20 63 68 61 6e 67 65 20 74 69 6d 65 d to change time
4ed0: 73 74 61 6d 70 20 6f 6e 20 6c 6f 67 20 66 69 6c stamp on log fil
4ee0: 65 20 22 20 73 65 72 76 65 72 2d 6c 6f 67 2d 66 e " server-log-f
4ef0: 69 6c 65 20 22 2e 20 41 72 65 20 79 6f 75 20 6f ile ". Are you o
4f00: 75 74 20 6f 66 20 73 70 61 63 65 20 6f 6e 20 74 ut of space on t
4f10: 68 61 74 20 64 69 73 6b 3f 22 29 0a 09 09 20 20 hat disk?")...
4f20: 28 69 66 20 28 6e 6f 74 20 2a 73 65 72 76 65 72 (if (not *server
4f30: 2d 6f 76 65 72 6c 6f 61 64 65 64 2a 29 0a 09 09 -overloaded*)...
4f40: 20 20 20 20 20 20 28 63 68 61 6e 67 65 2d 66 69 (change-fi
4f50: 6c 65 2d 74 69 6d 65 73 20 73 65 72 76 65 72 2d le-times server-
4f60: 6c 6f 67 2d 66 69 6c 65 20 63 75 72 72 2d 74 69 log-file curr-ti
4f70: 6d 65 20 63 75 72 72 2d 74 69 6d 65 29 29 29 29 me curr-time))))
4f80: 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f ). (loo
4f90: 70 20 30 20 73 65 72 76 65 72 2d 73 74 61 74 65 p 0 server-state
4fa0: 20 62 61 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 bad-sync-count
4fb0: 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 (current-millise
4fc0: 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 20 20 conds))).
4fd0: 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 (else.
4fe0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
4ff0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
5000: 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 72 og-port* "Server
5010: 20 74 69 6d 65 64 20 6f 75 74 2e 20 73 65 63 6f timed out. seco
5020: 6e 64 73 20 73 69 6e 63 65 20 6c 61 73 74 20 64 nds since last d
5030: 62 20 61 63 63 65 73 73 3a 20 22 20 28 2d 20 28 b access: " (- (
5040: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
5050: 20 6c 61 73 74 2d 61 63 63 65 73 73 29 29 0a 20 last-access)).
5060: 20 20 20 20 20 20 20 20 20 28 68 74 74 70 2d 74 (http-t
5070: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
5080: 73 68 75 74 64 6f 77 6e 20 70 6f 72 74 29 29 29 shutdown port)))
5090: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 ))))..(define (h
50a0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 ttp-transport:se
50b0: 72 76 65 72 2d 73 68 75 74 64 6f 77 6e 20 70 6f rver-shutdown po
50c0: 72 74 29 0a 20 20 28 62 65 67 69 6e 0a 20 20 20 rt). (begin.
50d0: 20 3b 3b 28 42 42 3e 20 22 68 74 74 70 2d 74 72 ;;(BB> "http-tr
50e0: 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 73 ansport:server-s
50f0: 68 75 74 64 6f 77 6e 20 63 61 6c 6c 65 64 22 29 hutdown called")
5100: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
5110: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
5120: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 74 61 t-log-port* "Sta
5130: 72 74 69 6e 67 20 74 6f 20 73 68 75 74 64 6f 77 rting to shutdow
5140: 6e 20 74 68 65 20 73 65 72 76 65 72 2e 20 70 69 n the server. pi
5150: 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 d="(current-proc
5160: 65 73 73 2d 69 64 29 29 0a 20 20 20 20 3b 3b 0a ess-id)). ;;.
5170: 20 20 20 20 3b 3b 20 73 74 61 72 74 5f 73 68 75 ;; start_shu
5180: 74 64 6f 77 6e 0a 20 20 20 20 3b 3b 0a 20 20 20 tdown. ;;.
5190: 20 28 73 65 74 21 20 2a 74 69 6d 65 2d 74 6f 2d (set! *time-to-
51a0: 65 78 69 74 2a 20 23 74 29 20 3b 3b 20 74 65 6c exit* #t) ;; tel
51b0: 6c 20 6f 6e 2d 65 78 69 74 20 74 6f 20 62 65 20 l on-exit to be
51c0: 66 61 73 74 20 61 73 20 77 65 27 76 65 20 61 6c fast as we've al
51d0: 72 65 61 64 79 20 63 6c 65 61 6e 65 64 20 75 70 ready cleaned up
51e0: 0a 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 . (portlogger
51f0: 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 :open-run-close
5200: 70 6f 72 74 6c 6f 67 67 65 72 3a 73 65 74 2d 70 portlogger:set-p
5210: 6f 72 74 20 70 6f 72 74 20 22 72 65 6c 65 61 73 ort port "releas
5220: 65 64 22 29 0a 20 20 20 20 28 74 68 72 65 61 64 ed"). (thread
5230: 2d 73 6c 65 65 70 21 20 31 29 0a 0a 20 20 20 20 -sleep! 1)..
5240: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ;; (debug:print-
5250: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
5260: 6c 6f 67 2d 70 6f 72 74 2a 20 22 4d 61 78 20 63 log-port* "Max c
5270: 61 63 68 65 64 20 71 75 65 72 69 65 73 20 77 61 ached queries wa
5280: 73 20 20 20 20 22 20 2a 6d 61 78 2d 63 61 63 68 s " *max-cach
5290: 65 2d 73 69 7a 65 2a 29 0a 20 20 20 20 3b 3b 20 e-size*). ;;
52a0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
52b0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
52c0: 2d 70 6f 72 74 2a 20 22 4e 75 6d 62 65 72 20 6f -port* "Number o
52d0: 66 20 63 61 63 68 65 64 20 77 72 69 74 65 73 20 f cached writes
52e0: 20 20 22 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 " *number-of-w
52f0: 72 69 74 65 73 2a 29 0a 20 20 20 20 3b 3b 20 28 rites*). ;; (
5300: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
5310: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
5320: 70 6f 72 74 2a 20 22 41 76 65 72 61 67 65 20 63 port* "Average c
5330: 61 63 68 65 64 20 77 72 69 74 65 20 74 69 6d 65 ached write time
5340: 20 22 0a 20 20 20 20 3b 3b 20 09 09 20 20 20 20 ". ;; ..
5350: 20 20 28 69 66 20 28 65 71 3f 20 2a 6e 75 6d 62 (if (eq? *numb
5360: 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a 20 30 29 er-of-writes* 0)
5370: 0a 20 20 20 20 3b 3b 20 09 09 09 20 20 22 6e 2f . ;; ... "n/
5380: 61 20 28 6e 6f 20 77 72 69 74 65 73 29 22 0a 20 a (no writes)".
5390: 20 20 20 3b 3b 20 09 09 09 20 20 28 2f 20 2a 77 ;; ... (/ *w
53a0: 72 69 74 65 73 2d 74 6f 74 61 6c 2d 64 65 6c 61 rites-total-dela
53b0: 79 2a 0a 20 20 20 20 3b 3b 20 09 09 09 20 20 20 y*. ;; ...
53c0: 20 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 *number-of-wri
53d0: 74 65 73 2a 29 29 0a 20 20 20 20 3b 3b 20 09 09 tes*)). ;; ..
53e0: 20 20 20 20 20 20 22 20 6d 73 22 29 0a 20 20 20 " ms").
53f0: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
5400: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
5410: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4e 75 6d 62 -log-port* "Numb
5420: 65 72 20 6e 6f 6e 2d 63 61 63 68 65 64 20 71 75 er non-cached qu
5430: 65 72 69 65 73 20 22 20 20 2a 6e 75 6d 62 65 72 eries " *number
5440: 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 -non-write-queri
5450: 65 73 2a 29 0a 20 20 20 20 3b 3b 20 28 64 65 62 es*). ;; (deb
5460: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
5470: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
5480: 74 2a 20 22 41 76 65 72 61 67 65 20 6e 6f 6e 2d t* "Average non-
5490: 63 61 63 68 65 64 20 74 69 6d 65 20 20 20 22 0a cached time ".
54a0: 20 20 20 20 3b 3b 20 09 09 20 20 20 20 20 20 28 ;; .. (
54b0: 69 66 20 28 65 71 3f 20 2a 6e 75 6d 62 65 72 2d if (eq? *number-
54c0: 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 non-write-querie
54d0: 73 2a 20 30 29 0a 20 20 20 20 3b 3b 20 09 09 09 s* 0). ;; ...
54e0: 20 20 22 6e 2f 61 20 28 6e 6f 20 71 75 65 72 69 "n/a (no queri
54f0: 65 73 29 22 0a 20 20 20 20 3b 3b 20 09 09 09 20 es)". ;; ...
5500: 20 28 2f 20 2a 74 6f 74 61 6c 2d 6e 6f 6e 2d 77 (/ *total-non-w
5510: 72 69 74 65 2d 64 65 6c 61 79 2a 20 0a 20 20 20 rite-delay* .
5520: 20 3b 3b 20 09 09 09 20 20 20 20 20 2a 6e 75 6d ;; ... *num
5530: 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 ber-non-write-qu
5540: 65 72 69 65 73 2a 29 29 0a 20 20 20 20 3b 3b 20 eries*)). ;;
5550: 09 09 20 20 20 20 20 20 22 20 6d 73 22 29 0a 20 .. " ms").
5560: 20 20 20 0a 20 20 20 20 28 64 62 3a 70 72 69 6e . (db:prin
5570: 74 2d 63 75 72 72 65 6e 74 2d 71 75 65 72 79 2d t-current-query-
5580: 73 74 61 74 73 29 0a 20 20 20 20 0a 20 20 20 20 stats). .
5590: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
55a0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
55b0: 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 72 20 73 -port* "Server s
55c0: 68 75 74 64 6f 77 6e 20 63 6f 6d 70 6c 65 74 65 hutdown complete
55d0: 2e 20 45 78 69 74 69 6e 67 22 29 0a 20 20 20 20 . Exiting").
55e0: 28 65 78 69 74 29 29 29 0a 0a 3b 3b 20 61 6c 6c (exit)))..;; all
55f0: 20 72 6f 75 74 65 73 20 74 68 6f 75 67 68 20 68 routes though h
5600: 65 72 65 20 65 6e 64 20 69 6e 20 65 78 69 74 20 ere end in exit
5610: 2e 2e 2e 0a 3b 3b 0a 3b 3b 20 73 74 61 72 74 5f ....;;.;; start_
5620: 73 65 72 76 65 72 3f 20 0a 3b 3b 0a 28 64 65 66 server? .;;.(def
5630: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
5640: 6f 72 74 3a 6c 61 75 6e 63 68 29 0a 20 20 3b 3b ort:launch). ;;
5650: 20 63 68 65 63 6b 20 74 68 61 74 20 61 20 73 65 check that a se
5660: 72 76 65 72 20 73 74 61 72 74 20 69 73 20 69 6e rver start is in
5670: 20 70 72 6f 67 72 65 73 73 2c 20 70 61 75 73 65 progress, pause
5680: 20 6f 72 20 65 78 69 74 20 69 66 20 73 6f 0a 20 or exit if so.
5690: 20 28 6c 65 74 2a 20 28 28 74 6d 70 2d 61 72 65 (let* ((tmp-are
56a0: 61 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f a (co
56b0: 6d 6d 6f 6e 3a 67 65 74 2d 64 62 2d 74 6d 70 2d mmon:get-db-tmp-
56c0: 61 72 65 61 29 29 0a 09 20 28 73 65 72 76 65 72 area)).. (server
56d0: 2d 73 74 61 72 74 20 20 20 20 20 20 20 20 28 63 -start (c
56e0: 6f 6e 63 20 74 6d 70 2d 61 72 65 61 20 22 2f 2e onc tmp-area "/.
56f0: 73 65 72 76 65 72 2d 73 74 61 72 74 22 29 29 0a server-start")).
5700: 09 20 28 73 65 72 76 65 72 2d 73 74 61 72 74 65 . (server-starte
5710: 64 20 20 20 20 20 20 28 63 6f 6e 63 20 74 6d 70 d (conc tmp
5720: 2d 61 72 65 61 20 22 2f 2e 73 65 72 76 65 72 2d -area "/.server-
5730: 73 74 61 72 74 65 64 22 29 29 0a 09 20 28 73 74 started")).. (st
5740: 61 72 74 2d 74 69 6d 65 20 20 20 20 20 20 20 20 art-time
5750: 20 20 28 63 6f 6d 6d 6f 6e 3a 6c 61 7a 79 2d 6d (common:lazy-m
5760: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
5770: 20 73 65 72 76 65 72 2d 73 74 61 72 74 29 29 0a server-start)).
5780: 09 20 28 73 74 61 72 74 65 64 2d 74 69 6d 65 20 . (started-time
5790: 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 6c (common:l
57a0: 61 7a 79 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e azy-modification
57b0: 2d 74 69 6d 65 20 73 65 72 76 65 72 2d 73 74 61 -time server-sta
57c0: 72 74 65 64 29 29 0a 09 20 28 73 65 72 76 65 72 rted)).. (server
57d0: 2d 73 74 61 72 74 69 6e 67 20 20 20 20 20 28 3c -starting (<
57e0: 20 73 74 61 72 74 2d 74 69 6d 65 20 73 74 61 72 start-time star
57f0: 74 65 64 2d 74 69 6d 65 29 29 20 3b 3b 20 69 66 ted-time)) ;; if
5800: 20 73 74 61 72 74 2d 74 69 6d 65 20 69 73 20 6c start-time is l
5810: 65 73 73 20 74 68 61 6e 20 73 74 61 72 74 65 64 ess than started
5820: 2d 74 69 6d 65 20 74 68 65 6e 20 61 20 73 65 72 -time then a ser
5830: 76 65 72 20 69 73 20 73 74 69 6c 6c 20 73 74 61 ver is still sta
5840: 72 74 69 6e 67 0a 09 20 28 73 74 61 72 74 2d 74 rting.. (start-t
5850: 69 6d 65 2d 6f 6c 64 20 20 20 20 20 20 28 3e 20 ime-old (>
5860: 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
5870: 6e 64 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 nds) start-time)
5880: 20 35 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 5))). (if (a
5890: 6e 64 20 28 6e 6f 74 20 73 74 61 72 74 2d 74 69 nd (not start-ti
58a0: 6d 65 2d 6f 6c 64 29 20 3b 3b 20 6c 61 73 74 20 me-old) ;; last
58b0: 73 65 72 76 65 72 20 73 74 61 72 74 20 74 72 79 server start try
58c0: 20 77 61 73 20 6c 65 73 73 20 74 68 61 6e 20 66 was less than f
58d0: 69 76 65 20 73 65 63 6f 6e 64 73 20 61 67 6f 0a ive seconds ago.
58e0: 09 20 20 20 20 20 28 6e 6f 74 20 73 65 72 76 65 . (not serve
58f0: 72 2d 73 74 61 72 74 69 6e 67 29 29 0a 09 28 62 r-starting))..(b
5900: 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 egin.. (debug:p
5910: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
5920: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5930: 4e 4f 54 20 73 74 61 72 74 69 6e 67 20 73 65 72 NOT starting ser
5940: 76 65 72 2c 20 74 68 65 72 65 20 69 73 20 65 69 ver, there is ei
5950: 74 68 65 72 20 61 20 72 65 63 65 6e 74 6c 79 20 ther a recently
5960: 73 74 61 72 74 65 64 20 73 65 72 76 65 72 20 6f started server o
5970: 72 20 61 20 73 65 72 76 65 72 20 69 6e 20 70 72 r a server in pr
5980: 6f 63 65 73 73 20 6f 66 20 73 74 61 72 74 69 6e ocess of startin
5990: 67 22 29 0a 09 20 20 28 65 78 69 74 29 29 29 29 g").. (exit))))
59a0: 0a 20 20 3b 3b 20 6c 65 74 73 20 6e 6f 74 20 65 . ;; lets not e
59b0: 76 65 6e 20 62 6f 74 68 65 72 20 74 6f 20 73 74 ven bother to st
59c0: 61 72 74 20 69 66 20 74 68 65 72 65 20 61 72 65 art if there are
59d0: 20 61 6c 72 65 61 64 79 20 74 68 72 65 65 20 6f already three o
59e0: 72 20 6d 6f 72 65 20 73 65 72 76 65 72 20 66 69 r more server fi
59f0: 6c 65 73 20 72 65 61 64 79 20 74 6f 20 67 6f 0a les ready to go.
5a00: 20 20 28 6c 65 74 2a 20 28 28 6e 75 6d 2d 61 6c (let* ((num-al
5a10: 69 76 65 20 20 20 28 73 65 72 76 65 72 3a 67 65 ive (server:ge
5a20: 74 2d 6e 75 6d 2d 61 6c 69 76 65 20 28 73 65 72 t-num-alive (ser
5a30: 76 65 72 3a 67 65 74 2d 6c 69 73 74 20 2a 74 6f ver:get-list *to
5a40: 70 70 61 74 68 2a 29 29 29 29 0a 20 20 20 20 28 ppath*)))). (
5a50: 69 66 20 28 3e 20 6e 75 6d 2d 61 6c 69 76 65 20 if (> num-alive
5a60: 33 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 3)..(begin.. (d
5a70: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
5a80: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5a90: 22 45 52 52 4f 52 3a 20 41 62 6f 72 74 69 6e 67 "ERROR: Aborting
5aa0: 20 73 65 72 76 65 72 20 73 74 61 72 74 20 62 65 server start be
5ab0: 63 61 75 73 65 20 74 68 65 72 65 20 61 72 65 20 cause there are
5ac0: 61 6c 72 65 61 64 79 20 22 20 6e 75 6d 2d 61 6c already " num-al
5ad0: 69 76 65 20 22 20 70 6f 73 73 69 62 6c 65 20 73 ive " possible s
5ae0: 65 72 76 65 72 73 20 65 69 74 68 65 72 20 72 75 ervers either ru
5af0: 6e 6e 69 6e 67 20 6f 72 20 73 74 61 72 74 69 6e nning or startin
5b00: 67 20 75 70 22 29 0a 09 20 20 28 65 78 69 74 29 g up").. (exit)
5b10: 29 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 68 ))). (let* ((th
5b20: 32 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 2 (make-thread (
5b30: 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 lambda ()....
5b40: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
5b50: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
5b60: 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 72 og-port* "Server
5b70: 20 72 75 6e 20 74 68 72 65 61 64 20 73 74 61 72 run thread star
5b80: 74 65 64 22 29 0a 09 09 09 20 20 20 20 20 28 68 ted").... (h
5b90: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 ttp-transport:ru
5ba0: 6e 20 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 n .... (if
5bb0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
5bc0: 73 65 72 76 65 72 22 29 0a 09 09 09 09 20 20 28 server")..... (
5bd0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 args:get-arg "-s
5be0: 65 72 76 65 72 22 29 0a 09 09 09 09 20 20 22 2d erver")..... "-
5bf0: 22 29 0a 09 09 09 20 20 20 20 20 20 29 29 20 22 ").... )) "
5c00: 53 65 72 76 65 72 20 72 75 6e 22 29 29 0a 09 20 Server run"))..
5c10: 28 74 68 33 20 28 6d 61 6b 65 2d 74 68 72 65 61 (th3 (make-threa
5c20: 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 d (lambda ()....
5c30: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
5c40: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
5c50: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 t-log-port* "Ser
5c60: 76 65 72 20 6d 6f 6e 69 74 6f 72 20 74 68 72 65 ver monitor thre
5c70: 61 64 20 73 74 61 72 74 65 64 22 29 0a 09 09 09 ad started")....
5c80: 20 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 (http-trans
5c90: 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e port:keep-runnin
5ca0: 67 29 0a 09 09 09 20 20 20 22 4b 65 65 70 20 72 g).... "Keep r
5cb0: 75 6e 6e 69 6e 67 22 29 29 29 29 0a 20 20 20 20 unning")))).
5cc0: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
5cd0: 68 32 29 0a 20 20 20 20 28 74 68 72 65 61 64 2d h2). (thread-
5ce0: 73 6c 65 65 70 21 20 30 2e 32 35 29 20 3b 3b 20 sleep! 0.25) ;;
5cf0: 67 69 76 65 20 74 68 65 20 73 65 72 76 65 72 20 give the server
5d00: 74 69 6d 65 20 74 6f 20 73 65 74 74 6c 65 20 62 time to settle b
5d10: 65 66 6f 72 65 20 73 74 61 72 74 69 6e 67 20 74 efore starting t
5d20: 68 65 20 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 he keep-running
5d30: 6d 6f 6e 69 74 6f 72 2e 0a 20 20 20 20 28 74 68 monitor.. (th
5d40: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 33 29 read-start! th3)
5d50: 0a 20 20 20 20 28 73 65 74 21 20 2a 64 69 64 73 . (set! *dids
5d60: 6f 6d 65 74 68 69 6e 67 2a 20 23 74 29 0a 20 20 omething* #t).
5d70: 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 (thread-join!
5d80: 74 68 32 29 0a 20 20 20 20 28 65 78 69 74 29 29 th2). (exit))
5d90: 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 68 )..;; (define (h
5da0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 ttp-transport:se
5db0: 72 76 65 72 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 rver-signal-hand
5dc0: 6c 65 72 20 73 69 67 6e 75 6d 29 0a 3b 3b 20 20 ler signum).;;
5dd0: 20 28 73 69 67 6e 61 6c 2d 6d 61 73 6b 21 20 73 (signal-mask! s
5de0: 69 67 6e 75 6d 29 0a 3b 3b 20 20 20 28 68 61 6e ignum).;; (han
5df0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 3b dle-exceptions.;
5e00: 3b 20 20 20 20 65 78 6e 0a 3b 3b 20 20 20 20 28 ; exn.;; (
5e10: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
5e20: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
5e30: 20 22 20 2e 2e 2e 20 65 78 69 74 69 6e 67 20 2e " ... exiting .
5e40: 2e 2e 22 29 0a 3b 3b 20 20 20 20 28 6c 65 74 20 ..").;; (let
5e50: 28 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 ((th1 (make-thre
5e60: 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b ad (lambda ().;;
5e70: 20 09 09 09 20 20 20 20 20 28 74 68 72 65 61 64 ... (thread
5e80: 2d 73 6c 65 65 70 21 20 31 29 29 0a 3b 3b 20 09 -sleep! 1)).;; .
5e90: 09 09 20 20 20 22 65 61 74 20 72 65 73 70 6f 6e .. "eat respon
5ea0: 73 65 22 29 29 0a 3b 3b 20 09 20 28 74 68 32 20 se")).;; . (th2
5eb0: 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 (make-thread (la
5ec0: 6d 62 64 61 20 28 29 0a 3b 3b 20 09 09 09 20 20 mbda ().;; ...
5ed0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
5ee0: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
5ef0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 65 63 65 -log-port* "Rece
5f00: 69 76 65 64 20 5e 43 2c 20 61 74 74 65 6d 70 74 ived ^C, attempt
5f10: 69 6e 67 20 63 6c 65 61 6e 20 65 78 69 74 2e 20 ing clean exit.
5f20: 50 6c 65 61 73 65 20 62 65 20 70 61 74 69 65 6e Please be patien
5f30: 74 20 61 6e 64 20 77 61 69 74 20 61 20 66 65 77 t and wait a few
5f40: 20 73 65 63 6f 6e 64 73 20 62 65 66 6f 72 65 20 seconds before
5f50: 68 69 74 74 69 6e 67 20 5e 43 20 61 67 61 69 6e hitting ^C again
5f60: 2e 22 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 28 .").;; ... (
5f70: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 33 29 thread-sleep! 3)
5f80: 20 3b 3b 20 67 69 76 65 20 74 68 65 20 66 6c 75 ;; give the flu
5f90: 73 68 20 74 68 72 65 65 20 73 65 63 6f 6e 64 73 sh three seconds
5fa0: 20 74 6f 20 64 6f 20 69 74 27 73 20 73 74 75 66 to do it's stuf
5fb0: 66 0a 3b 3b 20 09 09 09 20 20 20 20 20 28 64 65 f.;; ... (de
5fc0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
5fd0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5fe0: 20 20 20 20 20 20 20 44 6f 6e 65 2e 22 29 0a 3b Done.").;
5ff0: 3b 20 09 09 09 20 20 20 20 20 28 65 78 69 74 20 ; ... (exit
6000: 34 29 29 0a 3b 3b 20 09 09 09 20 20 20 22 65 78 4)).;; ... "ex
6010: 69 74 20 6f 6e 20 5e 43 20 74 69 6d 65 72 22 29 it on ^C timer")
6020: 29 29 0a 3b 3b 20 20 20 20 20 20 28 74 68 72 65 )).;; (thre
6030: 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a 3b ad-start! th2).;
6040: 3b 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 ; (thread-s
6050: 74 61 72 74 21 20 74 68 31 29 0a 3b 3b 20 20 20 tart! th1).;;
6060: 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 (thread-join!
6070: 20 74 68 32 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d th2))))..;;====
6080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60c0: 3d 3d 0a 3b 3b 20 77 65 62 20 70 61 67 65 73 0a ==.;; web pages.
60d0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
60e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6110: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
6120: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
6130: 74 3a 6d 61 69 6e 2d 70 61 67 65 29 0a 20 20 28 t:main-page). (
6140: 6c 65 74 20 28 28 6c 69 6e 6b 70 61 74 68 20 28 let ((linkpath (
6150: 72 6f 6f 74 2d 70 61 74 68 29 29 29 0a 20 20 20 root-path))).
6160: 20 28 63 6f 6e 63 20 22 3c 68 65 61 64 3e 3c 68 (conc "<head><h
6170: 31 3e 22 20 28 70 61 74 68 6e 61 6d 65 2d 73 74 1>" (pathname-st
6180: 72 69 70 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 rip-directory *t
6190: 6f 70 70 61 74 68 2a 29 20 22 3c 2f 68 31 3e 3c oppath*) "</h1><
61a0: 2f 68 65 61 64 3e 22 0a 09 20 20 22 3c 62 6f 64 /head>".. "<bod
61b0: 79 3e 22 0a 09 20 20 22 52 75 6e 20 61 72 65 61 y>".. "Run area
61c0: 3a 20 22 20 2a 74 6f 70 70 61 74 68 2a 0a 09 20 : " *toppath*..
61d0: 20 22 3c 68 32 3e 53 65 72 76 65 72 20 53 74 61 "<h2>Server Sta
61e0: 74 73 3c 2f 68 32 3e 22 0a 09 20 20 28 68 74 74 ts</h2>".. (htt
61f0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 74 61 74 p-transport:stat
6200: 73 2d 74 61 62 6c 65 29 20 0a 09 20 20 22 3c 68 s-table) .. "<h
6210: 72 3e 22 0a 09 20 20 28 68 74 74 70 2d 74 72 61 r>".. (http-tra
6220: 6e 73 70 6f 72 74 3a 72 75 6e 73 20 6c 69 6e 6b nsport:runs link
6230: 70 61 74 68 29 0a 09 20 20 22 3c 68 72 3e 22 0a path).. "<hr>".
6240: 09 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f . (http-transpo
6250: 72 74 3a 72 75 6e 2d 73 74 61 74 73 29 0a 09 20 rt:run-stats)..
6260: 20 22 3c 2f 62 6f 64 79 3e 22 0a 09 20 20 29 29 "</body>".. ))
6270: 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 )..(define (http
6280: 2d 74 72 61 6e 73 70 6f 72 74 3a 73 74 61 74 73 -transport:stats
6290: 2d 74 61 62 6c 65 29 0a 20 20 28 6d 75 74 65 78 -table). (mutex
62a0: 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 -lock! *heartbea
62b0: 74 2d 6d 75 74 65 78 2a 29 0a 20 20 28 6c 65 74 t-mutex*). (let
62c0: 20 28 28 72 65 73 20 0a 09 20 28 63 6f 6e 63 20 ((res .. (conc
62d0: 22 3c 74 61 62 6c 65 3e 22 0a 09 20 20 20 20 20 "<table>"..
62e0: 20 20 3b 3b 20 22 3c 74 72 3e 3c 74 64 3e 4d 61 ;; "<tr><td>Ma
62f0: 78 20 63 61 63 68 65 64 20 71 75 65 72 69 65 73 x cached queries
6300: 3c 2f 74 64 3e 20 20 20 20 20 20 20 20 3c 74 64 </td> <td
6310: 3e 22 20 2a 6d 61 78 2d 63 61 63 68 65 2d 73 69 >" *max-cache-si
6320: 7a 65 2a 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 ze* "</td></tr>"
6330: 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 .. "<tr><t
6340: 64 3e 4e 75 6d 62 65 72 20 6f 66 20 63 61 63 68 d>Number of cach
6350: 65 64 20 77 72 69 74 65 73 3c 2f 74 64 3e 20 20 ed writes</td>
6360: 20 3c 74 64 3e 22 20 2a 6e 75 6d 62 65 72 2d 6f <td>" *number-o
6370: 66 2d 77 72 69 74 65 73 2a 20 22 3c 2f 74 64 3e f-writes* "</td>
6380: 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 </tr>".. "
6390: 3c 74 72 3e 3c 74 64 3e 41 76 65 72 61 67 65 20 <tr><td>Average
63a0: 63 61 63 68 65 64 20 77 72 69 74 65 20 74 69 6d cached write tim
63b0: 65 3c 2f 74 64 3e 20 3c 74 64 3e 22 20 28 69 66 e</td> <td>" (if
63c0: 20 28 65 71 3f 20 2a 6e 75 6d 62 65 72 2d 6f 66 (eq? *number-of
63d0: 2d 77 72 69 74 65 73 2a 20 30 29 0a 09 09 09 09 -writes* 0).....
63e0: 09 09 09 09 20 22 6e 2f 61 20 28 6e 6f 20 77 72 .... "n/a (no wr
63f0: 69 74 65 73 29 22 0a 09 09 09 09 09 09 09 09 20 ites)".........
6400: 28 2f 20 2a 77 72 69 74 65 73 2d 74 6f 74 61 6c (/ *writes-total
6410: 2d 64 65 6c 61 79 2a 0a 09 09 09 09 09 09 09 09 -delay*.........
6420: 20 20 20 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 *number-of-w
6430: 72 69 74 65 73 2a 29 29 0a 09 20 20 20 20 20 20 rites*))..
6440: 20 22 20 6d 73 3c 2f 74 64 3e 3c 2f 74 72 3e 22 " ms</td></tr>"
6450: 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 .. "<tr><t
6460: 64 3e 4e 75 6d 62 65 72 20 6e 6f 6e 2d 63 61 63 d>Number non-cac
6470: 68 65 64 20 71 75 65 72 69 65 73 3c 2f 74 64 3e hed queries</td>
6480: 20 3c 74 64 3e 22 20 20 2a 6e 75 6d 62 65 72 2d <td>" *number-
6490: 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 non-write-querie
64a0: 73 2a 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a s* "</td></tr>".
64b0: 09 20 20 20 20 20 20 20 3b 3b 20 22 3c 74 72 3e . ;; "<tr>
64c0: 3c 74 64 3e 41 76 65 72 61 67 65 20 6e 6f 6e 2d <td>Average non-
64d0: 63 61 63 68 65 64 20 74 69 6d 65 3c 2f 74 64 3e cached time</td>
64e0: 20 20 20 3c 74 64 3e 22 20 28 69 66 20 28 65 71 <td>" (if (eq
64f0: 3f 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 ? *number-non-wr
6500: 69 74 65 2d 71 75 65 72 69 65 73 2a 20 30 29 0a ite-queries* 0).
6510: 09 20 20 20 20 20 20 20 3b 3b 20 09 09 09 09 09 . ;; .....
6520: 09 09 20 22 6e 2f 61 20 28 6e 6f 20 71 75 65 72 .. "n/a (no quer
6530: 69 65 73 29 22 0a 09 20 20 20 20 20 20 20 3b 3b ies)".. ;;
6540: 20 09 09 09 09 09 09 09 20 28 2f 20 2a 74 6f 74 ....... (/ *tot
6550: 61 6c 2d 6e 6f 6e 2d 77 72 69 74 65 2d 64 65 6c al-non-write-del
6560: 61 79 2a 20 0a 09 20 20 20 20 20 20 20 3b 3b 20 ay* .. ;;
6570: 09 09 09 09 09 09 09 20 20 20 20 2a 6e 75 6d 62 ....... *numb
6580: 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 er-non-write-que
6590: 72 69 65 73 2a 29 29 0a 09 20 20 20 20 20 20 20 ries*))..
65a0: 22 20 6d 73 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a " ms</td></tr>".
65b0: 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 . "<tr><td
65c0: 3e 4c 61 73 74 20 61 63 63 65 73 73 3c 2f 74 64 >Last access</td
65d0: 3e 3c 74 64 3e 22 20 20 20 20 20 20 20 20 20 20 ><td>"
65e0: 20 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 (seconds->ti
65f0: 6d 65 2d 73 74 72 69 6e 67 20 2a 64 62 2d 6c 61 me-string *db-la
6600: 73 74 2d 61 63 63 65 73 73 2a 29 20 22 3c 2f 74 st-access*) "</t
6610: 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 d></tr>"..
6620: 20 22 3c 2f 74 61 62 6c 65 3e 22 29 29 29 0a 20 "</table>"))).
6630: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
6640: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
6650: 65 78 2a 29 0a 20 20 20 20 72 65 73 29 29 0a 0a ex*). res))..
6660: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
6670: 61 6e 73 70 6f 72 74 3a 72 75 6e 73 20 6c 69 6e ansport:runs lin
6680: 6b 70 61 74 68 29 0a 20 20 28 63 6f 6e 63 20 22 kpath). (conc "
6690: 3c 68 33 3e 52 75 6e 73 3c 2f 68 33 3e 22 0a 09 <h3>Runs</h3>"..
66a0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
66b0: 72 73 65 0a 09 20 28 6c 65 74 20 28 28 66 69 6c rse.. (let ((fil
66c0: 65 73 20 28 6d 61 70 20 70 61 74 68 6e 61 6d 65 es (map pathname
66d0: 2d 73 74 72 69 70 2d 64 69 72 65 63 74 6f 72 79 -strip-directory
66e0: 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 6c 69 6e (glob (conc lin
66f0: 6b 70 61 74 68 20 22 2f 2a 22 29 29 29 29 29 0a kpath "/*"))))).
6700: 09 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 . (map (lambda
6710: 20 28 70 29 0a 09 09 20 20 28 63 6f 6e 63 20 22 (p)... (conc "
6720: 3c 61 20 68 72 65 66 3d 5c 22 22 20 70 20 22 5c <a href=\"" p "\
6730: 22 3e 22 20 70 20 22 3c 2f 61 3e 3c 62 72 3e 22 ">" p "</a><br>"
6740: 29 29 0a 09 09 66 69 6c 65 73 29 29 0a 09 20 22 ))...files)).. "
6750: 20 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ")))..(define (
6760: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 http-transport:r
6770: 75 6e 2d 73 74 61 74 73 29 0a 20 20 28 6c 65 74 un-stats). (let
6780: 20 28 28 73 74 61 74 73 20 28 6f 70 65 6e 2d 72 ((stats (open-r
6790: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d un-close db:get-
67a0: 72 75 6e 6e 69 6e 67 2d 73 74 61 74 73 20 23 66 running-stats #f
67b0: 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 3c ))). (conc "<
67c0: 74 61 62 6c 65 3e 22 0a 09 20 20 28 73 74 72 69 table>".. (stri
67d0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 0a 09 ng-intersperse..
67e0: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
67f0: 28 73 74 61 74 29 0a 09 09 20 20 28 63 6f 6e 63 (stat)... (conc
6800: 20 22 3c 74 72 3e 3c 74 64 3e 22 20 28 63 61 72 "<tr><td>" (car
6810: 20 73 74 61 74 29 20 22 3c 2f 74 64 3e 3c 74 64 stat) "</td><td
6820: 3e 22 20 28 63 61 64 72 20 73 74 61 74 29 20 22 >" (cadr stat) "
6830: 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 </td></tr>"))...
6840: 73 74 61 74 73 29 0a 09 20 20 20 22 20 22 29 0a stats).. " ").
6850: 09 20 20 22 3c 2f 74 61 62 6c 65 3e 22 29 29 29 . "</table>")))
6860: 0a .