Artifact
880b0371c44ac4e1abbf4bafd59101a196b5d9be:
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 29 20 3b 3b 20 73 71 6c 69 74 65 33 0a 3b 3b t) ;; sqlite3.;;
01d0: 20 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 (import (prefix
01e0: 20 73 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 sqlite3 sqlite3
01f0: 3a 29 29 0a 0a 28 75 73 65 20 73 70 69 66 66 79 :))..(use spiffy
0200: 20 75 72 69 2d 63 6f 6d 6d 6f 6e 20 69 6e 74 61 uri-common inta
0210: 72 77 65 62 20 68 74 74 70 2d 63 6c 69 65 6e 74 rweb http-client
0220: 20 73 70 69 66 66 79 2d 72 65 71 75 65 73 74 2d spiffy-request-
0230: 76 61 72 73 20 69 6e 74 61 72 77 65 62 20 73 70 vars intarweb sp
0240: 69 66 66 79 2d 64 69 72 65 63 74 6f 72 79 2d 6c iffy-directory-l
0250: 69 73 74 69 6e 67 29 0a 0a 3b 3b 20 43 6f 6e 66 isting)..;; Conf
0260: 69 67 75 72 61 74 69 6f 6e 73 20 66 6f 72 20 73 igurations for s
0270: 65 72 76 65 72 0a 28 74 63 70 2d 62 75 66 66 65 erver.(tcp-buffe
0280: 72 2d 73 69 7a 65 20 32 30 34 38 29 0a 28 6d 61 r-size 2048).(ma
0290: 78 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 32 30 x-connections 20
02a0: 34 38 29 20 0a 0a 28 64 65 63 6c 61 72 65 20 28 48) ..(declare (
02b0: 75 6e 69 74 20 68 74 74 70 2d 74 72 61 6e 73 70 unit http-transp
02c0: 6f 72 74 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 ort))..(declare
02d0: 28 75 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 (uses common)).(
02e0: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 62 declare (uses db
02f0: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0300: 73 20 74 65 73 74 73 29 29 0a 28 64 65 63 6c 61 s tests)).(decla
0310: 72 65 20 28 75 73 65 73 20 74 61 73 6b 73 29 29 re (uses tasks))
0320: 20 3b 3b 20 74 61 73 6b 73 20 61 72 65 20 77 68 ;; tasks are wh
0330: 65 72 65 20 73 74 75 66 66 20 69 73 20 6d 61 69 ere stuff is mai
0340: 6e 74 61 69 6e 65 64 20 61 62 6f 75 74 20 77 68 ntained about wh
0350: 61 74 20 69 73 20 72 75 6e 6e 69 6e 67 2e 0a 28 at is running..(
0360: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 65 declare (uses se
0370: 72 76 65 72 29 29 0a 28 64 65 63 6c 61 72 65 20 rver)).(declare
0380: 28 75 73 65 73 20 64 61 65 6d 6f 6e 29 29 0a 28 (uses daemon)).(
0390: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 70 6f declare (uses po
03a0: 72 74 6c 6f 67 67 65 72 29 29 0a 28 64 65 63 6c rtlogger)).(decl
03b0: 61 72 65 20 28 75 73 65 73 20 72 6d 74 29 29 0a are (uses rmt)).
03c0: 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f .(include "commo
03d0: 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a n_records.scm").
03e0: 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 63 (include "db_rec
03f0: 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 28 64 65 66 ords.scm")..(def
0400: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
0410: 6f 72 74 3a 6d 61 6b 65 2d 73 65 72 76 65 72 2d ort:make-server-
0420: 75 72 6c 20 68 6f 73 74 70 6f 72 74 29 0a 20 20 url hostport).
0430: 28 69 66 20 28 6e 6f 74 20 68 6f 73 74 70 6f 72 (if (not hostpor
0440: 74 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 t). #f.
0450: 20 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f (conc "http://
0460: 22 20 28 63 61 72 20 68 6f 73 74 70 6f 72 74 29 " (car hostport)
0470: 20 22 3a 22 20 28 63 61 64 72 20 68 6f 73 74 70 ":" (cadr hostp
0480: 6f 72 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ort))))..(define
0490: 20 2a 73 65 72 76 65 72 2d 6c 6f 6f 70 2d 68 65 *server-loop-he
04a0: 61 72 74 2d 62 65 61 74 2a 20 28 63 75 72 72 65 art-beat* (curre
04b0: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 0a 3b 3b nt-seconds))..;;
04c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0500: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 20 ======.;; S E R
0510: 56 20 45 20 52 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d V E R.;;========
0520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
0560: 3b 3b 20 43 61 6c 6c 20 74 68 69 73 20 74 6f 20 ;; Call this to
0570: 73 74 61 72 74 20 74 68 65 20 61 63 74 75 61 6c start the actual
0580: 20 73 65 72 76 65 72 0a 3b 3b 0a 0a 28 64 65 66 server.;;..(def
0590: 69 6e 65 20 2a 64 62 3a 70 72 6f 63 65 73 73 2d ine *db:process-
05a0: 71 75 65 75 65 2d 6d 75 74 65 78 2a 20 28 6d 61 queue-mutex* (ma
05b0: 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 28 64 65 66 ke-mutex))..(def
05c0: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
05d0: 6f 72 74 3a 72 75 6e 20 68 6f 73 74 6e 20 72 75 ort:run hostn ru
05e0: 6e 2d 69 64 20 73 65 72 76 65 72 2d 69 64 29 0a n-id server-id).
05f0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
0600: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
0610: 72 74 2a 20 22 41 74 74 65 6d 70 74 69 6e 67 20 rt* "Attempting
0620: 74 6f 20 73 74 61 72 74 20 74 68 65 20 73 65 72 to start the ser
0630: 76 65 72 20 2e 2e 2e 22 29 0a 20 20 28 6c 65 74 ver ..."). (let
0640: 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 20 * ((db
0650: 20 20 20 20 23 66 29 20 3b 3b 20 20 20 20 20 20 #f) ;;
0660: 20 20 28 6f 70 65 6e 2d 64 62 29 29 20 3b 3b 20 (open-db)) ;;
0670: 77 65 20 64 6f 6e 27 74 20 77 61 6e 74 20 74 68 we don't want th
0680: 65 20 73 65 72 76 65 72 20 74 6f 20 62 65 20 6f e server to be o
0690: 70 65 6e 69 6e 67 20 61 6e 64 20 63 6c 6f 73 69 pening and closi
06a0: 6e 67 20 74 68 65 20 64 62 20 75 6e 6e 65 63 65 ng the db unnece
06b0: 73 61 72 69 6c 79 0a 09 20 28 68 6f 73 74 6e 61 sarily.. (hostna
06c0: 6d 65 20 20 20 20 20 20 20 20 28 67 65 74 2d 68 me (get-h
06d0: 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 69 70 ost-name)).. (ip
06e0: 61 64 64 72 73 74 72 20 20 20 20 20 20 20 28 6c addrstr (l
06f0: 65 74 20 28 28 69 70 73 74 72 20 28 69 66 20 28 et ((ipstr (if (
0700: 73 74 72 69 6e 67 3d 3f 20 22 2d 22 20 68 6f 73 string=? "-" hos
0710: 74 6e 29 0a 09 09 09 09 09 20 20 20 3b 3b 20 28 tn)...... ;; (
0720: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
0730: 73 65 20 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e se (map number->
0740: 73 74 72 69 6e 67 20 28 75 38 76 65 63 74 6f 72 string (u8vector
0750: 2d 3e 6c 69 73 74 20 28 68 6f 73 74 6e 61 6d 65 ->list (hostname
0760: 2d 3e 69 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 ->ip hostname)))
0770: 20 22 2e 22 29 0a 09 09 09 09 09 20 20 20 28 73 ".")...... (s
0780: 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 erver:get-best-g
0790: 75 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f 73 uess-address hos
07a0: 74 6e 61 6d 65 29 0a 09 09 09 09 09 20 20 20 23 tname)...... #
07b0: 66 29 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 f))).... (if
07c0: 69 70 73 74 72 20 69 70 73 74 72 20 68 6f 73 74 ipstr ipstr host
07d0: 6e 29 29 29 20 3b 3b 20 68 6f 73 74 6e 61 6d 65 n))) ;; hostname
07e0: 29 29 29 20 0a 09 20 28 73 74 61 72 74 2d 70 6f ))) .. (start-po
07f0: 72 74 20 20 20 20 20 20 28 70 6f 72 74 6c 6f 67 rt (portlog
0800: 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f ger:open-run-clo
0810: 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 66 69 se portlogger:fi
0820: 6e 64 2d 70 6f 72 74 29 29 0a 09 20 28 6c 69 6e nd-port)).. (lin
0830: 6b 2d 74 72 65 65 2d 70 61 74 68 20 20 28 63 6f k-tree-path (co
0840: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
0850: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
0860: 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 29 0a 20 "linktree"))).
0870: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
0880: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
0890: 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 6f 72 74 6c log-port* "portl
08a0: 6f 67 67 65 72 20 72 65 63 6f 6d 6d 65 6e 64 65 ogger recommende
08b0: 64 20 70 6f 72 74 3a 20 22 20 73 74 61 72 74 2d d port: " start-
08c0: 70 6f 72 74 29 0a 20 20 20 20 28 72 6f 6f 74 2d port). (root-
08d0: 70 61 74 68 20 20 20 20 20 28 69 66 20 6c 69 6e path (if lin
08e0: 6b 2d 74 72 65 65 2d 70 61 74 68 20 0a 09 09 20 k-tree-path ...
08f0: 20 20 20 20 20 20 6c 69 6e 6b 2d 74 72 65 65 2d link-tree-
0900: 70 61 74 68 0a 09 09 20 20 20 20 20 20 20 28 63 path... (c
0910: 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 urrent-directory
0920: 29 29 29 20 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 ))) ;; WARNING:
0930: 53 45 43 55 52 49 54 59 20 48 4f 4c 45 2e 20 46 SECURITY HOLE. F
0940: 49 58 20 41 53 41 50 21 0a 20 20 20 20 28 68 61 IX ASAP!. (ha
0950: 6e 64 6c 65 2d 64 69 72 65 63 74 6f 72 79 20 73 ndle-directory s
0960: 70 69 66 66 79 2d 64 69 72 65 63 74 6f 72 79 2d piffy-directory-
0970: 6c 69 73 74 69 6e 67 29 0a 20 20 20 20 28 68 61 listing). (ha
0980: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 20 28 ndle-exception (
0990: 6c 61 6d 62 64 61 20 28 65 78 6e 20 63 68 61 69 lambda (exn chai
09a0: 6e 29 0a 09 09 09 28 73 69 67 6e 61 6c 20 28 6d n)....(signal (m
09b0: 61 6b 65 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 6f ake-composite-co
09c0: 6e 64 69 74 69 6f 6e 0a 09 09 09 09 20 28 6d 61 ndition..... (ma
09d0: 6b 65 2d 70 72 6f 70 65 72 74 79 2d 63 6f 6e 64 ke-property-cond
09e0: 69 74 69 6f 6e 20 0a 09 09 09 09 20 20 27 73 65 ition ..... 'se
09f0: 72 76 65 72 0a 09 09 09 09 20 20 27 6d 65 73 73 rver..... 'mess
0a00: 61 67 65 20 22 73 65 72 76 65 72 20 65 72 72 6f age "server erro
0a10: 72 22 29 29 29 29 29 0a 0a 20 20 20 20 3b 3b 20 r"))))).. ;;
0a20: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 68 http-transport:h
0a30: 61 6e 64 6c 65 2d 64 69 72 65 63 74 6f 72 79 29 andle-directory)
0a40: 20 3b 3b 20 73 69 6d 70 6c 65 2d 64 69 72 65 63 ;; simple-direc
0a50: 74 6f 72 79 2d 68 61 6e 64 6c 65 72 29 0a 20 20 tory-handler).
0a60: 20 20 3b 3b 20 53 65 74 75 70 20 74 68 65 20 77 ;; Setup the w
0a70: 65 62 20 73 65 72 76 65 72 20 61 6e 64 20 61 20 eb server and a
0a80: 2f 63 74 72 6c 20 69 6e 74 65 72 66 61 63 65 0a /ctrl interface.
0a90: 20 20 20 20 3b 3b 0a 20 20 20 20 28 76 68 6f 73 ;;. (vhos
0aa0: 74 2d 6d 61 70 20 60 28 28 28 2a 20 61 6e 79 29 t-map `(((* any)
0ab0: 20 2e 20 2c 28 6c 61 6d 62 64 61 20 28 63 6f 6e . ,(lambda (con
0ac0: 74 69 6e 75 65 29 0a 09 09 09 20 20 20 20 20 20 tinue)....
0ad0: 20 3b 3b 20 6f 70 65 6e 20 74 68 65 20 64 62 20 ;; open the db
0ae0: 6f 6e 20 74 68 65 20 66 69 72 73 74 20 63 61 6c on the first cal
0af0: 6c 20 0a 09 09 09 09 20 3b 3b 20 54 68 69 73 20 l ..... ;; This
0b00: 69 73 20 77 65 72 65 20 77 65 20 73 65 74 20 75 is were we set u
0b10: 70 20 74 68 65 20 64 61 74 61 62 61 73 65 20 63 p the database c
0b20: 6f 6e 6e 65 63 74 69 6f 6e 73 0a 09 09 09 20 20 onnections....
0b30: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 24 20 20 (let* (($
0b40: 20 28 72 65 71 75 65 73 74 2d 76 61 72 73 20 73 (request-vars s
0b50: 6f 75 72 63 65 3a 20 27 62 6f 74 68 29 29 0a 09 ource: 'both))..
0b60: 09 09 09 20 20 20 20 20 20 28 64 61 74 20 28 24 ... (dat ($
0b70: 20 27 64 61 74 29 29 0a 09 09 09 09 20 20 20 20 'dat)).....
0b80: 20 20 28 72 65 73 20 23 66 29 29 0a 09 09 09 09 (res #f)).....
0b90: 20 28 63 6f 6e 64 0a 09 09 09 09 20 20 28 28 65 (cond..... ((e
0ba0: 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 qual? (uri-path
0bb0: 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 (request-uri (cu
0bc0: 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 rrent-request)))
0bd0: 0a 09 09 09 09 09 20 20 20 27 28 2f 20 22 61 70 ...... '(/ "ap
0be0: 69 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e i"))..... (sen
0bf0: 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a d-response body:
0c00: 20 20 20 20 28 61 70 69 3a 70 72 6f 63 65 73 73 (api:process
0c10: 2d 72 65 71 75 65 73 74 20 2a 64 62 73 74 72 75 -request *dbstru
0c20: 63 74 2d 64 62 2a 20 24 29 20 3b 3b 20 74 68 65 ct-db* $) ;; the
0c30: 20 24 20 69 73 20 74 68 65 20 72 65 71 75 65 73 $ is the reques
0c40: 74 20 76 61 72 73 20 70 72 6f 63 0a 09 09 09 09 t vars proc.....
0c50: 09 09 20 20 68 65 61 64 65 72 73 3a 20 27 28 28 .. headers: '((
0c60: 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 65 78 content-type tex
0c70: 74 2f 70 6c 61 69 6e 29 29 29 0a 09 09 09 09 20 t/plain))).....
0c80: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
0c90: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
0ca0: 29 0a 09 09 09 09 20 20 20 28 73 65 74 21 20 2a )..... (set! *
0cb0: 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 db-last-access*
0cc0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
0cd0: 29 29 0a 09 09 09 09 20 20 20 28 6d 75 74 65 78 ))..... (mutex
0ce0: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 -unlock! *heartb
0cf0: 65 61 74 2d 6d 75 74 65 78 2a 29 29 0a 09 09 09 eat-mutex*))....
0d00: 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 69 . ((equal? (uri
0d10: 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 2d 75 -path (request-u
0d20: 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 75 ri (current-requ
0d30: 65 73 74 29 29 29 20 0a 09 09 09 09 09 20 20 20 est))) ......
0d40: 27 28 2f 20 22 22 29 29 0a 09 09 09 09 20 20 20 '(/ "")).....
0d50: 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 (send-response b
0d60: 6f 64 79 3a 20 28 68 74 74 70 2d 74 72 61 6e 73 ody: (http-trans
0d70: 70 6f 72 74 3a 6d 61 69 6e 2d 70 61 67 65 29 29 port:main-page))
0d80: 29 0a 09 09 09 09 20 20 28 28 65 71 75 61 6c 3f )..... ((equal?
0d90: 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 (uri-path (requ
0da0: 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 est-uri (current
0db0: 2d 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 09 -request))) ....
0dc0: 09 09 20 20 20 27 28 2f 20 22 6a 73 6f 6e 5f 61 .. '(/ "json_a
0dd0: 70 69 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 pi"))..... (se
0de0: 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 nd-response body
0df0: 3a 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 : (http-transpor
0e00: 74 3a 6d 61 69 6e 2d 70 61 67 65 29 29 29 0a 09 t:main-page)))..
0e10: 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 ... ((equal? (u
0e20: 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 ri-path (request
0e30: 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 -uri (current-re
0e40: 71 75 65 73 74 29 29 29 20 0a 09 09 09 09 09 20 quest))) ......
0e50: 20 20 27 28 2f 20 22 72 75 6e 73 22 29 29 0a 09 '(/ "runs"))..
0e60: 09 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 ... (send-resp
0e70: 6f 6e 73 65 20 62 6f 64 79 3a 20 28 68 74 74 70 onse body: (http
0e80: 2d 74 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e 2d -transport:main-
0e90: 70 61 67 65 29 29 29 0a 09 09 09 09 20 20 28 28 page)))..... ((
0ea0: 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 equal? (uri-path
0eb0: 20 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 (request-uri (c
0ec0: 75 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 urrent-request))
0ed0: 29 20 0a 09 09 09 09 09 20 20 20 27 28 2f 20 61 ) ...... '(/ a
0ee0: 6e 79 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e ny))..... (sen
0ef0: 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a d-response body:
0f00: 20 22 68 65 79 20 74 68 65 72 65 21 5c 6e 22 0a "hey there!\n".
0f10: 09 09 09 09 09 09 20 20 68 65 61 64 65 72 73 3a ...... headers:
0f20: 20 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 65 '((content-type
0f30: 20 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 29 0a text/plain)))).
0f40: 09 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 .... ((equal? (
0f50: 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 uri-path (reques
0f60: 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 t-uri (current-r
0f70: 65 71 75 65 73 74 29 29 29 20 0a 09 09 09 09 09 equest))) ......
0f80: 20 20 20 27 28 2f 20 22 68 65 79 22 29 29 0a 09 '(/ "hey"))..
0f90: 09 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 ... (send-resp
0fa0: 6f 6e 73 65 20 62 6f 64 79 3a 20 22 68 65 79 20 onse body: "hey
0fb0: 74 68 65 72 65 21 5c 6e 22 0a 09 09 09 09 09 09 there!\n".......
0fc0: 20 20 68 65 61 64 65 72 73 3a 20 27 28 28 63 6f headers: '((co
0fd0: 6e 74 65 6e 74 2d 74 79 70 65 20 74 65 78 74 2f ntent-type text/
0fe0: 70 6c 61 69 6e 29 29 29 29 0a 09 09 09 09 20 20 plain)))).....
0ff0: 28 65 6c 73 65 20 28 63 6f 6e 74 69 6e 75 65 29 (else (continue)
1000: 29 29 29 29 29 29 29 0a 20 20 20 20 28 68 74 74 ))))))). (htt
1010: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d p-transport:try-
1020: 73 74 61 72 74 2d 73 65 72 76 65 72 20 72 75 6e start-server run
1030: 2d 69 64 20 69 70 61 64 64 72 73 74 72 20 73 74 -id ipaddrstr st
1040: 61 72 74 2d 70 6f 72 74 20 73 65 72 76 65 72 2d art-port server-
1050: 69 64 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 69 id)))..;; This i
1060: 73 20 72 65 63 75 72 73 69 76 65 6c 79 20 72 75 s recursively ru
1070: 6e 20 62 79 20 68 74 74 70 2d 74 72 61 6e 73 70 n by http-transp
1080: 6f 72 74 3a 72 75 6e 20 75 6e 74 69 6c 20 73 75 ort:run until su
1090: 63 65 73 73 66 75 6c 0a 3b 3b 0a 28 64 65 66 69 cessful.;;.(defi
10a0: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
10b0: 72 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 rt:try-start-ser
10c0: 76 65 72 20 72 75 6e 2d 69 64 20 69 70 61 64 64 ver run-id ipadd
10d0: 72 73 74 72 20 70 6f 72 74 6e 75 6d 20 73 65 72 rstr portnum ser
10e0: 76 65 72 2d 69 64 29 0a 20 20 28 6c 65 74 20 28 ver-id). (let (
10f0: 28 63 6f 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 (config-hostname
1100: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
1110: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
1120: 72 76 65 72 22 20 22 68 6f 73 74 6e 61 6d 65 22 rver" "hostname"
1130: 29 29 0a 09 28 74 64 62 64 61 74 20 20 20 20 20 ))..(tdbdat
1140: 20 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 6e (tasks:open
1150: 2d 64 62 29 29 29 0a 20 20 20 20 28 64 65 62 75 -db))). (debu
1160: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
1170: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1180: 2a 20 22 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 * "http-transpor
1190: 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 76 t:try-start-serv
11a0: 65 72 20 74 69 6d 65 3d 22 20 28 73 65 63 6f 6e er time=" (secon
11b0: 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 ds->time-string
11c0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
11d0: 29 29 20 22 20 72 75 6e 2d 69 64 3d 22 20 72 75 )) " run-id=" ru
11e0: 6e 2d 69 64 20 22 20 69 70 61 64 64 72 73 73 74 n-id " ipaddrsst
11f0: 72 3d 22 20 69 70 61 64 64 72 73 74 72 20 22 20 r=" ipaddrstr "
1200: 70 6f 72 74 6e 75 6d 3d 22 20 70 6f 72 74 6e 75 portnum=" portnu
1210: 6d 20 22 20 73 65 72 76 65 72 2d 69 64 3d 22 20 m " server-id="
1220: 73 65 72 76 65 72 2d 69 64 20 22 20 63 6f 6e 66 server-id " conf
1230: 69 67 2d 68 6f 73 74 6e 61 6d 65 3d 22 20 63 6f ig-hostname=" co
1240: 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 29 0a 20 nfig-hostname).
1250: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
1260: 74 69 6f 6e 73 0a 20 20 20 20 20 65 78 6e 0a 20 tions. exn.
1270: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
1280: 20 20 28 70 72 69 6e 74 2d 65 72 72 6f 72 2d 6d (print-error-m
1290: 65 73 73 61 67 65 20 65 78 6e 29 0a 20 20 20 20 essage exn).
12a0: 20 20 20 28 69 66 20 28 3c 20 70 6f 72 74 6e 75 (if (< portnu
12b0: 6d 20 36 34 30 30 30 29 0a 09 20 20 20 28 62 65 m 64000).. (be
12c0: 67 69 6e 20 0a 09 20 20 20 20 20 28 64 65 62 75 gin .. (debu
12d0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
12e0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
12f0: 52 4e 49 4e 47 3a 20 61 74 74 65 6d 70 74 20 74 RNING: attempt t
1300: 6f 20 73 74 61 72 74 20 73 65 72 76 65 72 20 66 o start server f
1310: 61 69 6c 65 64 2e 20 54 72 79 69 6e 67 20 61 67 ailed. Trying ag
1320: 61 69 6e 20 2e 2e 2e 22 29 0a 09 20 20 20 20 20 ain ...")..
1330: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
1340: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1350: 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 * " message: " (
1360: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
1370: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
1380: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
1390: 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ).. (debug:p
13a0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
13b0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 65 78 6e 3d 22 log-port* "exn="
13c0: 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 (condition->lis
13d0: 74 20 65 78 6e 29 29 0a 09 20 20 20 20 20 28 70 t exn)).. (p
13e0: 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 ortlogger:open-r
13f0: 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 un-close portlog
1400: 67 65 72 3a 73 65 74 2d 66 61 69 6c 65 64 20 70 ger:set-failed p
1410: 6f 72 74 6e 75 6d 29 0a 09 20 20 20 20 20 28 64 ortnum).. (d
1420: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
1430: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1440: 22 57 41 52 4e 49 4e 47 3a 20 66 61 69 6c 65 64 "WARNING: failed
1450: 20 74 6f 20 73 74 61 72 74 20 6f 6e 20 70 6f 72 to start on por
1460: 74 6e 75 6d 3a 20 22 20 70 6f 72 74 6e 75 6d 20 tnum: " portnum
1470: 22 2c 20 74 72 79 69 6e 67 20 6e 65 78 74 20 70 ", trying next p
1480: 6f 72 74 22 29 0a 09 20 20 20 20 20 28 74 68 72 ort").. (thr
1490: 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 31 29 0a ead-sleep! 0.1).
14a0: 0a 09 20 20 20 20 20 3b 3b 20 67 65 74 5f 6e 65 .. ;; get_ne
14b0: 78 74 5f 70 6f 72 74 20 67 6f 65 73 20 68 65 72 xt_port goes her
14c0: 65 0a 09 20 20 20 20 20 28 68 74 74 70 2d 74 72 e.. (http-tr
14d0: 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 ansport:try-star
14e0: 74 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 0a t-server run-id.
14f0: 09 09 09 09 09 20 20 20 20 20 20 69 70 61 64 64 ..... ipadd
1500: 72 73 74 72 0a 09 09 09 09 09 20 20 20 20 20 20 rstr......
1510: 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 6e (portlogger:open
1520: 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 6c -run-close portl
1530: 6f 67 67 65 72 3a 66 69 6e 64 2d 70 6f 72 74 29 ogger:find-port)
1540: 0a 09 09 09 09 09 20 20 20 20 20 20 73 65 72 76 ...... serv
1550: 65 72 2d 69 64 29 29 0a 09 20 20 20 28 62 65 67 er-id)).. (beg
1560: 69 6e 0a 09 20 20 20 20 20 28 74 61 73 6b 73 3a in.. (tasks:
1570: 73 65 72 76 65 72 2d 66 6f 72 63 65 2d 63 6c 65 server-force-cle
1580: 61 6e 2d 72 75 6e 2d 72 65 63 6f 72 64 20 28 64 an-run-record (d
1590: 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 b:delay-if-busy
15a0: 74 64 62 64 61 74 29 20 72 75 6e 2d 69 64 20 69 tdbdat) run-id i
15b0: 70 61 64 64 72 73 74 72 20 70 6f 72 74 6e 75 6d paddrstr portnum
15c0: 20 22 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 " http-transpor
15d0: 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 76 t:try-start-serv
15e0: 65 72 22 29 0a 09 20 20 20 20 20 28 70 72 69 6e er").. (prin
15f0: 74 20 22 45 52 52 4f 52 3a 20 54 72 69 65 64 20 t "ERROR: Tried
1600: 61 6e 64 20 74 72 69 65 64 20 62 75 74 20 63 6f and tried but co
1610: 75 6c 64 20 6e 6f 74 20 73 74 61 72 74 20 74 68 uld not start th
1620: 65 20 73 65 72 76 65 72 22 29 29 29 29 0a 20 20 e server")))).
1630: 20 20 20 3b 3b 20 61 6e 79 20 65 72 72 6f 72 20 ;; any error
1640: 69 6e 20 66 6f 6c 6c 6f 77 69 6e 67 20 73 74 65 in following ste
1650: 70 73 20 77 69 6c 6c 20 72 65 73 75 6c 74 20 69 ps will result i
1660: 6e 20 61 20 72 65 74 72 79 0a 20 20 20 20 20 28 n a retry. (
1670: 73 65 74 21 20 2a 73 65 72 76 65 72 2d 69 6e 66 set! *server-inf
1680: 6f 2a 20 28 6c 69 73 74 20 69 70 61 64 64 72 73 o* (list ipaddrs
1690: 74 72 20 70 6f 72 74 6e 75 6d 29 29 0a 20 20 20 tr portnum)).
16a0: 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d (tasks:server-
16b0: 73 65 74 2d 69 6e 74 65 72 66 61 63 65 2d 70 6f set-interface-po
16c0: 72 74 20 0a 09 09 20 20 20 20 20 28 64 62 3a 64 rt ... (db:d
16d0: 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 62 elay-if-busy tdb
16e0: 64 61 74 29 0a 09 09 20 20 20 20 20 73 65 72 76 dat)... serv
16f0: 65 72 2d 69 64 20 0a 09 09 20 20 20 20 20 69 70 er-id ... ip
1700: 61 64 64 72 73 74 72 20 70 6f 72 74 6e 75 6d 29 addrstr portnum)
1710: 0a 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
1720: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
1730: 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 54 g-port* "INFO: T
1740: 72 79 69 6e 67 20 74 6f 20 73 74 61 72 74 20 73 rying to start s
1750: 65 72 76 65 72 20 6f 6e 20 22 20 69 70 61 64 64 erver on " ipadd
1760: 72 73 74 72 20 22 3a 22 20 70 6f 72 74 6e 75 6d rstr ":" portnum
1770: 29 0a 20 20 20 20 20 3b 3b 20 54 68 69 73 20 73 ). ;; This s
1780: 74 61 72 74 73 20 74 68 65 20 73 70 69 66 66 79 tarts the spiffy
1790: 20 73 65 72 76 65 72 0a 20 20 20 20 20 3b 3b 20 server. ;;
17a0: 4e 45 45 44 20 57 41 59 20 54 4f 20 53 45 54 20 NEED WAY TO SET
17b0: 49 50 20 54 4f 20 23 66 20 54 4f 20 42 49 4e 44 IP TO #f TO BIND
17c0: 20 41 4c 4c 0a 20 20 20 20 20 3b 3b 20 28 73 74 ALL. ;; (st
17d0: 61 72 74 2d 73 65 72 76 65 72 20 62 69 6e 64 2d art-server bind-
17e0: 61 64 64 72 65 73 73 3a 20 69 70 61 64 64 72 73 address: ipaddrs
17f0: 74 72 20 70 6f 72 74 3a 20 70 6f 72 74 6e 75 6d tr port: portnum
1800: 29 0a 20 20 20 20 20 28 69 66 20 63 6f 6e 66 69 ). (if confi
1810: 67 2d 68 6f 73 74 6e 61 6d 65 20 3b 3b 20 74 68 g-hostname ;; th
1820: 69 73 20 69 73 20 61 20 68 69 6e 74 20 74 6f 20 is is a hint to
1830: 62 69 6e 64 20 64 69 72 65 63 74 6c 79 0a 09 20 bind directly..
1840: 28 73 74 61 72 74 2d 73 65 72 76 65 72 20 70 6f (start-server po
1850: 72 74 3a 20 70 6f 72 74 6e 75 6d 20 62 69 6e 64 rt: portnum bind
1860: 2d 61 64 64 72 65 73 73 3a 20 28 69 66 20 28 65 -address: (if (e
1870: 71 75 61 6c 3f 20 63 6f 6e 66 69 67 2d 68 6f 73 qual? config-hos
1880: 74 6e 61 6d 65 20 22 2d 22 29 0a 09 09 09 09 09 tname "-")......
1890: 09 20 20 20 20 20 20 20 69 70 61 64 64 72 73 74 . ipaddrst
18a0: 72 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 63 r....... c
18b0: 6f 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 29 29 onfig-hostname))
18c0: 0a 09 20 28 73 74 61 72 74 2d 73 65 72 76 65 72 .. (start-server
18d0: 20 70 6f 72 74 3a 20 70 6f 72 74 6e 75 6d 29 29 port: portnum))
18e0: 0a 20 20 20 20 20 3b 3b 20 20 28 70 6f 72 74 6c . ;; (portl
18f0: 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 ogger:open-run-c
1900: 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a lose portlogger:
1910: 73 65 74 2d 70 6f 72 74 20 70 6f 72 74 6e 75 6d set-port portnum
1920: 20 22 72 65 6c 65 61 73 65 64 22 29 0a 20 20 20 "released").
1930: 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d (tasks:server-
1940: 66 6f 72 63 65 2d 63 6c 65 61 6e 2d 72 75 6e 2d force-clean-run-
1950: 72 65 63 6f 72 64 20 28 64 62 3a 64 65 6c 61 79 record (db:delay
1960: 2d 69 66 2d 62 75 73 79 20 74 64 62 64 61 74 29 -if-busy tdbdat)
1970: 20 72 75 6e 2d 69 64 20 69 70 61 64 64 72 73 74 run-id ipaddrst
1980: 72 20 70 6f 72 74 6e 75 6d 20 22 20 68 74 74 70 r portnum " http
1990: 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 -transport:try-s
19a0: 74 61 72 74 2d 73 65 72 76 65 72 22 29 0a 20 20 tart-server").
19b0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
19c0: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
19d0: 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 73 65 72 76 ort* "INFO: serv
19e0: 65 72 20 68 61 73 20 62 65 65 6e 20 73 74 6f 70 er has been stop
19f0: 70 65 64 22 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d ped"))))..;;====
1a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a20: 3d 3d 3d 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 0a 3b 3b 20 53 20 45 20 52 20 56 20 45 20 ==.;; S E R V E
1a50: 52 20 20 20 55 20 54 20 49 20 4c 20 49 20 54 20 R U T I L I T
1a60: 49 20 45 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d I E S .;;=======
1a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
1ab0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
1ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 20 4c =========.;; C L
1b00: 20 49 20 45 20 4e 20 54 20 53 0a 3b 3b 3d 3d 3d I E N T S.;;===
1b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b50: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 2a 68 74 ===..(define *ht
1b60: 74 70 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d tp-mutex* (make-
1b70: 6d 75 74 65 78 29 29 0a 0a 3b 3b 20 4e 4f 54 45 mutex))..;; NOTE
1b80: 3a 20 4c 61 72 67 65 20 62 6c 6f 63 6b 20 6f 66 : Large block of
1b90: 20 63 6f 64 65 20 66 72 6f 6d 20 33 32 34 33 36 code from 32436
1ba0: 62 34 32 36 31 38 38 30 38 30 66 37 32 66 63 65 b426188080f72fce
1bb0: 62 36 38 39 34 61 66 35 34 31 66 62 61 64 39 39 b6894af541fbad99
1bc0: 32 31 65 20 72 65 6d 6f 76 65 64 20 68 65 72 65 21e removed here
1bd0: 0a 3b 3b 20 20 20 20 20 20 20 49 27 6d 20 70 72 .;; I'm pr
1be0: 65 74 74 79 20 73 75 72 65 20 69 74 20 69 73 20 etty sure it is
1bf0: 64 65 66 75 6e 63 74 2e 0a 0a 3b 3b 20 54 68 69 defunct...;; Thi
1c00: 73 20 6e 65 78 74 20 62 6c 6f 63 6b 20 61 6c 6c s next block all
1c10: 20 69 6d 70 6f 72 74 65 64 20 65 6e 2d 6d 61 73 imported en-mas
1c20: 73 20 66 72 6f 6d 20 74 68 65 20 61 70 69 20 62 s from the api b
1c30: 72 61 6e 63 68 0a 28 64 65 66 69 6e 65 20 2a 68 ranch.(define *h
1c40: 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d ttp-requests-in-
1c50: 70 72 6f 67 72 65 73 73 2a 20 30 29 0a 28 64 65 progress* 0).(de
1c60: 66 69 6e 65 20 2a 68 74 74 70 2d 63 6f 6e 6e 65 fine *http-conne
1c70: 63 74 69 6f 6e 73 2d 6e 65 78 74 2d 63 6c 65 61 ctions-next-clea
1c80: 6e 75 70 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 nup* (current-se
1c90: 63 6f 6e 64 73 29 29 0a 0a 28 64 65 66 69 6e 65 conds))..(define
1ca0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
1cb0: 3a 67 65 74 2d 74 69 6d 65 2d 74 6f 2d 63 6c 65 :get-time-to-cle
1cc0: 61 6e 75 70 29 0a 20 20 28 6c 65 74 20 28 28 72 anup). (let ((r
1cd0: 65 73 20 23 66 29 29 0a 20 20 20 20 28 6d 75 74 es #f)). (mut
1ce0: 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d ex-lock! *http-m
1cf0: 75 74 65 78 2a 29 0a 20 20 20 20 28 73 65 74 21 utex*). (set!
1d00: 20 72 65 73 20 28 3e 20 28 63 75 72 72 65 6e 74 res (> (current
1d10: 2d 73 65 63 6f 6e 64 73 29 20 2a 68 74 74 70 2d -seconds) *http-
1d20: 63 6f 6e 6e 65 63 74 69 6f 6e 73 2d 6e 65 78 74 connections-next
1d30: 2d 63 6c 65 61 6e 75 70 2a 29 29 0a 20 20 20 20 -cleanup*)).
1d40: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
1d50: 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 20 http-mutex*).
1d60: 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 res))..(define
1d70: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
1d80: 69 6e 63 2d 72 65 71 75 65 73 74 73 2d 63 6f 75 inc-requests-cou
1d90: 6e 74 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 nt). (mutex-loc
1da0: 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 k! *http-mutex*)
1db0: 0a 20 20 28 73 65 74 21 20 2a 68 74 74 70 2d 72 . (set! *http-r
1dc0: 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 equests-in-progr
1dd0: 65 73 73 2a 20 28 2b 20 31 20 2a 68 74 74 70 2d ess* (+ 1 *http-
1de0: 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 requests-in-prog
1df0: 72 65 73 73 2a 29 29 0a 20 20 3b 3b 20 55 73 65 ress*)). ;; Use
1e00: 20 74 68 69 73 20 6f 70 70 6f 72 74 75 6e 69 74 this opportunit
1e10: 79 20 74 6f 20 73 6c 6f 77 20 74 68 69 6e 67 73 y to slow things
1e20: 20 64 6f 77 6e 20 69 66 66 20 74 68 65 72 65 20 down iff there
1e30: 61 72 65 20 74 6f 6f 20 6d 61 6e 79 20 72 65 71 are too many req
1e40: 75 65 73 74 73 20 69 6e 20 66 6c 69 67 68 74 0a uests in flight.
1e50: 20 20 28 69 66 20 28 3e 20 2a 68 74 74 70 2d 72 (if (> *http-r
1e60: 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 equests-in-progr
1e70: 65 73 73 2a 20 35 29 0a 20 20 20 20 20 20 28 62 ess* 5). (b
1e80: 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 egin..(debug:pri
1e90: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
1ea0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 68 lt-log-port* "Wh
1eb0: 6f 61 20 74 68 65 72 65 20 62 75 64 64 79 2c 20 oa there buddy,
1ec0: 65 61 73 65 20 75 70 2e 2e 2e 22 29 0a 09 28 74 ease up...")..(t
1ed0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 29 hread-sleep! 1))
1ee0: 29 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 ). (mutex-unloc
1ef0: 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 k! *http-mutex*)
1f00: 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 )..(define (http
1f10: 2d 74 72 61 6e 73 70 6f 72 74 3a 64 65 63 2d 72 -transport:dec-r
1f20: 65 71 75 65 73 74 73 2d 63 6f 75 6e 74 20 70 72 equests-count pr
1f30: 6f 63 29 20 0a 20 20 28 6d 75 74 65 78 2d 6c 6f oc) . (mutex-lo
1f40: 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a ck! *http-mutex*
1f50: 29 0a 20 20 28 70 72 6f 63 29 0a 20 20 28 73 65 ). (proc). (se
1f60: 74 21 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 t! *http-request
1f70: 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 28 s-in-progress* (
1f80: 2d 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 - *http-requests
1f90: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 31 29 -in-progress* 1)
1fa0: 29 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 ). (mutex-unloc
1fb0: 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 k! *http-mutex*)
1fc0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 )..(define (http
1fd0: 2d 74 72 61 6e 73 70 6f 72 74 3a 64 65 63 2d 72 -transport:dec-r
1fe0: 65 71 75 65 73 74 73 2d 63 6f 75 6e 74 2d 61 6e equests-count-an
1ff0: 64 2d 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e d-close-all-conn
2000: 65 63 74 69 6f 6e 73 29 0a 20 20 28 73 65 74 21 ections). (set!
2010: 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d *http-requests-
2020: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 28 2d 20 in-progress* (-
2030: 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 *http-requests-i
2040: 6e 2d 70 72 6f 67 72 65 73 73 2a 20 31 29 29 0a n-progress* 1)).
2050: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 65 74 (let loop ((et
2060: 69 6d 65 20 28 2b 20 28 63 75 72 72 65 6e 74 2d ime (+ (current-
2070: 73 65 63 6f 6e 64 73 29 20 35 29 29 29 20 3b 3b seconds) 5))) ;;
2080: 20 67 69 76 65 20 75 70 20 69 6e 20 66 69 76 65 give up in five
2090: 20 73 65 63 6f 6e 64 73 0a 20 20 20 20 28 69 66 seconds. (if
20a0: 20 28 3e 20 2a 68 74 74 70 2d 72 65 71 75 65 73 (> *http-reques
20b0: 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 ts-in-progress*
20c0: 30 29 0a 09 28 69 66 20 28 3e 20 65 74 69 6d 65 0)..(if (> etime
20d0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
20e0: 73 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a s)).. (begin.
20f0: 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
2100: 6c 65 65 70 21 20 30 2e 30 35 29 0a 09 20 20 20 leep! 0.05)..
2110: 20 20 20 28 6c 6f 6f 70 20 65 74 69 6d 65 29 29 (loop etime))
2120: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
2130: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
2140: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 ult-log-port* "r
2150: 65 71 75 65 73 74 73 20 73 74 69 6c 6c 20 69 6e equests still in
2160: 20 70 72 6f 67 72 65 73 73 20 61 66 74 65 72 20 progress after
2170: 35 20 73 65 63 6f 6e 64 73 20 6f 66 20 77 61 69 5 seconds of wai
2180: 74 69 6e 67 2e 20 49 27 6d 20 67 6f 69 6e 67 20 ting. I'm going
2190: 74 6f 20 70 61 73 73 20 6f 6e 20 63 6c 65 61 6e to pass on clean
21a0: 69 6e 67 20 75 70 20 68 74 74 70 20 63 6f 6e 6e ing up http conn
21b0: 65 63 74 69 6f 6e 73 22 29 29 0a 09 28 63 6c 6f ections"))..(clo
21c0: 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f se-all-connectio
21d0: 6e 73 21 29 29 29 0a 20 20 28 73 65 74 21 20 2a ns!))). (set! *
21e0: 68 74 74 70 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 http-connections
21f0: 2d 6e 65 78 74 2d 63 6c 65 61 6e 75 70 2a 20 28 -next-cleanup* (
2200: 2b 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e + (current-secon
2210: 64 73 29 20 31 30 29 29 0a 20 20 28 6d 75 74 65 ds) 10)). (mute
2220: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d x-unlock! *http-
2230: 6d 75 74 65 78 2a 29 29 0a 0a 28 64 65 66 69 6e mutex*))..(defin
2240: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
2250: 74 3a 69 6e 63 2d 72 65 71 75 65 73 74 73 2d 61 t:inc-requests-a
2260: 6e 64 2d 70 72 65 70 2d 74 6f 2d 63 6c 6f 73 65 nd-prep-to-close
2270: 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 -all-connections
2280: 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 ). (mutex-lock!
2290: 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 *http-mutex*).
22a0: 20 28 73 65 74 21 20 2a 68 74 74 70 2d 72 65 71 (set! *http-req
22b0: 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 uests-in-progres
22c0: 73 2a 20 28 2b 20 31 20 2a 68 74 74 70 2d 72 65 s* (+ 1 *http-re
22d0: 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 quests-in-progre
22e0: 73 73 2a 29 29 29 0a 0a 3b 3b 20 53 65 6e 64 20 ss*)))..;; Send
22f0: 22 63 6d 64 22 20 77 69 74 68 20 6a 73 6f 6e 20 "cmd" with json
2300: 70 61 79 6c 6f 61 64 20 22 70 61 72 61 6d 73 22 payload "params"
2310: 20 74 6f 20 73 65 72 76 65 72 64 61 74 20 61 6e to serverdat an
2320: 64 20 72 65 63 65 69 76 65 20 72 65 73 75 6c 74 d receive result
2330: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 74 .;;.(define (htt
2340: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 p-transport:clie
2350: 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 nt-api-send-rece
2360: 69 76 65 20 72 75 6e 2d 69 64 20 73 65 72 76 65 ive run-id serve
2370: 72 64 61 74 20 63 6d 64 20 70 61 72 61 6d 73 20 rdat cmd params
2380: 23 21 6b 65 79 20 28 6e 75 6d 72 65 74 72 69 65 #!key (numretrie
2390: 73 20 33 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 s 3)). (let* ((
23a0: 66 75 6c 6c 75 72 6c 20 20 20 20 28 69 66 20 28 fullurl (if (
23b0: 76 65 63 74 6f 72 3f 20 73 65 72 76 65 72 64 61 vector? serverda
23c0: 74 29 0a 09 09 09 20 28 68 74 74 70 2d 74 72 61 t).... (http-tra
23d0: 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 nsport:server-da
23e0: 74 2d 67 65 74 2d 61 70 69 2d 72 65 71 20 73 65 t-get-api-req se
23f0: 72 76 65 72 64 61 74 29 0a 09 09 09 20 28 62 65 rverdat).... (be
2400: 67 69 6e 0a 09 09 09 20 20 20 28 64 65 62 75 67 gin.... (debug
2410: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
2420: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 41 54 t-log-port* "FAT
2430: 41 4c 20 45 52 52 4f 52 3a 20 68 74 74 70 2d 74 AL ERROR: http-t
2440: 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d ransport:client-
2450: 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 api-send-receive
2460: 20 63 61 6c 6c 65 64 20 77 69 74 68 20 6e 6f 20 called with no
2470: 73 65 72 76 65 72 20 69 6e 66 6f 22 29 0a 09 09 server info")...
2480: 09 20 20 20 28 65 78 69 74 20 31 29 29 29 29 0a . (exit 1)))).
2490: 09 20 28 72 65 73 20 20 20 20 20 20 20 20 28 76 . (res (v
24a0: 65 63 74 6f 72 20 23 66 20 22 75 6e 69 6e 69 74 ector #f "uninit
24b0: 69 61 6c 69 7a 65 64 22 29 29 0a 09 20 28 73 75 ialized")).. (su
24c0: 63 63 65 73 73 20 20 20 20 23 74 29 0a 09 20 28 ccess #t).. (
24d0: 73 70 61 72 61 6d 73 20 20 20 20 28 64 62 3a 6f sparams (db:o
24e0: 62 6a 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d bj->string param
24f0: 73 20 74 72 61 6e 73 70 6f 72 74 3a 20 27 68 74 s transport: 'ht
2500: 74 70 29 29 29 0a 20 20 20 20 20 20 20 28 64 65 tp))). (de
2510: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
2520: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
2530: 6f 72 74 2a 20 22 66 75 6c 6c 75 72 6c 3d 22 20 ort* "fullurl="
2540: 66 75 6c 6c 75 72 6c 20 22 2c 20 63 6d 64 3d 22 fullurl ", cmd="
2550: 20 63 6d 64 20 22 2c 20 70 61 72 61 6d 73 3d 22 cmd ", params="
2560: 20 70 61 72 61 6d 73 20 22 2c 20 72 75 6e 2d 69 params ", run-i
2570: 64 3d 22 20 72 75 6e 2d 69 64 20 22 5c 6e 22 29 d=" run-id "\n")
2580: 0a 20 20 20 20 20 20 20 3b 3b 20 73 65 74 20 75 . ;; set u
2590: 70 20 74 68 65 20 68 74 74 70 2d 63 6c 69 65 6e p the http-clien
25a0: 74 20 68 65 72 65 0a 20 20 20 20 20 20 20 28 6d t here. (m
25b0: 61 78 2d 72 65 74 72 79 2d 61 74 74 65 6d 70 74 ax-retry-attempt
25c0: 73 20 31 29 0a 20 20 20 20 20 20 20 3b 3b 20 63 s 1). ;; c
25d0: 6f 6e 73 69 64 65 72 20 61 6c 6c 20 72 65 71 75 onsider all requ
25e0: 65 73 74 73 20 69 6e 64 65 6d 70 6f 74 65 6e 74 ests indempotent
25f0: 0a 20 20 20 20 20 20 20 28 72 65 74 72 79 2d 72 . (retry-r
2600: 65 71 75 65 73 74 3f 20 28 6c 61 6d 62 64 61 20 equest? (lambda
2610: 28 72 65 71 75 65 73 74 29 0a 09 09 09 20 23 66 (request).... #f
2620: 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 73 65 6e )). ;; sen
2630: 64 20 74 68 65 20 64 61 74 61 20 61 6e 64 20 67 d the data and g
2640: 65 74 20 74 68 65 20 72 65 73 70 6f 6e 73 65 0a et the response.
2650: 20 20 20 20 20 20 20 3b 3b 20 65 78 74 72 61 63 ;; extrac
2660: 74 20 74 68 65 20 6e 65 65 64 65 64 20 69 6e 66 t the needed inf
2670: 6f 20 66 72 6f 6d 20 74 68 65 20 68 74 74 70 20 o from the http
2680: 64 61 74 61 20 61 6e 64 20 0a 20 20 20 20 20 20 data and .
2690: 20 3b 3b 20 70 72 6f 63 65 73 73 20 61 6e 64 20 ;; process and
26a0: 72 65 74 75 72 6e 20 69 74 2e 0a 20 20 20 20 20 return it..
26b0: 20 20 28 6c 65 74 2a 20 28 28 73 65 6e 64 2d 72 (let* ((send-r
26c0: 65 63 69 65 76 65 20 28 6c 61 6d 62 64 61 20 28 ecieve (lambda (
26d0: 29 0a 09 09 09 20 20 20 20 20 20 28 6d 75 74 65 ).... (mute
26e0: 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 x-lock! *http-mu
26f0: 74 65 78 2a 29 0a 09 09 09 20 20 20 20 20 20 3b tex*).... ;
2700: 3b 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 ; (condition-cas
2710: 65 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 e (with-input-fr
2720: 6f 6d 2d 72 65 71 75 65 73 74 20 22 68 74 74 70 om-request "http
2730: 3a 2f 2f 6c 6f 63 61 6c 68 6f 73 74 22 3b 20 23 ://localhost"; #
2740: 66 20 72 65 61 64 2d 6c 69 6e 65 73 29 0a 09 09 f read-lines)...
2750: 09 20 20 20 20 20 20 3b 3b 09 09 09 09 09 20 20 . ;;.....
2760: 20 20 20 20 20 28 28 65 78 6e 20 68 74 74 70 20 ((exn http
2770: 63 6c 69 65 6e 74 2d 65 72 72 6f 72 29 20 65 20 client-error) e
2780: 28 70 72 69 6e 74 20 65 29 29 29 0a 09 09 09 20 (print e)))....
2790: 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 28 (set! res (
27a0: 76 65 63 74 6f 72 0a 09 09 09 09 09 20 73 75 63 vector...... suc
27b0: 63 65 73 73 0a 09 09 09 09 09 20 28 64 62 3a 73 cess...... (db:s
27c0: 74 72 69 6e 67 2d 3e 6f 62 6a 20 0a 09 09 09 09 tring->obj .....
27d0: 09 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 . (handle-excep
27e0: 74 69 6f 6e 73 0a 09 09 09 09 09 20 20 20 65 78 tions...... ex
27f0: 6e 0a 09 09 09 09 09 20 20 20 28 62 65 67 69 6e n...... (begin
2800: 0a 09 09 09 09 09 20 20 20 20 20 28 73 65 74 21 ...... (set!
2810: 20 73 75 63 63 65 73 73 20 23 66 29 0a 09 09 09 success #f)....
2820: 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
2830: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
2840: 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e og-port* "WARNIN
2850: 47 3a 20 66 61 69 6c 75 72 65 20 69 6e 20 77 69 G: failure in wi
2860: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 65 th-input-from-re
2870: 71 75 65 73 74 20 74 6f 20 22 20 66 75 6c 6c 75 quest to " fullu
2880: 72 6c 20 22 2e 22 29 0a 09 09 09 09 09 20 20 20 rl ".")......
2890: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
28a0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
28b0: 72 74 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 rt* " message: "
28c0: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
28d0: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
28e0: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
28f0: 6e 29 29 0a 09 09 09 09 09 20 20 20 20 20 28 69 n))...... (i
2900: 66 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 0a 20 20 f *runremote*.
2910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2940: 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 2d 73 remote-conndat-s
2950: 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 et! *runremote*
2960: 23 66 29 29 0a 09 09 09 09 09 20 20 20 20 20 3b #f))...... ;
2970: 3b 20 4b 69 6c 6c 69 6e 67 20 61 73 73 6f 63 69 ; Killing associ
2980: 61 74 65 64 20 73 65 72 76 65 72 20 74 6f 20 61 ated server to a
2990: 6c 6c 6f 77 20 63 6c 65 61 6e 20 72 65 74 72 79 llow clean retry
29a0: 2e 22 29 0a 09 09 09 09 09 20 20 20 20 20 3b 3b .")...... ;;
29b0: 20 28 74 61 73 6b 73 3a 6b 69 6c 6c 2d 73 65 72 (tasks:kill-ser
29c0: 76 65 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 ver-run-id run-i
29d0: 64 29 20 20 3b 3b 20 62 65 74 74 65 72 20 74 6f d) ;; better to
29e0: 20 6b 69 6c 6c 20 74 68 65 20 73 65 72 76 65 72 kill the server
29f0: 20 69 6e 20 74 68 65 20 6c 6f 67 69 63 20 74 68 in the logic th
2a00: 61 74 20 63 61 6c 6c 65 64 20 74 68 69 73 20 72 at called this r
2a10: 6f 75 74 69 6e 65 3f 0a 09 09 09 09 09 20 20 20 outine?......
2a20: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
2a30: 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 09 *http-mutex*)..
2a40: 09 09 09 09 20 20 20 20 20 3b 3b 3b 20 28 73 69 .... ;;; (si
2a50: 67 6e 61 6c 20 28 6d 61 6b 65 2d 63 6f 6d 70 6f gnal (make-compo
2a60: 73 69 74 65 2d 63 6f 6e 64 69 74 69 6f 6e 0a 09 site-condition..
2a70: 09 09 09 09 20 20 20 20 20 3b 3b 3b 20 20 20 20 .... ;;;
2a80: 20 20 20 20 20 20 28 6d 61 6b 65 2d 70 72 6f 70 (make-prop
2a90: 65 72 74 79 2d 63 6f 6e 64 69 74 69 6f 6e 20 27 erty-condition '
2aa0: 63 6f 6d 6d 66 61 69 6c 20 27 6d 65 73 73 61 67 commfail 'messag
2ab0: 65 20 22 66 61 69 6c 65 64 20 74 6f 20 63 6f 6e e "failed to con
2ac0: 6e 65 63 74 20 74 6f 20 73 65 72 76 65 72 22 29 nect to server")
2ad0: 29 29 0a 09 09 09 09 09 20 20 20 20 20 3b 3b 3b ))...... ;;;
2ae0: 20 22 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 73 "communications
2af0: 20 66 61 69 6c 65 64 22 0a 09 09 09 09 09 20 20 failed"......
2b00: 20 20 20 28 64 62 3a 6f 62 6a 2d 3e 73 74 72 69 (db:obj->stri
2b10: 6e 67 20 23 66 29 29 0a 09 09 09 09 09 20 20 20 ng #f))......
2b20: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
2b30: 2d 72 65 71 75 65 73 74 20 3b 3b 20 77 61 73 20 -request ;; was
2b40: 64 61 74 0a 09 09 09 09 09 20 20 20 20 66 75 6c dat...... ful
2b50: 6c 75 72 6c 20 0a 09 09 09 09 09 20 20 20 20 28 lurl ...... (
2b60: 6c 69 73 74 20 28 63 6f 6e 73 20 27 6b 65 79 20 list (cons 'key
2b70: 22 74 68 65 6b 65 79 22 29 0a 09 09 09 09 09 09 "thekey").......
2b80: 20 20 28 63 6f 6e 73 20 27 63 6d 64 20 63 6d 64 (cons 'cmd cmd
2b90: 29 0a 09 09 09 09 09 09 20 20 28 63 6f 6e 73 20 )....... (cons
2ba0: 27 70 61 72 61 6d 73 20 73 70 61 72 61 6d 73 29 'params sparams)
2bb0: 29 0a 09 09 09 09 09 20 20 20 20 72 65 61 64 2d )...... read-
2bc0: 73 74 72 69 6e 67 29 29 0a 09 09 09 09 09 20 20 string))......
2bd0: 74 72 61 6e 73 70 6f 72 74 3a 20 27 68 74 74 70 transport: 'http
2be0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c00: 20 20 20 20 20 20 20 20 20 20 20 30 29 29 20 3b 0)) ;
2c10: 3b 20 61 64 64 65 64 20 74 68 69 73 20 73 70 65 ; added this spe
2c20: 63 75 6c 61 74 69 76 65 6c 79 0a 09 09 09 20 20 culatively....
2c30: 20 20 20 20 3b 3b 20 53 68 6f 75 6c 64 6e 27 74 ;; Shouldn't
2c40: 20 74 68 69 73 20 62 65 20 61 20 63 61 6c 6c 20 this be a call
2c50: 74 6f 20 74 68 65 20 6d 61 6e 61 67 65 64 20 63 to the managed c
2c60: 61 6c 6c 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 all-all-connecti
2c70: 6f 6e 73 20 73 74 75 66 66 20 61 62 6f 76 65 3f ons stuff above?
2c80: 0a 09 09 09 20 20 20 20 20 20 28 63 6c 6f 73 65 .... (close
2c90: 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 -all-connections
2ca0: 21 29 0a 09 09 09 20 20 20 20 20 20 28 6d 75 74 !).... (mut
2cb0: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 ex-unlock! *http
2cc0: 2d 6d 75 74 65 78 2a 29 0a 09 09 09 20 20 20 20 -mutex*)....
2cd0: 20 20 29 29 0a 09 20 20 20 20 20 20 28 74 69 6d )).. (tim
2ce0: 65 2d 6f 75 74 20 20 20 20 20 28 6c 61 6d 62 64 e-out (lambd
2cf0: 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 28 74 a ().... (t
2d00: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 34 35 29 hread-sleep! 45)
2d10: 0a 09 09 09 20 20 20 20 20 20 23 66 29 29 0a 09 .... #f))..
2d20: 20 20 20 20 20 20 28 74 68 31 20 28 6d 61 6b 65 (th1 (make
2d30: 2d 74 68 72 65 61 64 20 73 65 6e 64 2d 72 65 63 -thread send-rec
2d40: 69 65 76 65 20 22 77 69 74 68 2d 69 6e 70 75 74 ieve "with-input
2d50: 2d 66 72 6f 6d 2d 72 65 71 75 65 73 74 22 29 29 -from-request"))
2d60: 0a 09 20 20 20 20 20 20 28 74 68 32 20 28 6d 61 .. (th2 (ma
2d70: 6b 65 2d 74 68 72 65 61 64 20 74 69 6d 65 2d 6f ke-thread time-o
2d80: 75 74 20 20 20 20 20 22 74 69 6d 65 20 6f 75 74 ut "time out
2d90: 22 29 29 29 0a 09 20 28 74 68 72 65 61 64 2d 73 "))).. (thread-s
2da0: 74 61 72 74 21 20 74 68 31 29 0a 09 20 28 74 68 tart! th1).. (th
2db0: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 read-start! th2)
2dc0: 0a 09 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 .. (thread-join!
2dd0: 20 74 68 31 29 0a 09 20 28 74 68 72 65 61 64 2d th1).. (thread-
2de0: 74 65 72 6d 69 6e 61 74 65 21 20 74 68 32 29 0a terminate! th2).
2df0: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 . (debug:print-i
2e00: 6e 66 6f 20 31 31 20 2a 64 65 66 61 75 6c 74 2d nfo 11 *default-
2e10: 6c 6f 67 2d 70 6f 72 74 2a 20 22 67 6f 74 20 72 log-port* "got r
2e20: 65 73 3d 22 20 72 65 73 29 0a 09 20 28 69 66 20 es=" res).. (if
2e30: 28 76 65 63 74 6f 72 3f 20 72 65 73 29 0a 09 20 (vector? res)..
2e40: 20 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 2d (if (vector-
2e50: 72 65 66 20 72 65 73 20 30 29 0a 09 09 20 72 65 ref res 0)... re
2e60: 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s.
2e70: 20 20 20 28 69 66 20 28 64 65 62 75 67 3a 64 65 (if (debug:de
2e80: 62 75 67 2d 6d 6f 64 65 20 31 31 29 0a 20 20 20 bug-mode 11).
2e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ea0: 20 20 28 62 65 67 69 6e 20 3b 3b 20 6e 6f 74 65 (begin ;; note
2eb0: 3a 20 74 68 69 73 20 63 6f 64 65 20 61 6c 73 6f : this code also
2ec0: 20 63 61 6c 6c 65 64 20 69 6e 20 6e 6d 73 67 2d called in nmsg-
2ed0: 74 72 61 6e 73 70 6f 72 74 20 2d 20 63 6f 6e 73 transport - cons
2ee0: 69 64 65 72 20 63 6f 6e 73 6f 6c 69 64 61 74 69 ider consolidati
2ef0: 6e 67 20 69 74 0a 20 20 20 20 20 20 20 20 20 20 ng it.
2f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
2f10: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
2f20: 31 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 11 *default-log-
2f30: 70 6f 72 74 2a 20 22 65 72 72 6f 72 20 6f 63 63 port* "error occ
2f40: 75 72 65 64 20 61 74 20 73 65 72 76 65 72 2c 20 ured at server,
2f50: 69 6e 66 6f 3d 22 20 28 76 65 63 74 6f 72 2d 72 info=" (vector-r
2f60: 65 66 20 72 65 73 20 32 29 29 0a 20 20 20 20 20 ef res 2)).
2f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f80: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
2f90: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
2fa0: 6f 72 74 2a 20 22 20 63 6c 69 65 6e 74 20 63 61 ort* " client ca
2fb0: 6c 6c 20 63 68 61 69 6e 3a 22 29 0a 20 20 20 20 ll chain:").
2fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2fd0: 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 (print-call-c
2fe0: 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 hain (current-er
2ff0: 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 20 20 20 ror-port)).
3000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3010: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
3020: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
3030: 6f 72 74 2a 20 22 20 73 65 72 76 65 72 20 63 61 ort* " server ca
3040: 6c 6c 20 63 68 61 69 6e 3a 22 29 0a 20 20 20 20 ll chain:").
3050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3060: 20 20 20 28 70 70 20 28 76 65 63 74 6f 72 2d 72 (pp (vector-r
3070: 65 66 20 72 65 73 20 31 29 20 28 63 75 72 72 65 ef res 1) (curre
3080: 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a nt-error-port)).
3090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
30a0: 20 20 20 20 20 20 20 28 73 69 67 6e 61 6c 20 28 (signal (
30b0: 76 65 63 74 6f 72 2d 72 65 66 20 72 65 73 20 30 vector-ref res 0
30c0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
30d0: 20 20 20 20 20 20 20 20 20 72 65 73 29 29 0a 09 res))..
30e0: 20 20 20 20 20 28 73 69 67 6e 61 6c 20 28 6d 61 (signal (ma
30f0: 6b 65 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 6f 6e ke-composite-con
3100: 64 69 74 69 6f 6e 0a 09 09 20 20 20 20 20 20 28 dition... (
3110: 6d 61 6b 65 2d 70 72 6f 70 65 72 74 79 2d 63 6f make-property-co
3120: 6e 64 69 74 69 6f 6e 20 0a 09 09 20 20 20 20 20 ndition ...
3130: 20 20 27 74 69 6d 65 6f 75 74 0a 09 09 20 20 20 'timeout...
3140: 20 20 20 20 27 6d 65 73 73 61 67 65 20 22 6e 6d 'message "nm
3150: 73 67 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 sg-transport:cli
3160: 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 ent-api-send-rec
3170: 65 69 76 65 2d 72 61 77 20 74 69 6d 65 64 20 6f eive-raw timed o
3180: 75 74 20 74 61 6c 6b 69 6e 67 20 74 6f 20 73 65 ut talking to se
3190: 72 76 65 72 22 29 29 29 29 29 29 29 0a 0a 3b 3b rver")))))))..;;
31a0: 20 63 61 72 65 66 75 6c 20 63 6c 6f 73 69 6e 67 careful closing
31b0: 20 6f 66 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 of connections
31c0: 73 74 6f 72 65 64 20 69 6e 20 2a 72 75 6e 72 65 stored in *runre
31d0: 6d 6f 74 65 2a 0a 3b 3b 0a 28 64 65 66 69 6e 65 mote*.;;.(define
31e0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
31f0: 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 6f :close-connectio
3200: 6e 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 ns run-id). (le
3210: 74 2a 20 28 28 73 65 72 76 65 72 2d 64 61 74 20 t* ((server-dat
3220: 28 69 66 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 0a (if *runremote*.
3230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3240: 20 20 20 20 20 20 20 20 20 28 72 65 6d 6f 74 65 (remote
3250: 2d 63 6f 6e 6e 64 61 74 20 2a 72 75 6e 72 65 6d -conndat *runrem
3260: 6f 74 65 2a 29 0a 20 20 20 20 20 20 20 20 20 20 ote*).
3270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 #
3280: 66 29 29 29 20 3b 3b 20 28 68 61 73 68 2d 74 61 f))) ;; (hash-ta
3290: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
32a0: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d *runremote* run-
32b0: 69 64 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 id #f))). (if
32c0: 20 28 76 65 63 74 6f 72 3f 20 73 65 72 76 65 72 (vector? server
32d0: 2d 64 61 74 29 0a 09 28 6c 65 74 20 28 28 61 70 -dat)..(let ((ap
32e0: 69 2d 64 61 74 20 28 68 74 74 70 2d 74 72 61 6e i-dat (http-tran
32f0: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 sport:server-dat
3300: 2d 67 65 74 2d 61 70 69 2d 75 72 69 20 73 65 72 -get-api-uri ser
3310: 76 65 72 2d 64 61 74 29 29 29 0a 09 20 20 28 63 ver-dat))).. (c
3320: 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 6f 6e 21 lose-connection!
3330: 20 61 70 69 2d 64 61 74 29 0a 09 20 20 23 74 29 api-dat).. #t)
3340: 0a 09 23 66 29 29 29 0a 0a 0a 28 64 65 66 69 6e ..#f)))...(defin
3350: 65 20 28 6d 61 6b 65 2d 68 74 74 70 2d 74 72 61 e (make-http-tra
3360: 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 nsport:server-da
3370: 74 29 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 36 t)(make-vector 6
3380: 29 29 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 )).(define (http
3390: 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 -transport:serve
33a0: 72 2d 64 61 74 2d 67 65 74 2d 69 66 61 63 65 20 r-dat-get-iface
33b0: 20 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 vec)
33c0: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
33d0: 20 30 29 29 0a 28 64 65 66 69 6e 65 20 28 68 74 0)).(define (ht
33e0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
33f0: 76 65 72 2d 64 61 74 2d 67 65 74 2d 70 6f 72 74 ver-dat-get-port
3400: 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 vec)
3410: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
3420: 65 63 20 31 29 29 0a 28 64 65 66 69 6e 65 20 28 ec 1)).(define (
3430: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
3440: 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 61 70 erver-dat-get-ap
3450: 69 2d 75 72 69 20 20 20 20 20 20 20 76 65 63 29 i-uri vec)
3460: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
3470: 20 76 65 63 20 32 29 29 0a 28 64 65 66 69 6e 65 vec 2)).(define
3480: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
3490: 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d :server-dat-get-
34a0: 61 70 69 2d 75 72 6c 20 20 20 20 20 20 20 76 65 api-url ve
34b0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
34c0: 66 20 20 76 65 63 20 33 29 29 0a 28 64 65 66 69 f vec 3)).(defi
34d0: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
34e0: 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 rt:server-dat-ge
34f0: 74 2d 61 70 69 2d 72 65 71 20 20 20 20 20 20 20 t-api-req
3500: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
3510: 72 65 66 20 20 76 65 63 20 34 29 29 0a 28 64 65 ref vec 4)).(de
3520: 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
3530: 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
3540: 67 65 74 2d 6c 61 73 74 2d 61 63 63 65 73 73 20 get-last-access
3550: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
3560: 72 2d 72 65 66 20 20 76 65 63 20 35 29 29 0a 28 r-ref vec 5)).(
3570: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
3580: 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 nsport:server-da
3590: 74 2d 67 65 74 2d 73 6f 63 6b 65 74 20 20 20 20 t-get-socket
35a0: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
35b0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 36 29 29 tor-ref vec 6))
35c0: 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ..(define (http-
35d0: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
35e0: 2d 64 61 74 2d 6d 61 6b 65 2d 75 72 6c 20 76 65 -dat-make-url ve
35f0: 63 29 0a 20 20 28 69 66 20 28 61 6e 64 20 28 68 c). (if (and (h
3600: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 ttp-transport:se
3610: 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 69 66 61 rver-dat-get-ifa
3620: 63 65 20 76 65 63 29 0a 09 20 20 20 28 68 74 74 ce vec).. (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 76 65 63 29 29 0a 20 20 20 20 20 20 28 63 6f vec)). (co
3660: 6e 63 20 22 68 74 74 70 3a 2f 2f 22 20 0a 09 20 nc "http://" ..
3670: 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f (http-transpo
3680: 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 rt:server-dat-ge
3690: 74 2d 69 66 61 63 65 20 76 65 63 29 0a 09 20 20 t-iface vec)..
36a0: 20 20 22 3a 22 0a 09 20 20 20 20 28 68 74 74 70 ":".. (http
36b0: 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 -transport:serve
36c0: 72 2d 64 61 74 2d 67 65 74 2d 70 6f 72 74 20 20 r-dat-get-port
36d0: 76 65 63 29 29 0a 20 20 20 20 20 20 23 66 29 29 vec)). #f))
36e0: 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ..(define (http-
36f0: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
3700: 2d 64 61 74 2d 75 70 64 61 74 65 2d 6c 61 73 74 -dat-update-last
3710: 2d 61 63 63 65 73 73 20 76 65 63 29 0a 20 20 28 -access vec). (
3720: 69 66 20 28 76 65 63 74 6f 72 3f 20 76 65 63 29 if (vector? vec)
3730: 0a 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 . (vector-s
3740: 65 74 21 20 76 65 63 20 35 20 28 63 75 72 72 65 et! vec 5 (curre
3750: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 20 20 20 nt-seconds)).
3760: 20 20 20 28 62 65 67 69 6e 0a 09 28 70 72 69 6e (begin..(prin
3770: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 t-call-chain (cu
3780: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
3790: 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ))..(debug:print
37a0: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
37b0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 6c t-log-port* "cal
37c0: 6c 20 74 6f 20 68 74 74 70 2d 74 72 61 6e 73 70 l to http-transp
37d0: 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 75 ort:server-dat-u
37e0: 70 64 61 74 65 2d 6c 61 73 74 2d 61 63 63 65 73 pdate-last-acces
37f0: 73 20 77 69 74 68 20 6e 6f 6e 2d 76 65 63 74 6f s with non-vecto
3800: 72 21 21 22 29 29 29 29 0a 0a 3b 3b 0a 3b 3b 20 r!!"))))..;;.;;
3810: 63 6f 6e 6e 65 63 74 0a 3b 3b 0a 28 64 65 66 69 connect.;;.(defi
3820: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
3830: 72 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 rt:client-connec
3840: 74 20 69 66 61 63 65 20 70 6f 72 74 29 0a 20 20 t iface port).
3850: 28 6c 65 74 2a 20 28 28 61 70 69 2d 75 72 6c 20 (let* ((api-url
3860: 20 20 20 20 20 28 63 6f 6e 63 20 22 68 74 74 70 (conc "http
3870: 3a 2f 2f 22 20 69 66 61 63 65 20 22 3a 22 20 70 ://" iface ":" p
3880: 6f 72 74 20 22 2f 61 70 69 22 29 29 0a 09 20 28 ort "/api")).. (
3890: 61 70 69 2d 75 72 69 20 20 20 20 20 20 28 75 72 api-uri (ur
38a0: 69 2d 72 65 66 65 72 65 6e 63 65 20 28 63 6f 6e i-reference (con
38b0: 63 20 22 68 74 74 70 3a 2f 2f 22 20 69 66 61 63 c "http://" ifac
38c0: 65 20 22 3a 22 20 70 6f 72 74 20 22 2f 61 70 69 e ":" port "/api
38d0: 22 29 29 29 0a 09 20 28 61 70 69 2d 72 65 71 20 "))).. (api-req
38e0: 20 20 20 20 20 28 6d 61 6b 65 2d 72 65 71 75 65 (make-reque
38f0: 73 74 20 6d 65 74 68 6f 64 3a 20 27 50 4f 53 54 st method: 'POST
3900: 20 75 72 69 3a 20 61 70 69 2d 75 72 69 29 29 0a uri: api-uri)).
3910: 09 20 28 73 65 72 76 65 72 2d 64 61 74 20 20 20 . (server-dat
3920: 28 76 65 63 74 6f 72 20 69 66 61 63 65 20 70 6f (vector iface po
3930: 72 74 20 61 70 69 2d 75 72 69 20 61 70 69 2d 75 rt api-uri api-u
3940: 72 6c 20 61 70 69 2d 72 65 71 20 28 63 75 72 72 rl api-req (curr
3950: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a ent-seconds)))).
3960: 20 20 20 20 73 65 72 76 65 72 2d 64 61 74 29 29 server-dat))
3970: 0a 0a 3b 3b 20 72 75 6e 20 68 74 74 70 2d 74 72 ..;; run http-tr
3980: 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e ansport:keep-run
3990: 6e 69 6e 67 20 69 6e 20 61 20 70 61 72 61 6c 6c ning in a parall
39a0: 65 6c 20 74 68 72 65 61 64 20 74 6f 20 6d 6f 6e el thread to mon
39b0: 69 74 6f 72 20 74 68 61 74 20 74 68 65 20 64 62 itor that the db
39c0: 20 69 73 20 62 65 69 6e 67 20 0a 3b 3b 20 75 73 is being .;; us
39d0: 65 64 20 61 6e 64 20 74 6f 20 73 68 75 74 64 6f ed and to shutdo
39e0: 77 6e 20 61 66 74 65 72 20 73 6f 6d 65 74 69 6d wn after sometim
39f0: 65 20 69 66 20 69 74 20 69 73 20 6e 6f 74 2e 0a e if it is not..
3a00: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 ;;.(define (http
3a10: 2d 74 72 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d -transport:keep-
3a20: 72 75 6e 6e 69 6e 67 20 73 65 72 76 65 72 2d 69 running server-i
3a30: 64 20 72 75 6e 2d 69 64 29 0a 20 20 3b 3b 20 69 d run-id). ;; i
3a40: 66 20 6e 6f 6e 65 20 72 75 6e 6e 69 6e 67 20 6f f none running o
3a50: 72 20 69 66 20 3e 20 32 30 20 73 65 63 6f 6e 64 r if > 20 second
3a60: 73 20 73 69 6e 63 65 20 0a 20 20 3b 3b 20 73 65 s since . ;; se
3a70: 72 76 65 72 20 6c 61 73 74 20 75 73 65 64 20 74 rver last used t
3a80: 68 65 6e 20 73 74 61 72 74 20 73 68 75 74 64 6f hen start shutdo
3a90: 77 6e 0a 20 20 3b 3b 20 54 68 69 73 20 74 68 72 wn. ;; This thr
3aa0: 65 61 64 20 77 61 69 74 73 20 66 6f 72 20 74 68 ead waits for th
3ab0: 65 20 73 65 72 76 65 72 20 74 6f 20 63 6f 6d 65 e server to come
3ac0: 20 61 6c 69 76 65 0a 20 20 28 64 65 62 75 67 3a alive. (debug:
3ad0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
3ae0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
3af0: 22 53 74 61 72 74 69 6e 67 20 74 68 65 20 73 79 "Starting the sy
3b00: 6e 63 2d 62 61 63 6b 2c 20 6b 65 65 70 20 61 6c nc-back, keep al
3b10: 69 76 65 20 74 68 72 65 61 64 20 69 6e 20 73 65 ive thread in se
3b20: 72 76 65 72 20 66 6f 72 20 72 75 6e 2d 69 64 3d rver for run-id=
3b30: 22 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 74 " run-id). (let
3b40: 2a 20 28 28 74 64 62 64 61 74 20 20 20 20 20 20 * ((tdbdat
3b50: 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 (tasks:open-db))
3b60: 0a 09 20 28 73 65 72 76 65 72 2d 73 74 61 72 74 .. (server-start
3b70: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 -time (current-s
3b80: 65 63 6f 6e 64 73 29 29 0a 09 20 28 73 65 72 76 econds)).. (serv
3b90: 65 72 2d 69 6e 66 6f 20 28 6c 65 74 20 6c 6f 6f er-info (let loo
3ba0: 70 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 28 p ((start-time (
3bb0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
3bc0: 29 0a 09 09 09 09 20 28 63 68 61 6e 67 65 64 20 )..... (changed
3bd0: 20 20 20 23 74 29 0a 09 09 09 09 20 28 6c 61 73 #t)..... (las
3be0: 74 2d 73 64 61 74 20 20 22 6e 6f 74 20 74 68 69 t-sdat "not thi
3bf0: 73 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 s")).
3c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
3c10: 74 20 28 28 73 64 61 74 20 23 66 29 29 0a 09 09 t ((sdat #f))...
3c20: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
3c30: 21 20 30 2e 30 31 29 0a 09 09 09 20 20 28 64 65 ! 0.01).... (de
3c40: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
3c50: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3c60: 72 74 2a 20 22 57 61 69 74 69 6e 67 20 66 6f 72 rt* "Waiting for
3c70: 20 73 65 72 76 65 72 20 61 6c 69 76 65 20 73 69 server alive si
3c80: 67 6e 61 74 75 72 65 22 29 0a 20 20 20 20 20 20 gnature").
3c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ca0: 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 (mutex-lock!
3cb0: 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 *heartbeat-mute
3cc0: 78 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 x*).
3cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
3ce0: 65 74 21 20 73 64 61 74 20 2a 73 65 72 76 65 72 et! sdat *server
3cf0: 2d 69 6e 66 6f 2a 29 0a 20 20 20 20 20 20 20 20 -info*).
3d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3d10: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
3d20: 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 *heartbeat-mute
3d30: 78 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 x*).
3d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
3d50: 66 20 28 61 6e 64 20 73 64 61 74 0a 09 09 09 09 f (and sdat.....
3d60: 20 20 20 28 6e 6f 74 20 63 68 61 6e 67 65 64 29 (not changed)
3d70: 0a 09 09 09 09 20 20 20 28 3e 20 28 2d 20 28 63 ..... (> (- (c
3d80: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
3d90: 73 74 61 72 74 2d 74 69 6d 65 29 20 32 29 29 0a start-time) 2)).
3da0: 09 09 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ... (begin.
3db0: 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
3dc0: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
3dd0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 65 63 65 -log-port* "Rece
3de0: 69 76 65 64 20 73 65 72 76 65 72 20 61 6c 69 76 ived server aliv
3df0: 65 20 73 69 67 6e 61 74 75 72 65 22 29 0a 09 09 e signature")...
3e00: 09 09 73 64 61 74 29 0a 20 20 20 20 20 20 20 20 ..sdat).
3e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3e20: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
3e30: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e .(debug:print-in
3e40: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
3e50: 67 2d 70 6f 72 74 2a 20 22 53 74 69 6c 6c 20 77 g-port* "Still w
3e60: 61 69 74 69 6e 67 2c 20 6c 61 73 74 2d 73 64 61 aiting, last-sda
3e70: 74 3d 22 20 6c 61 73 74 2d 73 64 61 74 29 0a 20 t=" last-sdat).
3e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3ea0: 73 6c 65 65 70 20 34 29 0a 09 09 09 09 28 69 66 sleep 4).....(if
3eb0: 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d (> (- (current-
3ec0: 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d 74 seconds) start-t
3ed0: 69 6d 65 29 20 31 32 30 29 20 3b 3b 20 62 65 65 ime) 120) ;; bee
3ee0: 6e 20 77 61 69 74 69 6e 67 20 66 6f 72 20 74 77 n waiting for tw
3ef0: 6f 20 6d 69 6e 75 74 65 73 0a 09 09 09 09 20 20 o minutes.....
3f00: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 (begin.....
3f10: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
3f20: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
3f30: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 72 61 6e -log-port* "tran
3f40: 73 70 6f 72 74 20 61 70 70 65 61 72 73 20 74 6f sport appears to
3f50: 20 68 61 76 65 20 64 69 65 64 2c 20 65 78 69 74 have died, exit
3f60: 69 6e 67 20 73 65 72 76 65 72 20 22 20 73 65 72 ing server " ser
3f70: 76 65 72 2d 69 64 20 22 20 66 6f 72 20 72 75 6e ver-id " for run
3f80: 20 22 20 72 75 6e 2d 69 64 29 0a 09 09 09 09 20 " run-id).....
3f90: 20 20 20 20 20 28 74 61 73 6b 73 3a 73 65 72 76 (tasks:serv
3fa0: 65 72 2d 64 65 6c 65 74 65 2d 72 65 63 6f 72 64 er-delete-record
3fb0: 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 (db:delay-if-bu
3fc0: 73 79 20 74 64 62 64 61 74 29 20 73 65 72 76 65 sy tdbdat) serve
3fd0: 72 2d 69 64 20 22 66 61 69 6c 65 64 20 74 6f 20 r-id "failed to
3fe0: 73 74 61 72 74 2c 20 6e 65 76 65 72 20 72 65 63 start, never rec
3ff0: 65 69 76 65 64 20 73 65 72 76 65 72 20 61 6c 69 eived server ali
4000: 76 65 20 73 69 67 6e 61 74 75 72 65 22 29 0a 09 ve signature")..
4010: 09 09 09 20 20 20 20 20 20 28 65 78 69 74 29 29 ... (exit))
4020: 0a 09 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 73 ..... (loop s
4030: 74 61 72 74 2d 74 69 6d 65 0a 09 09 09 09 09 20 tart-time......
4040: 20 28 65 71 75 61 6c 3f 20 73 64 61 74 20 6c 61 (equal? sdat la
4050: 73 74 2d 73 64 61 74 29 0a 09 09 09 09 09 20 20 st-sdat)......
4060: 73 64 61 74 29 29 29 29 29 29 29 0a 20 20 20 20 sdat))))))).
4070: 20 20 20 20 20 28 69 66 61 63 65 20 20 20 20 20 (iface
4080: 20 20 28 63 61 72 20 73 65 72 76 65 72 2d 69 6e (car server-in
4090: 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 28 70 fo)). (p
40a0: 6f 72 74 20 20 20 20 20 20 20 20 28 63 61 64 72 ort (cadr
40b0: 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 29 0a 20 server-info)).
40c0: 20 20 20 20 20 20 20 20 28 6c 61 73 74 2d 61 63 (last-ac
40d0: 63 65 73 73 20 30 29 0a 09 20 28 73 65 72 76 65 cess 0).. (serve
40e0: 72 2d 74 69 6d 65 6f 75 74 20 28 73 65 72 76 65 r-timeout (serve
40f0: 72 3a 67 65 74 2d 74 69 6d 65 6f 75 74 29 29 0a r:get-timeout)).
4100: 09 20 28 73 65 72 76 65 72 2d 67 6f 69 6e 67 20 . (server-going
4110: 20 23 66 29 29 0a 20 20 20 20 28 6c 65 74 20 6c #f)). (let l
4120: 6f 6f 70 20 28 28 63 6f 75 6e 74 20 20 20 20 20 oop ((count
4130: 20 20 20 20 30 29 0a 09 20 20 20 20 20 20 20 28 0).. (
4140: 73 65 72 76 65 72 2d 73 74 61 74 65 20 27 61 76 server-state 'av
4150: 61 69 6c 61 62 6c 65 29 0a 09 20 20 20 20 20 20 ailable)..
4160: 20 28 62 61 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 (bad-sync-count
4170: 20 30 29 0a 09 20 20 20 20 20 20 20 28 73 74 61 0).. (sta
4180: 72 74 2d 74 69 6d 65 20 20 20 20 20 28 63 75 72 rt-time (cur
4190: 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 rent-millisecond
41a0: 73 29 29 29 0a 20 20 20 20 20 20 3b 3b 28 42 42 s))). ;;(BB
41b0: 3e 20 22 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 > "http-transpor
41c0: 74 3a 20 74 6f 70 20 6f 66 20 6c 6f 6f 70 3b 20 t: top of loop;
41d0: 63 6f 75 6e 74 3d 22 63 6f 75 6e 74 22 20 73 65 count="count" se
41e0: 72 76 65 72 2d 73 74 61 74 65 3d 22 73 65 72 76 rver-state="serv
41f0: 65 72 2d 73 74 61 74 65 22 20 62 61 64 2d 73 79 er-state" bad-sy
4200: 6e 63 2d 63 6f 75 6e 74 3d 22 62 61 64 2d 73 79 nc-count="bad-sy
4210: 6e 63 2d 63 6f 75 6e 74 22 20 73 65 72 76 65 72 nc-count" server
4220: 2d 67 6f 69 6e 67 3d 22 73 65 72 76 65 72 2d 67 -going="server-g
4230: 6f 69 6e 67 29 0a 20 20 20 20 20 20 3b 3b 20 55 oing). ;; U
4240: 73 65 20 74 68 69 73 20 6f 70 70 6f 72 74 75 6e se this opportun
4250: 69 74 79 20 74 6f 20 73 79 6e 63 20 74 68 65 20 ity to sync the
4260: 74 6d 70 20 64 62 20 74 6f 20 6d 65 67 61 74 65 tmp db to megate
4270: 73 74 2e 64 62 0a 20 20 20 20 20 20 28 69 66 20 st.db. (if
4280: 28 6e 6f 74 20 73 65 72 76 65 72 2d 67 6f 69 6e (not server-goin
4290: 67 29 20 3b 3b 20 2a 64 62 73 74 72 75 63 74 2d g) ;; *dbstruct-
42a0: 64 62 2a 20 0a 09 20 20 20 20 3b 3b 20 52 65 6d db* .. ;; Rem
42b0: 6f 76 65 64 20 63 6f 64 65 20 69 73 20 70 61 73 oved code is pas
42c0: 74 65 64 20 62 65 6c 6f 77 20 28 6b 65 65 70 69 ted below (keepi
42d0: 6e 67 20 69 74 20 61 72 6f 75 6e 64 20 75 6e 74 ng it around unt
42e0: 69 6c 20 77 65 20 61 72 65 20 63 6c 65 61 72 20 il we are clear
42f0: 69 74 20 69 73 20 6e 6f 74 20 6e 65 65 64 65 64 it is not needed
4300: 29 2e 0a 09 20 20 20 20 3b 3b 20 6e 6f 20 2a 64 )... ;; no *d
4310: 62 73 74 72 75 63 74 2d 64 62 2a 20 79 65 74 2c bstruct-db* yet,
4320: 20 73 65 74 20 72 75 6e 6e 69 6e 67 20 61 66 74 set running aft
4330: 65 72 20 6f 75 72 20 66 69 72 73 74 20 70 61 73 er our first pas
4340: 73 20 74 68 72 6f 75 67 68 20 61 6e 64 20 73 74 s through and st
4350: 61 72 74 20 74 68 65 20 64 62 0a 09 20 20 20 20 art the db..
4360: 28 69 66 20 28 65 71 3f 20 73 65 72 76 65 72 2d (if (eq? server-
4370: 73 74 61 74 65 20 27 61 76 61 69 6c 61 62 6c 65 state 'available
4380: 29 0a 09 09 28 6c 65 74 20 28 28 6e 65 77 2d 73 )...(let ((new-s
4390: 65 72 76 65 72 2d 69 64 20 28 74 61 73 6b 73 3a erver-id (tasks:
43a0: 73 65 72 76 65 72 2d 61 6d 2d 69 2d 74 68 65 2d server-am-i-the-
43b0: 73 65 72 76 65 72 3f 20 28 64 62 3a 64 65 6c 61 server? (db:dela
43c0: 79 2d 69 66 2d 62 75 73 79 20 74 64 62 64 61 74 y-if-busy tdbdat
43d0: 29 20 72 75 6e 2d 69 64 29 29 29 20 3b 3b 20 74 ) run-id))) ;; t
43e0: 72 79 20 74 6f 20 65 6e 73 75 72 65 20 6e 6f 20 ry to ensure no
43f0: 64 6f 75 62 6c 65 20 72 65 67 69 73 74 65 72 69 double registeri
4400: 6e 67 20 6f 66 20 73 65 72 76 65 72 73 0a 09 09 ng of servers...
4410: 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 6e 65 (if (equal? ne
4420: 77 2d 73 65 72 76 65 72 2d 69 64 20 73 65 72 76 w-server-id serv
4430: 65 72 2d 69 64 29 0a 09 09 20 20 20 20 20 20 28 er-id)... (
4440: 62 65 67 69 6e 0a 09 09 09 28 74 61 73 6b 73 3a begin....(tasks:
4450: 73 65 72 76 65 72 2d 73 65 74 2d 73 74 61 74 65 server-set-state
4460: 21 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 ! (db:delay-if-b
4470: 75 73 79 20 74 64 62 64 61 74 29 20 73 65 72 76 usy tdbdat) serv
4480: 65 72 2d 69 64 20 22 64 62 70 72 65 70 22 29 0a er-id "dbprep").
4490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
44a0: 20 20 20 20 20 20 20 20 3b 3b 28 42 42 3e 20 22 ;;(BB> "
44b0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 20 http-transport:
44c0: 2d 3e 64 62 70 72 65 70 22 29 0a 09 09 09 28 74 ->dbprep")....(t
44d0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 35 hread-sleep! 0.5
44e0: 29 20 3b 3b 20 67 69 76 65 20 73 6f 6d 65 20 6d ) ;; give some m
44f0: 61 72 67 69 6e 20 66 6f 72 20 71 75 65 72 69 65 argin for querie
4500: 73 20 74 6f 20 63 6f 6d 70 6c 65 74 65 20 62 65 s to complete be
4510: 66 6f 72 65 20 73 77 69 74 63 68 69 6e 67 20 66 fore switching f
4520: 72 6f 6d 20 66 69 6c 65 20 62 61 73 65 64 20 61 rom file based a
4530: 63 63 65 73 73 20 74 6f 20 73 65 72 76 65 72 20 ccess to server
4540: 62 61 73 65 64 20 61 63 63 65 73 73 0a 09 09 09 based access....
4550: 28 73 65 74 21 20 2a 64 62 73 74 72 75 63 74 2d (set! *dbstruct-
4560: 64 62 2a 20 20 28 64 62 3a 73 65 74 75 70 29 29 db* (db:setup))
4570: 20 3b 3b 20 20 72 75 6e 2d 69 64 29 29 0a 09 09 ;; run-id))...
4580: 09 28 73 65 74 21 20 73 65 72 76 65 72 2d 67 6f .(set! server-go
4590: 69 6e 67 20 23 74 29 0a 09 09 09 28 74 61 73 6b ing #t)....(task
45a0: 73 3a 73 65 72 76 65 72 2d 73 65 74 2d 73 74 61 s:server-set-sta
45b0: 74 65 21 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 te! (db:delay-if
45c0: 2d 62 75 73 79 20 74 64 62 64 61 74 29 20 73 65 -busy tdbdat) se
45d0: 72 76 65 72 2d 69 64 20 22 72 75 6e 6e 69 6e 67 rver-id "running
45e0: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
45f0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 28 42 42 ;;(BB
4600: 3e 20 22 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 > "http-transpor
4610: 74 3a 20 2d 3e 72 75 6e 6e 69 6e 67 22 29 0a 09 t: ->running")..
4620: 09 09 28 73 65 72 76 65 72 3a 77 72 69 74 65 2d ..(server:write-
4630: 64 6f 74 73 65 72 76 65 72 20 2a 74 6f 70 70 61 dotserver *toppa
4640: 74 68 2a 20 69 66 61 63 65 20 70 6f 72 74 20 28 th* iface port (
4650: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
4660: 69 64 29 20 27 68 74 74 70 29 0a 20 20 20 20 20 id) 'http).
4670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4680: 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 (thread-start
4690: 21 20 2a 77 61 74 63 68 64 6f 67 2a 29 0a 20 20 ! *watchdog*).
46a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
46b0: 20 20 20 20 20 20 28 73 65 72 76 65 72 3a 63 6f (server:co
46c0: 6d 70 6c 65 74 65 2d 61 74 74 65 6d 70 74 20 2a mplete-attempt *
46d0: 74 6f 70 70 61 74 68 2a 29 29 0a 09 09 20 20 20 toppath*))...
46e0: 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 67 6f 74 (begin ;; got
46f0: 74 61 20 65 78 69 74 20 6e 69 63 65 6c 79 0a 20 ta exit nicely.
4700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4710: 20 20 20 20 20 20 20 3b 3b 28 42 42 3e 20 22 68 ;;(BB> "h
4720: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 20 2d ttp-transport: -
4730: 3e 63 6f 6c 6c 69 73 69 6f 6e 22 29 0a 09 09 09 >collision")....
4740: 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 73 65 (tasks:server-se
4750: 74 2d 73 74 61 74 65 21 20 28 64 62 3a 64 65 6c t-state! (db:del
4760: 61 79 2d 69 66 2d 62 75 73 79 20 74 64 62 64 61 ay-if-busy tdbda
4770: 74 29 20 73 65 72 76 65 72 2d 69 64 20 22 63 6f t) server-id "co
4780: 6c 6c 69 73 69 6f 6e 22 29 0a 09 09 09 28 68 74 llision")....(ht
4790: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
47a0: 76 65 72 2d 73 68 75 74 64 6f 77 6e 20 73 65 72 ver-shutdown ser
47b0: 76 65 72 2d 69 64 20 70 6f 72 74 29 29 29 29 29 ver-id port)))))
47c0: 29 0a 20 20 20 20 20 20 0a 20 20 20 20 20 20 3b ). . ;
47d0: 3b 20 77 68 65 6e 20 74 68 69 6e 67 73 20 67 6f ; when things go
47e0: 20 77 72 6f 6e 67 20 77 65 20 64 6f 6e 27 74 20 wrong we don't
47f0: 77 61 6e 74 20 74 6f 20 62 65 20 64 6f 69 6e 67 want to be doing
4800: 20 74 68 65 20 76 61 72 69 6f 75 73 20 71 75 65 the various que
4810: 72 69 65 73 20 74 6f 6f 20 6f 66 74 65 6e 0a 20 ries too often.
4820: 20 20 20 20 20 3b 3b 20 73 6f 20 77 65 20 73 74 ;; so we st
4830: 72 69 76 65 20 74 6f 20 72 75 6e 20 74 68 69 73 rive to run this
4840: 20 73 74 75 66 66 20 6f 6e 6c 79 20 65 76 65 72 stuff only ever
4850: 79 20 66 6f 75 72 20 73 65 63 6f 6e 64 73 20 6f y four seconds o
4860: 72 20 73 6f 2e 0a 20 20 20 20 20 20 28 6c 65 74 r so.. (let
4870: 2a 20 28 28 73 79 6e 63 2d 74 69 6d 65 20 28 2d * ((sync-time (-
4880: 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 (current-millis
4890: 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d 74 69 econds) start-ti
48a0: 6d 65 29 29 0a 09 20 20 20 20 28 72 65 6d 2d 74 me)).. (rem-t
48b0: 69 6d 65 20 20 28 71 75 6f 74 69 65 6e 74 20 28 ime (quotient (
48c0: 2d 20 34 30 30 30 20 73 79 6e 63 2d 74 69 6d 65 - 4000 sync-time
48d0: 29 20 31 30 30 30 29 29 29 0a 09 28 69 66 20 28 ) 1000)))..(if (
48e0: 61 6e 64 20 28 3c 3d 20 72 65 6d 2d 74 69 6d 65 and (<= rem-time
48f0: 20 34 29 0a 09 09 20 28 3e 20 20 72 65 6d 2d 74 4)... (> rem-t
4900: 69 6d 65 20 30 29 29 0a 09 20 20 20 20 28 74 68 ime 0)).. (th
4910: 72 65 61 64 2d 73 6c 65 65 70 21 20 72 65 6d 2d read-sleep! rem-
4920: 74 69 6d 65 29 29 29 0a 20 20 20 20 20 20 0a 20 time))). .
4930: 20 20 20 20 20 28 69 66 20 28 3c 20 63 6f 75 6e (if (< coun
4940: 74 20 31 29 20 3b 3b 20 33 78 33 20 3d 20 39 20 t 1) ;; 3x3 = 9
4950: 73 65 63 73 20 61 70 72 6f 78 0a 09 20 20 28 6c secs aprox.. (l
4960: 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 20 31 29 20 oop (+ count 1)
4970: 27 72 75 6e 6e 69 6e 67 20 62 61 64 2d 73 79 6e 'running bad-syn
4980: 63 2d 63 6f 75 6e 74 20 28 63 75 72 72 65 6e 74 c-count (current
4990: 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 -milliseconds)))
49a0: 0a 20 20 20 20 20 20 0a 20 20 20 20 20 20 3b 3b . . ;;
49b0: 20 43 68 65 63 6b 20 74 68 61 74 20 69 66 61 63 Check that ifac
49c0: 65 20 61 6e 64 20 70 6f 72 74 20 68 61 76 65 20 e and port have
49d0: 6e 6f 74 20 63 68 61 6e 67 65 64 20 28 63 61 6e not changed (can
49e0: 20 68 61 70 70 65 6e 20 69 66 20 73 65 72 76 65 happen if serve
49f0: 72 20 70 6f 72 74 20 63 6f 6c 6c 69 64 65 73 29 r port collides)
4a00: 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f . (mutex-lo
4a10: 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
4a20: 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 73 65 utex*). (se
4a30: 74 21 20 73 64 61 74 20 2a 73 65 72 76 65 72 2d t! sdat *server-
4a40: 69 6e 66 6f 2a 29 0a 20 20 20 20 20 20 28 6d 75 info*). (mu
4a50: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 tex-unlock! *hea
4a60: 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 rtbeat-mutex*).
4a70: 20 20 20 20 20 0a 20 20 20 20 20 20 28 69 66 20 . (if
4a80: 28 6f 72 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f (or (not (equal?
4a90: 20 73 64 61 74 20 28 6c 69 73 74 20 69 66 61 63 sdat (list ifac
4aa0: 65 20 70 6f 72 74 29 29 29 0a 09 20 20 20 20 20 e port)))..
4ab0: 20 28 6e 6f 74 20 73 65 72 76 65 72 2d 69 64 29 (not server-id)
4ac0: 29 0a 09 20 20 28 62 65 67 69 6e 20 0a 09 20 20 ).. (begin ..
4ad0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
4ae0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
4af0: 6f 67 2d 70 6f 72 74 2a 20 22 69 6e 74 65 72 66 og-port* "interf
4b00: 61 63 65 20 63 68 61 6e 67 65 64 2c 20 72 65 66 ace changed, ref
4b10: 72 65 73 68 69 6e 67 20 69 66 61 63 65 20 61 6e reshing iface an
4b20: 64 20 70 6f 72 74 20 69 6e 66 6f 22 29 0a 09 20 d port info")..
4b30: 20 20 20 28 73 65 74 21 20 69 66 61 63 65 20 28 (set! iface (
4b40: 63 61 72 20 73 64 61 74 29 29 0a 09 20 20 20 20 car sdat))..
4b50: 28 73 65 74 21 20 70 6f 72 74 20 20 28 63 61 64 (set! port (cad
4b60: 72 20 73 64 61 74 29 29 0a 20 20 20 20 20 20 20 r sdat)).
4b70: 20 20 20 20 20 28 73 65 72 76 65 72 3a 77 72 69 (server:wri
4b80: 74 65 2d 64 6f 74 73 65 72 76 65 72 20 2a 74 6f te-dotserver *to
4b90: 70 70 61 74 68 2a 20 69 66 61 63 65 20 70 6f 72 ppath* iface por
4ba0: 74 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 t (current-proce
4bb0: 73 73 2d 69 64 29 20 27 68 74 74 70 29 29 29 0a ss-id) 'http))).
4bc0: 20 20 20 20 20 20 0a 20 20 20 20 20 20 3b 3b 20 . ;;
4bd0: 54 72 61 6e 73 66 65 72 20 2a 64 62 2d 6c 61 73 Transfer *db-las
4be0: 74 2d 61 63 63 65 73 73 2a 20 74 6f 20 6c 61 73 t-access* to las
4bf0: 74 2d 61 63 63 65 73 73 20 74 6f 20 75 73 65 20 t-access to use
4c00: 69 6e 20 63 68 65 63 6b 69 6e 67 20 74 68 61 74 in checking that
4c10: 20 77 65 20 61 72 65 20 73 74 69 6c 6c 20 61 6c we are still al
4c20: 69 76 65 0a 20 20 20 20 20 20 28 6d 75 74 65 78 ive. (mutex
4c30: 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 -lock! *heartbea
4c40: 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 t-mutex*).
4c50: 28 73 65 74 21 20 6c 61 73 74 2d 61 63 63 65 73 (set! last-acces
4c60: 73 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 s *db-last-acces
4c70: 73 2a 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 s*). (mutex
4c80: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 -unlock! *heartb
4c90: 65 61 74 2d 6d 75 74 65 78 2a 29 0a 0a 20 20 20 eat-mutex*)..
4ca0: 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 ;; (debug:pri
4cb0: 6e 74 20 31 31 20 2a 64 65 66 61 75 6c 74 2d 6c nt 11 *default-l
4cc0: 6f 67 2d 70 6f 72 74 2a 20 22 6c 61 73 74 2d 61 og-port* "last-a
4cd0: 63 63 65 73 73 3d 22 20 6c 61 73 74 2d 61 63 63 ccess=" last-acc
4ce0: 65 73 73 20 22 2c 20 73 65 72 76 65 72 2d 74 69 ess ", server-ti
4cf0: 6d 65 6f 75 74 3d 22 20 73 65 72 76 65 72 2d 74 meout=" server-t
4d00: 69 6d 65 6f 75 74 29 0a 20 20 20 20 20 20 3b 3b imeout). ;;
4d10: 0a 20 20 20 20 20 20 3b 3b 20 6e 6f 5f 74 72 61 . ;; no_tra
4d20: 66 66 69 63 2c 20 6e 6f 20 72 75 6e 6e 69 6e 67 ffic, no running
4d30: 20 74 65 73 74 73 2c 20 69 66 20 73 65 72 76 65 tests, if serve
4d40: 72 20 30 2c 20 6e 6f 20 72 75 6e 6e 69 6e 67 20 r 0, no running
4d50: 73 65 72 76 65 72 73 0a 20 20 20 20 20 20 3b 3b servers. ;;
4d60: 0a 20 20 20 20 20 20 3b 3b 20 28 6c 65 74 20 28 . ;; (let (
4d70: 28 77 61 69 74 2d 6f 6e 2d 72 75 6e 6e 69 6e 67 (wait-on-running
4d80: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
4d90: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
4da0: 72 76 65 72 22 20 62 22 77 61 69 74 2d 6f 6e 2d rver" b"wait-on-
4db0: 72 75 6e 6e 69 6e 67 22 29 29 29 20 3b 3b 20 77 running"))) ;; w
4dc0: 61 69 74 20 6f 6e 20 72 75 6e 6e 69 6e 67 20 74 ait on running t
4dd0: 61 73 6b 73 20 28 69 66 20 6e 6f 74 20 74 72 75 asks (if not tru
4de0: 65 20 74 68 65 6e 20 65 78 69 74 20 6f 6e 20 74 e then exit on t
4df0: 69 6d 65 20 6f 75 74 29 0a 20 20 20 20 20 20 3b ime out). ;
4e00: 3b 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ;. (let* ((
4e10: 68 72 73 2d 73 69 6e 63 65 2d 73 74 61 72 74 20 hrs-since-start
4e20: 20 28 2f 20 28 2d 20 28 63 75 72 72 65 6e 74 2d (/ (- (current-
4e30: 73 65 63 6f 6e 64 73 29 20 73 65 72 76 65 72 2d seconds) server-
4e40: 73 74 61 72 74 2d 74 69 6d 65 29 20 33 36 30 30 start-time) 3600
4e50: 29 29 0a 09 20 20 20 20 20 28 61 64 6a 75 73 74 )).. (adjust
4e60: 65 64 2d 74 69 6d 65 6f 75 74 20 28 69 66 20 28 ed-timeout (if (
4e70: 3e 20 68 72 73 2d 73 69 6e 63 65 2d 73 74 61 72 > hrs-since-star
4e80: 74 20 31 29 0a 09 09 09 09 20 20 20 28 2d 20 73 t 1)..... (- s
4e90: 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 20 28 69 erver-timeout (i
4ea0: 6e 65 78 61 63 74 2d 3e 65 78 61 63 74 20 28 72 nexact->exact (r
4eb0: 6f 75 6e 64 20 28 2a 20 68 72 73 2d 73 69 6e 63 ound (* hrs-sinc
4ec0: 65 2d 73 74 61 72 74 20 36 30 29 29 29 29 20 20 e-start 60))))
4ed0: 3b 3b 20 73 75 62 74 72 61 63 74 20 36 30 20 73 ;; subtract 60 s
4ee0: 65 63 6f 6e 64 73 20 70 65 72 20 68 6f 75 72 0a econds per hour.
4ef0: 09 09 09 09 20 20 20 73 65 72 76 65 72 2d 74 69 .... server-ti
4f00: 6d 65 6f 75 74 29 29 29 0a 09 28 69 66 20 28 63 meout)))..(if (c
4f10: 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d ommon:low-noise-
4f20: 70 72 69 6e 74 20 31 32 30 20 22 73 65 72 76 65 print 120 "serve
4f30: 72 20 74 69 6d 65 6f 75 74 22 29 0a 09 20 20 20 r timeout")..
4f40: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
4f50: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
4f60: 67 2d 70 6f 72 74 2a 20 22 41 64 6a 75 73 74 65 g-port* "Adjuste
4f70: 64 20 73 65 72 76 65 72 20 74 69 6d 65 6f 75 74 d server timeout
4f80: 3a 20 22 20 61 64 6a 75 73 74 65 64 2d 74 69 6d : " adjusted-tim
4f90: 65 6f 75 74 29 29 0a 09 28 63 6f 6e 64 0a 20 20 eout))..(cond.
4fa0: 20 20 20 20 20 20 20 28 28 6e 6f 74 20 28 73 65 ((not (se
4fb0: 72 76 65 72 3a 63 6f 6e 66 69 72 6d 2d 64 6f 74 rver:confirm-dot
4fc0: 73 65 72 76 65 72 20 2a 74 6f 70 70 61 74 68 2a server *toppath*
4fd0: 20 69 66 61 63 65 20 70 6f 72 74 20 28 63 75 72 iface port (cur
4fe0: 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 rent-process-id)
4ff0: 20 27 68 74 74 70 29 29 0a 20 20 20 20 20 20 20 'http)).
5000: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
5010: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
5020: 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 log-port* "Serve
5030: 72 20 2e 73 65 72 76 65 72 20 66 69 6c 65 20 64 r .server file d
5040: 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 20 6f 72 oes not exist or
5050: 20 63 6f 6e 74 65 6e 74 73 20 64 6f 20 6e 6f 74 contents do not
5060: 20 6d 61 74 63 68 2e 20 20 49 6e 69 74 69 61 74 match. Initiat
5070: 65 20 73 65 72 76 65 72 20 73 68 75 74 64 6f 77 e server shutdow
5080: 6e 2e 22 29 0a 20 20 20 20 20 20 20 20 20 20 28 n."). (
5090: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
50a0: 65 72 76 65 72 2d 73 68 75 74 64 6f 77 6e 20 73 erver-shutdown s
50b0: 65 72 76 65 72 2d 69 64 20 70 6f 72 74 29 29 0a erver-id port)).
50c0: 20 20 20 20 20 20 20 20 20 28 28 61 6e 64 20 2a ((and *
50d0: 73 65 72 76 65 72 2d 72 75 6e 2a 0a 09 09 20 28 server-run*... (
50e0: 3e 20 28 2b 20 6c 61 73 74 2d 61 63 63 65 73 73 > (+ last-access
50f0: 20 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 29 server-timeout)
5100: 0a 09 09 20 20 20 20 28 63 75 72 72 65 6e 74 2d ... (current-
5110: 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 seconds))).
5120: 20 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e (if (common
5130: 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 :low-noise-print
5140: 20 31 32 30 20 22 73 65 72 76 65 72 20 63 6f 6e 120 "server con
5150: 74 69 6e 75 69 6e 67 22 29 0a 20 20 20 20 20 20 tinuing").
5160: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
5170: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
5180: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5190: 53 65 72 76 65 72 20 63 6f 6e 74 69 6e 75 69 6e Server continuin
51a0: 67 2c 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 g, seconds since
51b0: 20 6c 61 73 74 20 64 62 20 61 63 63 65 73 73 3a last db access:
51c0: 20 22 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 " (- (current-s
51d0: 65 63 6f 6e 64 73 29 20 6c 61 73 74 2d 61 63 63 econds) last-acc
51e0: 65 73 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 ess))).
51f0: 20 3b 3b 0a 20 20 20 20 20 20 20 20 20 20 3b 3b ;;. ;;
5200: 20 43 6f 6e 73 69 64 65 72 20 69 6d 70 6c 65 6d Consider implem
5210: 65 6e 74 69 6e 67 20 73 6f 6d 65 20 73 6d 61 72 enting some smar
5220: 74 73 20 68 65 72 65 20 74 6f 20 72 65 2d 69 6e ts here to re-in
5230: 73 65 72 74 20 74 68 65 20 72 65 63 6f 72 64 20 sert the record
5240: 6f 72 20 6b 69 6c 6c 20 73 65 6c 66 20 69 73 0a or kill self is.
5250: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 ;; the
5260: 20 64 62 20 69 6e 64 69 63 61 74 65 73 20 73 6f db indicates so
5270: 0a 20 20 20 20 20 20 20 20 20 20 3b 3b 0a 20 20 . ;;.
5280: 20 20 20 20 20 20 20 20 3b 3b 20 28 69 66 20 28 ;; (if (
5290: 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 61 6d 2d tasks:server-am-
52a0: 69 2d 74 68 65 2d 73 65 72 76 65 72 3f 20 74 64 i-the-server? td
52b0: 62 20 72 75 6e 2d 69 64 29 0a 20 20 20 20 20 20 b run-id).
52c0: 20 20 20 20 3b 3b 20 20 20 20 20 28 74 61 73 6b ;; (task
52d0: 73 3a 73 65 72 76 65 72 2d 73 65 74 2d 73 74 61 s:server-set-sta
52e0: 74 65 21 20 74 64 62 20 73 65 72 76 65 72 2d 69 te! tdb server-i
52f0: 64 20 22 72 75 6e 6e 69 6e 67 22 29 29 0a 20 20 d "running")).
5300: 20 20 20 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 ;;.
5310: 20 20 20 20 20 28 6c 6f 6f 70 20 30 20 73 65 72 (loop 0 ser
5320: 76 65 72 2d 73 74 61 74 65 20 62 61 64 2d 73 79 ver-state bad-sy
5330: 6e 63 2d 63 6f 75 6e 74 20 28 63 75 72 72 65 6e nc-count (curren
5340: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 t-milliseconds))
5350: 29 0a 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 ). (else
5360: 0a 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 . (debu
5370: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
5380: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
5390: 2a 20 22 53 65 72 76 65 72 20 74 69 6d 65 65 64 * "Server timeed
53a0: 20 6f 75 74 2e 20 73 65 63 6f 6e 64 73 20 73 69 out. seconds si
53b0: 6e 63 65 20 6c 61 73 74 20 64 62 20 61 63 63 65 nce last db acce
53c0: 73 73 3a 20 22 20 28 2d 20 28 63 75 72 72 65 6e ss: " (- (curren
53d0: 74 2d 73 65 63 6f 6e 64 73 29 20 6c 61 73 74 2d t-seconds) last-
53e0: 61 63 63 65 73 73 29 29 0a 20 20 20 20 20 20 20 access)).
53f0: 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f (http-transpo
5400: 72 74 3a 73 65 72 76 65 72 2d 73 68 75 74 64 6f rt:server-shutdo
5410: 77 6e 20 73 65 72 76 65 72 2d 69 64 20 70 6f 72 wn server-id por
5420: 74 29 29 29 29 29 29 29 0a 0a 3b 3b 20 63 6f 64 t)))))))..;; cod
5430: 65 20 63 75 74 20 6f 75 74 20 66 72 6f 6d 20 61 e cut out from a
5440: 62 6f 76 65 0a 3b 3b 0a 3b 3b 20 28 63 6f 6e 64 bove.;;.;; (cond
5450: 69 74 69 6f 6e 2d 63 61 73 65 0a 3b 3b 20 20 3b ition-case.;; ;
5460: 3b 20 28 69 66 20 28 61 6e 64 20 28 6d 65 6d 62 ; (if (and (memb
5470: 65 72 20 28 6d 75 74 65 78 2d 73 74 61 74 65 20 er (mutex-state
5480: 2a 64 62 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 *db-sync-mutex*)
5490: 20 27 28 61 62 61 6e 64 6f 6e 65 64 20 6e 6f 74 '(abandoned not
54a0: 2d 61 62 61 6e 64 6f 6e 65 64 29 29 0a 3b 3b 20 -abandoned)).;;
54b0: 20 3b 3b 09 20 20 20 20 20 20 28 3e 20 28 2d 20 ;;. (> (-
54c0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
54d0: 29 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a ) *db-last-sync*
54e0: 29 20 35 29 29 20 3b 3b 20 69 66 20 6e 6f 74 20 ) 5)) ;; if not
54f0: 63 75 72 72 65 6e 74 6c 79 20 62 65 69 6e 67 20 currently being
5500: 73 79 6e 63 65 64 20 6e 6f 72 20 72 65 63 65 6e synced nor recen
5510: 74 6c 79 20 73 79 6e 63 65 64 0a 3b 3b 20 20 28 tly synced.;; (
5520: 64 62 3a 73 79 6e 63 2d 74 6f 75 63 68 65 64 20 db:sync-touched
5530: 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 20 2a 72 *dbstruct-db* *r
5540: 75 6e 2d 69 64 2a 20 66 6f 72 63 65 2d 73 79 6e un-id* force-syn
5550: 63 3a 20 23 74 29 20 3b 3b 20 75 73 75 61 6c 6c c: #t) ;; usuall
5560: 79 20 64 6f 6e 65 20 69 6e 20 74 68 65 20 77 61 y done in the wa
5570: 74 63 68 64 6f 67 2c 20 6e 6f 74 20 68 65 72 65 tchdog, not here
5580: 2e 0a 3b 3b 20 20 28 28 73 79 6e 63 2d 66 61 69 ..;; ((sync-fai
5590: 6c 65 64 29 28 63 6f 6e 64 0a 3b 3b 20 09 09 20 led)(cond.;; ..
55a0: 20 20 20 28 28 3e 20 62 61 64 2d 73 79 6e 63 2d ((> bad-sync-
55b0: 63 6f 75 6e 74 20 31 30 29 20 3b 3b 20 74 69 6d count 10) ;; tim
55c0: 65 20 74 6f 20 67 69 76 65 20 75 70 0a 3b 3b 20 e to give up.;;
55d0: 09 09 20 20 20 20 20 28 68 74 74 70 2d 74 72 61 .. (http-tra
55e0: 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 73 68 nsport:server-sh
55f0: 75 74 64 6f 77 6e 20 73 65 72 76 65 72 2d 69 64 utdown server-id
5600: 20 70 6f 72 74 29 29 0a 3b 3b 20 09 09 20 20 20 port)).;; ..
5610: 20 28 65 6c 73 65 20 3b 3b 20 28 3e 20 62 61 64 (else ;; (> bad
5620: 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 30 29 20 20 -sync-count 0)
5630: 3b 3b 20 77 65 27 76 65 20 68 61 64 20 61 20 66 ;; we've had a f
5640: 61 69 6c 20 6f 72 20 74 77 6f 2c 20 64 65 6c 61 ail or two, dela
5650: 79 20 61 6e 64 20 6c 6f 6f 70 0a 3b 3b 20 09 09 y and loop.;; ..
5660: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
5670: 65 70 21 20 35 29 0a 3b 3b 20 09 09 20 20 20 20 ep! 5).;; ..
5680: 20 28 6c 6f 6f 70 20 63 6f 75 6e 74 20 73 65 72 (loop count ser
5690: 76 65 72 2d 73 74 61 74 65 20 28 2b 20 62 61 64 ver-state (+ bad
56a0: 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 31 29 29 29 -sync-count 1)))
56b0: 29 29 0a 3b 3b 20 20 28 28 65 78 6e 29 0a 3b 3b )).;; ((exn).;;
56c0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
56d0: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
56e0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 65 72 72 6f -log-port* "erro
56f0: 72 20 66 72 6f 6d 20 73 79 6e 63 20 63 6f 64 65 r from sync code
5700: 20 6f 74 68 65 72 20 74 68 61 6e 20 27 73 79 6e other than 'syn
5710: 63 2d 66 61 69 6c 65 64 2e 20 41 74 74 65 6d 70 c-failed. Attemp
5720: 74 69 6e 67 20 74 6f 20 67 72 61 63 65 66 75 6c ting to graceful
5730: 6c 79 20 73 68 75 74 64 6f 77 6e 20 74 68 65 20 ly shutdown the
5740: 73 65 72 76 65 72 22 29 0a 3b 3b 20 20 20 28 74 server").;; (t
5750: 61 73 6b 73 3a 73 65 72 76 65 72 2d 64 65 6c 65 asks:server-dele
5760: 74 65 2d 72 65 63 6f 72 64 20 28 64 62 3a 64 65 te-record (db:de
5770: 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 62 64 lay-if-busy tdbd
5780: 61 74 29 20 73 65 72 76 65 72 2d 69 64 20 22 20 at) server-id "
5790: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6b http-transport:k
57a0: 65 65 70 2d 72 75 6e 6e 69 6e 67 20 63 72 61 73 eep-running cras
57b0: 68 65 64 22 29 0a 3b 3b 20 20 20 28 65 78 69 74 hed").;; (exit
57c0: 29 29 29 0a 3b 3b 20 28 73 65 74 21 20 73 79 6e ))).;; (set! syn
57d0: 63 2d 74 69 6d 65 20 20 28 2d 20 28 63 75 72 72 c-time (- (curr
57e0: 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 ent-milliseconds
57f0: 29 20 73 74 61 72 74 2d 74 69 6d 65 29 29 0a 3b ) start-time)).;
5800: 3b 20 28 73 65 74 21 20 72 65 6d 2d 74 69 6d 65 ; (set! rem-time
5810: 20 28 71 75 6f 74 69 65 6e 74 20 28 2d 20 34 30 (quotient (- 40
5820: 30 30 20 73 79 6e 63 2d 74 69 6d 65 29 20 31 30 00 sync-time) 10
5830: 30 30 29 29 0a 3b 3b 20 28 64 65 62 75 67 3a 70 00)).;; (debug:p
5840: 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d rint 4 *default-
5850: 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 59 4e 43 3a log-port* "SYNC:
5860: 20 74 69 6d 65 3d 20 22 20 73 79 6e 63 2d 74 69 time= " sync-ti
5870: 6d 65 20 22 2c 20 72 65 6d 2d 74 69 6d 65 3d 22 me ", rem-time="
5880: 20 72 65 6d 2d 74 69 6d 65 29 0a 3b 3b 20 0a 3b rem-time).;; .;
5890: 3b 20 28 69 66 20 28 61 6e 64 20 28 3c 3d 20 72 ; (if (and (<= r
58a0: 65 6d 2d 74 69 6d 65 20 34 29 0a 3b 3b 20 09 20 em-time 4).;; .
58b0: 20 20 20 20 28 3e 20 72 65 6d 2d 74 69 6d 65 20 (> rem-time
58c0: 30 29 29 0a 3b 3b 20 09 28 74 68 72 65 61 64 2d 0)).;; .(thread-
58d0: 73 6c 65 65 70 21 20 72 65 6d 2d 74 69 6d 65 29 sleep! rem-time)
58e0: 0a 3b 3b 20 09 28 74 68 72 65 61 64 2d 73 6c 65 .;; .(thread-sle
58f0: 65 70 21 20 34 29 29 29 20 3b 3b 20 66 61 6c 6c ep! 4))) ;; fall
5900: 62 61 63 6b 20 66 6f 72 20 69 66 20 74 68 65 20 back for if the
5910: 6d 61 74 68 20 69 73 20 63 68 61 6e 67 65 64 20 math is changed
5920: 2e 2e 2e 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 .....(define (ht
5930: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
5940: 76 65 72 2d 73 68 75 74 64 6f 77 6e 20 73 65 72 ver-shutdown ser
5950: 76 65 72 2d 69 64 20 70 6f 72 74 29 0a 20 20 28 ver-id port). (
5960: 6c 65 74 20 28 28 74 64 62 64 61 74 20 28 74 61 let ((tdbdat (ta
5970: 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 sks:open-db))).
5980: 20 20 20 3b 3b 28 42 42 3e 20 22 68 74 74 70 2d ;;(BB> "http-
5990: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
59a0: 2d 73 68 75 74 64 6f 77 6e 20 63 61 6c 6c 65 64 -shutdown called
59b0: 22 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 "). (debug:pr
59c0: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
59d0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 ult-log-port* "S
59e0: 74 61 72 74 69 6e 67 20 74 6f 20 73 68 75 74 64 tarting to shutd
59f0: 6f 77 6e 20 74 68 65 20 73 65 72 76 65 72 2e 20 own the server.
5a00: 70 69 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 pid="(current-pr
5a10: 6f 63 65 73 73 2d 69 64 29 29 0a 20 20 20 20 3b ocess-id)). ;
5a20: 3b 0a 20 20 20 20 3b 3b 20 73 74 61 72 74 5f 73 ;. ;; start_s
5a30: 68 75 74 64 6f 77 6e 0a 20 20 20 20 3b 3b 0a 20 hutdown. ;;.
5a40: 20 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 (tasks:server
5a50: 2d 73 65 74 2d 73 74 61 74 65 21 20 28 64 62 3a -set-state! (db:
5a60: 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 delay-if-busy td
5a70: 62 64 61 74 29 20 73 65 72 76 65 72 2d 69 64 20 bdat) server-id
5a80: 22 73 68 75 74 74 69 6e 67 2d 64 6f 77 6e 22 29 "shutting-down")
5a90: 0a 20 20 20 20 28 73 65 74 21 20 2a 74 69 6d 65 . (set! *time
5aa0: 2d 74 6f 2d 65 78 69 74 2a 20 23 74 29 20 3b 3b -to-exit* #t) ;;
5ab0: 20 74 65 6c 6c 20 6f 6e 2d 65 78 69 74 20 74 6f tell on-exit to
5ac0: 20 62 65 20 66 61 73 74 20 61 73 20 77 65 27 76 be fast as we'v
5ad0: 65 20 61 6c 72 65 61 64 79 20 63 6c 65 61 6e 65 e already cleane
5ae0: 64 20 75 70 0a 20 20 20 20 28 70 6f 72 74 6c 6f d up. (portlo
5af0: 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c gger:open-run-cl
5b00: 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 73 ose portlogger:s
5b10: 65 74 2d 70 6f 72 74 20 70 6f 72 74 20 22 72 65 et-port port "re
5b20: 6c 65 61 73 65 64 22 29 0a 20 20 20 20 28 74 68 leased"). (th
5b30: 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 0a 20 read-sleep! 5).
5b40: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
5b50: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
5b60: 6c 6f 67 2d 70 6f 72 74 2a 20 22 4d 61 78 20 63 log-port* "Max c
5b70: 61 63 68 65 64 20 71 75 65 72 69 65 73 20 77 61 ached queries wa
5b80: 73 20 20 20 20 22 20 2a 6d 61 78 2d 63 61 63 68 s " *max-cach
5b90: 65 2d 73 69 7a 65 2a 29 0a 20 20 20 20 28 64 65 e-size*). (de
5ba0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
5bb0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5bc0: 72 74 2a 20 22 4e 75 6d 62 65 72 20 6f 66 20 63 rt* "Number of c
5bd0: 61 63 68 65 64 20 77 72 69 74 65 73 20 20 20 22 ached writes "
5be0: 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 *number-of-writ
5bf0: 65 73 2a 29 0a 20 20 20 20 28 64 65 62 75 67 3a es*). (debug:
5c00: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
5c10: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5c20: 22 41 76 65 72 61 67 65 20 63 61 63 68 65 64 20 "Average cached
5c30: 77 72 69 74 65 20 74 69 6d 65 20 22 0a 09 09 20 write time "...
5c40: 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 2a 6e (if (eq? *n
5c50: 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a umber-of-writes*
5c60: 20 30 29 0a 09 09 09 20 20 22 6e 2f 61 20 28 6e 0).... "n/a (n
5c70: 6f 20 77 72 69 74 65 73 29 22 0a 09 09 09 20 20 o writes)"....
5c80: 28 2f 20 2a 77 72 69 74 65 73 2d 74 6f 74 61 6c (/ *writes-total
5c90: 2d 64 65 6c 61 79 2a 0a 09 09 09 20 20 20 20 20 -delay*....
5ca0: 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 *number-of-write
5cb0: 73 2a 29 29 0a 09 09 20 20 20 20 20 20 22 20 6d s*))... " m
5cc0: 73 22 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 s"). (debug:p
5cd0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
5ce0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5cf0: 4e 75 6d 62 65 72 20 6e 6f 6e 2d 63 61 63 68 65 Number non-cache
5d00: 64 20 71 75 65 72 69 65 73 20 22 20 20 2a 6e 75 d queries " *nu
5d10: 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 mber-non-write-q
5d20: 75 65 72 69 65 73 2a 29 0a 20 20 20 20 28 64 65 ueries*). (de
5d30: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
5d40: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5d50: 72 74 2a 20 22 41 76 65 72 61 67 65 20 6e 6f 6e rt* "Average non
5d60: 2d 63 61 63 68 65 64 20 74 69 6d 65 20 20 20 22 -cached time "
5d70: 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 65 71 ... (if (eq
5d80: 3f 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 ? *number-non-wr
5d90: 69 74 65 2d 71 75 65 72 69 65 73 2a 20 30 29 0a ite-queries* 0).
5da0: 09 09 09 20 20 22 6e 2f 61 20 28 6e 6f 20 71 75 ... "n/a (no qu
5db0: 65 72 69 65 73 29 22 0a 09 09 09 20 20 28 2f 20 eries)".... (/
5dc0: 2a 74 6f 74 61 6c 2d 6e 6f 6e 2d 77 72 69 74 65 *total-non-write
5dd0: 2d 64 65 6c 61 79 2a 20 0a 09 09 09 20 20 20 20 -delay* ....
5de0: 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 *number-non-wri
5df0: 74 65 2d 71 75 65 72 69 65 73 2a 29 29 0a 09 09 te-queries*))...
5e00: 20 20 20 20 20 20 22 20 6d 73 22 29 0a 20 20 20 " ms").
5e10: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
5e20: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
5e30: 67 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 72 20 g-port* "Server
5e40: 73 68 75 74 64 6f 77 6e 20 63 6f 6d 70 6c 65 74 shutdown complet
5e50: 65 2e 20 45 78 69 74 69 6e 67 22 29 0a 20 20 20 e. Exiting").
5e60: 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 64 (tasks:server-d
5e70: 65 6c 65 74 65 2d 72 65 63 6f 72 64 20 28 64 62 elete-record (db
5e80: 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 :delay-if-busy t
5e90: 64 62 64 61 74 29 20 73 65 72 76 65 72 2d 69 64 dbdat) server-id
5ea0: 20 22 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 " http-transpor
5eb0: 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 63 t:keep-running c
5ec0: 6f 6d 70 6c 65 74 65 22 29 0a 20 20 20 20 3b 3b omplete"). ;;
5ed0: 20 69 66 20 74 68 65 20 2e 73 65 72 76 65 72 20 if the .server
5ee0: 66 69 6c 65 20 63 6f 6e 74 61 69 6e 65 64 20 3a file contained :
5ef0: 6d 79 70 6f 72 74 20 74 68 65 6e 20 77 65 20 63 myport then we c
5f00: 61 6e 20 72 65 6d 6f 76 65 20 69 74 0a 20 20 20 an remove it.
5f10: 20 28 73 65 72 76 65 72 3a 72 65 6d 6f 76 65 2d (server:remove-
5f20: 64 6f 74 73 65 72 76 65 72 2d 66 69 6c 65 20 2a dotserver-file *
5f30: 74 6f 70 70 61 74 68 2a 20 70 6f 72 74 29 0a 20 toppath* port).
5f40: 20 20 20 3b 3b 28 42 42 3e 20 22 68 74 74 70 2d ;;(BB> "http-
5f50: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
5f60: 2d 73 68 75 74 64 6f 77 6e 20 2d 3e 20 65 78 69 -shutdown -> exi
5f70: 74 22 29 0a 20 20 20 20 28 65 78 69 74 29 29 29 t"). (exit)))
5f80: 0a 0a 3b 3b 20 61 6c 6c 20 72 6f 75 74 65 73 20 ..;; all routes
5f90: 74 68 6f 75 67 68 20 68 65 72 65 20 65 6e 64 20 though here end
5fa0: 69 6e 20 65 78 69 74 20 2e 2e 2e 0a 3b 3b 0a 3b in exit ....;;.;
5fb0: 3b 20 73 74 61 72 74 5f 73 65 72 76 65 72 3f 20 ; start_server?
5fc0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 74 .;;.(define (htt
5fd0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e p-transport:laun
5fe0: 63 68 20 72 75 6e 2d 69 64 29 0a 20 20 28 73 65 ch run-id). (se
5ff0: 72 76 65 72 3a 61 74 74 65 6d 70 74 69 6e 67 2d rver:attempting-
6000: 73 74 61 72 74 20 2a 74 6f 70 70 61 74 68 2a 29 start *toppath*)
6010: 0a 20 20 28 6c 65 74 2a 20 28 28 74 64 62 64 61 . (let* ((tdbda
6020: 74 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 t (tasks:open-db
6030: 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 2a 72 ))). (set! *r
6040: 75 6e 2d 69 64 2a 20 20 20 72 75 6e 2d 69 64 29 un-id* run-id)
6050: 0a 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 . (if (args:g
6060: 65 74 2d 61 72 67 20 22 2d 64 61 65 6d 6f 6e 69 et-arg "-daemoni
6070: 7a 65 22 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 ze")..(begin..
6080: 28 64 61 65 6d 6f 6e 3a 69 7a 65 29 0a 09 20 20 (daemon:ize)..
6090: 28 69 66 20 2a 61 6c 74 2d 6c 6f 67 2d 66 69 6c (if *alt-log-fil
60a0: 65 2a 20 3b 3b 20 77 65 20 73 68 6f 75 6c 64 20 e* ;; we should
60b0: 72 65 2d 63 6f 6e 6e 65 63 74 20 74 6f 20 74 68 re-connect to th
60c0: 69 73 20 70 6f 72 74 2c 20 49 20 74 68 69 6e 6b is port, I think
60d0: 20 64 61 65 6d 6f 6e 3a 69 7a 65 20 64 69 73 72 daemon:ize disr
60e0: 75 70 74 73 20 69 74 0a 09 20 20 20 20 20 20 28 upts it.. (
60f0: 62 65 67 69 6e 0a 09 09 28 63 75 72 72 65 6e 74 begin...(current
6100: 2d 65 72 72 6f 72 2d 70 6f 72 74 20 2a 61 6c 74 -error-port *alt
6110: 2d 6c 6f 67 2d 66 69 6c 65 2a 29 0a 09 09 28 63 -log-file*)...(c
6120: 75 72 72 65 6e 74 2d 6f 75 74 70 75 74 2d 70 6f urrent-output-po
6130: 72 74 20 2a 61 6c 74 2d 6c 6f 67 2d 66 69 6c 65 rt *alt-log-file
6140: 2a 29 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 *))))). (if (
6150: 61 6e 64 20 28 73 65 72 76 65 72 3a 72 65 61 64 and (server:read
6160: 2d 64 6f 74 73 65 72 76 65 72 20 2a 74 6f 70 70 -dotserver *topp
6170: 61 74 68 2a 29 0a 20 20 20 20 20 20 20 20 20 20 ath*).
6180: 20 20 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b (server:check
6190: 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 72 75 6e 2d -if-running run-
61a0: 69 64 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 id))..(begin..
61b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
61c0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
61d0: 2a 20 22 49 4e 46 4f 3a 20 53 65 72 76 65 72 20 * "INFO: Server
61e0: 66 6f 72 20 72 75 6e 2d 69 64 20 22 20 72 75 6e for run-id " run
61f0: 2d 69 64 20 22 20 61 6c 72 65 61 64 79 20 72 75 -id " already ru
6200: 6e 6e 69 6e 67 22 29 0a 09 20 20 28 65 78 69 74 nning").. (exit
6210: 20 30 29 29 0a 09 28 62 65 67 69 6e 20 3b 3b 20 0))..(begin ;;
6220: 6f 6b 2c 20 6e 6f 20 73 65 72 76 65 72 20 64 65 ok, no server de
6230: 74 65 63 74 65 64 2c 20 63 6c 65 61 6e 20 6f 75 tected, clean ou
6240: 74 20 61 6e 79 20 6c 69 6e 67 65 72 69 6e 67 20 t any lingering
6250: 72 65 63 6f 72 64 73 0a 20 20 20 20 20 20 20 20 records.
6260: 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d (tasks:server-
6270: 66 6f 72 63 65 2d 63 6c 65 61 6e 2d 72 75 6e 6e force-clean-runn
6280: 69 6e 67 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d ing-records-for-
6290: 72 75 6e 2d 69 64 20 20 28 64 62 3a 64 65 6c 61 run-id (db:dela
62a0: 79 2d 69 66 2d 62 75 73 79 20 74 64 62 64 61 74 y-if-busy tdbdat
62b0: 29 20 72 75 6e 2d 69 64 20 22 6e 6f 74 72 65 73 ) run-id "notres
62c0: 70 6f 6e 64 69 6e 67 22 29 29 29 0a 20 20 20 20 ponding"))).
62d0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 73 65 72 76 (let loop ((serv
62e0: 65 72 2d 69 64 20 28 74 61 73 6b 73 3a 73 65 72 er-id (tasks:ser
62f0: 76 65 72 2d 6c 6f 63 6b 2d 73 6c 6f 74 20 28 64 ver-lock-slot (d
6300: 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 b:delay-if-busy
6310: 74 64 62 64 61 74 29 20 72 75 6e 2d 69 64 29 29 tdbdat) run-id))
6320: 0a 09 20 20 20 20 20 20 20 28 72 65 6d 74 72 69 .. (remtri
6330: 65 73 20 20 34 29 29 0a 20 20 20 20 20 20 28 69 es 4)). (i
6340: 66 20 28 6e 6f 74 20 73 65 72 76 65 72 2d 69 64 f (not server-id
6350: 29 0a 09 20 20 28 69 66 20 28 3e 20 72 65 6d 74 ).. (if (> remt
6360: 72 69 65 73 20 30 29 0a 09 20 20 20 20 20 20 28 ries 0).. (
6370: 62 65 67 69 6e 0a 09 09 28 74 68 72 65 61 64 2d begin...(thread-
6380: 73 6c 65 65 70 21 20 32 29 0a 09 09 28 6c 6f 6f sleep! 2)...(loo
6390: 70 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d p (tasks:server-
63a0: 6c 6f 63 6b 2d 73 6c 6f 74 20 28 64 62 3a 64 65 lock-slot (db:de
63b0: 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 62 64 lay-if-busy tdbd
63c0: 61 74 29 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 at) run-id)...
63d0: 20 20 20 20 28 2d 20 72 65 6d 74 72 69 65 73 20 (- remtries
63e0: 31 29 29 29 0a 09 20 20 20 20 20 20 28 62 65 67 1))).. (beg
63f0: 69 6e 0a 09 09 3b 3b 20 73 69 6e 63 65 20 77 65 in...;; since we
6400: 20 64 69 64 6e 27 74 20 67 65 74 20 74 68 65 20 didn't get the
6410: 73 65 72 76 65 72 20 6c 6f 63 6b 20 77 65 20 61 server lock we a
6420: 72 65 20 67 6f 69 6e 67 20 74 6f 20 63 6c 65 61 re going to clea
6430: 6e 20 75 70 20 61 6e 64 20 62 61 69 6c 20 6f 75 n up and bail ou
6440: 74 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 t...(debug:print
6450: 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 -info 2 *default
6460: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f -log-port* "INFO
6470: 3a 20 73 65 72 76 65 72 20 70 69 64 3d 22 20 28 : server pid=" (
6480: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
6490: 69 64 29 20 22 2c 20 68 6f 73 74 6e 61 6d 65 3d id) ", hostname=
64a0: 22 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 " (get-host-name
64b0: 29 20 22 20 6e 6f 74 20 73 74 61 72 74 69 6e 67 ) " not starting
64c0: 20 64 75 65 20 74 6f 20 6f 74 68 65 72 20 63 61 due to other ca
64d0: 6e 64 69 64 61 74 65 73 20 61 68 65 61 64 20 69 ndidates ahead i
64e0: 6e 20 73 74 61 72 74 20 71 75 65 75 65 22 29 0a n start queue").
64f0: 09 09 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d ..(tasks:server-
6500: 64 65 6c 65 74 65 2d 72 65 63 6f 72 64 73 2d 66 delete-records-f
6510: 6f 72 2d 74 68 69 73 2d 70 69 64 20 28 64 62 3a or-this-pid (db:
6520: 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 delay-if-busy td
6530: 62 64 61 74 29 20 22 20 68 74 74 70 2d 74 72 61 bdat) " http-tra
6540: 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 22 29 0a nsport:launch").
6550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6560: 28 73 65 72 76 65 72 3a 63 6f 6d 70 6c 65 74 65 (server:complete
6570: 2d 61 74 74 65 6d 70 74 20 2a 74 6f 70 70 61 74 -attempt *toppat
6580: 68 2a 29 0a 09 09 29 29 0a 09 20 20 28 6c 65 74 h*)...)).. (let
6590: 2a 20 28 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 * ((th2 (make-th
65a0: 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a read (lambda ().
65b0: 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a .... (debug:
65c0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
65d0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
65e0: 22 53 65 72 76 65 72 20 72 75 6e 20 74 68 72 65 "Server run thre
65f0: 61 64 20 73 74 61 72 74 65 64 22 29 0a 09 09 09 ad started")....
6600: 09 20 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e . (http-tran
6610: 73 70 6f 72 74 3a 72 75 6e 20 0a 09 09 09 09 20 sport:run .....
6620: 20 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 (if (args:g
6630: 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 et-arg "-server"
6640: 29 0a 09 09 09 09 09 20 20 28 61 72 67 73 3a 67 )...... (args:g
6650: 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 et-arg "-server"
6660: 29 0a 09 09 09 09 09 20 20 22 2d 22 29 0a 09 09 )...... "-")...
6670: 09 09 20 20 20 20 20 20 72 75 6e 2d 69 64 0a 09 .. run-id..
6680: 09 09 09 20 20 20 20 20 20 73 65 72 76 65 72 2d ... server-
6690: 69 64 29 29 20 22 53 65 72 76 65 72 20 72 75 6e id)) "Server run
66a0: 22 29 29 0a 09 09 20 28 74 68 33 20 28 6d 61 6b "))... (th3 (mak
66b0: 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 e-thread (lambda
66c0: 20 28 29 0a 09 09 09 09 20 20 20 20 20 28 64 65 ()..... (de
66d0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
66e0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
66f0: 72 74 2a 20 22 53 65 72 76 65 72 20 6d 6f 6e 69 rt* "Server moni
6700: 74 6f 72 20 74 68 72 65 61 64 20 73 74 61 72 74 tor thread start
6710: 65 64 22 29 0a 09 09 09 09 20 20 20 20 20 28 68 ed")..... (h
6720: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6b 65 ttp-transport:ke
6730: 65 70 2d 72 75 6e 6e 69 6e 67 20 73 65 72 76 65 ep-running serve
6740: 72 2d 69 64 20 72 75 6e 2d 69 64 29 29 0a 09 09 r-id run-id))...
6750: 09 09 20 20 20 22 4b 65 65 70 20 72 75 6e 6e 69 .. "Keep runni
6760: 6e 67 22 29 29 29 0a 09 20 20 20 20 28 74 68 72 ng"))).. (thr
6770: 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a ead-start! th2).
6780: 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 . (thread-sle
6790: 65 70 21 20 30 2e 32 35 29 20 3b 3b 20 67 69 76 ep! 0.25) ;; giv
67a0: 65 20 74 68 65 20 73 65 72 76 65 72 20 74 69 6d e the server tim
67b0: 65 20 74 6f 20 73 65 74 74 6c 65 20 62 65 66 6f e to settle befo
67c0: 72 65 20 73 74 61 72 74 69 6e 67 20 74 68 65 20 re starting the
67d0: 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 6d 6f 6e keep-running mon
67e0: 69 74 6f 72 2e 0a 09 20 20 20 20 28 74 68 72 65 itor... (thre
67f0: 61 64 2d 73 74 61 72 74 21 20 74 68 33 29 0a 09 ad-start! th3)..
6800: 20 20 20 20 28 73 65 74 21 20 2a 64 69 64 73 6f (set! *didso
6810: 6d 65 74 68 69 6e 67 2a 20 23 74 29 0a 09 20 20 mething* #t)..
6820: 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 (thread-join!
6830: 74 68 32 29 0a 09 20 20 20 20 28 65 78 69 74 29 th2).. (exit)
6840: 29 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e )))))..;; (defin
6850: 65 20 28 68 74 74 70 3a 70 69 6e 67 20 72 75 6e e (http:ping run
6860: 2d 69 64 20 68 6f 73 74 2d 70 6f 72 74 29 0a 3b -id host-port).;
6870: 3b 20 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 ; (let* ((serv
6880: 65 72 2d 64 61 74 20 28 68 74 74 70 2d 74 72 61 er-dat (http-tra
6890: 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 63 6f nsport:client-co
68a0: 6e 6e 65 63 74 20 28 63 61 72 20 68 6f 73 74 2d nnect (car host-
68b0: 70 6f 72 74 29 28 63 61 64 72 20 68 6f 73 74 2d port)(cadr host-
68c0: 70 6f 72 74 29 29 29 0a 3b 3b 20 09 20 28 6c 6f port))).;; . (lo
68d0: 67 69 6e 2d 72 65 73 20 20 28 72 6d 74 3a 6c 6f gin-res (rmt:lo
68e0: 67 69 6e 2d 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 gin-no-auto-clie
68f0: 6e 74 2d 73 65 74 75 70 20 73 65 72 76 65 72 2d nt-setup server-
6900: 64 61 74 20 72 75 6e 2d 69 64 29 29 29 0a 3b 3b dat run-id))).;;
6910: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6c (if (and (l
6920: 69 73 74 3f 20 6c 6f 67 69 6e 2d 72 65 73 29 0a ist? login-res).
6930: 3b 3b 20 09 20 20 20 20 20 28 63 61 72 20 6c 6f ;; . (car lo
6940: 67 69 6e 2d 72 65 73 29 29 0a 3b 3b 20 09 28 62 gin-res)).;; .(b
6950: 65 67 69 6e 0a 3b 3b 20 09 20 20 28 70 72 69 6e egin.;; . (prin
6960: 74 20 22 4c 4f 47 49 4e 5f 4f 4b 22 29 0a 3b 3b t "LOGIN_OK").;;
6970: 20 09 20 20 28 65 78 69 74 20 30 29 29 0a 3b 3b . (exit 0)).;;
6980: 20 09 28 62 65 67 69 6e 0a 3b 3b 20 09 20 20 28 .(begin.;; . (
6990: 70 72 69 6e 74 20 22 4c 4f 47 49 4e 5f 46 41 49 print "LOGIN_FAI
69a0: 4c 45 44 22 29 0a 3b 3b 20 09 20 20 28 65 78 69 LED").;; . (exi
69b0: 74 20 31 29 29 29 29 29 0a 0a 28 64 65 66 69 6e t 1)))))..(defin
69c0: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
69d0: 74 3a 73 65 72 76 65 72 2d 73 69 67 6e 61 6c 2d t:server-signal-
69e0: 68 61 6e 64 6c 65 72 20 73 69 67 6e 75 6d 29 0a handler signum).
69f0: 20 20 28 73 69 67 6e 61 6c 2d 6d 61 73 6b 21 20 (signal-mask!
6a00: 73 69 67 6e 75 6d 29 0a 20 20 28 68 61 6e 64 6c signum). (handl
6a10: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 e-exceptions.
6a20: 65 78 6e 0a 20 20 20 28 64 65 62 75 67 3a 70 72 exn. (debug:pr
6a30: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
6a40: 6f 67 2d 70 6f 72 74 2a 20 22 20 2e 2e 2e 20 65 og-port* " ... e
6a50: 78 69 74 69 6e 67 20 2e 2e 2e 22 29 0a 20 20 20 xiting ...").
6a60: 28 6c 65 74 20 28 28 74 68 31 20 28 6d 61 6b 65 (let ((th1 (make
6a70: 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 -thread (lambda
6a80: 28 29 0a 09 09 09 20 20 20 20 20 28 74 68 72 65 ().... (thre
6a90: 61 64 2d 73 6c 65 65 70 21 20 31 29 29 0a 09 09 ad-sleep! 1))...
6aa0: 09 20 20 20 22 65 61 74 20 72 65 73 70 6f 6e 73 . "eat respons
6ab0: 65 22 29 29 0a 09 20 28 74 68 32 20 28 6d 61 6b e")).. (th2 (mak
6ac0: 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 e-thread (lambda
6ad0: 20 28 29 0a 09 09 09 20 20 20 20 20 28 64 65 62 ().... (deb
6ae0: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
6af0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6b00: 72 74 2a 20 22 52 65 63 65 69 76 65 64 20 5e 43 rt* "Received ^C
6b10: 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 63 6c 65 , attempting cle
6b20: 61 6e 20 65 78 69 74 2e 20 50 6c 65 61 73 65 20 an exit. Please
6b30: 62 65 20 70 61 74 69 65 6e 74 20 61 6e 64 20 77 be patient and w
6b40: 61 69 74 20 61 20 66 65 77 20 73 65 63 6f 6e 64 ait a few second
6b50: 73 20 62 65 66 6f 72 65 20 68 69 74 74 69 6e 67 s before hitting
6b60: 20 5e 43 20 61 67 61 69 6e 2e 22 29 0a 09 09 09 ^C again.")....
6b70: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
6b80: 65 70 21 20 33 29 20 3b 3b 20 67 69 76 65 20 74 ep! 3) ;; give t
6b90: 68 65 20 66 6c 75 73 68 20 74 68 72 65 65 20 73 he flush three s
6ba0: 65 63 6f 6e 64 73 20 74 6f 20 64 6f 20 69 74 27 econds to do it'
6bb0: 73 20 73 74 75 66 66 0a 09 09 09 20 20 20 20 20 s stuff....
6bc0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
6bd0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
6be0: 2a 20 22 20 20 20 20 20 20 20 44 6f 6e 65 2e 22 * " Done."
6bf0: 29 0a 09 09 09 20 20 20 20 20 28 65 78 69 74 20 ).... (exit
6c00: 34 29 29 0a 09 09 09 20 20 20 22 65 78 69 74 20 4)).... "exit
6c10: 6f 6e 20 5e 43 20 74 69 6d 65 72 22 29 29 29 0a on ^C timer"))).
6c20: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 (thread-sta
6c30: 72 74 21 20 74 68 32 29 0a 20 20 20 20 20 28 74 rt! th2). (t
6c40: 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 hread-start! th1
6c50: 29 0a 20 20 20 20 20 28 74 68 72 65 61 64 2d 6a ). (thread-j
6c60: 6f 69 6e 21 20 74 68 32 29 29 29 29 0a 0a 3b 3b oin! th2))))..;;
6c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6cb0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 77 65 62 20 70 61 ======.;; web pa
6cc0: 67 65 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ges.;;==========
6cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6d00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
6d10: 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e efine (http-tran
6d20: 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 61 67 65 29 sport:main-page)
6d30: 0a 20 20 28 6c 65 74 20 28 28 6c 69 6e 6b 70 61 . (let ((linkpa
6d40: 74 68 20 28 72 6f 6f 74 2d 70 61 74 68 29 29 29 th (root-path)))
6d50: 0a 20 20 20 20 28 63 6f 6e 63 20 22 3c 68 65 61 . (conc "<hea
6d60: 64 3e 3c 68 31 3e 22 20 28 70 61 74 68 6e 61 6d d><h1>" (pathnam
6d70: 65 2d 73 74 72 69 70 2d 64 69 72 65 63 74 6f 72 e-strip-director
6d80: 79 20 2a 74 6f 70 70 61 74 68 2a 29 20 22 3c 2f y *toppath*) "</
6d90: 68 31 3e 3c 2f 68 65 61 64 3e 22 0a 09 20 20 22 h1></head>".. "
6da0: 3c 62 6f 64 79 3e 22 0a 09 20 20 22 52 75 6e 20 <body>".. "Run
6db0: 61 72 65 61 3a 20 22 20 2a 74 6f 70 70 61 74 68 area: " *toppath
6dc0: 2a 0a 09 20 20 22 3c 68 32 3e 53 65 72 76 65 72 *.. "<h2>Server
6dd0: 20 53 74 61 74 73 3c 2f 68 32 3e 22 0a 09 20 20 Stats</h2>"..
6de0: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
6df0: 73 74 61 74 73 2d 74 61 62 6c 65 29 20 0a 09 20 stats-table) ..
6e00: 20 22 3c 68 72 3e 22 0a 09 20 20 28 68 74 74 70 "<hr>".. (http
6e10: 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 73 20 -transport:runs
6e20: 6c 69 6e 6b 70 61 74 68 29 0a 09 20 20 22 3c 68 linkpath).. "<h
6e30: 72 3e 22 0a 09 20 20 28 68 74 74 70 2d 74 72 61 r>".. (http-tra
6e40: 6e 73 70 6f 72 74 3a 72 75 6e 2d 73 74 61 74 73 nsport:run-stats
6e50: 29 0a 09 20 20 22 3c 2f 62 6f 64 79 3e 22 0a 09 ).. "</body>"..
6e60: 20 20 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))..(define (
6e70: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
6e80: 74 61 74 73 2d 74 61 62 6c 65 29 0a 20 20 28 6d tats-table). (m
6e90: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 utex-lock! *hear
6ea0: 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 tbeat-mutex*).
6eb0: 28 6c 65 74 20 28 28 72 65 73 20 0a 09 20 28 63 (let ((res .. (c
6ec0: 6f 6e 63 20 22 3c 74 61 62 6c 65 3e 22 0a 09 20 onc "<table>"..
6ed0: 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4d "<tr><td>M
6ee0: 61 78 20 63 61 63 68 65 64 20 71 75 65 72 69 65 ax cached querie
6ef0: 73 3c 2f 74 64 3e 20 20 20 20 20 20 20 20 3c 74 s</td> <t
6f00: 64 3e 22 20 2a 6d 61 78 2d 63 61 63 68 65 2d 73 d>" *max-cache-s
6f10: 69 7a 65 2a 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e ize* "</td></tr>
6f20: 22 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c ".. "<tr><
6f30: 74 64 3e 4e 75 6d 62 65 72 20 6f 66 20 63 61 63 td>Number of cac
6f40: 68 65 64 20 77 72 69 74 65 73 3c 2f 74 64 3e 20 hed writes</td>
6f50: 20 20 3c 74 64 3e 22 20 2a 6e 75 6d 62 65 72 2d <td>" *number-
6f60: 6f 66 2d 77 72 69 74 65 73 2a 20 22 3c 2f 74 64 of-writes* "</td
6f70: 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 20 ></tr>"..
6f80: 22 3c 74 72 3e 3c 74 64 3e 41 76 65 72 61 67 65 "<tr><td>Average
6f90: 20 63 61 63 68 65 64 20 77 72 69 74 65 20 74 69 cached write ti
6fa0: 6d 65 3c 2f 74 64 3e 20 3c 74 64 3e 22 20 28 69 me</td> <td>" (i
6fb0: 66 20 28 65 71 3f 20 2a 6e 75 6d 62 65 72 2d 6f f (eq? *number-o
6fc0: 66 2d 77 72 69 74 65 73 2a 20 30 29 0a 09 09 09 f-writes* 0)....
6fd0: 09 09 09 09 09 20 22 6e 2f 61 20 28 6e 6f 20 77 ..... "n/a (no w
6fe0: 72 69 74 65 73 29 22 0a 09 09 09 09 09 09 09 09 rites)".........
6ff0: 20 28 2f 20 2a 77 72 69 74 65 73 2d 74 6f 74 61 (/ *writes-tota
7000: 6c 2d 64 65 6c 61 79 2a 0a 09 09 09 09 09 09 09 l-delay*........
7010: 09 20 20 20 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d . *number-of-
7020: 77 72 69 74 65 73 2a 29 29 0a 09 20 20 20 20 20 writes*))..
7030: 20 20 22 20 6d 73 3c 2f 74 64 3e 3c 2f 74 72 3e " ms</td></tr>
7040: 22 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c ".. "<tr><
7050: 74 64 3e 4e 75 6d 62 65 72 20 6e 6f 6e 2d 63 61 td>Number non-ca
7060: 63 68 65 64 20 71 75 65 72 69 65 73 3c 2f 74 64 ched queries</td
7070: 3e 20 3c 74 64 3e 22 20 20 2a 6e 75 6d 62 65 72 > <td>" *number
7080: 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 -non-write-queri
7090: 65 73 2a 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 es* "</td></tr>"
70a0: 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 .. "<tr><t
70b0: 64 3e 41 76 65 72 61 67 65 20 6e 6f 6e 2d 63 61 d>Average non-ca
70c0: 63 68 65 64 20 74 69 6d 65 3c 2f 74 64 3e 20 20 ched time</td>
70d0: 20 3c 74 64 3e 22 20 28 69 66 20 28 65 71 3f 20 <td>" (if (eq?
70e0: 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 *number-non-writ
70f0: 65 2d 71 75 65 72 69 65 73 2a 20 30 29 0a 09 09 e-queries* 0)...
7100: 09 09 09 09 09 09 20 22 6e 2f 61 20 28 6e 6f 20 ...... "n/a (no
7110: 71 75 65 72 69 65 73 29 22 0a 09 09 09 09 09 09 queries)".......
7120: 09 09 20 28 2f 20 2a 74 6f 74 61 6c 2d 6e 6f 6e .. (/ *total-non
7130: 2d 77 72 69 74 65 2d 64 65 6c 61 79 2a 20 0a 09 -write-delay* ..
7140: 09 09 09 09 09 09 09 20 20 20 20 2a 6e 75 6d 62 ....... *numb
7150: 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 er-non-write-que
7160: 72 69 65 73 2a 29 29 0a 09 20 20 20 20 20 20 20 ries*))..
7170: 22 20 6d 73 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a " ms</td></tr>".
7180: 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 . "<tr><td
7190: 3e 4c 61 73 74 20 61 63 63 65 73 73 3c 2f 74 64 >Last access</td
71a0: 3e 3c 74 64 3e 22 20 20 20 20 20 20 20 20 20 20 ><td>"
71b0: 20 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 (seconds->ti
71c0: 6d 65 2d 73 74 72 69 6e 67 20 2a 64 62 2d 6c 61 me-string *db-la
71d0: 73 74 2d 61 63 63 65 73 73 2a 29 20 22 3c 2f 74 st-access*) "</t
71e0: 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 d></tr>"..
71f0: 20 22 3c 2f 74 61 62 6c 65 3e 22 29 29 29 0a 20 "</table>"))).
7200: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
7210: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
7220: 65 78 2a 29 0a 20 20 20 20 72 65 73 29 29 0a 0a ex*). res))..
7230: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
7240: 61 6e 73 70 6f 72 74 3a 72 75 6e 73 20 6c 69 6e ansport:runs lin
7250: 6b 70 61 74 68 29 0a 20 20 28 63 6f 6e 63 20 22 kpath). (conc "
7260: 3c 68 33 3e 52 75 6e 73 3c 2f 68 33 3e 22 0a 09 <h3>Runs</h3>"..
7270: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
7280: 72 73 65 0a 09 20 28 6c 65 74 20 28 28 66 69 6c rse.. (let ((fil
7290: 65 73 20 28 6d 61 70 20 70 61 74 68 6e 61 6d 65 es (map pathname
72a0: 2d 73 74 72 69 70 2d 64 69 72 65 63 74 6f 72 79 -strip-directory
72b0: 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 6c 69 6e (glob (conc lin
72c0: 6b 70 61 74 68 20 22 2f 2a 22 29 29 29 29 29 0a kpath "/*"))))).
72d0: 09 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 . (map (lambda
72e0: 20 28 70 29 0a 09 09 20 20 28 63 6f 6e 63 20 22 (p)... (conc "
72f0: 3c 61 20 68 72 65 66 3d 5c 22 22 20 70 20 22 5c <a href=\"" p "\
7300: 22 3e 22 20 70 20 22 3c 2f 61 3e 3c 62 72 3e 22 ">" p "</a><br>"
7310: 29 29 0a 09 09 66 69 6c 65 73 29 29 0a 09 20 22 ))...files)).. "
7320: 20 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ")))..(define (
7330: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 http-transport:r
7340: 75 6e 2d 73 74 61 74 73 29 0a 20 20 28 6c 65 74 un-stats). (let
7350: 20 28 28 73 74 61 74 73 20 28 6f 70 65 6e 2d 72 ((stats (open-r
7360: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d un-close db:get-
7370: 72 75 6e 6e 69 6e 67 2d 73 74 61 74 73 20 23 66 running-stats #f
7380: 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 3c ))). (conc "<
7390: 74 61 62 6c 65 3e 22 0a 09 20 20 28 73 74 72 69 table>".. (stri
73a0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 0a 09 ng-intersperse..
73b0: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
73c0: 28 73 74 61 74 29 0a 09 09 20 20 28 63 6f 6e 63 (stat)... (conc
73d0: 20 22 3c 74 72 3e 3c 74 64 3e 22 20 28 63 61 72 "<tr><td>" (car
73e0: 20 73 74 61 74 29 20 22 3c 2f 74 64 3e 3c 74 64 stat) "</td><td
73f0: 3e 22 20 28 63 61 64 72 20 73 74 61 74 29 20 22 >" (cadr stat) "
7400: 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 </td></tr>"))...
7410: 73 74 61 74 73 29 0a 09 20 20 20 22 20 22 29 0a stats).. " ").
7420: 09 20 20 22 3c 2f 74 61 62 6c 65 3e 22 29 29 29 . "</table>")))
7430: 0a .