Artifact
da311848d88300dee2dd2ad44289e183bf72ce25:
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 54 68 69 73 20 66 69 6c 65 20 69 73 20 70 61 This file is pa
0040: 72 74 20 6f 66 20 4d 65 67 61 74 65 73 74 2e 0a rt of Megatest..
0050: 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 ;; .;; Megat
0060: 65 73 74 20 69 73 20 66 72 65 65 20 73 6f 66 74 est is free soft
0070: 77 61 72 65 3a 20 79 6f 75 20 63 61 6e 20 72 65 ware: you can re
0080: 64 69 73 74 72 69 62 75 74 65 20 69 74 20 61 6e distribute it an
0090: 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b 3b 20 20 d/or modify.;;
00a0: 20 20 20 69 74 20 75 6e 64 65 72 20 74 68 65 20 it under the
00b0: 74 65 72 6d 73 20 6f 66 20 74 68 65 20 47 4e 55 terms of the GNU
00c0: 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 General Public
00d0: 4c 69 63 65 6e 73 65 20 61 73 20 70 75 62 6c 69 License as publi
00e0: 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 20 20 74 shed by.;; t
00f0: 68 65 20 46 72 65 65 20 53 6f 66 74 77 61 72 65 he Free Software
0100: 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 65 69 74 Foundation, eit
0110: 68 65 72 20 76 65 72 73 69 6f 6e 20 33 20 6f 66 her version 3 of
0120: 20 74 68 65 20 4c 69 63 65 6e 73 65 2c 20 6f 72 the License, or
0130: 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 6f 75 72 .;; (at your
0140: 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 6c 61 74 option) any lat
0150: 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b 3b 20 0a er version..;; .
0160: 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 73 74 20 ;; Megatest
0170: 69 73 20 64 69 73 74 72 69 62 75 74 65 64 20 69 is distributed i
0180: 6e 20 74 68 65 20 68 6f 70 65 20 74 68 61 74 20 n the hope that
0190: 69 74 20 77 69 6c 6c 20 62 65 20 75 73 65 66 75 it will be usefu
01a0: 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 20 57 49 l,.;; but WI
01b0: 54 48 4f 55 54 20 41 4e 59 20 57 41 52 52 41 4e THOUT ANY WARRAN
01c0: 54 59 3b 20 77 69 74 68 6f 75 74 20 65 76 65 6e TY; without even
01d0: 20 74 68 65 20 69 6d 70 6c 69 65 64 20 77 61 72 the implied war
01e0: 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 20 20 20 ranty of.;;
01f0: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0200: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0210: 20 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 PARTICULAR PURP
0220: 4f 53 45 2e 20 20 53 65 65 20 74 68 65 0a 3b 3b OSE. See the.;;
0230: 20 20 20 20 20 47 4e 55 20 47 65 6e 65 72 61 6c GNU General
0240: 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 Public License
0250: 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 69 6c 73 for more details
0260: 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 59 6f 75 ..;; .;; You
0270: 20 73 68 6f 75 6c 64 20 68 61 76 65 20 72 65 63 should have rec
0280: 65 69 76 65 64 20 61 20 63 6f 70 79 20 6f 66 20 eived a copy of
0290: 74 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 the GNU General
02a0: 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 0a 3b Public License.;
02b0: 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 69 74 68 ; along with
02c0: 20 4d 65 67 61 74 65 73 74 2e 20 20 49 66 20 6e Megatest. If n
02d0: 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 3a 2f 2f ot, see <http://
02e0: 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c 69 63 65 www.gnu.org/lice
02f0: 6e 73 65 73 2f 3e 2e 0a 0a 28 72 65 71 75 69 72 nses/>...(requir
0300: 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 73 72 66 e-extension (srf
0310: 69 20 31 38 29 20 65 78 74 72 61 73 20 74 63 70 i 18) extras tcp
0320: 20 73 31 31 6e 29 0a 0a 0a 28 75 73 65 20 20 73 s11n)...(use s
0330: 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 rfi-1 posix rege
0340: 78 20 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 x regex-case srf
0350: 69 2d 36 39 20 68 6f 73 74 69 6e 66 6f 20 6d 64 i-69 hostinfo md
0360: 35 20 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 5 message-digest
0370: 20 70 6f 73 69 78 2d 65 78 74 72 61 73 29 0a 0a posix-extras)..
0380: 28 75 73 65 20 73 70 69 66 66 79 20 75 72 69 2d (use spiffy uri-
0390: 63 6f 6d 6d 6f 6e 20 69 6e 74 61 72 77 65 62 20 common intarweb
03a0: 68 74 74 70 2d 63 6c 69 65 6e 74 20 73 70 69 66 http-client spif
03b0: 66 79 2d 72 65 71 75 65 73 74 2d 76 61 72 73 20 fy-request-vars
03c0: 69 6e 74 61 72 77 65 62 20 73 70 69 66 66 79 2d intarweb spiffy-
03d0: 64 69 72 65 63 74 6f 72 79 2d 6c 69 73 74 69 6e directory-listin
03e0: 67 29 0a 0a 3b 3b 20 43 6f 6e 66 69 67 75 72 61 g)..;; Configura
03f0: 74 69 6f 6e 73 20 66 6f 72 20 73 65 72 76 65 72 tions for server
0400: 0a 28 74 63 70 2d 62 75 66 66 65 72 2d 73 69 7a .(tcp-buffer-siz
0410: 65 20 32 30 34 38 29 0a 28 6d 61 78 2d 63 6f 6e e 2048).(max-con
0420: 6e 65 63 74 69 6f 6e 73 20 32 30 34 38 29 20 0a nections 2048) .
0430: 0a 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 .(declare (unit
0440: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 29 29 http-transport))
0450: 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ..(declare (uses
0460: 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 63 6c 61 common)).(decla
0470: 72 65 20 28 75 73 65 73 20 64 62 29 29 0a 28 64 re (uses db)).(d
0480: 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 65 73 eclare (uses tes
0490: 74 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 ts)).(declare (u
04a0: 73 65 73 20 74 61 73 6b 73 29 29 20 3b 3b 20 74 ses tasks)) ;; t
04b0: 61 73 6b 73 20 61 72 65 20 77 68 65 72 65 20 73 asks are where s
04c0: 74 75 66 66 20 69 73 20 6d 61 69 6e 74 61 69 6e tuff is maintain
04d0: 65 64 20 61 62 6f 75 74 20 77 68 61 74 20 69 73 ed about what is
04e0: 20 72 75 6e 6e 69 6e 67 2e 0a 28 64 65 63 6c 61 running..(decla
04f0: 72 65 20 28 75 73 65 73 20 73 65 72 76 65 72 29 re (uses server)
0500: 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 ).;; (declare (u
0510: 73 65 73 20 64 61 65 6d 6f 6e 29 29 0a 28 64 65 ses daemon)).(de
0520: 63 6c 61 72 65 20 28 75 73 65 73 20 70 6f 72 74 clare (uses port
0530: 6c 6f 67 67 65 72 29 29 0a 28 64 65 63 6c 61 72 logger)).(declar
0540: 65 20 28 75 73 65 73 20 72 6d 74 29 29 0a 0a 28 e (uses rmt))..(
0550: 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f include "common_
0560: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 records.scm").(i
0570: 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 63 6f 72 nclude "db_recor
0580: 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 ds.scm").(includ
0590: 65 20 22 6a 73 2d 70 61 74 68 2e 73 63 6d 22 29 e "js-path.scm")
05a0: 0a 0a 28 72 65 71 75 69 72 65 2d 6c 69 62 72 61 ..(require-libra
05b0: 72 79 20 73 74 6d 6c 29 0a 28 64 65 66 69 6e 65 ry stml).(define
05c0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
05d0: 3a 6d 61 6b 65 2d 73 65 72 76 65 72 2d 75 72 6c :make-server-url
05e0: 20 68 6f 73 74 70 6f 72 74 29 0a 20 20 28 69 66 hostport). (if
05f0: 20 28 6e 6f 74 20 68 6f 73 74 70 6f 72 74 29 0a (not hostport).
0600: 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 #f. (
0610: 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f 22 20 28 conc "http://" (
0620: 63 61 72 20 68 6f 73 74 70 6f 72 74 29 20 22 3a car hostport) ":
0630: 22 20 28 63 61 64 72 20 68 6f 73 74 70 6f 72 74 " (cadr hostport
0640: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 73 ))))..(define *s
0650: 65 72 76 65 72 2d 6c 6f 6f 70 2d 68 65 61 72 74 erver-loop-heart
0660: 2d 62 65 61 74 2a 20 28 63 75 72 72 65 6e 74 2d -beat* (current-
0670: 73 65 63 6f 6e 64 73 29 29 0a 0a 3b 3b 3d 3d 3d seconds))..;;===
0680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06c0: 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 20 56 20 45 ===.;; S E R V E
06d0: 20 52 0a 3b 3b 20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d R.;; ==========
06e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
0720: 20 43 61 6c 6c 20 74 68 69 73 20 74 6f 20 73 74 Call this to st
0730: 61 72 74 20 74 68 65 20 61 63 74 75 61 6c 20 73 art the actual s
0740: 65 72 76 65 72 0a 3b 3b 0a 0a 28 64 65 66 69 6e erver.;;..(defin
0750: 65 20 2a 64 62 3a 70 72 6f 63 65 73 73 2d 71 75 e *db:process-qu
0760: 65 75 65 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 eue-mutex* (make
0770: 2d 6d 75 74 65 78 29 29 0a 0a 28 64 65 66 69 6e -mutex))..(defin
0780: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
0790: 74 3a 72 75 6e 20 68 6f 73 74 6e 29 0a 20 20 28 t:run hostn). (
07a0: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 debug:print 2 *d
07b0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
07c0: 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 "Attempting to
07d0: 73 74 61 72 74 20 74 68 65 20 73 65 72 76 65 72 start the server
07e0: 20 2e 2e 2e 22 29 0a 20 20 28 6c 65 74 2a 20 28 ..."). (let* (
07f0: 28 64 62 20 20 20 20 20 20 20 20 20 20 20 20 20 (db
0800: 20 23 66 29 20 3b 3b 20 20 20 20 20 20 20 20 28 #f) ;; (
0810: 6f 70 65 6e 2d 64 62 29 29 20 3b 3b 20 77 65 20 open-db)) ;; we
0820: 64 6f 6e 27 74 20 77 61 6e 74 20 74 68 65 20 73 don't want the s
0830: 65 72 76 65 72 20 74 6f 20 62 65 20 6f 70 65 6e erver to be open
0840: 69 6e 67 20 61 6e 64 20 63 6c 6f 73 69 6e 67 20 ing and closing
0850: 74 68 65 20 64 62 20 75 6e 6e 65 63 65 73 61 72 the db unnecesar
0860: 69 6c 79 0a 09 20 28 68 6f 73 74 6e 61 6d 65 20 ily.. (hostname
0870: 20 20 20 20 20 20 20 28 67 65 74 2d 68 6f 73 74 (get-host
0880: 2d 6e 61 6d 65 29 29 0a 09 20 28 69 70 61 64 64 -name)).. (ipadd
0890: 72 73 74 72 20 20 20 20 20 20 20 28 6c 65 74 20 rstr (let
08a0: 28 28 69 70 73 74 72 20 28 69 66 20 28 73 74 72 ((ipstr (if (str
08b0: 69 6e 67 3d 3f 20 22 2d 22 20 68 6f 73 74 6e 29 ing=? "-" hostn)
08c0: 0a 09 09 09 09 09 20 20 20 3b 3b 20 28 73 74 72 ...... ;; (str
08d0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
08e0: 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e 73 74 72 (map number->str
08f0: 69 6e 67 20 28 75 38 76 65 63 74 6f 72 2d 3e 6c ing (u8vector->l
0900: 69 73 74 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 69 ist (hostname->i
0910: 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 20 22 2e p hostname))) ".
0920: 22 29 0a 09 09 09 09 09 20 20 20 28 73 65 72 76 ")...... (serv
0930: 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 er:get-best-gues
0940: 73 2d 61 64 64 72 65 73 73 20 68 6f 73 74 6e 61 s-address hostna
0950: 6d 65 29 0a 09 09 09 09 09 20 20 20 23 66 29 29 me)...... #f))
0960: 29 0a 09 09 09 20 20 20 20 28 69 66 20 69 70 73 ).... (if ips
0970: 74 72 20 69 70 73 74 72 20 68 6f 73 74 6e 29 29 tr ipstr hostn))
0980: 29 20 3b 3b 20 68 6f 73 74 6e 61 6d 65 29 29 29 ) ;; hostname)))
0990: 20 0a 09 20 28 73 74 61 72 74 2d 70 6f 72 74 20 .. (start-port
09a0: 20 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 (portlogger
09b0: 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 :open-run-close
09c0: 70 6f 72 74 6c 6f 67 67 65 72 3a 66 69 6e 64 2d portlogger:find-
09d0: 70 6f 72 74 29 29 0a 09 20 28 6c 69 6e 6b 2d 74 port)).. (link-t
09e0: 72 65 65 2d 70 61 74 68 20 20 28 63 6f 6d 6d 6f ree-path (commo
09f0: 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 29 n:get-linktree))
0a00: 0a 09 20 28 74 6d 70 2d 61 72 65 61 20 20 20 20 .. (tmp-area
0a10: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d (common:get-
0a20: 64 62 2d 74 6d 70 2d 61 72 65 61 29 29 0a 09 20 db-tmp-area))..
0a30: 28 73 74 61 72 74 2d 66 69 6c 65 20 20 20 20 20 (start-file
0a40: 20 28 63 6f 6e 63 20 74 6d 70 2d 61 72 65 61 20 (conc tmp-area
0a50: 22 2f 2e 73 65 72 76 65 72 2d 73 74 61 72 74 22 "/.server-start"
0a60: 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 ))). (debug:p
0a70: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
0a80: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
0a90: 70 6f 72 74 6c 6f 67 67 65 72 20 72 65 63 6f 6d portlogger recom
0aa0: 6d 65 6e 64 65 64 20 70 6f 72 74 3a 20 22 20 73 mended port: " s
0ab0: 74 61 72 74 2d 70 6f 72 74 29 0a 20 20 20 20 3b tart-port). ;
0ac0: 3b 20 73 65 74 20 73 6f 6d 65 20 70 61 72 61 6d ; set some param
0ad0: 65 74 65 72 73 20 66 6f 72 20 74 68 65 20 73 65 eters for the se
0ae0: 72 76 65 72 0a 20 20 20 20 28 72 6f 6f 74 2d 70 rver. (root-p
0af0: 61 74 68 20 20 20 20 20 28 69 66 20 6c 69 6e 6b ath (if link
0b00: 2d 74 72 65 65 2d 70 61 74 68 20 0a 09 09 20 20 -tree-path ...
0b10: 20 20 20 20 20 6c 69 6e 6b 2d 74 72 65 65 2d 70 link-tree-p
0b20: 61 74 68 0a 09 09 20 20 20 20 20 20 20 28 63 75 ath... (cu
0b30: 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 rrent-directory)
0b40: 29 29 20 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 53 )) ;; WARNING: S
0b50: 45 43 55 52 49 54 59 20 48 4f 4c 45 2e 20 46 49 ECURITY HOLE. FI
0b60: 58 20 41 53 41 50 21 0a 20 20 20 20 28 68 61 6e X ASAP!. (han
0b70: 64 6c 65 2d 64 69 72 65 63 74 6f 72 79 20 73 70 dle-directory sp
0b80: 69 66 66 79 2d 64 69 72 65 63 74 6f 72 79 2d 6c iffy-directory-l
0b90: 69 73 74 69 6e 67 29 0a 20 20 20 20 28 68 61 6e isting). (han
0ba0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 20 28 6c dle-exception (l
0bb0: 61 6d 62 64 61 20 28 65 78 6e 20 63 68 61 69 6e ambda (exn chain
0bc0: 29 0a 09 09 09 28 73 69 67 6e 61 6c 20 28 6d 61 )....(signal (ma
0bd0: 6b 65 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 6f 6e ke-composite-con
0be0: 64 69 74 69 6f 6e 0a 09 09 09 09 20 28 6d 61 6b dition..... (mak
0bf0: 65 2d 70 72 6f 70 65 72 74 79 2d 63 6f 6e 64 69 e-property-condi
0c00: 74 69 6f 6e 20 0a 09 09 09 09 20 20 27 73 65 72 tion ..... 'ser
0c10: 76 65 72 0a 09 09 09 09 20 20 27 6d 65 73 73 61 ver..... 'messa
0c20: 67 65 20 22 73 65 72 76 65 72 20 65 72 72 6f 72 ge "server error
0c30: 22 29 29 29 29 29 0a 0a 20 20 20 20 3b 3b 20 68 "))))).. ;; h
0c40: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 68 61 ttp-transport:ha
0c50: 6e 64 6c 65 2d 64 69 72 65 63 74 6f 72 79 29 20 ndle-directory)
0c60: 3b 3b 20 73 69 6d 70 6c 65 2d 64 69 72 65 63 74 ;; simple-direct
0c70: 6f 72 79 2d 68 61 6e 64 6c 65 72 29 0a 20 20 20 ory-handler).
0c80: 20 3b 3b 20 53 65 74 75 70 20 74 68 65 20 77 65 ;; Setup the we
0c90: 62 20 73 65 72 76 65 72 20 61 6e 64 20 61 20 2f b server and a /
0ca0: 63 74 72 6c 20 69 6e 74 65 72 66 61 63 65 0a 20 ctrl interface.
0cb0: 20 20 20 3b 3b 0a 20 20 20 20 28 76 68 6f 73 74 ;;. (vhost
0cc0: 2d 6d 61 70 20 60 28 28 28 2a 20 61 6e 79 29 20 -map `(((* any)
0cd0: 2e 20 2c 28 6c 61 6d 62 64 61 20 28 63 6f 6e 74 . ,(lambda (cont
0ce0: 69 6e 75 65 29 0a 09 09 09 20 20 20 20 20 20 20 inue)....
0cf0: 3b 3b 20 6f 70 65 6e 20 74 68 65 20 64 62 20 6f ;; open the db o
0d00: 6e 20 74 68 65 20 66 69 72 73 74 20 63 61 6c 6c n the first call
0d10: 20 0a 09 09 09 09 20 3b 3b 20 54 68 69 73 20 69 ..... ;; This i
0d20: 73 20 77 65 72 65 20 77 65 20 73 65 74 20 75 70 s were we set up
0d30: 20 74 68 65 20 64 61 74 61 62 61 73 65 20 63 6f the database co
0d40: 6e 6e 65 63 74 69 6f 6e 73 0a 09 09 09 20 20 20 nnections....
0d50: 20 20 20 20 28 6c 65 74 2a 20 28 28 24 20 20 20 (let* (($
0d60: 28 72 65 71 75 65 73 74 2d 76 61 72 73 20 73 6f (request-vars so
0d70: 75 72 63 65 3a 20 27 62 6f 74 68 29 29 0a 09 09 urce: 'both))...
0d80: 09 09 20 20 20 20 20 20 28 64 61 74 20 28 24 20 .. (dat ($
0d90: 27 64 61 74 29 29 0a 09 09 09 09 20 20 20 20 20 'dat)).....
0da0: 20 28 72 65 73 20 23 66 29 29 0a 09 09 09 09 20 (res #f)).....
0db0: 28 63 6f 6e 64 0a 09 09 09 09 20 20 28 28 65 71 (cond..... ((eq
0dc0: 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 28 ual? (uri-path (
0dd0: 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 72 request-uri (cur
0de0: 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 0a rent-request))).
0df0: 09 09 09 09 09 20 20 20 27 28 2f 20 22 61 70 69 ..... '(/ "api
0e00: 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e 64 "))..... (send
0e10: 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 -response body:
0e20: 20 20 20 28 61 70 69 3a 70 72 6f 63 65 73 73 2d (api:process-
0e30: 72 65 71 75 65 73 74 20 2a 64 62 73 74 72 75 63 request *dbstruc
0e40: 74 2d 64 62 2a 20 24 29 20 3b 3b 20 74 68 65 20 t-db* $) ;; the
0e50: 24 20 69 73 20 74 68 65 20 72 65 71 75 65 73 74 $ is the request
0e60: 20 76 61 72 73 20 70 72 6f 63 0a 09 09 09 09 09 vars proc......
0e70: 09 20 20 68 65 61 64 65 72 73 3a 20 27 28 28 63 . headers: '((c
0e80: 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 65 78 74 ontent-type text
0e90: 2f 70 6c 61 69 6e 29 29 29 0a 09 09 09 09 20 20 /plain))).....
0ea0: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 (mutex-lock! *h
0eb0: 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 eartbeat-mutex*)
0ec0: 0a 09 09 09 09 20 20 20 28 73 65 74 21 20 2a 64 ..... (set! *d
0ed0: 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 28 b-last-access* (
0ee0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
0ef0: 29 0a 09 09 09 09 20 20 20 28 6d 75 74 65 78 2d )..... (mutex-
0f00: 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 unlock! *heartbe
0f10: 61 74 2d 6d 75 74 65 78 2a 29 29 0a 09 09 09 09 at-mutex*)).....
0f20: 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 69 2d ((equal? (uri-
0f30: 70 61 74 68 20 28 72 65 71 75 65 73 74 2d 75 72 path (request-ur
0f40: 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 75 65 i (current-reque
0f50: 73 74 29 29 29 20 0a 09 09 09 09 09 20 20 20 27 st))) ...... '
0f60: 28 2f 20 22 22 29 29 0a 09 09 09 09 20 20 20 28 (/ ""))..... (
0f70: 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f send-response bo
0f80: 64 79 3a 20 28 68 74 74 70 2d 74 72 61 6e 73 70 dy: (http-transp
0f90: 6f 72 74 3a 6d 61 69 6e 2d 70 61 67 65 29 29 29 ort:main-page)))
0fa0: 0a 09 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 ..... ((equal?
0fb0: 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 (uri-path (reque
0fc0: 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d st-uri (current-
0fd0: 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 09 09 request))) .....
0fe0: 09 20 20 20 27 28 2f 20 22 6a 73 6f 6e 5f 61 70 . '(/ "json_ap
0ff0: 69 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e i"))..... (sen
1000: 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a d-response body:
1010: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
1020: 3a 6d 61 69 6e 2d 70 61 67 65 29 29 29 0a 09 09 :main-page)))...
1030: 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 .. ((equal? (ur
1040: 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 2d i-path (request-
1050: 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 uri (current-req
1060: 75 65 73 74 29 29 29 20 0a 09 09 09 09 09 20 20 uest))) ......
1070: 20 27 28 2f 20 22 72 75 6e 73 22 29 29 0a 09 09 '(/ "runs"))...
1080: 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f .. (send-respo
1090: 6e 73 65 20 62 6f 64 79 3a 20 28 68 74 74 70 2d nse body: (http-
10a0: 74 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 transport:main-p
10b0: 61 67 65 29 29 29 0a 09 09 09 09 20 20 28 28 65 age)))..... ((e
10c0: 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 qual? (uri-path
10d0: 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 (request-uri (cu
10e0: 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 rrent-request)))
10f0: 20 0a 09 09 09 09 09 20 20 20 27 28 2f 20 61 6e ...... '(/ an
1100: 79 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e 64 y))..... (send
1110: 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 -response body:
1120: 22 68 65 79 20 74 68 65 72 65 21 5c 6e 22 0a 09 "hey there!\n"..
1130: 09 09 09 09 09 20 20 68 65 61 64 65 72 73 3a 20 ..... headers:
1140: 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 '((content-type
1150: 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 29 0a 09 text/plain))))..
1160: 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 ... ((equal? (u
1170: 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 ri-path (request
1180: 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 -uri (current-re
1190: 71 75 65 73 74 29 29 29 20 0a 09 09 09 09 09 20 quest))) ......
11a0: 20 20 27 28 2f 20 22 68 65 79 22 29 29 0a 09 09 '(/ "hey"))...
11b0: 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f .. (send-respo
11c0: 6e 73 65 20 62 6f 64 79 3a 20 22 68 65 79 20 74 nse body: "hey t
11d0: 68 65 72 65 21 5c 6e 22 20 0a 09 09 09 09 09 09 here!\n" .......
11e0: 20 20 68 65 61 64 65 72 73 3a 20 27 28 28 63 6f headers: '((co
11f0: 6e 74 65 6e 74 2d 74 79 70 65 20 74 65 78 74 2f ntent-type text/
1200: 70 6c 61 69 6e 29 29 29 29 0a 20 20 20 20 20 20 plain)))).
1210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1220: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 65 71 ((eq
1230: 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 28 ual? (uri-path (
1240: 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 72 request-uri (cur
1250: 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 20 rent-request)))
1260: 0a 09 09 09 09 09 20 20 20 27 28 2f 20 22 6a 71 ...... '(/ "jq
1270: 75 65 72 79 33 2e 31 2e 30 2e 6a 73 22 29 29 0a uery3.1.0.js")).
1280: 09 09 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 .... (send-res
1290: 70 6f 6e 73 65 20 62 6f 64 79 3a 20 28 68 74 74 ponse body: (htt
12a0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 68 6f 77 p-transport:show
12b0: 2d 6a 71 75 65 72 79 29 20 0a 09 09 09 09 09 09 -jquery) .......
12c0: 20 20 68 65 61 64 65 72 73 3a 20 27 28 28 63 6f headers: '((co
12d0: 6e 74 65 6e 74 2d 74 79 70 65 20 61 70 70 6c 69 ntent-type appli
12e0: 63 61 74 69 6f 6e 2f 6a 61 76 61 73 63 72 69 70 cation/javascrip
12f0: 74 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 t)))).
1300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1310: 20 20 20 20 20 20 20 20 28 28 65 71 75 61 6c 3f ((equal?
1320: 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 (uri-path (requ
1330: 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 est-uri (current
1340: 2d 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 09 -request))) ....
1350: 09 09 20 20 20 27 28 2f 20 22 74 65 73 74 5f 6c .. '(/ "test_l
1360: 6f 67 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 og"))..... (se
1370: 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 nd-response body
1380: 3a 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 : (http-transpor
1390: 74 3a 68 74 6d 6c 2d 74 65 73 74 2d 6c 6f 67 20 t:html-test-log
13a0: 24 29 20 0a 09 09 09 09 09 09 20 20 68 65 61 64 $) ....... head
13b0: 65 72 73 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d ers: '((content-
13c0: 74 79 70 65 20 74 65 78 74 2f 48 54 4d 4c 29 29 type text/HTML))
13d0: 29 29 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 )) .
13e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13f0: 20 20 20 20 20 20 20 20 20 28 28 65 71 75 61 6c ((equal
1400: 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 ? (uri-path (req
1410: 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e uest-uri (curren
1420: 74 2d 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 t-request))) ...
1430: 09 09 09 20 20 20 27 28 2f 20 22 64 61 73 68 62 ... '(/ "dashb
1440: 6f 61 72 64 22 29 29 0a 09 09 09 09 20 20 20 28 oard"))..... (
1450: 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f send-response bo
1460: 64 79 3a 20 28 68 74 74 70 2d 74 72 61 6e 73 70 dy: (http-transp
1470: 6f 72 74 3a 68 74 6d 6c 2d 64 62 6f 61 72 64 20 ort:html-dboard
1480: 24 29 20 0a 09 09 09 09 09 09 20 20 68 65 61 64 $) ....... head
1490: 65 72 73 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d ers: '((content-
14a0: 74 79 70 65 20 74 65 78 74 2f 48 54 4d 4c 29 29 type text/HTML))
14b0: 29 29 20 0a 09 09 09 09 20 20 28 65 6c 73 65 20 )) ..... (else
14c0: 28 63 6f 6e 74 69 6e 75 65 29 29 29 29 29 29 29 (continue)))))))
14d0: 29 0a 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 ). (with-outp
14e0: 75 74 2d 74 6f 2d 66 69 6c 65 20 73 74 61 72 74 ut-to-file start
14f0: 2d 66 69 6c 65 20 28 6c 61 6d 62 64 61 20 28 29 -file (lambda ()
1500: 28 70 72 69 6e 74 20 28 63 75 72 72 65 6e 74 2d (print (current-
1510: 70 72 6f 63 65 73 73 2d 69 64 29 29 29 29 0a 20 process-id)))).
1520: 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f (http-transpo
1530: 72 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 rt:try-start-ser
1540: 76 65 72 20 69 70 61 64 64 72 73 74 72 20 73 74 ver ipaddrstr st
1550: 61 72 74 2d 70 6f 72 74 29 29 29 0a 0a 3b 3b 20 art-port)))..;;
1560: 54 68 69 73 20 69 73 20 72 65 63 75 72 73 69 76 This is recursiv
1570: 65 6c 79 20 72 75 6e 20 62 79 20 68 74 74 70 2d ely run by http-
1580: 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 20 75 6e transport:run un
1590: 74 69 6c 20 73 75 63 65 73 73 66 75 6c 0a 3b 3b til sucessful.;;
15a0: 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 .(define (http-t
15b0: 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 74 61 ransport:try-sta
15c0: 72 74 2d 73 65 72 76 65 72 20 69 70 61 64 64 72 rt-server ipaddr
15d0: 73 74 72 20 70 6f 72 74 6e 75 6d 29 0a 20 20 28 str portnum). (
15e0: 6c 65 74 20 28 28 63 6f 6e 66 69 67 2d 68 6f 73 let ((config-hos
15f0: 74 6e 61 6d 65 20 28 63 6f 6e 66 69 67 66 3a 6c tname (configf:l
1600: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
1610: 2a 20 22 73 65 72 76 65 72 22 20 22 68 6f 73 74 * "server" "host
1620: 6e 61 6d 65 22 29 29 0a 09 28 63 6f 6e 66 69 67 name"))..(config
1630: 2d 75 73 65 2d 70 72 6f 78 79 20 28 65 71 75 61 -use-proxy (equa
1640: 6c 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b l? (configf:look
1650: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
1660: 63 6c 69 65 6e 74 22 20 22 75 73 65 2d 68 74 74 client" "use-htt
1670: 70 5f 70 72 6f 78 79 22 29 20 22 79 65 73 22 29 p_proxy") "yes")
1680: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
1690: 63 6f 6e 66 69 67 2d 75 73 65 2d 70 72 6f 78 79 config-use-proxy
16a0: 29 0a 09 28 64 65 74 65 72 6d 69 6e 65 2d 70 72 )..(determine-pr
16b0: 6f 78 79 20 28 63 6f 6e 73 74 61 6e 74 6c 79 20 oxy (constantly
16c0: 23 66 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 #f))). (debug
16d0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
16e0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
16f0: 20 22 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 "http-transport
1700: 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 76 65 :try-start-serve
1710: 72 20 74 69 6d 65 3d 22 20 28 73 65 63 6f 6e 64 r time=" (second
1720: 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 28 s->time-string (
1730: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
1740: 29 20 22 20 69 70 61 64 64 72 73 73 74 72 3d 22 ) " ipaddrsstr="
1750: 20 69 70 61 64 64 72 73 74 72 20 22 20 70 6f 72 ipaddrstr " por
1760: 74 6e 75 6d 3d 22 20 70 6f 72 74 6e 75 6d 20 22 tnum=" portnum "
1770: 20 63 6f 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 config-hostname
1780: 3d 22 20 63 6f 6e 66 69 67 2d 68 6f 73 74 6e 61 =" config-hostna
1790: 6d 65 29 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d me). (handle-
17a0: 65 78 63 65 70 74 69 6f 6e 73 0a 09 65 78 6e 0a exceptions..exn.
17b0: 09 28 62 65 67 69 6e 0a 09 20 20 28 70 72 69 6e .(begin.. (prin
17c0: 74 2d 65 72 72 6f 72 2d 6d 65 73 73 61 67 65 20 t-error-message
17d0: 65 78 6e 29 0a 09 20 20 28 69 66 20 28 3c 20 70 exn).. (if (< p
17e0: 6f 72 74 6e 75 6d 20 36 34 30 30 30 29 0a 09 20 ortnum 64000)..
17f0: 20 20 20 20 20 28 62 65 67 69 6e 20 0a 09 09 28 (begin ...(
1800: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
1810: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1820: 20 22 57 41 52 4e 49 4e 47 3a 20 61 74 74 65 6d "WARNING: attem
1830: 70 74 20 74 6f 20 73 74 61 72 74 20 73 65 72 76 pt to start serv
1840: 65 72 20 66 61 69 6c 65 64 2e 20 54 72 79 69 6e er failed. Tryin
1850: 67 20 61 67 61 69 6e 20 2e 2e 2e 22 29 0a 09 09 g again ...")...
1860: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
1870: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1880: 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 * " message: " (
1890: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
18a0: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
18b0: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
18c0: 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 )...(debug:print
18d0: 20 35 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 5 *default-log-
18e0: 70 6f 72 74 2a 20 22 65 78 6e 3d 22 20 28 63 6f port* "exn=" (co
18f0: 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 ndition->list ex
1900: 6e 29 29 0a 09 09 28 70 6f 72 74 6c 6f 67 67 65 n))...(portlogge
1910: 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 r:open-run-close
1920: 20 70 6f 72 74 6c 6f 67 67 65 72 3a 73 65 74 2d portlogger:set-
1930: 66 61 69 6c 65 64 20 70 6f 72 74 6e 75 6d 29 0a failed portnum).
1940: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
1950: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1960: 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 66 61 rt* "WARNING: fa
1970: 69 6c 65 64 20 74 6f 20 73 74 61 72 74 20 6f 6e iled to start on
1980: 20 70 6f 72 74 6e 75 6d 3a 20 22 20 70 6f 72 74 portnum: " port
1990: 6e 75 6d 20 22 2c 20 74 72 79 69 6e 67 20 6e 65 num ", trying ne
19a0: 78 74 20 70 6f 72 74 22 29 0a 09 09 28 74 68 72 xt port")...(thr
19b0: 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 31 29 0a ead-sleep! 0.1).
19c0: 09 09 0a 09 09 3b 3b 20 67 65 74 5f 6e 65 78 74 .....;; get_next
19d0: 5f 70 6f 72 74 20 67 6f 65 73 20 68 65 72 65 0a _port goes here.
19e0: 09 09 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 ..(http-transpor
19f0: 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 76 t:try-start-serv
1a00: 65 72 20 69 70 61 64 64 72 73 74 72 0a 09 09 09 er ipaddrstr....
1a10: 09 09 09 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a ... (portlogger:
1a20: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 open-run-close p
1a30: 6f 72 74 6c 6f 67 67 65 72 3a 66 69 6e 64 2d 70 ortlogger:find-p
1a40: 6f 72 74 29 29 29 0a 09 20 20 20 20 20 20 28 62 ort))).. (b
1a50: 65 67 69 6e 0a 09 09 28 70 72 69 6e 74 20 22 45 egin...(print "E
1a60: 52 52 4f 52 3a 20 54 72 69 65 64 20 61 6e 64 20 RROR: Tried and
1a70: 74 72 69 65 64 20 62 75 74 20 63 6f 75 6c 64 20 tried but could
1a80: 6e 6f 74 20 73 74 61 72 74 20 74 68 65 20 73 65 not start the se
1a90: 72 76 65 72 22 29 29 29 29 0a 20 20 20 20 20 20 rver")))).
1aa0: 3b 3b 20 61 6e 79 20 65 72 72 6f 72 20 69 6e 20 ;; any error in
1ab0: 66 6f 6c 6c 6f 77 69 6e 67 20 73 74 65 70 73 20 following steps
1ac0: 77 69 6c 6c 20 72 65 73 75 6c 74 20 69 6e 20 61 will result in a
1ad0: 20 72 65 74 72 79 0a 20 20 20 20 20 20 28 73 65 retry. (se
1ae0: 74 21 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a t! *server-info*
1af0: 20 28 6c 69 73 74 20 69 70 61 64 64 72 73 74 72 (list ipaddrstr
1b00: 20 70 6f 72 74 6e 75 6d 29 29 0a 20 20 20 20 20 portnum)).
1b10: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
1b20: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
1b30: 74 2a 20 22 49 4e 46 4f 3a 20 54 72 79 69 6e 67 t* "INFO: Trying
1b40: 20 74 6f 20 73 74 61 72 74 20 73 65 72 76 65 72 to start server
1b50: 20 6f 6e 20 22 20 69 70 61 64 64 72 73 74 72 20 on " ipaddrstr
1b60: 22 3a 22 20 70 6f 72 74 6e 75 6d 29 0a 20 20 20 ":" portnum).
1b70: 20 20 20 3b 3b 20 54 68 69 73 20 73 74 61 72 74 ;; This start
1b80: 73 20 74 68 65 20 73 70 69 66 66 79 20 73 65 72 s the spiffy ser
1b90: 76 65 72 0a 20 20 20 20 20 20 3b 3b 20 4e 45 45 ver. ;; NEE
1ba0: 44 20 57 41 59 20 54 4f 20 53 45 54 20 49 50 20 D WAY TO SET IP
1bb0: 54 4f 20 23 66 20 54 4f 20 42 49 4e 44 20 41 4c TO #f TO BIND AL
1bc0: 4c 0a 20 20 20 20 20 20 3b 3b 20 28 73 74 61 72 L. ;; (star
1bd0: 74 2d 73 65 72 76 65 72 20 62 69 6e 64 2d 61 64 t-server bind-ad
1be0: 64 72 65 73 73 3a 20 69 70 61 64 64 72 73 74 72 dress: ipaddrstr
1bf0: 20 70 6f 72 74 3a 20 70 6f 72 74 6e 75 6d 29 0a port: portnum).
1c00: 20 20 20 20 20 20 28 69 66 20 63 6f 6e 66 69 67 (if config
1c10: 2d 68 6f 73 74 6e 61 6d 65 20 3b 3b 20 74 68 69 -hostname ;; thi
1c20: 73 20 69 73 20 61 20 68 69 6e 74 20 74 6f 20 62 s is a hint to b
1c30: 69 6e 64 20 64 69 72 65 63 74 6c 79 0a 09 20 20 ind directly..
1c40: 28 73 74 61 72 74 2d 73 65 72 76 65 72 20 70 6f (start-server po
1c50: 72 74 3a 20 70 6f 72 74 6e 75 6d 20 62 69 6e 64 rt: portnum bind
1c60: 2d 61 64 64 72 65 73 73 3a 20 28 69 66 20 28 65 -address: (if (e
1c70: 71 75 61 6c 3f 20 63 6f 6e 66 69 67 2d 68 6f 73 qual? config-hos
1c80: 74 6e 61 6d 65 20 22 2d 22 29 0a 09 09 09 09 09 tname "-")......
1c90: 09 09 69 70 61 64 64 72 73 74 72 0a 09 09 09 09 ..ipaddrstr.....
1ca0: 09 09 09 63 6f 6e 66 69 67 2d 68 6f 73 74 6e 61 ...config-hostna
1cb0: 6d 65 29 29 0a 09 20 20 28 73 74 61 72 74 2d 73 me)).. (start-s
1cc0: 65 72 76 65 72 20 70 6f 72 74 3a 20 70 6f 72 74 erver port: port
1cd0: 6e 75 6d 29 29 0a 20 20 20 20 20 20 28 70 6f 72 num)). (por
1ce0: 74 6c 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e tlogger:open-run
1cf0: 2d 63 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 -close portlogge
1d00: 72 3a 73 65 74 2d 70 6f 72 74 20 70 6f 72 74 6e r:set-port portn
1d10: 75 6d 20 22 72 65 6c 65 61 73 65 64 22 29 0a 20 um "released").
1d20: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1d30: 74 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 1 *default-log
1d40: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 73 65 -port* "INFO: se
1d50: 72 76 65 72 20 68 61 73 20 62 65 65 6e 20 73 74 rver has been st
1d60: 6f 70 70 65 64 22 29 29 29 29 0a 0a 3b 3b 3d 3d opped"))))..;;==
1d70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1d80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1db0: 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 20 56 20 ====.;; S E R V
1dc0: 45 20 52 20 20 20 55 20 54 20 49 20 4c 20 49 20 E R U T I L I
1dd0: 54 20 49 20 45 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d T I E S .;;=====
1de0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1df0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e20: 3d 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d =..;;===========
1e30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 ===========.;; C
1e70: 20 4c 20 49 20 45 20 4e 20 54 20 53 0a 3b 3b 3d L I E N T S.;;=
1e80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ec0: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 2a =====..(define *
1ed0: 68 74 74 70 2d 6d 75 74 65 78 2a 20 28 6d 61 6b http-mutex* (mak
1ee0: 65 2d 6d 75 74 65 78 29 29 0a 0a 3b 3b 20 4e 4f e-mutex))..;; NO
1ef0: 54 45 3a 20 4c 61 72 67 65 20 62 6c 6f 63 6b 20 TE: Large block
1f00: 6f 66 20 63 6f 64 65 20 66 72 6f 6d 20 33 32 34 of code from 324
1f10: 33 36 62 34 32 36 31 38 38 30 38 30 66 37 32 66 36b426188080f72f
1f20: 63 65 62 36 38 39 34 61 66 35 34 31 66 62 61 64 ceb6894af541fbad
1f30: 39 39 32 31 65 20 72 65 6d 6f 76 65 64 20 68 65 9921e removed he
1f40: 72 65 0a 3b 3b 20 20 20 20 20 20 20 49 27 6d 20 re.;; I'm
1f50: 70 72 65 74 74 79 20 73 75 72 65 20 69 74 20 69 pretty sure it i
1f60: 73 20 64 65 66 75 6e 63 74 2e 0a 0a 3b 3b 20 54 s defunct...;; T
1f70: 68 69 73 20 6e 65 78 74 20 62 6c 6f 63 6b 20 61 his next block a
1f80: 6c 6c 20 69 6d 70 6f 72 74 65 64 20 65 6e 2d 6d ll imported en-m
1f90: 61 73 73 20 66 72 6f 6d 20 74 68 65 20 61 70 69 ass from the api
1fa0: 20 62 72 61 6e 63 68 0a 28 64 65 66 69 6e 65 20 branch.(define
1fb0: 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 *http-requests-i
1fc0: 6e 2d 70 72 6f 67 72 65 73 73 2a 20 30 29 0a 28 n-progress* 0).(
1fd0: 64 65 66 69 6e 65 20 2a 68 74 74 70 2d 63 6f 6e define *http-con
1fe0: 6e 65 63 74 69 6f 6e 73 2d 6e 65 78 74 2d 63 6c nections-next-cl
1ff0: 65 61 6e 75 70 2a 20 28 63 75 72 72 65 6e 74 2d eanup* (current-
2000: 73 65 63 6f 6e 64 73 29 29 0a 0a 28 64 65 66 69 seconds))..(defi
2010: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
2020: 72 74 3a 67 65 74 2d 74 69 6d 65 2d 74 6f 2d 63 rt:get-time-to-c
2030: 6c 65 61 6e 75 70 29 0a 20 20 28 6c 65 74 20 28 leanup). (let (
2040: 28 72 65 73 20 23 66 29 29 0a 20 20 20 20 28 6d (res #f)). (m
2050: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 utex-lock! *http
2060: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 28 73 65 -mutex*). (se
2070: 74 21 20 72 65 73 20 28 3e 20 28 63 75 72 72 65 t! res (> (curre
2080: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 2a 68 74 74 nt-seconds) *htt
2090: 70 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 2d 6e 65 p-connections-ne
20a0: 78 74 2d 63 6c 65 61 6e 75 70 2a 29 29 0a 20 20 xt-cleanup*)).
20b0: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
20c0: 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 *http-mutex*).
20d0: 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e res))..(defin
20e0: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
20f0: 74 3a 69 6e 63 2d 72 65 71 75 65 73 74 73 2d 63 t:inc-requests-c
2100: 6f 75 6e 74 29 0a 20 20 28 6d 75 74 65 78 2d 6c ount). (mutex-l
2110: 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 ock! *http-mutex
2120: 2a 29 0a 20 20 28 73 65 74 21 20 2a 68 74 74 70 *). (set! *http
2130: 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f -requests-in-pro
2140: 67 72 65 73 73 2a 20 28 2b 20 31 20 2a 68 74 74 gress* (+ 1 *htt
2150: 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 p-requests-in-pr
2160: 6f 67 72 65 73 73 2a 29 29 0a 20 20 3b 3b 20 55 ogress*)). ;; U
2170: 73 65 20 74 68 69 73 20 6f 70 70 6f 72 74 75 6e se this opportun
2180: 69 74 79 20 74 6f 20 73 6c 6f 77 20 74 68 69 6e ity to slow thin
2190: 67 73 20 64 6f 77 6e 20 69 66 66 20 74 68 65 72 gs down iff ther
21a0: 65 20 61 72 65 20 74 6f 6f 20 6d 61 6e 79 20 72 e are too many r
21b0: 65 71 75 65 73 74 73 20 69 6e 20 66 6c 69 67 68 equests in fligh
21c0: 74 0a 20 20 28 69 66 20 28 3e 20 2a 68 74 74 70 t. (if (> *http
21d0: 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f -requests-in-pro
21e0: 67 72 65 73 73 2a 20 35 29 0a 20 20 20 20 20 20 gress* 5).
21f0: 28 62 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 (begin..(debug:p
2200: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
2210: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
2220: 57 68 6f 61 20 74 68 65 72 65 20 62 75 64 64 79 Whoa there buddy
2230: 2c 20 65 61 73 65 20 75 70 2e 2e 2e 22 29 0a 09 , ease up...")..
2240: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 (thread-sleep! 1
2250: 29 29 29 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c ))). (mutex-unl
2260: 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 ock! *http-mutex
2270: 2a 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 *))..(define (ht
2280: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 64 65 63 tp-transport:dec
2290: 2d 72 65 71 75 65 73 74 73 2d 63 6f 75 6e 74 20 -requests-count
22a0: 70 72 6f 63 29 20 0a 20 20 28 6d 75 74 65 78 2d proc) . (mutex-
22b0: 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 lock! *http-mute
22c0: 78 2a 29 0a 20 20 28 70 72 6f 63 29 0a 20 20 28 x*). (proc). (
22d0: 73 65 74 21 20 2a 68 74 74 70 2d 72 65 71 75 65 set! *http-reque
22e0: 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a sts-in-progress*
22f0: 20 28 2d 20 2a 68 74 74 70 2d 72 65 71 75 65 73 (- *http-reques
2300: 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 ts-in-progress*
2310: 31 29 29 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 1)). (mutex-unl
2320: 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 ock! *http-mutex
2330: 2a 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 *))..(define (ht
2340: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 64 65 63 tp-transport:dec
2350: 2d 72 65 71 75 65 73 74 73 2d 63 6f 75 6e 74 2d -requests-count-
2360: 61 6e 64 2d 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f and-close-all-co
2370: 6e 6e 65 63 74 69 6f 6e 73 29 0a 20 20 28 73 65 nnections). (se
2380: 74 21 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 t! *http-request
2390: 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 28 s-in-progress* (
23a0: 2d 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 - *http-requests
23b0: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 31 29 -in-progress* 1)
23c0: 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 ). (let loop ((
23d0: 65 74 69 6d 65 20 28 2b 20 28 63 75 72 72 65 6e etime (+ (curren
23e0: 74 2d 73 65 63 6f 6e 64 73 29 20 35 29 29 29 20 t-seconds) 5)))
23f0: 3b 3b 20 67 69 76 65 20 75 70 20 69 6e 20 66 69 ;; give up in fi
2400: 76 65 20 73 65 63 6f 6e 64 73 0a 20 20 20 20 28 ve seconds. (
2410: 69 66 20 28 3e 20 2a 68 74 74 70 2d 72 65 71 75 if (> *http-requ
2420: 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 ests-in-progress
2430: 2a 20 30 29 0a 09 28 69 66 20 28 3e 20 65 74 69 * 0)..(if (> eti
2440: 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f me (current-seco
2450: 6e 64 73 29 29 0a 09 20 20 20 20 28 62 65 67 69 nds)).. (begi
2460: 6e 0a 09 20 20 20 20 20 20 28 74 68 72 65 61 64 n.. (thread
2470: 2d 73 6c 65 65 70 21 20 30 2e 30 35 29 0a 09 20 -sleep! 0.05)..
2480: 20 20 20 20 20 28 6c 6f 6f 70 20 65 74 69 6d 65 (loop etime
2490: 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 )).. (debug:p
24a0: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
24b0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
24c0: 22 72 65 71 75 65 73 74 73 20 73 74 69 6c 6c 20 "requests still
24d0: 69 6e 20 70 72 6f 67 72 65 73 73 20 61 66 74 65 in progress afte
24e0: 72 20 35 20 73 65 63 6f 6e 64 73 20 6f 66 20 77 r 5 seconds of w
24f0: 61 69 74 69 6e 67 2e 20 49 27 6d 20 67 6f 69 6e aiting. I'm goin
2500: 67 20 74 6f 20 70 61 73 73 20 6f 6e 20 63 6c 65 g to pass on cle
2510: 61 6e 69 6e 67 20 75 70 20 68 74 74 70 20 63 6f aning up http co
2520: 6e 6e 65 63 74 69 6f 6e 73 22 29 29 0a 09 28 63 nnections"))..(c
2530: 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 lose-all-connect
2540: 69 6f 6e 73 21 29 29 29 0a 20 20 28 73 65 74 21 ions!))). (set!
2550: 20 2a 68 74 74 70 2d 63 6f 6e 6e 65 63 74 69 6f *http-connectio
2560: 6e 73 2d 6e 65 78 74 2d 63 6c 65 61 6e 75 70 2a ns-next-cleanup*
2570: 20 28 2b 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (+ (current-sec
2580: 6f 6e 64 73 29 20 31 30 29 29 0a 20 20 28 6d 75 onds) 10)). (mu
2590: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 tex-unlock! *htt
25a0: 70 2d 6d 75 74 65 78 2a 29 29 0a 0a 28 64 65 66 p-mutex*))..(def
25b0: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
25c0: 6f 72 74 3a 69 6e 63 2d 72 65 71 75 65 73 74 73 ort:inc-requests
25d0: 2d 61 6e 64 2d 70 72 65 70 2d 74 6f 2d 63 6c 6f -and-prep-to-clo
25e0: 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f se-all-connectio
25f0: 6e 73 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 ns). (mutex-loc
2600: 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 k! *http-mutex*)
2610: 0a 20 20 28 73 65 74 21 20 2a 68 74 74 70 2d 72 . (set! *http-r
2620: 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 equests-in-progr
2630: 65 73 73 2a 20 28 2b 20 31 20 2a 68 74 74 70 2d ess* (+ 1 *http-
2640: 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 requests-in-prog
2650: 72 65 73 73 2a 29 29 29 0a 0a 3b 3b 20 53 65 6e ress*)))..;; Sen
2660: 64 20 22 63 6d 64 22 20 77 69 74 68 20 6a 73 6f d "cmd" with jso
2670: 6e 20 70 61 79 6c 6f 61 64 20 22 70 61 72 61 6d n payload "param
2680: 73 22 20 74 6f 20 73 65 72 76 65 72 64 61 74 20 s" to serverdat
2690: 61 6e 64 20 72 65 63 65 69 76 65 20 72 65 73 75 and receive resu
26a0: 6c 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 lt.;;.(define (h
26b0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c ttp-transport:cl
26c0: 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 ient-api-send-re
26d0: 63 65 69 76 65 20 72 75 6e 2d 69 64 20 73 65 72 ceive run-id ser
26e0: 76 65 72 64 61 74 20 63 6d 64 20 70 61 72 61 6d verdat cmd param
26f0: 73 20 23 21 6b 65 79 20 28 6e 75 6d 72 65 74 72 s #!key (numretr
2700: 69 65 73 20 33 29 28 61 72 65 61 2d 64 61 74 20 ies 3)(area-dat
2710: 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 #f)). (let* ((f
2720: 75 6c 6c 75 72 6c 20 20 20 20 28 69 66 20 28 76 ullurl (if (v
2730: 65 63 74 6f 72 3f 20 73 65 72 76 65 72 64 61 74 ector? serverdat
2740: 29 0a 09 09 09 20 28 68 74 74 70 2d 74 72 61 6e ).... (http-tran
2750: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 sport:server-dat
2760: 2d 67 65 74 2d 61 70 69 2d 72 65 71 20 73 65 72 -get-api-req ser
2770: 76 65 72 64 61 74 29 0a 09 09 09 20 28 62 65 67 verdat).... (beg
2780: 69 6e 0a 09 09 09 20 20 20 28 64 65 62 75 67 3a in.... (debug:
2790: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
27a0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 41 54 41 -log-port* "FATA
27b0: 4c 20 45 52 52 4f 52 3a 20 68 74 74 70 2d 74 72 L ERROR: http-tr
27c0: 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 ansport:client-a
27d0: 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 20 pi-send-receive
27e0: 63 61 6c 6c 65 64 20 77 69 74 68 20 6e 6f 20 73 called with no s
27f0: 65 72 76 65 72 20 69 6e 66 6f 22 29 0a 09 09 09 erver info")....
2800: 20 20 20 28 65 78 69 74 20 31 29 29 29 29 0a 09 (exit 1))))..
2810: 20 28 72 65 73 20 20 20 20 20 20 20 20 28 76 65 (res (ve
2820: 63 74 6f 72 20 23 66 20 22 75 6e 69 6e 69 74 69 ctor #f "uniniti
2830: 61 6c 69 7a 65 64 22 29 29 0a 09 20 28 73 75 63 alized")).. (suc
2840: 63 65 73 73 20 20 20 20 23 74 29 0a 09 20 28 73 cess #t).. (s
2850: 70 61 72 61 6d 73 20 20 20 20 28 64 62 3a 6f 62 params (db:ob
2860: 6a 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d 73 j->string params
2870: 20 74 72 61 6e 73 70 6f 72 74 3a 20 27 68 74 74 transport: 'htt
2880: 70 29 29 0a 09 20 28 72 75 6e 72 65 6d 6f 74 65 p)).. (runremote
2890: 20 20 28 6f 72 20 61 72 65 61 2d 64 61 74 20 2a (or area-dat *
28a0: 72 75 6e 72 65 6d 6f 74 65 2a 29 29 29 0a 20 20 runremote*))).
28b0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
28c0: 74 2d 69 6e 66 6f 20 31 31 20 2a 64 65 66 61 75 t-info 11 *defau
28d0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 75 lt-log-port* "fu
28e0: 6c 6c 75 72 6c 3d 22 20 66 75 6c 6c 75 72 6c 20 llurl=" fullurl
28f0: 22 2c 20 63 6d 64 3d 22 20 63 6d 64 20 22 2c 20 ", cmd=" cmd ",
2900: 70 61 72 61 6d 73 3d 22 20 70 61 72 61 6d 73 20 params=" params
2910: 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d ", run-id=" run-
2920: 69 64 20 22 5c 6e 22 29 0a 20 20 20 20 20 20 20 id "\n").
2930: 3b 3b 20 73 65 74 20 75 70 20 74 68 65 20 68 74 ;; set up the ht
2940: 74 70 2d 63 6c 69 65 6e 74 20 68 65 72 65 0a 20 tp-client here.
2950: 20 20 20 20 20 20 28 6d 61 78 2d 72 65 74 72 79 (max-retry
2960: 2d 61 74 74 65 6d 70 74 73 20 31 29 0a 20 20 20 -attempts 1).
2970: 20 20 20 20 3b 3b 20 63 6f 6e 73 69 64 65 72 20 ;; consider
2980: 61 6c 6c 20 72 65 71 75 65 73 74 73 20 69 6e 64 all requests ind
2990: 65 6d 70 6f 74 65 6e 74 0a 20 20 20 20 20 20 20 empotent.
29a0: 28 72 65 74 72 79 2d 72 65 71 75 65 73 74 3f 20 (retry-request?
29b0: 28 6c 61 6d 62 64 61 20 28 72 65 71 75 65 73 74 (lambda (request
29c0: 29 0a 09 09 09 20 23 66 29 29 0a 20 20 20 20 20 ).... #f)).
29d0: 20 20 3b 3b 20 73 65 6e 64 20 74 68 65 20 64 61 ;; send the da
29e0: 74 61 20 61 6e 64 20 67 65 74 20 74 68 65 20 72 ta and get the r
29f0: 65 73 70 6f 6e 73 65 0a 20 20 20 20 20 20 20 3b esponse. ;
2a00: 3b 20 65 78 74 72 61 63 74 20 74 68 65 20 6e 65 ; extract the ne
2a10: 65 64 65 64 20 69 6e 66 6f 20 66 72 6f 6d 20 74 eded info from t
2a20: 68 65 20 68 74 74 70 20 64 61 74 61 20 61 6e 64 he http data and
2a30: 20 0a 20 20 20 20 20 20 20 3b 3b 20 70 72 6f 63 . ;; proc
2a40: 65 73 73 20 61 6e 64 20 72 65 74 75 72 6e 20 69 ess and return i
2a50: 74 2e 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 t.. (let*
2a60: 28 28 73 65 6e 64 2d 72 65 63 69 65 76 65 20 28 ((send-recieve (
2a70: 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 lambda ()....
2a80: 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 (mutex-lock!
2a90: 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 09 09 *http-mutex*)...
2aa0: 09 20 20 20 20 20 20 3b 3b 20 28 63 6f 6e 64 69 . ;; (condi
2ab0: 74 69 6f 6e 2d 63 61 73 65 20 28 77 69 74 68 2d tion-case (with-
2ac0: 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 65 71 75 65 input-from-reque
2ad0: 73 74 20 22 68 74 74 70 3a 2f 2f 6c 6f 63 61 6c st "http://local
2ae0: 68 6f 73 74 22 3b 20 23 66 20 72 65 61 64 2d 6c host"; #f read-l
2af0: 69 6e 65 73 29 0a 09 09 09 20 20 20 20 20 20 3b ines).... ;
2b00: 3b 09 09 09 09 09 20 20 20 20 20 20 20 28 28 65 ;..... ((e
2b10: 78 6e 20 68 74 74 70 20 63 6c 69 65 6e 74 2d 65 xn http client-e
2b20: 72 72 6f 72 29 20 65 20 28 70 72 69 6e 74 20 65 rror) e (print e
2b30: 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 ))).... (se
2b40: 74 21 20 72 65 73 20 28 76 65 63 74 6f 72 20 20 t! res (vector
2b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
2b60: 3b 20 44 4f 4e 27 54 20 46 4f 52 47 45 54 20 2d ; DON'T FORGET -
2b70: 20 54 48 49 53 20 49 53 20 54 48 45 20 43 4c 49 THIS IS THE CLI
2b80: 45 4e 54 20 53 49 44 45 21 20 4e 4f 54 45 3a 20 ENT SIDE! NOTE:
2b90: 63 6f 6e 73 69 64 65 72 20 6d 6f 76 69 6e 67 20 consider moving
2ba0: 74 68 69 73 20 74 6f 20 63 6c 69 65 6e 74 2e 73 this to client.s
2bb0: 63 6d 20 73 69 6e 63 65 20 77 65 20 61 72 65 20 cm since we are
2bc0: 6f 6e 6c 79 20 73 75 70 70 6f 72 74 69 6e 67 20 only supporting
2bd0: 68 74 74 70 20 74 72 61 6e 73 70 6f 72 74 20 61 http transport a
2be0: 74 20 74 68 69 73 20 74 69 6d 65 2e 0a 09 09 09 t this time.....
2bf0: 09 09 20 73 75 63 63 65 73 73 0a 09 09 09 09 09 .. success......
2c00: 20 28 64 62 3a 73 74 72 69 6e 67 2d 3e 6f 62 6a (db:string->obj
2c10: 20 0a 09 09 09 09 09 20 20 28 68 61 6e 64 6c 65 ...... (handle
2c20: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 -exceptions.....
2c30: 09 20 20 20 20 20 20 65 78 6e 0a 09 09 09 09 09 . exn......
2c40: 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 61 6c (let ((cal
2c50: 6c 2d 63 68 61 69 6e 20 28 67 65 74 2d 63 61 6c l-chain (get-cal
2c60: 6c 2d 63 68 61 69 6e 29 29 0a 09 09 09 09 09 09 l-chain)).......
2c70: 20 20 20 20 28 6d 73 67 20 20 20 20 20 20 20 20 (msg
2c80: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
2c90: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
2ca0: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
2cb0: 29 29 29 0a 09 09 09 09 09 09 28 73 65 74 21 20 ))).......(set!
2cc0: 73 75 63 63 65 73 73 20 23 66 29 0a 20 20 20 20 success #f).
2cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cf0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
2d00: 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 (debug:debug-mod
2d10: 65 20 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 e 1).
2d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d40: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
2d50: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
2d60: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
2d70: 22 63 6f 75 6c 64 6e 27 74 20 74 61 6c 6b 20 74 "couldn't talk t
2d80: 6f 20 73 65 72 76 65 72 2c 20 74 72 79 69 6e 67 o server, trying
2d90: 20 61 67 61 69 6e 20 2e 2e 2e 22 29 0a 20 20 20 again ...").
2da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2dd0: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
2de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
2e10: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
2e20: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
2e30: 22 57 41 52 4e 49 4e 47 3a 20 66 61 69 6c 75 72 "WARNING: failur
2e40: 65 20 69 6e 20 77 69 74 68 2d 69 6e 70 75 74 2d e in with-input-
2e50: 66 72 6f 6d 2d 72 65 71 75 65 73 74 20 74 6f 20 from-request to
2e60: 22 20 66 75 6c 6c 75 72 6c 20 22 2e 22 29 0a 20 " fullurl ".").
2e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ea0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
2eb0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
2ec0: 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 65 -port* " message
2ed0: 3a 20 22 20 6d 73 67 29 0a 20 20 20 20 20 20 20 : " msg).
2ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2f10: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
2f20: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2f30: 20 22 20 63 6d 64 3a 20 22 20 63 6d 64 20 22 20 " cmd: " cmd "
2f40: 70 61 72 61 6d 73 3a 20 22 20 70 61 72 61 6d 73 params: " params
2f50: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f80: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
2f90: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
2fa0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 63 61 6c 6c log-port* " call
2fb0: 2d 63 68 61 69 6e 3a 20 22 20 63 61 6c 6c 2d 63 -chain: " call-c
2fc0: 68 61 69 6e 29 29 29 0a 20 20 20 20 20 20 20 20 hain))).
2fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ff0: 20 20 20 20 20 20 20 20 28 69 66 20 72 75 6e 72 (if runr
3000: 65 6d 6f 74 65 0a 09 09 09 09 09 09 20 20 20 20 emote.......
3010: 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 2d (remote-conndat-
3020: 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 23 set! runremote #
3030: 66 29 29 0a 09 09 09 09 09 09 3b 3b 20 4b 69 6c f)).......;; Kil
3040: 6c 69 6e 67 20 61 73 73 6f 63 69 61 74 65 64 20 ling associated
3050: 73 65 72 76 65 72 20 74 6f 20 61 6c 6c 6f 77 20 server to allow
3060: 63 6c 65 61 6e 20 72 65 74 72 79 2e 22 29 0a 09 clean retry.")..
3070: 09 09 09 09 09 3b 3b 20 28 74 61 73 6b 73 3a 6b .....;; (tasks:k
3080: 69 6c 6c 2d 73 65 72 76 65 72 2d 72 75 6e 2d 69 ill-server-run-i
3090: 64 20 72 75 6e 2d 69 64 29 20 20 3b 3b 20 62 65 d run-id) ;; be
30a0: 74 74 65 72 20 74 6f 20 6b 69 6c 6c 20 74 68 65 tter to kill the
30b0: 20 73 65 72 76 65 72 20 69 6e 20 74 68 65 20 6c server in the l
30c0: 6f 67 69 63 20 74 68 61 74 20 63 61 6c 6c 65 64 ogic that called
30d0: 20 74 68 69 73 20 72 6f 75 74 69 6e 65 3f 0a 09 this routine?..
30e0: 09 09 09 09 09 28 6d 75 74 65 78 2d 75 6e 6c 6f .....(mutex-unlo
30f0: 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a ck! *http-mutex*
3100: 29 0a 09 09 09 09 09 20 20 20 20 20 3b 3b 3b 20 )...... ;;;
3110: 28 73 69 67 6e 61 6c 20 28 6d 61 6b 65 2d 63 6f (signal (make-co
3120: 6d 70 6f 73 69 74 65 2d 63 6f 6e 64 69 74 69 6f mposite-conditio
3130: 6e 0a 09 09 09 09 09 20 20 20 20 20 3b 3b 3b 20 n...... ;;;
3140: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 70 (make-p
3150: 72 6f 70 65 72 74 79 2d 63 6f 6e 64 69 74 69 6f roperty-conditio
3160: 6e 20 27 63 6f 6d 6d 66 61 69 6c 20 27 6d 65 73 n 'commfail 'mes
3170: 73 61 67 65 20 22 66 61 69 6c 65 64 20 74 6f 20 sage "failed to
3180: 63 6f 6e 6e 65 63 74 20 74 6f 20 73 65 72 76 65 connect to serve
3190: 72 22 29 29 29 0a 09 09 09 09 09 20 20 20 20 20 r")))......
31a0: 3b 3b 3b 20 22 63 6f 6d 6d 75 6e 69 63 61 74 69 ;;; "communicati
31b0: 6f 6e 73 20 66 61 69 6c 65 64 22 0a 09 09 09 09 ons failed".....
31c0: 09 09 28 64 62 3a 6f 62 6a 2d 3e 73 74 72 69 6e ..(db:obj->strin
31d0: 67 20 23 66 29 29 0a 09 09 09 09 09 20 20 20 20 g #f))......
31e0: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
31f0: 2d 72 65 71 75 65 73 74 20 3b 3b 20 77 61 73 20 -request ;; was
3200: 64 61 74 0a 09 09 09 09 09 20 20 20 20 20 66 75 dat...... fu
3210: 6c 6c 75 72 6c 20 0a 09 09 09 09 09 20 20 20 20 llurl ......
3220: 20 28 6c 69 73 74 20 28 63 6f 6e 73 20 27 6b 65 (list (cons 'ke
3230: 79 20 28 6f 72 20 2a 73 65 72 76 65 72 2d 69 64 y (or *server-id
3240: 2a 20 22 74 68 65 6b 65 79 22 29 29 0a 09 09 09 * "thekey"))....
3250: 09 09 09 20 20 20 28 63 6f 6e 73 20 27 63 6d 64 ... (cons 'cmd
3260: 20 63 6d 64 29 0a 09 09 09 09 09 09 20 20 20 28 cmd)....... (
3270: 63 6f 6e 73 20 27 70 61 72 61 6d 73 20 73 70 61 cons 'params spa
3280: 72 61 6d 73 29 29 0a 09 09 09 09 09 20 20 20 20 rams))......
3290: 20 72 65 61 64 2d 73 74 72 69 6e 67 29 29 0a 09 read-string))..
32a0: 09 09 09 09 20 20 74 72 61 6e 73 70 6f 72 74 3a .... transport:
32b0: 20 27 68 74 74 70 29 0a 20 20 20 20 20 20 20 20 'http).
32c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
32d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
32e0: 20 30 29 29 20 3b 3b 20 61 64 64 65 64 20 74 68 0)) ;; added th
32f0: 69 73 20 73 70 65 63 75 6c 61 74 69 76 65 6c 79 is speculatively
3300: 0a 09 09 09 20 20 20 20 20 20 3b 3b 20 53 68 6f .... ;; Sho
3310: 75 6c 64 6e 27 74 20 74 68 69 73 20 62 65 20 61 uldn't this be a
3320: 20 63 61 6c 6c 20 74 6f 20 74 68 65 20 6d 61 6e call to the man
3330: 61 67 65 64 20 63 61 6c 6c 2d 61 6c 6c 2d 63 6f aged call-all-co
3340: 6e 6e 65 63 74 69 6f 6e 73 20 73 74 75 66 66 20 nnections stuff
3350: 61 62 6f 76 65 3f 0a 09 09 09 20 20 20 20 20 20 above?....
3360: 28 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 (close-all-conne
3370: 63 74 69 6f 6e 73 21 29 0a 09 09 09 20 20 20 20 ctions!)....
3380: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
3390: 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 09 *http-mutex*)..
33a0: 09 09 20 20 20 20 20 20 29 29 0a 09 20 20 20 20 .. ))..
33b0: 20 20 28 74 69 6d 65 2d 6f 75 74 20 20 20 20 20 (time-out
33c0: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 (lambda ()....
33d0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
33e0: 70 21 20 34 35 29 0a 09 09 09 20 20 20 20 20 20 p! 45)....
33f0: 23 66 29 29 0a 09 20 20 20 20 20 20 28 74 68 31 #f)).. (th1
3400: 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 73 65 (make-thread se
3410: 6e 64 2d 72 65 63 69 65 76 65 20 22 77 69 74 68 nd-recieve "with
3420: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 65 71 75 -input-from-requ
3430: 65 73 74 22 29 29 0a 09 20 20 20 20 20 20 28 74 est")).. (t
3440: 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 h2 (make-thread
3450: 74 69 6d 65 2d 6f 75 74 20 20 20 20 20 22 74 69 time-out "ti
3460: 6d 65 20 6f 75 74 22 29 29 29 0a 09 20 28 74 68 me out"))).. (th
3470: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 read-start! th1)
3480: 0a 09 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 .. (thread-start
3490: 21 20 74 68 32 29 0a 09 20 28 74 68 72 65 61 64 ! th2).. (thread
34a0: 2d 6a 6f 69 6e 21 20 74 68 31 29 0a 09 20 28 74 -join! th1).. (t
34b0: 68 72 65 61 64 2d 74 65 72 6d 69 6e 61 74 65 21 hread-terminate!
34c0: 20 74 68 32 29 0a 09 20 28 64 65 62 75 67 3a 70 th2).. (debug:p
34d0: 72 69 6e 74 2d 69 6e 66 6f 20 31 31 20 2a 64 65 rint-info 11 *de
34e0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
34f0: 22 67 6f 74 20 72 65 73 3d 22 20 72 65 73 29 0a "got res=" res).
3500: 09 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 72 . (if (vector? r
3510: 65 73 29 0a 09 20 20 20 20 20 28 69 66 20 28 76 es).. (if (v
3520: 65 63 74 6f 72 2d 72 65 66 20 72 65 73 20 30 29 ector-ref res 0)
3530: 20 3b 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 ;; this is the
3540: 66 69 72 73 74 20 66 6c 61 67 20 6f 72 20 74 68 first flag or th
3550: 65 20 73 65 63 6f 6e 64 20 66 6c 61 67 3f 0a 09 e second flag?..
3560: 09 20 72 65 73 20 3b 3b 20 74 68 69 73 20 69 73 . res ;; this is
3570: 20 74 68 65 20 2a 69 6e 6e 65 72 2a 20 76 65 63 the *inner* vec
3580: 74 6f 72 3f 20 73 65 72 69 6f 75 73 6c 79 3f 20 tor? seriously?
3590: 77 68 79 3f 0a 20 20 20 20 20 20 20 20 20 20 20 why?.
35a0: 20 20 20 20 20 20 28 69 66 20 28 64 65 62 75 67 (if (debug
35b0: 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 31 29 0a :debug-mode 11).
35c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
35d0: 20 20 20 20 20 28 6c 65 74 20 28 28 63 61 6c 6c (let ((call
35e0: 2d 63 68 61 69 6e 20 28 67 65 74 2d 63 61 6c 6c -chain (get-call
35f0: 2d 63 68 61 69 6e 29 29 29 20 3b 3b 20 6e 6f 74 -chain))) ;; not
3600: 65 3a 20 74 68 69 73 20 63 6f 64 65 20 61 6c 73 e: this code als
3610: 6f 20 63 61 6c 6c 65 64 20 69 6e 20 6e 6d 73 67 o called in nmsg
3620: 2d 74 72 61 6e 73 70 6f 72 74 20 2d 20 63 6f 6e -transport - con
3630: 73 69 64 65 72 20 63 6f 6e 73 6f 6c 69 64 61 74 sider consolidat
3640: 69 6e 67 20 69 74 0a 20 20 20 20 20 20 20 20 20 ing it.
3650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
3660: 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 rint-call-chain
3670: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
3680: 6f 72 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 ort)).
3690: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
36a0: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
36b0: 31 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 11 *default-log-
36c0: 70 6f 72 74 2a 20 22 65 72 72 6f 72 20 61 62 6f port* "error abo
36d0: 76 65 20 6f 63 63 75 72 65 64 20 61 74 20 73 65 ve occured at se
36e0: 72 76 65 72 2c 20 72 65 73 3d 22 20 72 65 73 20 rver, res=" res
36f0: 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 " message: " ((c
3700: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
3710: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
3720: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 'message) exn)).
3730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3740: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
3750: 69 6e 74 20 31 31 20 2a 64 65 66 61 75 6c 74 2d int 11 *default-
3760: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 73 65 72 76 log-port* " serv
3770: 65 72 20 63 61 6c 6c 20 63 68 61 69 6e 3a 22 29 er call chain:")
3780: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3790: 20 20 20 20 20 20 20 20 28 70 70 20 28 76 65 63 (pp (vec
37a0: 74 6f 72 2d 72 65 66 20 72 65 73 20 31 29 20 28 tor-ref res 1) (
37b0: 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f current-error-po
37c0: 72 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 rt)).
37d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 69 67 (sig
37e0: 6e 61 6c 20 28 76 65 63 74 6f 72 2d 72 65 66 20 nal (vector-ref
37f0: 72 65 73 20 30 29 29 29 0a 20 20 20 20 20 20 20 res 0))).
3800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 72 65 re
3810: 73 29 29 0a 09 20 20 20 20 20 28 73 69 67 6e 61 s)).. (signa
3820: 6c 20 28 6d 61 6b 65 2d 63 6f 6d 70 6f 73 69 74 l (make-composit
3830: 65 2d 63 6f 6e 64 69 74 69 6f 6e 0a 09 09 20 20 e-condition...
3840: 20 20 20 20 28 6d 61 6b 65 2d 70 72 6f 70 65 72 (make-proper
3850: 74 79 2d 63 6f 6e 64 69 74 69 6f 6e 20 0a 09 09 ty-condition ...
3860: 20 20 20 20 20 20 20 27 74 69 6d 65 6f 75 74 0a 'timeout.
3870: 09 09 20 20 20 20 20 20 20 27 6d 65 73 73 61 67 .. 'messag
3880: 65 20 22 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 e "nmsg-transpor
3890: 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e t:client-api-sen
38a0: 64 2d 72 65 63 65 69 76 65 2d 72 61 77 20 74 69 d-receive-raw ti
38b0: 6d 65 64 20 6f 75 74 20 74 61 6c 6b 69 6e 67 20 med out talking
38c0: 74 6f 20 73 65 72 76 65 72 22 29 29 29 29 29 29 to server"))))))
38d0: 29 0a 0a 3b 3b 20 63 61 72 65 66 75 6c 20 63 6c )..;; careful cl
38e0: 6f 73 69 6e 67 20 6f 66 20 63 6f 6e 6e 65 63 74 osing of connect
38f0: 69 6f 6e 73 20 73 74 6f 72 65 64 20 69 6e 20 2a ions stored in *
3900: 72 75 6e 72 65 6d 6f 74 65 2a 0a 3b 3b 0a 28 64 runremote*.;;.(d
3910: 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e efine (http-tran
3920: 73 70 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e sport:close-conn
3930: 65 63 74 69 6f 6e 73 20 23 21 6b 65 79 20 28 61 ections #!key (a
3940: 72 65 61 2d 64 61 74 20 23 66 29 29 0a 20 20 28 rea-dat #f)). (
3950: 6c 65 74 2a 20 28 28 72 75 6e 72 65 6d 6f 74 65 let* ((runremote
3960: 20 20 28 6f 72 20 61 72 65 61 2d 64 61 74 20 2a (or area-dat *
3970: 72 75 6e 72 65 6d 6f 74 65 2a 29 29 0a 09 20 28 runremote*)).. (
3980: 73 65 72 76 65 72 2d 64 61 74 20 28 69 66 20 72 server-dat (if r
3990: 75 6e 72 65 6d 6f 74 65 0a 20 20 20 20 20 20 20 unremote.
39a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
39b0: 20 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 (remote-connda
39c0: 74 20 72 75 6e 72 65 6d 6f 74 65 29 0a 20 20 20 t runremote).
39d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
39e0: 20 20 20 20 20 20 23 66 29 29 29 20 3b 3b 20 28 #f))) ;; (
39f0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
3a00: 65 66 61 75 6c 74 20 2a 72 75 6e 72 65 6d 6f 74 efault *runremot
3a10: 65 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 29 0a e* run-id #f))).
3a20: 20 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f (if (vector?
3a30: 20 73 65 72 76 65 72 2d 64 61 74 29 0a 09 28 6c server-dat)..(l
3a40: 65 74 20 28 28 61 70 69 2d 64 61 74 20 28 68 74 et ((api-dat (ht
3a50: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
3a60: 76 65 72 2d 64 61 74 2d 67 65 74 2d 61 70 69 2d ver-dat-get-api-
3a70: 75 72 69 20 73 65 72 76 65 72 2d 64 61 74 29 29 uri server-dat))
3a80: 29 0a 09 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 ).. (handle-exc
3a90: 65 70 74 69 6f 6e 73 0a 09 20 20 20 20 65 78 6e eptions.. exn
3aa0: 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 .. (begin..
3ab0: 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d (print-call-
3ac0: 63 68 61 69 6e 20 2a 64 65 66 61 75 6c 74 2d 6c chain *default-l
3ad0: 6f 67 2d 70 6f 72 74 2a 29 0a 09 20 20 20 20 20 og-port*)..
3ae0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
3af0: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
3b00: 6f 67 2d 70 6f 72 74 2a 20 22 20 63 6c 6f 73 69 og-port* " closi
3b10: 6e 67 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 66 61 ng connection fa
3b20: 69 6c 65 64 20 77 69 74 68 20 65 72 72 6f 72 3a iled with error:
3b30: 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
3b40: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
3b50: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
3b60: 65 78 6e 29 29 29 0a 09 20 20 20 20 28 63 6c 6f exn))).. (clo
3b70: 73 65 2d 63 6f 6e 6e 65 63 74 69 6f 6e 21 20 61 se-connection! a
3b80: 70 69 2d 64 61 74 29 0a 20 20 20 20 20 20 20 20 pi-dat).
3b90: 20 20 20 20 3b 3b 28 63 6c 6f 73 65 2d 69 64 6c ;;(close-idl
3ba0: 65 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 0a e-connections!).
3bb0: 09 20 20 20 20 23 74 29 29 0a 09 23 66 29 29 29 . #t))..#f)))
3bc0: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 ...(define (make
3bd0: 2d 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a -http-transport:
3be0: 73 65 72 76 65 72 2d 64 61 74 29 28 6d 61 6b 65 server-dat)(make
3bf0: 2d 76 65 63 74 6f 72 20 36 29 29 0a 28 64 65 66 -vector 6)).(def
3c00: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
3c10: 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 ort:server-dat-g
3c20: 65 74 2d 69 66 61 63 65 20 20 20 20 20 20 20 20 et-iface
3c30: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
3c40: 2d 72 65 66 20 20 76 65 63 20 30 29 29 0a 28 64 -ref vec 0)).(d
3c50: 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e efine (http-tran
3c60: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 sport:server-dat
3c70: 2d 67 65 74 2d 70 6f 72 74 20 20 20 20 20 20 20 -get-port
3c80: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
3c90: 6f 72 2d 72 65 66 20 20 76 65 63 20 31 29 29 0a or-ref vec 1)).
3ca0: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
3cb0: 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 ansport:server-d
3cc0: 61 74 2d 67 65 74 2d 61 70 69 2d 75 72 69 20 20 at-get-api-uri
3cd0: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
3ce0: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 29 ctor-ref vec 2)
3cf0: 29 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ).(define (http-
3d00: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
3d10: 2d 64 61 74 2d 67 65 74 2d 61 70 69 2d 75 72 6c -dat-get-api-url
3d20: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
3d30: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
3d40: 33 29 29 0a 28 64 65 66 69 6e 65 20 28 68 74 74 3)).(define (htt
3d50: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 p-transport:serv
3d60: 65 72 2d 64 61 74 2d 67 65 74 2d 61 70 69 2d 72 er-dat-get-api-r
3d70: 65 71 20 20 20 20 20 20 20 76 65 63 29 20 20 20 eq vec)
3d80: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
3d90: 63 20 34 29 29 0a 28 64 65 66 69 6e 65 20 28 68 c 4)).(define (h
3da0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 ttp-transport:se
3db0: 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 6c 61 73 rver-dat-get-las
3dc0: 74 2d 61 63 63 65 73 73 20 20 20 76 65 63 29 20 t-access vec)
3dd0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
3de0: 76 65 63 20 35 29 29 0a 28 64 65 66 69 6e 65 20 vec 5)).(define
3df0: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
3e00: 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 73 server-dat-get-s
3e10: 6f 63 6b 65 74 20 20 20 20 20 20 20 20 76 65 63 ocket vec
3e20: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
3e30: 20 20 76 65 63 20 36 29 29 0a 0a 28 64 65 66 69 vec 6))..(defi
3e40: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
3e50: 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 6d 61 rt:server-dat-ma
3e60: 6b 65 2d 75 72 6c 20 76 65 63 29 0a 20 20 28 69 ke-url vec). (i
3e70: 66 20 28 61 6e 64 20 28 68 74 74 70 2d 74 72 61 f (and (http-tra
3e80: 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 nsport:server-da
3e90: 74 2d 67 65 74 2d 69 66 61 63 65 20 76 65 63 29 t-get-iface vec)
3ea0: 0a 09 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 .. (http-trans
3eb0: 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
3ec0: 67 65 74 2d 70 6f 72 74 20 20 76 65 63 29 29 0a get-port vec)).
3ed0: 20 20 20 20 20 20 28 63 6f 6e 63 20 22 68 74 74 (conc "htt
3ee0: 70 3a 2f 2f 22 20 0a 09 20 20 20 20 28 68 74 74 p://" .. (htt
3ef0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 p-transport:serv
3f00: 65 72 2d 64 61 74 2d 67 65 74 2d 69 66 61 63 65 er-dat-get-iface
3f10: 20 76 65 63 29 0a 09 20 20 20 20 22 3a 22 0a 09 vec).. ":"..
3f20: 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 (http-transp
3f30: 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 ort:server-dat-g
3f40: 65 74 2d 70 6f 72 74 20 20 76 65 63 29 29 0a 20 et-port vec)).
3f50: 20 20 20 20 20 23 66 29 29 0a 0a 28 64 65 66 69 #f))..(defi
3f60: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
3f70: 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 75 70 rt:server-dat-up
3f80: 64 61 74 65 2d 6c 61 73 74 2d 61 63 63 65 73 73 date-last-access
3f90: 20 76 65 63 29 0a 20 20 28 69 66 20 28 76 65 63 vec). (if (vec
3fa0: 74 6f 72 3f 20 76 65 63 29 0a 20 20 20 20 20 20 tor? vec).
3fb0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 (vector-set! vec
3fc0: 20 35 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 5 (current-seco
3fd0: 6e 64 73 29 29 0a 20 20 20 20 20 20 28 62 65 67 nds)). (beg
3fe0: 69 6e 0a 09 28 70 72 69 6e 74 2d 63 61 6c 6c 2d in..(print-call-
3ff0: 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 chain (current-e
4000: 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 28 64 65 rror-port))..(de
4010: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
4020: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
4030: 6f 72 74 2a 20 22 63 61 6c 6c 20 74 6f 20 68 74 ort* "call to ht
4040: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
4050: 76 65 72 2d 64 61 74 2d 75 70 64 61 74 65 2d 6c ver-dat-update-l
4060: 61 73 74 2d 61 63 63 65 73 73 20 77 69 74 68 20 ast-access with
4070: 6e 6f 6e 2d 76 65 63 74 6f 72 21 21 22 29 29 29 non-vector!!")))
4080: 29 0a 0a 3b 3b 0a 3b 3b 20 63 6f 6e 6e 65 63 74 )..;;.;; connect
4090: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 74 .;;.(define (htt
40a0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 p-transport:clie
40b0: 6e 74 2d 63 6f 6e 6e 65 63 74 20 69 66 61 63 65 nt-connect iface
40c0: 20 70 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 28 port). (let* (
40d0: 28 61 70 69 2d 75 72 6c 20 20 20 20 20 20 28 63 (api-url (c
40e0: 6f 6e 63 20 22 68 74 74 70 3a 2f 2f 22 20 69 66 onc "http://" if
40f0: 61 63 65 20 22 3a 22 20 70 6f 72 74 20 22 2f 61 ace ":" port "/a
4100: 70 69 22 29 29 0a 09 20 28 61 70 69 2d 75 72 69 pi")).. (api-uri
4110: 20 20 20 20 20 20 28 75 72 69 2d 72 65 66 65 72 (uri-refer
4120: 65 6e 63 65 20 28 63 6f 6e 63 20 22 68 74 74 70 ence (conc "http
4130: 3a 2f 2f 22 20 69 66 61 63 65 20 22 3a 22 20 70 ://" iface ":" p
4140: 6f 72 74 20 22 2f 61 70 69 22 29 29 29 0a 09 20 ort "/api")))..
4150: 28 61 70 69 2d 72 65 71 20 20 20 20 20 20 28 6d (api-req (m
4160: 61 6b 65 2d 72 65 71 75 65 73 74 20 6d 65 74 68 ake-request meth
4170: 6f 64 3a 20 27 50 4f 53 54 20 75 72 69 3a 20 61 od: 'POST uri: a
4180: 70 69 2d 75 72 69 29 29 0a 09 20 28 73 65 72 76 pi-uri)).. (serv
4190: 65 72 2d 64 61 74 20 20 20 28 76 65 63 74 6f 72 er-dat (vector
41a0: 20 69 66 61 63 65 20 70 6f 72 74 20 61 70 69 2d iface port api-
41b0: 75 72 69 20 61 70 69 2d 75 72 6c 20 61 70 69 2d uri api-url api-
41c0: 72 65 71 20 28 63 75 72 72 65 6e 74 2d 73 65 63 req (current-sec
41d0: 6f 6e 64 73 29 29 29 29 0a 20 20 20 20 73 65 72 onds)))). ser
41e0: 76 65 72 2d 64 61 74 29 29 0a 0a 3b 3b 20 72 75 ver-dat))..;; ru
41f0: 6e 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 n http-transport
4200: 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 69 6e :keep-running in
4210: 20 61 20 70 61 72 61 6c 6c 65 6c 20 74 68 72 65 a parallel thre
4220: 61 64 20 74 6f 20 6d 6f 6e 69 74 6f 72 20 74 68 ad to monitor th
4230: 61 74 20 74 68 65 20 64 62 20 69 73 20 62 65 69 at the db is bei
4240: 6e 67 20 0a 3b 3b 20 75 73 65 64 20 61 6e 64 20 ng .;; used and
4250: 74 6f 20 73 68 75 74 64 6f 77 6e 20 61 66 74 65 to shutdown afte
4260: 72 20 73 6f 6d 65 74 69 6d 65 20 69 66 20 69 74 r sometime if it
4270: 20 69 73 20 6e 6f 74 2e 0a 3b 3b 0a 28 64 65 66 is not..;;.(def
4280: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
4290: 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 ort:keep-running
42a0: 29 20 0a 20 20 3b 3b 20 69 66 20 6e 6f 6e 65 20 ) . ;; if none
42b0: 72 75 6e 6e 69 6e 67 20 6f 72 20 69 66 20 3e 20 running or if >
42c0: 32 30 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 seconds since
42d0: 20 0a 20 20 3b 3b 20 73 65 72 76 65 72 20 6c 61 . ;; server la
42e0: 73 74 20 75 73 65 64 20 74 68 65 6e 20 73 74 61 st used then sta
42f0: 72 74 20 73 68 75 74 64 6f 77 6e 0a 20 20 3b 3b rt shutdown. ;;
4300: 20 54 68 69 73 20 74 68 72 65 61 64 20 77 61 69 This thread wai
4310: 74 73 20 66 6f 72 20 74 68 65 20 73 65 72 76 65 ts for the serve
4320: 72 20 74 6f 20 63 6f 6d 65 20 61 6c 69 76 65 0a r to come alive.
4330: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
4340: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
4350: 6f 67 2d 70 6f 72 74 2a 20 22 53 74 61 72 74 69 og-port* "Starti
4360: 6e 67 20 74 68 65 20 73 79 6e 63 2d 62 61 63 6b ng the sync-back
4370: 2c 20 6b 65 65 70 20 61 6c 69 76 65 20 74 68 72 , keep alive thr
4380: 65 61 64 20 69 6e 20 73 65 72 76 65 72 22 29 0a ead in server").
4390: 20 20 28 6c 65 74 2a 20 28 28 74 6d 70 2d 61 72 (let* ((tmp-ar
43a0: 65 61 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d ea (com
43b0: 6d 6f 6e 3a 67 65 74 2d 64 62 2d 74 6d 70 2d 61 mon:get-db-tmp-a
43c0: 72 65 61 29 29 0a 09 20 28 73 74 61 72 74 65 64 rea)).. (started
43d0: 2d 66 69 6c 65 20 20 20 20 20 20 28 63 6f 6e 63 -file (conc
43e0: 20 74 6d 70 2d 61 72 65 61 20 22 2f 2e 73 65 72 tmp-area "/.ser
43f0: 76 65 72 2d 73 74 61 72 74 65 64 22 29 29 0a 09 ver-started"))..
4400: 20 28 73 65 72 76 65 72 2d 73 74 61 72 74 2d 74 (server-start-t
4410: 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ime (current-sec
4420: 6f 6e 64 73 29 29 0a 09 20 28 73 65 72 76 65 72 onds)).. (server
4430: 2d 69 6e 66 6f 20 28 6c 65 74 20 6c 6f 6f 70 20 -info (let loop
4440: 28 28 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 ((start-time (cu
4450: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
4460: 09 09 09 09 20 28 63 68 61 6e 67 65 64 20 20 20 .... (changed
4470: 20 23 74 29 0a 09 09 09 09 20 28 6c 61 73 74 2d #t)..... (last-
4480: 73 64 61 74 20 20 22 6e 6f 74 20 74 68 69 73 22 sdat "not this"
4490: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
44a0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
44b0: 28 28 73 64 61 74 20 23 66 29 29 0a 09 09 09 20 ((sdat #f))....
44c0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
44d0: 30 2e 30 31 29 0a 09 09 09 20 20 28 64 65 62 75 0.01).... (debu
44e0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
44f0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
4500: 2a 20 22 57 61 69 74 69 6e 67 20 66 6f 72 20 73 * "Waiting for s
4510: 65 72 76 65 72 20 61 6c 69 76 65 20 73 69 67 6e erver alive sign
4520: 61 74 75 72 65 22 29 0a 20 20 20 20 20 20 20 20 ature").
4530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4540: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
4550: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
4560: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4570: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 (set
4580: 21 20 73 64 61 74 20 2a 73 65 72 76 65 72 2d 69 ! sdat *server-i
4590: 6e 66 6f 2a 29 0a 20 20 20 20 20 20 20 20 20 20 nfo*).
45a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
45b0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
45c0: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
45d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
45e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
45f0: 28 61 6e 64 20 73 64 61 74 0a 09 09 09 09 20 20 (and sdat.....
4600: 20 28 6e 6f 74 20 63 68 61 6e 67 65 64 29 0a 09 (not changed)..
4610: 09 09 09 20 20 20 28 3e 20 28 2d 20 28 63 75 72 ... (> (- (cur
4620: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 74 rent-seconds) st
4630: 61 72 74 2d 74 69 6d 65 29 20 32 29 29 0a 09 09 art-time) 2))...
4640: 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 . (begin...
4650: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
4660: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
4670: 6f 67 2d 70 6f 72 74 2a 20 22 52 65 63 65 69 76 og-port* "Receiv
4680: 65 64 20 73 65 72 76 65 72 20 61 6c 69 76 65 20 ed server alive
4690: 73 69 67 6e 61 74 75 72 65 22 29 0a 20 20 20 20 signature").
46a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
46b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d (com
46c0: 6d 6f 6e 3a 73 61 76 65 2d 70 6b 74 20 60 28 28 mon:save-pkt `((
46d0: 61 63 74 69 6f 6e 20 2e 20 61 6c 69 76 65 29 0a action . alive).
46e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
46f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4710: 20 20 20 28 54 20 20 20 20 20 20 2e 20 73 65 72 (T . ser
4720: 76 65 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 ver).
4730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4750: 20 20 20 20 20 20 20 20 28 70 69 64 20 20 20 20 (pid
4760: 2e 20 2c 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 . ,(current-proc
4770: 65 73 73 2d 69 64 29 29 0a 20 20 20 20 20 20 20 ess-id)).
4780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
47a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 70 61 (ipa
47b0: 64 64 72 20 2e 20 2c 28 63 61 72 20 73 64 61 74 ddr . ,(car sdat
47c0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
47d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
47e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
47f0: 20 20 20 20 20 20 28 70 6f 72 74 20 20 20 2e 20 (port .
4800: 2c 28 63 61 64 72 20 73 64 61 74 29 29 29 0a 20 ,(cadr sdat))).
4810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4840: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 23 74 29 0a *configdat* #t).
4850: 09 09 09 09 73 64 61 74 29 0a 20 20 20 20 20 20 ....sdat).
4860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4870: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 (begin..
4880: 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ...(debug:print-
4890: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
48a0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 74 69 6c 6c log-port* "Still
48b0: 20 77 61 69 74 69 6e 67 2c 20 6c 61 73 74 2d 73 waiting, last-s
48c0: 64 61 74 3d 22 20 6c 61 73 74 2d 73 64 61 74 29 dat=" last-sdat)
48d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
48e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
48f0: 20 28 73 6c 65 65 70 20 34 29 0a 09 09 09 09 28 (sleep 4).....(
4900: 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e if (> (- (curren
4910: 74 2d 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 t-seconds) start
4920: 2d 74 69 6d 65 29 20 31 32 30 29 20 3b 3b 20 62 -time) 120) ;; b
4930: 65 65 6e 20 77 61 69 74 69 6e 67 20 66 6f 72 20 een waiting for
4940: 74 77 6f 20 6d 69 6e 75 74 65 73 0a 09 09 09 09 two minutes.....
4950: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 (begin.....
4960: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
4970: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
4980: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 72 lt-log-port* "tr
4990: 61 6e 73 70 6f 72 74 20 61 70 70 65 61 72 73 20 ansport appears
49a0: 74 6f 20 68 61 76 65 20 64 69 65 64 2c 20 65 78 to have died, ex
49b0: 69 74 69 6e 67 20 73 65 72 76 65 72 22 29 0a 20 iting server").
49c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
49d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
49e0: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 73 61 76 (common:sav
49f0: 65 2d 70 6b 74 20 60 28 28 61 63 74 69 6f 6e 20 e-pkt `((action
4a00: 2e 20 64 69 65 64 29 0a 20 20 20 20 20 20 20 20 . died).
4a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a40: 20 28 54 20 20 20 20 20 20 2e 20 73 65 72 76 65 (T . serve
4a50: 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 r).
4a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a80: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 69 64 (pid
4a90: 20 20 20 20 2e 20 2c 28 63 75 72 72 65 6e 74 2d . ,(current-
4aa0: 70 72 6f 63 65 73 73 2d 69 64 29 29 0a 20 20 20 process-id)).
4ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ae0: 20 20 20 20 20 20 28 69 70 61 64 64 72 20 2e 20 (ipaddr .
4af0: 2c 28 63 61 72 20 73 64 61 74 29 29 0a 20 20 20 ,(car sdat)).
4b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b30: 20 20 20 20 20 20 28 70 6f 72 74 20 20 20 2e 20 (port .
4b40: 2c 28 63 61 64 72 20 73 64 61 74 29 29 0a 20 20 ,(cadr sdat)).
4b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b80: 20 20 20 20 20 20 20 28 6d 73 67 20 20 20 20 2e (msg .
4b90: 20 22 54 72 61 6e 73 70 6f 72 74 20 64 69 65 64 "Transport died
4ba0: 3f 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ?")).
4bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4bd0: 20 20 20 20 20 20 2a 63 6f 6e 66 69 67 64 61 74 *configdat
4be0: 2a 20 23 74 29 0a 09 09 09 09 20 20 20 20 20 20 * #t).....
4bf0: 28 65 78 69 74 29 29 0a 09 09 09 09 20 20 20 20 (exit)).....
4c00: 28 6c 6f 6f 70 20 73 74 61 72 74 2d 74 69 6d 65 (loop start-time
4c10: 0a 09 09 09 09 09 20 20 28 65 71 75 61 6c 3f 20 ...... (equal?
4c20: 73 64 61 74 20 6c 61 73 74 2d 73 64 61 74 29 0a sdat last-sdat).
4c30: 09 09 09 09 09 20 20 73 64 61 74 29 29 29 29 29 ..... sdat)))))
4c40: 29 29 0a 20 20 20 20 20 20 20 20 20 28 69 66 61 )). (ifa
4c50: 63 65 20 20 20 20 20 20 20 28 63 61 72 20 73 65 ce (car se
4c60: 72 76 65 72 2d 69 6e 66 6f 29 29 0a 20 20 20 20 rver-info)).
4c70: 20 20 20 20 20 28 70 6f 72 74 20 20 20 20 20 20 (port
4c80: 20 20 28 63 61 64 72 20 73 65 72 76 65 72 2d 69 (cadr server-i
4c90: 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 28 nfo)). (
4ca0: 6c 61 73 74 2d 61 63 63 65 73 73 20 30 29 0a 09 last-access 0)..
4cb0: 20 28 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 (server-timeout
4cc0: 20 28 73 65 72 76 65 72 3a 65 78 70 69 72 61 74 (server:expirat
4cd0: 69 6f 6e 2d 74 69 6d 65 6f 75 74 29 29 0a 09 20 ion-timeout))..
4ce0: 28 73 65 72 76 65 72 2d 67 6f 69 6e 67 20 20 23 (server-going #
4cf0: 66 29 0a 09 20 28 73 65 72 76 65 72 2d 6c 6f 67 f).. (server-log
4d00: 2d 66 69 6c 65 20 28 61 72 67 73 3a 67 65 74 2d -file (args:get-
4d10: 61 72 67 20 22 2d 6c 6f 67 22 29 29 29 20 3b 3b arg "-log"))) ;;
4d20: 20 61 6c 77 61 79 73 20 73 65 74 20 77 68 65 6e always set when
4d30: 20 77 65 20 61 72 65 20 61 20 73 65 72 76 65 72 we are a server
4d40: 0a 0a 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 .. (with-outp
4d50: 75 74 2d 74 6f 2d 66 69 6c 65 20 73 74 61 72 74 ut-to-file start
4d60: 65 64 2d 66 69 6c 65 20 28 6c 61 6d 62 64 61 20 ed-file (lambda
4d70: 28 29 28 70 72 69 6e 74 20 28 63 75 72 72 65 6e ()(print (curren
4d80: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 29 t-process-id))))
4d90: 0a 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 .. (let loop
4da0: 28 28 63 6f 75 6e 74 20 20 20 20 20 20 20 20 20 ((count
4db0: 30 29 0a 09 20 20 20 20 20 20 20 28 73 65 72 76 0).. (serv
4dc0: 65 72 2d 73 74 61 74 65 20 27 61 76 61 69 6c 61 er-state 'availa
4dd0: 62 6c 65 29 0a 09 20 20 20 20 20 20 20 28 62 61 ble).. (ba
4de0: 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 30 29 0a d-sync-count 0).
4df0: 09 20 20 20 20 20 20 20 28 73 74 61 72 74 2d 74 . (start-t
4e00: 69 6d 65 20 20 20 20 20 28 63 75 72 72 65 6e 74 ime (current
4e10: 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 -milliseconds)))
4e20: 0a 20 20 20 20 20 20 3b 3b 20 55 73 65 20 74 68 . ;; Use th
4e30: 69 73 20 6f 70 70 6f 72 74 75 6e 69 74 79 20 74 is opportunity t
4e40: 6f 20 73 79 6e 63 20 74 68 65 20 74 6d 70 20 64 o sync the tmp d
4e50: 62 20 74 6f 20 6d 65 67 61 74 65 73 74 2e 64 62 b to megatest.db
4e60: 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 . (if (not
4e70: 73 65 72 76 65 72 2d 67 6f 69 6e 67 29 20 3b 3b server-going) ;;
4e80: 20 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 20 0a *dbstruct-db* .
4e90: 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 . (begin.. (
4ea0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
4eb0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
4ec0: 20 22 53 45 52 56 45 52 3a 20 64 62 70 72 65 70 "SERVER: dbprep
4ed0: 22 29 0a 09 20 20 20 20 28 73 65 74 21 20 2a 64 ").. (set! *d
4ee0: 62 73 74 72 75 63 74 2d 64 62 2a 20 20 28 64 62 bstruct-db* (db
4ef0: 3a 73 65 74 75 70 20 23 74 29 29 20 3b 3b 20 20 :setup #t)) ;;
4f00: 72 75 6e 2d 69 64 29 29 0a 09 20 20 20 20 28 73 run-id)).. (s
4f10: 65 74 21 20 73 65 72 76 65 72 2d 67 6f 69 6e 67 et! server-going
4f20: 20 23 74 29 0a 09 20 20 20 20 28 64 65 62 75 67 #t).. (debug
4f30: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
4f40: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 45 52 t-log-port* "SER
4f50: 56 45 52 3a 20 72 75 6e 6e 69 6e 67 2c 20 6d 65 VER: running, me
4f60: 67 61 74 65 73 74 20 76 65 72 73 69 6f 6e 3a 20 gatest version:
4f70: 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 75 " (common:get-fu
4f80: 6c 6c 2d 76 65 72 73 69 6f 6e 29 29 20 3b 3b 20 ll-version)) ;;
4f90: 4e 4f 54 45 3a 20 74 68 65 20 73 65 72 76 65 72 NOTE: the server
4fa0: 20 69 73 20 4e 4f 54 20 79 65 74 20 6d 61 72 6b is NOT yet mark
4fb0: 65 64 20 61 73 20 72 75 6e 6e 69 6e 67 20 69 6e ed as running in
4fc0: 20 74 68 65 20 6c 6f 67 2e 20 57 65 20 64 6f 20 the log. We do
4fd0: 74 68 61 74 20 69 6e 20 74 68 65 20 6b 65 65 70 that in the keep
4fe0: 2d 72 75 6e 6e 69 6e 67 20 72 6f 75 74 69 6e 65 -running routine
4ff0: 2e 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 ... (thread-s
5000: 74 61 72 74 21 20 2a 77 61 74 63 68 64 6f 67 2a tart! *watchdog*
5010: 29 29 29 0a 20 20 20 20 20 20 0a 20 20 20 20 20 ))). .
5020: 20 3b 3b 20 77 68 65 6e 20 74 68 69 6e 67 73 20 ;; when things
5030: 67 6f 20 77 72 6f 6e 67 20 77 65 20 64 6f 6e 27 go wrong we don'
5040: 74 20 77 61 6e 74 20 74 6f 20 62 65 20 64 6f 69 t want to be doi
5050: 6e 67 20 74 68 65 20 76 61 72 69 6f 75 73 20 71 ng the various q
5060: 75 65 72 69 65 73 20 74 6f 6f 20 6f 66 74 65 6e ueries too often
5070: 0a 20 20 20 20 20 20 3b 3b 20 73 6f 20 77 65 20 . ;; so we
5080: 73 74 72 69 76 65 20 74 6f 20 72 75 6e 20 74 68 strive to run th
5090: 69 73 20 73 74 75 66 66 20 6f 6e 6c 79 20 65 76 is stuff only ev
50a0: 65 72 79 20 66 6f 75 72 20 73 65 63 6f 6e 64 73 ery four seconds
50b0: 20 6f 72 20 73 6f 2e 0a 20 20 20 20 20 20 28 6c or so.. (l
50c0: 65 74 2a 20 28 28 73 79 6e 63 2d 74 69 6d 65 20 et* ((sync-time
50d0: 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c (- (current-mill
50e0: 69 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d iseconds) start-
50f0: 74 69 6d 65 29 29 0a 09 20 20 20 20 28 72 65 6d time)).. (rem
5100: 2d 74 69 6d 65 20 20 28 71 75 6f 74 69 65 6e 74 -time (quotient
5110: 20 28 2d 20 34 30 30 30 20 73 79 6e 63 2d 74 69 (- 4000 sync-ti
5120: 6d 65 29 20 31 30 30 30 29 29 29 0a 09 28 69 66 me) 1000)))..(if
5130: 20 28 61 6e 64 20 28 3c 3d 20 72 65 6d 2d 74 69 (and (<= rem-ti
5140: 6d 65 20 34 29 0a 09 09 20 28 3e 20 20 72 65 6d me 4)... (> rem
5150: 2d 74 69 6d 65 20 30 29 29 0a 09 20 20 20 20 28 -time 0)).. (
5160: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 72 65 thread-sleep! re
5170: 6d 2d 74 69 6d 65 29 29 29 0a 20 20 20 20 20 20 m-time))).
5180: 0a 20 20 20 20 20 20 28 69 66 20 28 3c 20 63 6f . (if (< co
5190: 75 6e 74 20 31 29 20 3b 3b 20 33 78 33 20 3d 20 unt 1) ;; 3x3 =
51a0: 39 20 73 65 63 73 20 61 70 72 6f 78 0a 09 20 20 9 secs aprox..
51b0: 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 20 31 (loop (+ count 1
51c0: 29 20 27 72 75 6e 6e 69 6e 67 20 62 61 64 2d 73 ) 'running bad-s
51d0: 79 6e 63 2d 63 6f 75 6e 74 20 28 63 75 72 72 65 ync-count (curre
51e0: 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
51f0: 29 29 0a 20 20 20 20 20 20 0a 20 20 20 20 20 20 )). .
5200: 3b 3b 20 43 68 65 63 6b 20 74 68 61 74 20 69 66 ;; Check that if
5210: 61 63 65 20 61 6e 64 20 70 6f 72 74 20 68 61 76 ace and port hav
5220: 65 20 6e 6f 74 20 63 68 61 6e 67 65 64 20 28 63 e not changed (c
5230: 61 6e 20 68 61 70 70 65 6e 20 69 66 20 73 65 72 an happen if ser
5240: 76 65 72 20 70 6f 72 74 20 63 6f 6c 6c 69 64 65 ver port collide
5250: 73 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d s). (mutex-
5260: 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 lock! *heartbeat
5270: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 -mutex*). (
5280: 73 65 74 21 20 73 64 61 74 20 2a 73 65 72 76 65 set! sdat *serve
5290: 72 2d 69 6e 66 6f 2a 29 0a 20 20 20 20 20 20 28 r-info*). (
52a0: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 mutex-unlock! *h
52b0: 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 eartbeat-mutex*)
52c0: 0a 20 20 20 20 20 20 0a 20 20 20 20 20 20 28 69 . . (i
52d0: 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 73 f (not (equal? s
52e0: 64 61 74 20 28 6c 69 73 74 20 69 66 61 63 65 20 dat (list iface
52f0: 70 6f 72 74 29 29 29 0a 09 20 20 28 6c 65 74 20 port))).. (let
5300: 28 28 6e 65 77 2d 69 66 61 63 65 20 28 63 61 72 ((new-iface (car
5310: 20 73 64 61 74 29 29 0a 09 09 28 6e 65 77 2d 70 sdat))...(new-p
5320: 6f 72 74 20 20 28 63 61 64 72 20 73 64 61 74 29 ort (cadr sdat)
5330: 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 )).. (debug:p
5340: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
5350: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5360: 57 41 52 4e 49 4e 47 3a 20 69 6e 74 65 72 66 61 WARNING: interfa
5370: 63 65 20 63 68 61 6e 67 65 64 2c 20 72 65 66 72 ce changed, refr
5380: 65 73 68 69 6e 67 20 69 66 61 63 65 20 61 6e 64 eshing iface and
5390: 20 70 6f 72 74 20 69 6e 66 6f 22 29 0a 09 20 20 port info")..
53a0: 20 20 28 73 65 74 21 20 69 66 61 63 65 20 6e 65 (set! iface ne
53b0: 77 2d 69 66 61 63 65 29 0a 09 20 20 20 20 28 73 w-iface).. (s
53c0: 65 74 21 20 70 6f 72 74 20 20 6e 65 77 2d 70 6f et! port new-po
53d0: 72 74 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a rt).. (debug:
53e0: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
53f0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 45 52 56 -log-port* "SERV
5400: 45 52 20 53 54 41 52 54 45 44 3a 20 22 20 69 66 ER STARTED: " if
5410: 61 63 65 20 22 3a 22 20 70 6f 72 74 20 22 20 41 ace ":" port " A
5420: 54 20 22 20 28 63 75 72 72 65 6e 74 2d 73 65 63 T " (current-sec
5430: 6f 6e 64 73 29 29 0a 09 20 20 20 20 28 66 6c 75 onds)).. (flu
5440: 73 68 2d 6f 75 74 70 75 74 20 2a 64 65 66 61 75 sh-output *defau
5450: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 29 29 29 0a lt-log-port*))).
5460: 20 20 20 20 20 20 0a 20 20 20 20 20 20 3b 3b 20 . ;;
5470: 54 72 61 6e 73 66 65 72 20 2a 64 62 2d 6c 61 73 Transfer *db-las
5480: 74 2d 61 63 63 65 73 73 2a 20 74 6f 20 6c 61 73 t-access* to las
5490: 74 2d 61 63 63 65 73 73 20 74 6f 20 75 73 65 20 t-access to use
54a0: 69 6e 20 63 68 65 63 6b 69 6e 67 20 74 68 61 74 in checking that
54b0: 20 77 65 20 61 72 65 20 73 74 69 6c 6c 20 61 6c we are still al
54c0: 69 76 65 0a 20 20 20 20 20 20 28 6d 75 74 65 78 ive. (mutex
54d0: 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 -lock! *heartbea
54e0: 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 t-mutex*).
54f0: 28 73 65 74 21 20 6c 61 73 74 2d 61 63 63 65 73 (set! last-acces
5500: 73 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 s *db-last-acces
5510: 73 2a 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 s*). (mutex
5520: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 -unlock! *heartb
5530: 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 eat-mutex*).
5540: 20 20 0a 20 20 20 20 20 20 28 69 66 20 28 63 6f . (if (co
5550: 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 mmon:low-noise-p
5560: 72 69 6e 74 20 31 32 30 20 28 63 6f 6e 63 20 22 rint 120 (conc "
5570: 73 65 72 76 65 72 20 72 75 6e 6e 69 6e 67 20 6f server running o
5580: 6e 20 22 20 69 66 61 63 65 20 22 3a 22 20 70 6f n " iface ":" po
5590: 72 74 29 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 rt)).. (begin..
55a0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
55b0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
55c0: 70 6f 72 74 2a 20 22 53 45 52 56 45 52 20 53 54 port* "SERVER ST
55d0: 41 52 54 45 44 3a 20 22 20 69 66 61 63 65 20 22 ARTED: " iface "
55e0: 3a 22 20 70 6f 72 74 20 22 20 41 54 20 22 20 28 :" port " AT " (
55f0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
5600: 29 0a 09 20 20 20 20 28 66 6c 75 73 68 2d 6f 75 ).. (flush-ou
5610: 74 70 75 74 20 2a 64 65 66 61 75 6c 74 2d 6c 6f tput *default-lo
5620: 67 2d 70 6f 72 74 2a 29 29 29 0a 20 20 20 20 20 g-port*))).
5630: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 (if (common:low
5640: 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 36 30 20 -noise-print 60
5650: 22 64 62 73 74 61 74 73 22 29 0a 09 20 20 28 62 "dbstats").. (b
5660: 65 67 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 egin.. (debug
5670: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
5680: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 t-log-port* "Ser
5690: 76 65 72 20 73 74 61 74 73 3a 22 29 0a 09 20 20 ver stats:")..
56a0: 20 20 28 64 62 3a 70 72 69 6e 74 2d 63 75 72 72 (db:print-curr
56b0: 65 6e 74 2d 71 75 65 72 79 2d 73 74 61 74 73 29 ent-query-stats)
56c0: 29 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 )). (let* (
56d0: 28 68 72 73 2d 73 69 6e 63 65 2d 73 74 61 72 74 (hrs-since-start
56e0: 20 20 28 2f 20 28 2d 20 28 63 75 72 72 65 6e 74 (/ (- (current
56f0: 2d 73 65 63 6f 6e 64 73 29 20 73 65 72 76 65 72 -seconds) server
5700: 2d 73 74 61 72 74 2d 74 69 6d 65 29 20 33 36 30 -start-time) 360
5710: 30 29 29 29 0a 09 28 63 6f 6e 64 0a 20 20 20 20 0)))..(cond.
5720: 20 20 20 20 20 28 28 61 6e 64 20 2a 73 65 72 76 ((and *serv
5730: 65 72 2d 72 75 6e 2a 0a 09 20 20 20 20 20 20 20 er-run*..
5740: 28 3e 20 28 2b 20 6c 61 73 74 2d 61 63 63 65 73 (> (+ last-acces
5750: 73 20 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 s server-timeout
5760: 29 0a 09 09 20 20 28 63 75 72 72 65 6e 74 2d 73 )... (current-s
5770: 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 20 econds))).
5780: 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a (if (common:
5790: 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 low-noise-print
57a0: 31 32 30 20 22 73 65 72 76 65 72 20 63 6f 6e 74 120 "server cont
57b0: 69 6e 75 69 6e 67 22 29 0a 20 20 20 20 20 20 20 inuing").
57c0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
57d0: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
57e0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 ult-log-port* "S
57f0: 65 72 76 65 72 20 63 6f 6e 74 69 6e 75 69 6e 67 erver continuing
5800: 2c 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 , seconds since
5810: 6c 61 73 74 20 64 62 20 61 63 63 65 73 73 3a 20 last db access:
5820: 22 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 " (- (current-se
5830: 63 6f 6e 64 73 29 20 6c 61 73 74 2d 61 63 63 65 conds) last-acce
5840: 73 73 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 ss)).. (let
5850: 20 28 28 63 75 72 72 2d 74 69 6d 65 20 28 63 75 ((curr-time (cu
5860: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 rrent-seconds)))
5870: 0a 09 09 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 ...(handle-excep
5880: 74 69 6f 6e 73 0a 09 09 20 20 20 20 65 78 6e 0a tions... exn.
5890: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
58a0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
58b0: 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 g-port* "ERROR:
58c0: 46 61 69 6c 65 64 20 74 6f 20 63 68 61 6e 67 65 Failed to change
58d0: 20 74 69 6d 65 73 74 61 6d 70 20 6f 6e 20 6c 6f timestamp on lo
58e0: 67 20 66 69 6c 65 20 22 20 73 65 72 76 65 72 2d g file " server-
58f0: 6c 6f 67 2d 66 69 6c 65 20 22 2e 20 41 72 65 20 log-file ". Are
5900: 79 6f 75 20 6f 75 74 20 6f 66 20 73 70 61 63 65 you out of space
5910: 20 6f 6e 20 74 68 61 74 20 64 69 73 6b 3f 22 29 on that disk?")
5920: 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 2a 73 ... (if (not *s
5930: 65 72 76 65 72 2d 6f 76 65 72 6c 6f 61 64 65 64 erver-overloaded
5940: 2a 29 0a 09 09 20 20 20 20 20 20 28 63 68 61 6e *)... (chan
5950: 67 65 2d 66 69 6c 65 2d 74 69 6d 65 73 20 73 65 ge-file-times se
5960: 72 76 65 72 2d 6c 6f 67 2d 66 69 6c 65 20 63 75 rver-log-file cu
5970: 72 72 2d 74 69 6d 65 20 63 75 72 72 2d 74 69 6d rr-time curr-tim
5980: 65 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 e))))).
5990: 20 28 6c 6f 6f 70 20 30 20 73 65 72 76 65 72 2d (loop 0 server-
59a0: 73 74 61 74 65 20 62 61 64 2d 73 79 6e 63 2d 63 state bad-sync-c
59b0: 6f 75 6e 74 20 28 63 75 72 72 65 6e 74 2d 6d 69 ount (current-mi
59c0: 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 lliseconds))).
59d0: 20 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 (else.
59e0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
59f0: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
5a00: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 ult-log-port* "S
5a10: 65 72 76 65 72 20 74 69 6d 65 64 20 6f 75 74 2e erver timed out.
5a20: 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 6c seconds since l
5a30: 61 73 74 20 64 62 20 61 63 63 65 73 73 3a 20 22 ast db access: "
5a40: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
5a50: 6f 6e 64 73 29 20 6c 61 73 74 2d 61 63 63 65 73 onds) last-acces
5a60: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 68 s)). (h
5a70: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 ttp-transport:se
5a80: 72 76 65 72 2d 73 68 75 74 64 6f 77 6e 20 70 6f rver-shutdown po
5a90: 72 74 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 rt)))))))..(defi
5aa0: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
5ab0: 72 74 3a 73 65 72 76 65 72 2d 73 68 75 74 64 6f rt:server-shutdo
5ac0: 77 6e 20 70 6f 72 74 29 0a 20 20 28 62 65 67 69 wn port). (begi
5ad0: 6e 0a 20 20 20 20 3b 3b 28 42 42 3e 20 22 68 74 n. ;;(BB> "ht
5ae0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
5af0: 76 65 72 2d 73 68 75 74 64 6f 77 6e 20 63 61 6c ver-shutdown cal
5b00: 6c 65 64 22 29 0a 20 20 20 20 28 64 65 62 75 67 led"). (debug
5b10: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
5b20: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
5b30: 20 22 53 74 61 72 74 69 6e 67 20 74 6f 20 73 68 "Starting to sh
5b40: 75 74 64 6f 77 6e 20 74 68 65 20 73 65 72 76 65 utdown the serve
5b50: 72 2e 20 70 69 64 3d 22 28 63 75 72 72 65 6e 74 r. pid="(current
5b60: 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 0a 20 20 -process-id)).
5b70: 20 20 3b 3b 0a 20 20 20 20 3b 3b 20 73 74 61 72 ;;. ;; star
5b80: 74 5f 73 68 75 74 64 6f 77 6e 0a 20 20 20 20 3b t_shutdown. ;
5b90: 3b 0a 20 20 20 20 28 73 65 74 21 20 2a 74 69 6d ;. (set! *tim
5ba0: 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 29 20 3b e-to-exit* #t) ;
5bb0: 3b 20 74 65 6c 6c 20 6f 6e 2d 65 78 69 74 20 74 ; tell on-exit t
5bc0: 6f 20 62 65 20 66 61 73 74 20 61 73 20 77 65 27 o be fast as we'
5bd0: 76 65 20 61 6c 72 65 61 64 79 20 63 6c 65 61 6e ve already clean
5be0: 65 64 20 75 70 0a 20 20 20 20 28 70 6f 72 74 6c ed up. (portl
5bf0: 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 ogger:open-run-c
5c00: 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a lose portlogger:
5c10: 73 65 74 2d 70 6f 72 74 20 70 6f 72 74 20 22 72 set-port port "r
5c20: 65 6c 65 61 73 65 64 22 29 0a 20 20 20 20 28 74 eleased"). (t
5c30: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a hread-sleep! 1).
5c40: 0a 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 . ;; (debug:p
5c50: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
5c60: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5c70: 4d 61 78 20 63 61 63 68 65 64 20 71 75 65 72 69 Max cached queri
5c80: 65 73 20 77 61 73 20 20 20 20 22 20 2a 6d 61 78 es was " *max
5c90: 2d 63 61 63 68 65 2d 73 69 7a 65 2a 29 0a 20 20 -cache-size*).
5ca0: 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
5cb0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
5cc0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4e 75 6d t-log-port* "Num
5cd0: 62 65 72 20 6f 66 20 63 61 63 68 65 64 20 77 72 ber of cached wr
5ce0: 69 74 65 73 20 20 20 22 20 2a 6e 75 6d 62 65 72 ites " *number
5cf0: 2d 6f 66 2d 77 72 69 74 65 73 2a 29 0a 20 20 20 -of-writes*).
5d00: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
5d10: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
5d20: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 41 76 65 72 -log-port* "Aver
5d30: 61 67 65 20 63 61 63 68 65 64 20 77 72 69 74 65 age cached write
5d40: 20 74 69 6d 65 20 22 0a 20 20 20 20 3b 3b 20 09 time ". ;; .
5d50: 09 20 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 . (if (eq?
5d60: 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 *number-of-write
5d70: 73 2a 20 30 29 0a 20 20 20 20 3b 3b 20 09 09 09 s* 0). ;; ...
5d80: 20 20 22 6e 2f 61 20 28 6e 6f 20 77 72 69 74 65 "n/a (no write
5d90: 73 29 22 0a 20 20 20 20 3b 3b 20 09 09 09 20 20 s)". ;; ...
5da0: 28 2f 20 2a 77 72 69 74 65 73 2d 74 6f 74 61 6c (/ *writes-total
5db0: 2d 64 65 6c 61 79 2a 0a 20 20 20 20 3b 3b 20 09 -delay*. ;; .
5dc0: 09 09 20 20 20 20 20 2a 6e 75 6d 62 65 72 2d 6f .. *number-o
5dd0: 66 2d 77 72 69 74 65 73 2a 29 29 0a 20 20 20 20 f-writes*)).
5de0: 3b 3b 20 09 09 20 20 20 20 20 20 22 20 6d 73 22 ;; .. " ms"
5df0: 29 0a 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a ). ;; (debug:
5e00: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
5e10: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5e20: 22 4e 75 6d 62 65 72 20 6e 6f 6e 2d 63 61 63 68 "Number non-cach
5e30: 65 64 20 71 75 65 72 69 65 73 20 22 20 20 2a 6e ed queries " *n
5e40: 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d umber-non-write-
5e50: 71 75 65 72 69 65 73 2a 29 0a 20 20 20 20 3b 3b queries*). ;;
5e60: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
5e70: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
5e80: 67 2d 70 6f 72 74 2a 20 22 41 76 65 72 61 67 65 g-port* "Average
5e90: 20 6e 6f 6e 2d 63 61 63 68 65 64 20 74 69 6d 65 non-cached time
5ea0: 20 20 20 22 0a 20 20 20 20 3b 3b 20 09 09 20 20 ". ;; ..
5eb0: 20 20 20 20 28 69 66 20 28 65 71 3f 20 2a 6e 75 (if (eq? *nu
5ec0: 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 mber-non-write-q
5ed0: 75 65 72 69 65 73 2a 20 30 29 0a 20 20 20 20 3b ueries* 0). ;
5ee0: 3b 20 09 09 09 20 20 22 6e 2f 61 20 28 6e 6f 20 ; ... "n/a (no
5ef0: 71 75 65 72 69 65 73 29 22 0a 20 20 20 20 3b 3b queries)". ;;
5f00: 20 09 09 09 20 20 28 2f 20 2a 74 6f 74 61 6c 2d ... (/ *total-
5f10: 6e 6f 6e 2d 77 72 69 74 65 2d 64 65 6c 61 79 2a non-write-delay*
5f20: 20 0a 20 20 20 20 3b 3b 20 09 09 09 20 20 20 20 . ;; ...
5f30: 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 *number-non-wri
5f40: 74 65 2d 71 75 65 72 69 65 73 2a 29 29 0a 20 20 te-queries*)).
5f50: 20 20 3b 3b 20 09 09 20 20 20 20 20 20 22 20 6d ;; .. " m
5f60: 73 22 29 0a 20 20 20 20 0a 20 20 20 20 28 64 62 s"). . (db
5f70: 3a 70 72 69 6e 74 2d 63 75 72 72 65 6e 74 2d 71 :print-current-q
5f80: 75 65 72 79 2d 73 74 61 74 73 29 0a 20 20 20 20 uery-stats).
5f90: 28 63 6f 6d 6d 6f 6e 3a 73 61 76 65 2d 70 6b 74 (common:save-pkt
5fa0: 20 60 28 28 61 63 74 69 6f 6e 20 2e 20 65 78 69 `((action . exi
5fb0: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
5fc0: 20 20 20 20 20 20 20 20 20 20 28 54 20 20 20 20 (T
5fd0: 20 20 2e 20 73 65 72 76 65 72 29 0a 20 20 20 20 . server).
5fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ff0: 20 20 20 28 70 69 64 20 20 20 20 2e 20 2c 28 63 (pid . ,(c
6000: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
6010: 64 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 d))).
6020: 20 20 20 20 20 20 20 20 20 20 2a 63 6f 6e 66 69 *confi
6030: 67 64 61 74 2a 20 23 74 29 0a 20 20 20 20 28 64 gdat* #t). (d
6040: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
6050: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
6060: 6f 72 74 2a 20 22 53 65 72 76 65 72 20 73 68 75 ort* "Server shu
6070: 74 64 6f 77 6e 20 63 6f 6d 70 6c 65 74 65 2e 20 tdown complete.
6080: 45 78 69 74 69 6e 67 22 29 0a 20 20 20 20 28 65 Exiting"). (e
6090: 78 69 74 29 29 29 0a 0a 3b 3b 20 61 6c 6c 20 72 xit)))..;; all r
60a0: 6f 75 74 65 73 20 74 68 6f 75 67 68 20 68 65 72 outes though her
60b0: 65 20 65 6e 64 20 69 6e 20 65 78 69 74 20 2e 2e e end in exit ..
60c0: 2e 0a 3b 3b 0a 3b 3b 20 73 74 61 72 74 5f 73 65 ..;;.;; start_se
60d0: 72 76 65 72 3f 20 0a 3b 3b 0a 28 64 65 66 69 6e rver? .;;.(defin
60e0: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
60f0: 74 3a 6c 61 75 6e 63 68 29 0a 20 20 3b 3b 20 63 t:launch). ;; c
6100: 68 65 63 6b 20 74 68 61 74 20 61 20 73 65 72 76 heck that a serv
6110: 65 72 20 73 74 61 72 74 20 69 73 20 69 6e 20 70 er start is in p
6120: 72 6f 67 72 65 73 73 2c 20 70 61 75 73 65 20 6f rogress, pause o
6130: 72 20 65 78 69 74 20 69 66 20 73 6f 0a 20 20 28 r exit if so. (
6140: 6c 65 74 2a 20 28 28 74 6d 70 2d 61 72 65 61 20 let* ((tmp-area
6150: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d (comm
6160: 6f 6e 3a 67 65 74 2d 64 62 2d 74 6d 70 2d 61 72 on:get-db-tmp-ar
6170: 65 61 29 29 0a 09 20 28 73 65 72 76 65 72 2d 73 ea)).. (server-s
6180: 74 61 72 74 20 20 20 20 20 20 20 20 28 63 6f 6e tart (con
6190: 63 20 74 6d 70 2d 61 72 65 61 20 22 2f 2e 73 65 c tmp-area "/.se
61a0: 72 76 65 72 2d 73 74 61 72 74 22 29 29 0a 09 20 rver-start"))..
61b0: 28 73 65 72 76 65 72 2d 73 74 61 72 74 65 64 20 (server-started
61c0: 20 20 20 20 20 28 63 6f 6e 63 20 74 6d 70 2d 61 (conc tmp-a
61d0: 72 65 61 20 22 2f 2e 73 65 72 76 65 72 2d 73 74 rea "/.server-st
61e0: 61 72 74 65 64 22 29 29 0a 09 20 28 73 74 61 72 arted")).. (star
61f0: 74 2d 74 69 6d 65 20 20 20 20 20 20 20 20 20 20 t-time
6200: 28 63 6f 6d 6d 6f 6e 3a 6c 61 7a 79 2d 6d 6f 64 (common:lazy-mod
6210: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 73 ification-time s
6220: 65 72 76 65 72 2d 73 74 61 72 74 29 29 0a 09 20 erver-start))..
6230: 28 73 74 61 72 74 65 64 2d 74 69 6d 65 20 20 20 (started-time
6240: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 6c 61 7a (common:laz
6250: 79 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 y-modification-t
6260: 69 6d 65 20 73 65 72 76 65 72 2d 73 74 61 72 74 ime server-start
6270: 65 64 29 29 0a 09 20 28 73 65 72 76 65 72 2d 73 ed)).. (server-s
6280: 74 61 72 74 69 6e 67 20 20 20 20 20 28 3c 20 73 tarting (< s
6290: 74 61 72 74 2d 74 69 6d 65 20 73 74 61 72 74 65 tart-time starte
62a0: 64 2d 74 69 6d 65 29 29 20 3b 3b 20 69 66 20 73 d-time)) ;; if s
62b0: 74 61 72 74 2d 74 69 6d 65 20 69 73 20 6c 65 73 tart-time is les
62c0: 73 20 74 68 61 6e 20 73 74 61 72 74 65 64 2d 74 s than started-t
62d0: 69 6d 65 20 74 68 65 6e 20 61 20 73 65 72 76 65 ime then a serve
62e0: 72 20 69 73 20 73 74 69 6c 6c 20 73 74 61 72 74 r is still start
62f0: 69 6e 67 0a 09 20 28 73 74 61 72 74 2d 74 69 6d ing.. (start-tim
6300: 65 2d 6f 6c 64 20 20 20 20 20 20 28 3e 20 28 2d e-old (> (-
6310: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
6320: 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 20 35 s) start-time) 5
6330: 29 29 0a 20 20 20 20 20 20 20 20 20 28 63 6c 65 )). (cle
6340: 61 6e 75 70 2d 70 72 6f 63 20 20 20 20 20 20 20 anup-proc
6350: 20 28 6c 61 6d 62 64 61 20 28 6d 73 67 29 0a 20 (lambda (msg).
6360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6380: 6c 65 74 2a 20 28 28 73 65 72 76 2d 66 6e 61 6d let* ((serv-fnam
6390: 65 20 20 20 20 20 20 28 63 6f 6e 63 20 22 73 65 e (conc "se
63a0: 72 76 65 72 2d 22 20 28 63 75 72 72 65 6e 74 2d rver-" (current-
63b0: 70 72 6f 63 65 73 73 2d 69 64 29 20 22 2d 22 20 process-id) "-"
63c0: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 (get-host-name)
63d0: 22 2e 6c 6f 67 22 29 29 0a 20 20 20 20 20 20 20 ".log")).
63e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
63f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6400: 28 66 75 6c 6c 2d 73 65 72 76 2d 66 6e 61 6d 65 (full-serv-fname
6410: 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a (conc *toppath*
6420: 20 22 2f 6c 6f 67 73 2f 22 20 73 65 72 76 2d 66 "/logs/" serv-f
6430: 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 name)).
6440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e (n
6460: 65 77 2d 73 65 72 76 2d 66 6e 61 6d 65 20 20 28 ew-serv-fname (
6470: 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
6480: 2f 6c 6f 67 73 2f 22 20 22 64 65 66 75 6e 63 74 /logs/" "defunct
6490: 2d 22 20 73 65 72 76 2d 66 6e 61 6d 65 29 29 29 -" serv-fname)))
64a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
64b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
64c0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
64d0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
64e0: 6f 72 74 2a 20 6d 73 67 29 0a 20 20 20 20 20 20 ort* msg).
64f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6500: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
6510: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
6520: 73 74 73 3f 20 66 75 6c 6c 2d 73 65 72 76 2d 66 sts? full-serv-f
6530: 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 name).
6540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6550: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 79 73 (sys
6560: 74 65 6d 20 28 63 6f 6e 63 20 22 73 6c 65 65 70 tem (conc "sleep
6570: 20 31 3b 6d 76 20 2d 66 20 22 20 66 75 6c 6c 2d 1;mv -f " full-
6580: 73 65 72 76 2d 66 6e 61 6d 65 20 22 20 22 20 6e serv-fname " " n
6590: 65 77 2d 73 65 72 76 2d 66 6e 61 6d 65 29 29 0a ew-serv-fname)).
65a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
65b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
65c0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
65d0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
65e0: 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 63 g-port* "INFO: c
65f0: 61 6e 6e 6f 74 20 6d 6f 76 65 20 22 20 66 75 6c annot move " ful
6600: 6c 2d 73 65 72 76 2d 66 6e 61 6d 65 20 22 20 74 l-serv-fname " t
6610: 6f 20 22 20 6e 65 77 2d 73 65 72 76 2d 66 6e 61 o " new-serv-fna
6620: 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 me)).
6630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6640: 20 20 20 20 20 20 20 28 65 78 69 74 29 29 29 29 (exit))))
6650: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 ). (if (and (
6660: 6e 6f 74 20 73 74 61 72 74 2d 74 69 6d 65 2d 6f not start-time-o
6670: 6c 64 29 20 3b 3b 20 6c 61 73 74 20 73 65 72 76 ld) ;; last serv
6680: 65 72 20 73 74 61 72 74 20 74 72 79 20 77 61 73 er start try was
6690: 20 6c 65 73 73 20 74 68 61 6e 20 66 69 76 65 20 less than five
66a0: 73 65 63 6f 6e 64 73 20 61 67 6f 0a 09 20 20 20 seconds ago..
66b0: 20 20 28 6e 6f 74 20 73 65 72 76 65 72 2d 73 74 (not server-st
66c0: 61 72 74 69 6e 67 29 29 0a 09 28 62 65 67 69 6e arting))..(begin
66d0: 0a 09 20 20 28 63 6c 65 61 6e 75 70 2d 70 72 6f .. (cleanup-pro
66e0: 63 20 22 4e 4f 54 20 73 74 61 72 74 69 6e 67 20 c "NOT starting
66f0: 73 65 72 76 65 72 2c 20 74 68 65 72 65 20 69 73 server, there is
6700: 20 65 69 74 68 65 72 20 61 20 72 65 63 65 6e 74 either a recent
6710: 6c 79 20 73 74 61 72 74 65 64 20 73 65 72 76 65 ly started serve
6720: 72 20 6f 72 20 61 20 73 65 72 76 65 72 20 69 6e r or a server in
6730: 20 70 72 6f 63 65 73 73 20 6f 66 20 73 74 61 72 process of star
6740: 74 69 6e 67 22 29 0a 09 20 20 28 65 78 69 74 29 ting").. (exit)
6750: 29 29 0a 20 20 20 20 3b 3b 20 6c 65 74 73 20 6e )). ;; lets n
6760: 6f 74 20 65 76 65 6e 20 62 6f 74 68 65 72 20 74 ot even bother t
6770: 6f 20 73 74 61 72 74 20 69 66 20 74 68 65 72 65 o start if there
6780: 20 61 72 65 20 61 6c 72 65 61 64 79 20 74 68 72 are already thr
6790: 65 65 20 6f 72 20 6d 6f 72 65 20 73 65 72 76 65 ee or more serve
67a0: 72 20 66 69 6c 65 73 20 72 65 61 64 79 20 74 6f r files ready to
67b0: 20 67 6f 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 go. (let* ((
67c0: 6e 75 6d 2d 61 6c 69 76 65 20 20 20 28 73 65 72 num-alive (ser
67d0: 76 65 72 3a 67 65 74 2d 6e 75 6d 2d 61 6c 69 76 ver:get-num-aliv
67e0: 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d 6c 69 e (server:get-li
67f0: 73 74 20 2a 74 6f 70 70 61 74 68 2a 29 29 29 29 st *toppath*))))
6800: 0a 20 20 20 20 20 20 28 69 66 20 28 3e 20 6e 75 . (if (> nu
6810: 6d 2d 61 6c 69 76 65 20 33 29 0a 20 20 20 20 20 m-alive 3).
6820: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
6830: 20 20 20 20 20 20 20 20 28 63 6c 65 61 6e 75 70 (cleanup
6840: 2d 70 72 6f 63 20 28 63 6f 6e 63 20 22 45 52 52 -proc (conc "ERR
6850: 4f 52 3a 20 41 62 6f 72 74 69 6e 67 20 73 65 72 OR: Aborting ser
6860: 76 65 72 20 73 74 61 72 74 20 62 65 63 61 75 73 ver start becaus
6870: 65 20 74 68 65 72 65 20 61 72 65 20 61 6c 72 65 e there are alre
6880: 61 64 79 20 22 20 6e 75 6d 2d 61 6c 69 76 65 20 ady " num-alive
6890: 22 20 70 6f 73 73 69 62 6c 65 20 73 65 72 76 65 " possible serve
68a0: 72 73 20 65 69 74 68 65 72 20 72 75 6e 6e 69 6e rs either runnin
68b0: 67 20 6f 72 20 73 74 61 72 74 69 6e 67 20 75 70 g or starting up
68c0: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
68d0: 28 65 78 69 74 29 29 29 29 0a 20 20 28 63 6f 6d (exit)))). (com
68e0: 6d 6f 6e 3a 73 61 76 65 2d 70 6b 74 20 60 28 28 mon:save-pkt `((
68f0: 61 63 74 69 6f 6e 20 2e 20 73 74 61 72 74 29 0a action . start).
6900: 09 09 20 20 20 20 20 28 54 20 20 20 20 20 20 2e .. (T .
6910: 20 73 65 72 76 65 72 29 0a 09 09 20 20 20 20 20 server)...
6920: 28 70 69 64 20 20 20 20 2e 20 2c 28 63 75 72 72 (pid . ,(curr
6930: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 ent-process-id))
6940: 29 0a 09 09 20 20 20 2a 63 6f 6e 66 69 67 64 61 )... *configda
6950: 74 2a 20 23 74 29 0a 20 20 20 20 28 6c 65 74 2a t* #t). (let*
6960: 20 28 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 ((th2 (make-thr
6970: 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 ead (lambda ().
6980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
69a0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
69b0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
69c0: 6f 72 74 2a 20 22 53 65 72 76 65 72 20 72 75 6e ort* "Server run
69d0: 20 74 68 72 65 61 64 20 73 74 61 72 74 65 64 22 thread started"
69e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
69f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a00: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
6a10: 3a 72 75 6e 20 0a 20 20 20 20 20 20 20 20 20 20 :run .
6a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a30: 20 20 20 20 20 20 28 69 66 20 28 61 72 67 73 3a (if (args:
6a40: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
6a50: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
6a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a70: 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 (args:get
6a80: 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a -arg "-server").
6a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ab0: 20 20 20 20 22 2d 22 29 0a 20 20 20 20 20 20 20 "-").
6ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ad0: 20 20 20 20 20 20 20 20 20 29 29 20 22 53 65 72 )) "Ser
6ae0: 76 65 72 20 72 75 6e 22 29 29 0a 20 20 20 20 20 ver run")).
6af0: 20 20 20 20 20 20 28 74 68 33 20 28 6d 61 6b 65 (th3 (make
6b00: 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 -thread (lambda
6b10: 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ().
6b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b30: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
6b40: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
6b50: 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 72 og-port* "Server
6b60: 20 6d 6f 6e 69 74 6f 72 20 74 68 72 65 61 64 20 monitor thread
6b70: 73 74 61 72 74 65 64 22 29 0a 20 20 20 20 20 20 started").
6b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b90: 20 20 20 20 20 20 20 20 20 28 68 74 74 70 2d 74 (http-t
6ba0: 72 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 ransport:keep-ru
6bb0: 6e 6e 69 6e 67 29 0a 20 20 20 20 20 20 20 20 20 nning).
6bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6bd0: 20 20 20 20 20 20 22 4b 65 65 70 20 72 75 6e 6e "Keep runn
6be0: 69 6e 67 22 29 29 29 29 0a 20 20 20 20 20 20 28 ing")))). (
6bf0: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th
6c00: 32 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2). (thread
6c10: 2d 73 6c 65 65 70 21 20 30 2e 32 35 29 20 3b 3b -sleep! 0.25) ;;
6c20: 20 67 69 76 65 20 74 68 65 20 73 65 72 76 65 72 give the server
6c30: 20 74 69 6d 65 20 74 6f 20 73 65 74 74 6c 65 20 time to settle
6c40: 62 65 66 6f 72 65 20 73 74 61 72 74 69 6e 67 20 before starting
6c50: 74 68 65 20 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 the keep-running
6c60: 20 6d 6f 6e 69 74 6f 72 2e 0a 20 20 20 20 20 20 monitor..
6c70: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
6c80: 68 33 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 h3). (set!
6c90: 2a 64 69 64 73 6f 6d 65 74 68 69 6e 67 2a 20 23 *didsomething* #
6ca0: 74 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 t). (thread
6cb0: 2d 6a 6f 69 6e 21 20 74 68 32 29 0a 20 20 20 20 -join! th2).
6cc0: 20 20 28 65 78 69 74 29 29 29 29 0a 0a 3b 3b 20 (exit))))..;;
6cd0: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
6ce0: 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 73 ansport:server-s
6cf0: 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 69 ignal-handler si
6d00: 67 6e 75 6d 29 0a 3b 3b 20 20 20 28 73 69 67 6e gnum).;; (sign
6d10: 61 6c 2d 6d 61 73 6b 21 20 73 69 67 6e 75 6d 29 al-mask! signum)
6d20: 0a 3b 3b 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 .;; (handle-ex
6d30: 63 65 70 74 69 6f 6e 73 0a 3b 3b 20 20 20 20 65 ceptions.;; e
6d40: 78 6e 0a 3b 3b 20 20 20 20 28 64 65 62 75 67 3a xn.;; (debug:
6d50: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
6d60: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 2e 2e 2e -log-port* " ...
6d70: 20 65 78 69 74 69 6e 67 20 2e 2e 2e 22 29 0a 3b exiting ...").;
6d80: 3b 20 20 20 20 28 6c 65 74 20 28 28 74 68 31 20 ; (let ((th1
6d90: 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 (make-thread (la
6da0: 6d 62 64 61 20 28 29 0a 3b 3b 20 09 09 09 20 20 mbda ().;; ...
6db0: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
6dc0: 21 20 31 29 29 0a 3b 3b 20 09 09 09 20 20 20 22 ! 1)).;; ... "
6dd0: 65 61 74 20 72 65 73 70 6f 6e 73 65 22 29 29 0a eat response")).
6de0: 3b 3b 20 09 20 28 74 68 32 20 28 6d 61 6b 65 2d ;; . (th2 (make-
6df0: 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 thread (lambda (
6e00: 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 28 64 65 ).;; ... (de
6e10: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
6e20: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
6e30: 6f 72 74 2a 20 22 52 65 63 65 69 76 65 64 20 5e ort* "Received ^
6e40: 43 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 63 6c C, attempting cl
6e50: 65 61 6e 20 65 78 69 74 2e 20 50 6c 65 61 73 65 ean exit. Please
6e60: 20 62 65 20 70 61 74 69 65 6e 74 20 61 6e 64 20 be patient and
6e70: 77 61 69 74 20 61 20 66 65 77 20 73 65 63 6f 6e wait a few secon
6e80: 64 73 20 62 65 66 6f 72 65 20 68 69 74 74 69 6e ds before hittin
6e90: 67 20 5e 43 20 61 67 61 69 6e 2e 22 29 0a 3b 3b g ^C again.").;;
6ea0: 20 09 09 09 20 20 20 20 20 28 74 68 72 65 61 64 ... (thread
6eb0: 2d 73 6c 65 65 70 21 20 33 29 20 3b 3b 20 67 69 -sleep! 3) ;; gi
6ec0: 76 65 20 74 68 65 20 66 6c 75 73 68 20 74 68 72 ve the flush thr
6ed0: 65 65 20 73 65 63 6f 6e 64 73 20 74 6f 20 64 6f ee seconds to do
6ee0: 20 69 74 27 73 20 73 74 75 66 66 0a 3b 3b 20 09 it's stuff.;; .
6ef0: 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
6f00: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
6f10: 6f 67 2d 70 6f 72 74 2a 20 22 20 20 20 20 20 20 og-port* "
6f20: 20 44 6f 6e 65 2e 22 29 0a 3b 3b 20 09 09 09 20 Done.").;; ...
6f30: 20 20 20 20 28 65 78 69 74 20 34 29 29 0a 3b 3b (exit 4)).;;
6f40: 20 09 09 09 20 20 20 22 65 78 69 74 20 6f 6e 20 ... "exit on
6f50: 5e 43 20 74 69 6d 65 72 22 29 29 29 0a 3b 3b 20 ^C timer"))).;;
6f60: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 (thread-sta
6f70: 72 74 21 20 74 68 32 29 0a 3b 3b 20 20 20 20 20 rt! th2).;;
6f80: 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 (thread-start!
6f90: 74 68 31 29 0a 3b 3b 20 20 20 20 20 20 28 74 68 th1).;; (th
6fa0: 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 32 29 29 read-join! th2))
6fb0: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
6fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6fe0: 3d 3d 3d 3d 3d 0a 3b 3b 20 4a 61 76 61 20 73 63 =====.;; Java sc
6ff0: 72 69 70 74 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ript.;;=========
7000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7020: 3d 3d 3d 3d 3d 3d 0a 28 64 65 66 69 6e 65 20 28 ======.(define (
7030: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
7040: 68 6f 77 2d 6a 71 75 65 72 79 29 0a 20 20 28 6c how-jquery). (l
7050: 65 74 2a 20 28 28 64 61 74 61 20 20 28 74 65 73 et* ((data (tes
7060: 74 73 3a 72 65 61 64 6c 69 6e 65 73 20 2a 6a 61 ts:readlines *ja
7070: 76 61 2d 73 63 72 69 70 74 2d 6c 69 62 2a 29 29 va-script-lib*))
7080: 29 0a 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 64 ).(string-join d
7090: 61 74 61 20 22 5c 6e 22 29 29 29 0a 0a 0a 0a 3b ata "\n")))....;
70a0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
70b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
70c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
70d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
70e0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 77 65 62 20 70 =======.;; web p
70f0: 61 67 65 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ages.;;=========
7100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
7140: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
7150: 6e 73 70 6f 72 74 3a 68 74 6d 6c 2d 74 65 73 74 nsport:html-test
7160: 2d 6c 6f 67 20 24 29 0a 20 20 20 28 6c 65 74 2a -log $). (let*
7170: 20 28 28 72 75 6e 2d 69 64 20 28 24 20 27 72 75 ((run-id ($ 'ru
7180: 6e 69 64 29 29 0a 20 20 20 20 20 20 20 20 20 28 nid)). (
7190: 74 65 73 74 2d 69 74 65 6d 20 28 24 20 27 74 65 test-item ($ 'te
71a0: 73 74 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 stname)).
71b0: 20 20 28 70 61 72 74 73 20 28 73 74 72 69 6e 67 (parts (string
71c0: 2d 73 70 6c 69 74 20 74 65 73 74 2d 69 74 65 6d -split test-item
71d0: 20 22 3a 22 29 29 0a 20 20 20 20 20 20 20 20 20 ":")).
71e0: 28 74 65 73 74 2d 6e 61 6d 65 20 28 63 61 72 20 (test-name (car
71f0: 70 61 72 74 73 29 29 0a 20 20 20 20 20 20 20 20 parts)).
7200: 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 28 . (
7210: 69 74 65 6d 2d 6e 61 6d 65 20 28 69 66 20 28 65 item-name (if (e
7220: 71 75 61 6c 3f 20 28 6c 65 6e 67 74 68 20 70 61 qual? (length pa
7230: 72 74 73 29 20 31 29 0a 20 20 20 20 20 20 20 20 rts) 1).
7240: 20 20 20 20 20 22 22 0a 20 20 20 20 20 20 20 20 "".
7250: 20 20 20 20 20 28 63 61 64 72 20 70 61 72 74 73 (cadr parts
7260: 29 29 29 29 0a 20 20 3b 28 70 72 69 6e 74 20 24 )))). ;(print $
7270: 29 20 0a 28 74 65 73 74 73 3a 67 65 74 2d 74 65 ) .(tests:get-te
7280: 73 74 2d 6c 6f 67 20 72 75 6e 2d 69 64 20 74 65 st-log run-id te
7290: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 6e 61 6d st-name item-nam
72a0: 65 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 e)))...(define (
72b0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 68 http-transport:h
72c0: 74 6d 6c 2d 64 62 6f 61 72 64 20 24 29 0a 20 20 tml-dboard $).
72d0: 28 6c 65 74 2a 20 28 28 70 61 67 65 20 28 24 20 (let* ((page ($
72e0: 27 70 61 67 65 29 29 0a 20 20 20 20 20 20 20 20 'page)).
72f0: 20 28 6f 75 70 20 20 20 20 20 20 20 28 6f 70 65 (oup (ope
7300: 6e 2d 6f 75 74 70 75 74 2d 73 74 72 69 6e 67 29 n-output-string)
7310: 29 20 0a 20 20 20 20 20 20 20 20 20 28 62 64 79 ) . (bdy
7320: 20 22 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d "--------------
7330: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 22 29 0a 0a ------------")..
7340: 20 20 20 20 20 20 20 20 20 28 72 65 74 20 20 28 (ret (
7350: 74 65 73 74 73 3a 64 79 6e 61 6d 69 63 2d 64 62 tests:dynamic-db
7360: 6f 61 72 64 20 70 61 67 65 29 29 29 0a 20 20 20 oard page))).
7370: 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 20 20 (s:output-new
7380: 6f 75 70 20 20 72 65 74 29 0a 20 20 20 28 63 6c oup ret). (cl
7390: 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 ose-output-port
73a0: 6f 75 70 29 0a 0a 20 20 28 73 65 74 21 20 62 64 oup).. (set! bd
73b0: 79 20 20 20 28 67 65 74 2d 6f 75 74 70 75 74 2d y (get-output-
73c0: 73 74 72 69 6e 67 20 6f 75 70 29 29 0a 20 20 20 string oup)).
73d0: 20 20 28 63 6f 6e 63 20 22 3c 68 31 3e 44 61 73 (conc "<h1>Das
73e0: 68 62 6f 61 72 64 3c 2f 68 31 3e 22 20 62 64 79 hboard</h1>" bdy
73f0: 20 22 3c 62 72 2f 3e 20 3c 62 72 2f 3e 20 22 20 "<br/> <br/> "
7400: 20 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 )))..(define (h
7410: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6d 61 ttp-transport:ma
7420: 69 6e 2d 70 61 67 65 29 0a 20 20 28 6c 65 74 20 in-page). (let
7430: 28 28 6c 69 6e 6b 70 61 74 68 20 28 72 6f 6f 74 ((linkpath (root
7440: 2d 70 61 74 68 29 29 29 0a 20 20 20 20 28 63 6f -path))). (co
7450: 6e 63 20 22 3c 68 65 61 64 3e 3c 68 31 3e 22 20 nc "<head><h1>"
7460: 28 70 61 74 68 6e 61 6d 65 2d 73 74 72 69 70 2d (pathname-strip-
7470: 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 directory *toppa
7480: 74 68 2a 29 20 22 3c 2f 68 31 3e 3c 2f 68 65 61 th*) "</h1></hea
7490: 64 3e 22 0a 09 20 20 22 3c 62 6f 64 79 3e 22 0a d>".. "<body>".
74a0: 09 20 20 22 52 75 6e 20 61 72 65 61 3a 20 22 20 . "Run area: "
74b0: 2a 74 6f 70 70 61 74 68 2a 0a 09 20 20 22 3c 68 *toppath*.. "<h
74c0: 32 3e 53 65 72 76 65 72 20 53 74 61 74 73 3c 2f 2>Server Stats</
74d0: 68 32 3e 22 0a 09 20 20 28 68 74 74 70 2d 74 72 h2>".. (http-tr
74e0: 61 6e 73 70 6f 72 74 3a 73 74 61 74 73 2d 74 61 ansport:stats-ta
74f0: 62 6c 65 29 20 0a 09 20 20 22 3c 68 72 3e 22 0a ble) .. "<hr>".
7500: 09 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f . (http-transpo
7510: 72 74 3a 72 75 6e 73 20 6c 69 6e 6b 70 61 74 68 rt:runs linkpath
7520: 29 0a 09 20 20 22 3c 68 72 3e 22 0a 09 20 20 28 ).. "<hr>".. (
7530: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 http-transport:r
7540: 75 6e 2d 73 74 61 74 73 29 0a 09 20 20 22 3c 2f un-stats).. "</
7550: 62 6f 64 79 3e 22 0a 09 20 20 29 29 29 0a 0a 28 body>".. )))..(
7560: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
7570: 6e 73 70 6f 72 74 3a 73 74 61 74 73 2d 74 61 62 nsport:stats-tab
7580: 6c 65 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 le). (mutex-loc
7590: 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 k! *heartbeat-mu
75a0: 74 65 78 2a 29 0a 20 20 28 6c 65 74 20 28 28 72 tex*). (let ((r
75b0: 65 73 20 0a 09 20 28 63 6f 6e 63 20 22 3c 74 61 es .. (conc "<ta
75c0: 62 6c 65 3e 22 0a 09 20 20 20 20 20 20 20 3b 3b ble>".. ;;
75d0: 20 22 3c 74 72 3e 3c 74 64 3e 4d 61 78 20 63 61 "<tr><td>Max ca
75e0: 63 68 65 64 20 71 75 65 72 69 65 73 3c 2f 74 64 ched queries</td
75f0: 3e 20 20 20 20 20 20 20 20 3c 74 64 3e 22 20 2a > <td>" *
7600: 6d 61 78 2d 63 61 63 68 65 2d 73 69 7a 65 2a 20 max-cache-size*
7610: 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 "</td></tr>"..
7620: 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4e 75 "<tr><td>Nu
7630: 6d 62 65 72 20 6f 66 20 63 61 63 68 65 64 20 77 mber of cached w
7640: 72 69 74 65 73 3c 2f 74 64 3e 20 20 20 3c 74 64 rites</td> <td
7650: 3e 22 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 >" *number-of-wr
7660: 69 74 65 73 2a 20 22 3c 2f 74 64 3e 3c 2f 74 72 ites* "</td></tr
7670: 3e 22 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e >".. "<tr>
7680: 3c 74 64 3e 41 76 65 72 61 67 65 20 63 61 63 68 <td>Average cach
7690: 65 64 20 77 72 69 74 65 20 74 69 6d 65 3c 2f 74 ed write time</t
76a0: 64 3e 20 3c 74 64 3e 22 20 28 69 66 20 28 65 71 d> <td>" (if (eq
76b0: 3f 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 ? *number-of-wri
76c0: 74 65 73 2a 20 30 29 0a 09 09 09 09 09 09 09 09 tes* 0).........
76d0: 20 22 6e 2f 61 20 28 6e 6f 20 77 72 69 74 65 73 "n/a (no writes
76e0: 29 22 0a 09 09 09 09 09 09 09 09 20 28 2f 20 2a )"......... (/ *
76f0: 77 72 69 74 65 73 2d 74 6f 74 61 6c 2d 64 65 6c writes-total-del
7700: 61 79 2a 0a 09 09 09 09 09 09 09 09 20 20 20 20 ay*.........
7710: 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 *number-of-write
7720: 73 2a 29 29 0a 09 20 20 20 20 20 20 20 22 20 6d s*)).. " m
7730: 73 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 s</td></tr>"..
7740: 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4e 75 "<tr><td>Nu
7750: 6d 62 65 72 20 6e 6f 6e 2d 63 61 63 68 65 64 20 mber non-cached
7760: 71 75 65 72 69 65 73 3c 2f 74 64 3e 20 3c 74 64 queries</td> <td
7770: 3e 22 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d >" *number-non-
7780: 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a 20 22 write-queries* "
7790: 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 </td></tr>"..
77a0: 20 20 20 20 3b 3b 20 22 3c 74 72 3e 3c 74 64 3e ;; "<tr><td>
77b0: 41 76 65 72 61 67 65 20 6e 6f 6e 2d 63 61 63 68 Average non-cach
77c0: 65 64 20 74 69 6d 65 3c 2f 74 64 3e 20 20 20 3c ed time</td> <
77d0: 74 64 3e 22 20 28 69 66 20 28 65 71 3f 20 2a 6e td>" (if (eq? *n
77e0: 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d umber-non-write-
77f0: 71 75 65 72 69 65 73 2a 20 30 29 0a 09 20 20 20 queries* 0)..
7800: 20 20 20 20 3b 3b 20 09 09 09 09 09 09 09 20 22 ;; ....... "
7810: 6e 2f 61 20 28 6e 6f 20 71 75 65 72 69 65 73 29 n/a (no queries)
7820: 22 0a 09 20 20 20 20 20 20 20 3b 3b 20 09 09 09 ".. ;; ...
7830: 09 09 09 09 20 28 2f 20 2a 74 6f 74 61 6c 2d 6e .... (/ *total-n
7840: 6f 6e 2d 77 72 69 74 65 2d 64 65 6c 61 79 2a 20 on-write-delay*
7850: 0a 09 20 20 20 20 20 20 20 3b 3b 20 09 09 09 09 .. ;; ....
7860: 09 09 09 20 20 20 20 2a 6e 75 6d 62 65 72 2d 6e ... *number-n
7870: 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 73 on-write-queries
7880: 2a 29 29 0a 09 20 20 20 20 20 20 20 22 20 6d 73 *)).. " ms
7890: 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 </td></tr>"..
78a0: 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4c 61 73 "<tr><td>Las
78b0: 74 20 61 63 63 65 73 73 3c 2f 74 64 3e 3c 74 64 t access</td><td
78c0: 3e 22 20 20 20 20 20 20 20 20 20 20 20 20 20 20 >"
78d0: 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 (seconds->time-s
78e0: 74 72 69 6e 67 20 2a 64 62 2d 6c 61 73 74 2d 61 tring *db-last-a
78f0: 63 63 65 73 73 2a 29 20 22 3c 2f 74 64 3e 3c 2f ccess*) "</td></
7900: 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c 2f tr>".. "</
7910: 74 61 62 6c 65 3e 22 29 29 29 0a 20 20 20 20 28 table>"))). (
7920: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 mutex-unlock! *h
7930: 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 eartbeat-mutex*)
7940: 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 . res))..(def
7950: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
7960: 6f 72 74 3a 72 75 6e 73 20 6c 69 6e 6b 70 61 74 ort:runs linkpat
7970: 68 29 0a 20 20 28 63 6f 6e 63 20 22 3c 68 33 3e h). (conc "<h3>
7980: 52 75 6e 73 3c 2f 68 33 3e 22 0a 09 28 73 74 72 Runs</h3>"..(str
7990: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 0a ing-intersperse.
79a0: 09 20 28 6c 65 74 20 28 28 66 69 6c 65 73 20 28 . (let ((files (
79b0: 6d 61 70 20 70 61 74 68 6e 61 6d 65 2d 73 74 72 map pathname-str
79c0: 69 70 2d 64 69 72 65 63 74 6f 72 79 20 28 67 6c ip-directory (gl
79d0: 6f 62 20 28 63 6f 6e 63 20 6c 69 6e 6b 70 61 74 ob (conc linkpat
79e0: 68 20 22 2f 2a 22 29 29 29 29 29 0a 09 20 20 20 h "/*")))))..
79f0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 70 29 (map (lambda (p)
7a00: 0a 09 09 20 20 28 63 6f 6e 63 20 22 3c 61 20 68 ... (conc "<a h
7a10: 72 65 66 3d 5c 22 22 20 70 20 22 5c 22 3e 22 20 ref=\"" p "\">"
7a20: 70 20 22 3c 2f 61 3e 3c 62 72 3e 22 29 29 0a 09 p "</a><br>"))..
7a30: 09 66 69 6c 65 73 29 29 0a 09 20 22 20 22 29 29 .files)).. " "))
7a40: 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 )..(define (http
7a50: 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 2d 73 -transport:run-s
7a60: 74 61 74 73 29 0a 20 20 28 6c 65 74 20 28 28 73 tats). (let ((s
7a70: 74 61 74 73 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 tats (open-run-c
7a80: 6c 6f 73 65 20 64 62 3a 67 65 74 2d 72 75 6e 6e lose db:get-runn
7a90: 69 6e 67 2d 73 74 61 74 73 20 23 66 29 29 29 0a ing-stats #f))).
7aa0: 20 20 20 20 28 63 6f 6e 63 20 22 3c 74 61 62 6c (conc "<tabl
7ab0: 65 3e 22 0a 09 20 20 28 73 74 72 69 6e 67 2d 69 e>".. (string-i
7ac0: 6e 74 65 72 73 70 65 72 73 65 0a 09 20 20 20 28 ntersperse.. (
7ad0: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 73 74 61 map (lambda (sta
7ae0: 74 29 0a 09 09 20 20 28 63 6f 6e 63 20 22 3c 74 t)... (conc "<t
7af0: 72 3e 3c 74 64 3e 22 20 28 63 61 72 20 73 74 61 r><td>" (car sta
7b00: 74 29 20 22 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 t) "</td><td>" (
7b10: 63 61 64 72 20 73 74 61 74 29 20 22 3c 2f 74 64 cadr stat) "</td
7b20: 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 73 74 61 74 ></tr>"))...stat
7b30: 73 29 0a 09 20 20 20 22 20 22 29 0a 09 20 20 22 s).. " ").. "
7b40: 3c 2f 74 61 62 6c 65 3e 22 29 29 29 0a </table>"))).