Artifact
b18d5a6f653c28d51c6bf64da3d0d8f3221d6d78:
0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 32 2c 20 4d 61 74 74 68 65 77 06-2012, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 28 72 65 71 75 PURPOSE...(requ
0150: 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 73 ire-extension (s
0160: 72 66 69 20 31 38 29 20 65 78 74 72 61 73 20 74 rfi 18) extras t
0170: 63 70 20 73 31 31 6e 29 0a 0a 28 75 73 65 20 20 cp s11n)..(use
0180: 73 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 67 srfi-1 posix reg
0190: 65 78 20 72 65 67 65 78 2d 63 61 73 65 20 73 72 ex regex-case sr
01a0: 66 69 2d 36 39 20 68 6f 73 74 69 6e 66 6f 20 6d fi-69 hostinfo m
01b0: 64 35 20 6d 65 73 73 61 67 65 2d 64 69 67 65 73 d5 message-diges
01c0: 74 29 20 3b 3b 20 73 71 6c 69 74 65 33 0a 3b 3b t) ;; sqlite3.;;
01d0: 20 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 (import (prefix
01e0: 20 73 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 sqlite3 sqlite3
01f0: 3a 29 29 0a 0a 28 75 73 65 20 73 70 69 66 66 79 :))..(use spiffy
0200: 20 75 72 69 2d 63 6f 6d 6d 6f 6e 20 69 6e 74 61 uri-common inta
0210: 72 77 65 62 20 68 74 74 70 2d 63 6c 69 65 6e 74 rweb http-client
0220: 20 73 70 69 66 66 79 2d 72 65 71 75 65 73 74 2d spiffy-request-
0230: 76 61 72 73 20 69 6e 74 61 72 77 65 62 20 73 70 vars intarweb sp
0240: 69 66 66 79 2d 64 69 72 65 63 74 6f 72 79 2d 6c iffy-directory-l
0250: 69 73 74 69 6e 67 29 0a 0a 3b 3b 20 43 6f 6e 66 isting)..;; Conf
0260: 69 67 75 72 61 74 69 6f 6e 73 20 66 6f 72 20 73 igurations for s
0270: 65 72 76 65 72 0a 28 74 63 70 2d 62 75 66 66 65 erver.(tcp-buffe
0280: 72 2d 73 69 7a 65 20 32 30 34 38 29 0a 28 6d 61 r-size 2048).(ma
0290: 78 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 32 30 x-connections 20
02a0: 34 38 29 20 0a 0a 28 64 65 63 6c 61 72 65 20 28 48) ..(declare (
02b0: 75 6e 69 74 20 68 74 74 70 2d 74 72 61 6e 73 70 unit http-transp
02c0: 6f 72 74 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 ort))..(declare
02d0: 28 75 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 (uses common)).(
02e0: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 62 declare (uses db
02f0: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0300: 73 20 74 65 73 74 73 29 29 0a 28 64 65 63 6c 61 s tests)).(decla
0310: 72 65 20 28 75 73 65 73 20 74 61 73 6b 73 29 29 re (uses tasks))
0320: 20 3b 3b 20 74 61 73 6b 73 20 61 72 65 20 77 68 ;; tasks are wh
0330: 65 72 65 20 73 74 75 66 66 20 69 73 20 6d 61 69 ere stuff is mai
0340: 6e 74 61 69 6e 65 64 20 61 62 6f 75 74 20 77 68 ntained about wh
0350: 61 74 20 69 73 20 72 75 6e 6e 69 6e 67 2e 0a 28 at is running..(
0360: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 65 declare (uses se
0370: 72 76 65 72 29 29 0a 28 64 65 63 6c 61 72 65 20 rver)).(declare
0380: 28 75 73 65 73 20 64 61 65 6d 6f 6e 29 29 0a 28 (uses daemon)).(
0390: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 70 6f declare (uses po
03a0: 72 74 6c 6f 67 67 65 72 29 29 0a 28 64 65 63 6c rtlogger)).(decl
03b0: 61 72 65 20 28 75 73 65 73 20 72 6d 74 29 29 0a are (uses rmt)).
03c0: 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f .(include "commo
03d0: 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a n_records.scm").
03e0: 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 63 (include "db_rec
03f0: 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 28 64 65 66 ords.scm")..(def
0400: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
0410: 6f 72 74 3a 6d 61 6b 65 2d 73 65 72 76 65 72 2d ort:make-server-
0420: 75 72 6c 20 68 6f 73 74 70 6f 72 74 29 0a 20 20 url hostport).
0430: 28 69 66 20 28 6e 6f 74 20 68 6f 73 74 70 6f 72 (if (not hostpor
0440: 74 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 t). #f.
0450: 20 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f (conc "http://
0460: 22 20 28 63 61 72 20 68 6f 73 74 70 6f 72 74 29 " (car hostport)
0470: 20 22 3a 22 20 28 63 61 64 72 20 68 6f 73 74 70 ":" (cadr hostp
0480: 6f 72 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ort))))..(define
0490: 20 2a 73 65 72 76 65 72 2d 6c 6f 6f 70 2d 68 65 *server-loop-he
04a0: 61 72 74 2d 62 65 61 74 2a 20 28 63 75 72 72 65 art-beat* (curre
04b0: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 0a 3b 3b nt-seconds))..;;
04c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0500: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 20 ======.;; S E R
0510: 56 20 45 20 52 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d V E R.;;========
0520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
0560: 3b 3b 20 43 61 6c 6c 20 74 68 69 73 20 74 6f 20 ;; Call this to
0570: 73 74 61 72 74 20 74 68 65 20 61 63 74 75 61 6c start the actual
0580: 20 73 65 72 76 65 72 0a 3b 3b 0a 0a 28 64 65 66 server.;;..(def
0590: 69 6e 65 20 2a 64 62 3a 70 72 6f 63 65 73 73 2d ine *db:process-
05a0: 71 75 65 75 65 2d 6d 75 74 65 78 2a 20 28 6d 61 queue-mutex* (ma
05b0: 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 28 64 65 66 ke-mutex))..(def
05c0: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
05d0: 6f 72 74 3a 72 75 6e 20 68 6f 73 74 6e 20 72 75 ort:run hostn ru
05e0: 6e 2d 69 64 20 73 65 72 76 65 72 2d 69 64 29 0a n-id server-id).
05f0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
0600: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
0610: 72 74 2a 20 22 41 74 74 65 6d 70 74 69 6e 67 20 rt* "Attempting
0620: 74 6f 20 73 74 61 72 74 20 74 68 65 20 73 65 72 to start the ser
0630: 76 65 72 20 2e 2e 2e 22 29 0a 20 20 28 6c 65 74 ver ..."). (let
0640: 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 20 * ((db
0650: 20 20 20 20 23 66 29 20 3b 3b 20 20 20 20 20 20 #f) ;;
0660: 20 20 28 6f 70 65 6e 2d 64 62 29 29 20 3b 3b 20 (open-db)) ;;
0670: 77 65 20 64 6f 6e 27 74 20 77 61 6e 74 20 74 68 we don't want th
0680: 65 20 73 65 72 76 65 72 20 74 6f 20 62 65 20 6f e server to be o
0690: 70 65 6e 69 6e 67 20 61 6e 64 20 63 6c 6f 73 69 pening and closi
06a0: 6e 67 20 74 68 65 20 64 62 20 75 6e 6e 65 63 65 ng the db unnece
06b0: 73 61 72 69 6c 79 0a 09 20 28 68 6f 73 74 6e 61 sarily.. (hostna
06c0: 6d 65 20 20 20 20 20 20 20 20 28 67 65 74 2d 68 me (get-h
06d0: 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 69 70 ost-name)).. (ip
06e0: 61 64 64 72 73 74 72 20 20 20 20 20 20 20 28 6c addrstr (l
06f0: 65 74 20 28 28 69 70 73 74 72 20 28 69 66 20 28 et ((ipstr (if (
0700: 73 74 72 69 6e 67 3d 3f 20 22 2d 22 20 68 6f 73 string=? "-" hos
0710: 74 6e 29 0a 09 09 09 09 09 20 20 20 3b 3b 20 28 tn)...... ;; (
0720: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
0730: 73 65 20 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e se (map number->
0740: 73 74 72 69 6e 67 20 28 75 38 76 65 63 74 6f 72 string (u8vector
0750: 2d 3e 6c 69 73 74 20 28 68 6f 73 74 6e 61 6d 65 ->list (hostname
0760: 2d 3e 69 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 ->ip hostname)))
0770: 20 22 2e 22 29 0a 09 09 09 09 09 20 20 20 28 73 ".")...... (s
0780: 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 erver:get-best-g
0790: 75 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f 73 uess-address hos
07a0: 74 6e 61 6d 65 29 0a 09 09 09 09 09 20 20 20 23 tname)...... #
07b0: 66 29 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 f))).... (if
07c0: 69 70 73 74 72 20 69 70 73 74 72 20 68 6f 73 74 ipstr ipstr host
07d0: 6e 29 29 29 20 3b 3b 20 68 6f 73 74 6e 61 6d 65 n))) ;; hostname
07e0: 29 29 29 20 0a 09 20 28 73 74 61 72 74 2d 70 6f ))) .. (start-po
07f0: 72 74 20 20 20 20 20 20 28 70 6f 72 74 6c 6f 67 rt (portlog
0800: 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f ger:open-run-clo
0810: 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 66 69 se portlogger:fi
0820: 6e 64 2d 70 6f 72 74 29 29 0a 09 20 28 6c 69 6e nd-port)).. (lin
0830: 6b 2d 74 72 65 65 2d 70 61 74 68 20 20 28 63 6f k-tree-path (co
0840: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
0850: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
0860: 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 29 0a 20 "linktree"))).
0870: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
0880: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
0890: 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 6f 72 74 6c log-port* "portl
08a0: 6f 67 67 65 72 20 72 65 63 6f 6d 6d 65 6e 64 65 ogger recommende
08b0: 64 20 70 6f 72 74 3a 20 22 20 73 74 61 72 74 2d d port: " start-
08c0: 70 6f 72 74 29 0a 20 20 20 20 28 72 6f 6f 74 2d port). (root-
08d0: 70 61 74 68 20 20 20 20 20 28 69 66 20 6c 69 6e path (if lin
08e0: 6b 2d 74 72 65 65 2d 70 61 74 68 20 0a 09 09 20 k-tree-path ...
08f0: 20 20 20 20 20 20 6c 69 6e 6b 2d 74 72 65 65 2d link-tree-
0900: 70 61 74 68 0a 09 09 20 20 20 20 20 20 20 28 63 path... (c
0910: 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 urrent-directory
0920: 29 29 29 20 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 ))) ;; WARNING:
0930: 53 45 43 55 52 49 54 59 20 48 4f 4c 45 2e 20 46 SECURITY HOLE. F
0940: 49 58 20 41 53 41 50 21 0a 20 20 20 20 28 68 61 IX ASAP!. (ha
0950: 6e 64 6c 65 2d 64 69 72 65 63 74 6f 72 79 20 73 ndle-directory s
0960: 70 69 66 66 79 2d 64 69 72 65 63 74 6f 72 79 2d piffy-directory-
0970: 6c 69 73 74 69 6e 67 29 0a 20 20 20 20 28 68 61 listing). (ha
0980: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 20 28 ndle-exception (
0990: 6c 61 6d 62 64 61 20 28 65 78 6e 20 63 68 61 69 lambda (exn chai
09a0: 6e 29 0a 09 09 09 28 73 69 67 6e 61 6c 20 28 6d n)....(signal (m
09b0: 61 6b 65 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 6f ake-composite-co
09c0: 6e 64 69 74 69 6f 6e 0a 09 09 09 09 20 28 6d 61 ndition..... (ma
09d0: 6b 65 2d 70 72 6f 70 65 72 74 79 2d 63 6f 6e 64 ke-property-cond
09e0: 69 74 69 6f 6e 20 0a 09 09 09 09 20 20 27 73 65 ition ..... 'se
09f0: 72 76 65 72 0a 09 09 09 09 20 20 27 6d 65 73 73 rver..... 'mess
0a00: 61 67 65 20 22 73 65 72 76 65 72 20 65 72 72 6f age "server erro
0a10: 72 22 29 29 29 29 29 0a 0a 20 20 20 20 3b 3b 20 r"))))).. ;;
0a20: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 68 http-transport:h
0a30: 61 6e 64 6c 65 2d 64 69 72 65 63 74 6f 72 79 29 andle-directory)
0a40: 20 3b 3b 20 73 69 6d 70 6c 65 2d 64 69 72 65 63 ;; simple-direc
0a50: 74 6f 72 79 2d 68 61 6e 64 6c 65 72 29 0a 20 20 tory-handler).
0a60: 20 20 3b 3b 20 53 65 74 75 70 20 74 68 65 20 77 ;; Setup the w
0a70: 65 62 20 73 65 72 76 65 72 20 61 6e 64 20 61 20 eb server and a
0a80: 2f 63 74 72 6c 20 69 6e 74 65 72 66 61 63 65 0a /ctrl interface.
0a90: 20 20 20 20 3b 3b 0a 20 20 20 20 28 76 68 6f 73 ;;. (vhos
0aa0: 74 2d 6d 61 70 20 60 28 28 28 2a 20 61 6e 79 29 t-map `(((* any)
0ab0: 20 2e 20 2c 28 6c 61 6d 62 64 61 20 28 63 6f 6e . ,(lambda (con
0ac0: 74 69 6e 75 65 29 0a 09 09 09 20 20 20 20 20 20 tinue)....
0ad0: 20 3b 3b 20 6f 70 65 6e 20 74 68 65 20 64 62 20 ;; open the db
0ae0: 6f 6e 20 74 68 65 20 66 69 72 73 74 20 63 61 6c on the first cal
0af0: 6c 20 0a 09 09 09 09 20 3b 3b 20 54 68 69 73 20 l ..... ;; This
0b00: 69 73 20 77 65 72 65 20 77 65 20 73 65 74 20 75 is were we set u
0b10: 70 20 74 68 65 20 64 61 74 61 62 61 73 65 20 63 p the database c
0b20: 6f 6e 6e 65 63 74 69 6f 6e 73 0a 09 09 09 20 20 onnections....
0b30: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 24 20 20 (let* (($
0b40: 20 28 72 65 71 75 65 73 74 2d 76 61 72 73 20 73 (request-vars s
0b50: 6f 75 72 63 65 3a 20 27 62 6f 74 68 29 29 0a 09 ource: 'both))..
0b60: 09 09 09 20 20 20 20 20 20 28 64 61 74 20 28 24 ... (dat ($
0b70: 20 27 64 61 74 29 29 0a 09 09 09 09 20 20 20 20 'dat)).....
0b80: 20 20 28 72 65 73 20 23 66 29 29 0a 09 09 09 09 (res #f)).....
0b90: 20 28 63 6f 6e 64 0a 09 09 09 09 20 20 28 28 65 (cond..... ((e
0ba0: 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 qual? (uri-path
0bb0: 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 (request-uri (cu
0bc0: 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 rrent-request)))
0bd0: 0a 09 09 09 09 09 20 20 20 27 28 2f 20 22 61 70 ...... '(/ "ap
0be0: 69 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e i"))..... (sen
0bf0: 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a d-response body:
0c00: 20 20 20 20 28 61 70 69 3a 70 72 6f 63 65 73 73 (api:process
0c10: 2d 72 65 71 75 65 73 74 20 2a 64 62 73 74 72 75 -request *dbstru
0c20: 63 74 2d 64 62 2a 20 24 29 20 3b 3b 20 74 68 65 ct-db* $) ;; the
0c30: 20 24 20 69 73 20 74 68 65 20 72 65 71 75 65 73 $ is the reques
0c40: 74 20 76 61 72 73 20 70 72 6f 63 0a 09 09 09 09 t vars proc.....
0c50: 09 09 20 20 68 65 61 64 65 72 73 3a 20 27 28 28 .. headers: '((
0c60: 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 65 78 content-type tex
0c70: 74 2f 70 6c 61 69 6e 29 29 29 0a 09 09 09 09 20 t/plain))).....
0c80: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
0c90: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
0ca0: 29 0a 09 09 09 09 20 20 20 28 73 65 74 21 20 2a )..... (set! *
0cb0: 64 62 2d 6c 61 73 74 61 63 63 65 73 73 2a 20 28 db-lastaccess* (
0cc0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
0cd0: 29 0a 09 09 09 09 20 20 20 28 6d 75 74 65 78 2d )..... (mutex-
0ce0: 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 unlock! *heartbe
0cf0: 61 74 2d 6d 75 74 65 78 2a 29 29 0a 09 09 09 09 at-mutex*)).....
0d00: 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 69 2d ((equal? (uri-
0d10: 70 61 74 68 20 28 72 65 71 75 65 73 74 2d 75 72 path (request-ur
0d20: 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 75 65 i (current-reque
0d30: 73 74 29 29 29 20 0a 09 09 09 09 09 20 20 20 27 st))) ...... '
0d40: 28 2f 20 22 22 29 29 0a 09 09 09 09 20 20 20 28 (/ ""))..... (
0d50: 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f send-response bo
0d60: 64 79 3a 20 28 68 74 74 70 2d 74 72 61 6e 73 70 dy: (http-transp
0d70: 6f 72 74 3a 6d 61 69 6e 2d 70 61 67 65 29 29 29 ort:main-page)))
0d80: 0a 09 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 ..... ((equal?
0d90: 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 (uri-path (reque
0da0: 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d st-uri (current-
0db0: 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 09 09 request))) .....
0dc0: 09 20 20 20 27 28 2f 20 22 6a 73 6f 6e 5f 61 70 . '(/ "json_ap
0dd0: 69 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e i"))..... (sen
0de0: 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a d-response body:
0df0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
0e00: 3a 6d 61 69 6e 2d 70 61 67 65 29 29 29 0a 09 09 :main-page)))...
0e10: 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 .. ((equal? (ur
0e20: 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 2d i-path (request-
0e30: 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 uri (current-req
0e40: 75 65 73 74 29 29 29 20 0a 09 09 09 09 09 20 20 uest))) ......
0e50: 20 27 28 2f 20 22 72 75 6e 73 22 29 29 0a 09 09 '(/ "runs"))...
0e60: 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f .. (send-respo
0e70: 6e 73 65 20 62 6f 64 79 3a 20 28 68 74 74 70 2d nse body: (http-
0e80: 74 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 transport:main-p
0e90: 61 67 65 29 29 29 0a 09 09 09 09 20 20 28 28 65 age)))..... ((e
0ea0: 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 qual? (uri-path
0eb0: 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 (request-uri (cu
0ec0: 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 rrent-request)))
0ed0: 20 0a 09 09 09 09 09 20 20 20 27 28 2f 20 61 6e ...... '(/ an
0ee0: 79 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e 64 y))..... (send
0ef0: 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 -response body:
0f00: 22 68 65 79 20 74 68 65 72 65 21 5c 6e 22 0a 09 "hey there!\n"..
0f10: 09 09 09 09 09 20 20 68 65 61 64 65 72 73 3a 20 ..... headers:
0f20: 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 '((content-type
0f30: 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 29 0a 09 text/plain))))..
0f40: 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 ... ((equal? (u
0f50: 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 ri-path (request
0f60: 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 -uri (current-re
0f70: 71 75 65 73 74 29 29 29 20 0a 09 09 09 09 09 20 quest))) ......
0f80: 20 20 27 28 2f 20 22 68 65 79 22 29 29 0a 09 09 '(/ "hey"))...
0f90: 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f .. (send-respo
0fa0: 6e 73 65 20 62 6f 64 79 3a 20 22 68 65 79 20 74 nse body: "hey t
0fb0: 68 65 72 65 21 5c 6e 22 0a 09 09 09 09 09 09 20 here!\n".......
0fc0: 20 68 65 61 64 65 72 73 3a 20 27 28 28 63 6f 6e headers: '((con
0fd0: 74 65 6e 74 2d 74 79 70 65 20 74 65 78 74 2f 70 tent-type text/p
0fe0: 6c 61 69 6e 29 29 29 29 0a 09 09 09 09 20 20 28 lain))))..... (
0ff0: 65 6c 73 65 20 28 63 6f 6e 74 69 6e 75 65 29 29 else (continue))
1000: 29 29 29 29 29 29 0a 20 20 20 20 28 68 74 74 70 )))))). (http
1010: 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 -transport:try-s
1020: 74 61 72 74 2d 73 65 72 76 65 72 20 72 75 6e 2d tart-server run-
1030: 69 64 20 69 70 61 64 64 72 73 74 72 20 73 74 61 id ipaddrstr sta
1040: 72 74 2d 70 6f 72 74 20 73 65 72 76 65 72 2d 69 rt-port server-i
1050: 64 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 69 73 d)))..;; This is
1060: 20 72 65 63 75 72 73 69 76 65 6c 79 20 72 75 6e recursively run
1070: 20 62 79 20 68 74 74 70 2d 74 72 61 6e 73 70 6f by http-transpo
1080: 72 74 3a 72 75 6e 20 75 6e 74 69 6c 20 73 75 63 rt:run until suc
1090: 65 73 73 66 75 6c 0a 3b 3b 0a 28 64 65 66 69 6e essful.;;.(defin
10a0: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
10b0: 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 76 t:try-start-serv
10c0: 65 72 20 72 75 6e 2d 69 64 20 69 70 61 64 64 72 er run-id ipaddr
10d0: 73 74 72 20 70 6f 72 74 6e 75 6d 20 73 65 72 76 str portnum serv
10e0: 65 72 2d 69 64 29 0a 20 20 28 6c 65 74 20 28 28 er-id). (let ((
10f0: 63 6f 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 20 config-hostname
1100: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
1110: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 *configdat* "ser
1120: 76 65 72 22 20 22 68 6f 73 74 6e 61 6d 65 22 29 ver" "hostname")
1130: 29 0a 09 28 74 64 62 64 61 74 20 20 20 20 20 20 )..(tdbdat
1140: 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d (tasks:open-
1150: 64 62 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 db))). (debug
1160: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
1170: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1180: 20 22 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 "http-transport
1190: 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 76 65 :try-start-serve
11a0: 72 20 74 69 6d 65 3d 22 20 28 73 65 63 6f 6e 64 r time=" (second
11b0: 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 28 s->time-string (
11c0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
11d0: 29 20 22 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e ) " run-id=" run
11e0: 2d 69 64 20 22 20 69 70 61 64 64 72 73 73 74 72 -id " ipaddrsstr
11f0: 3d 22 20 69 70 61 64 64 72 73 74 72 20 22 20 70 =" ipaddrstr " p
1200: 6f 72 74 6e 75 6d 3d 22 20 70 6f 72 74 6e 75 6d ortnum=" portnum
1210: 20 22 20 73 65 72 76 65 72 2d 69 64 3d 22 20 73 " server-id=" s
1220: 65 72 76 65 72 2d 69 64 20 22 20 63 6f 6e 66 69 erver-id " confi
1230: 67 2d 68 6f 73 74 6e 61 6d 65 3d 22 20 63 6f 6e g-hostname=" con
1240: 66 69 67 2d 68 6f 73 74 6e 61 6d 65 29 0a 20 20 fig-hostname).
1250: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
1260: 69 6f 6e 73 0a 20 20 20 20 20 65 78 6e 0a 20 20 ions. exn.
1270: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
1280: 20 28 70 72 69 6e 74 2d 65 72 72 6f 72 2d 6d 65 (print-error-me
1290: 73 73 61 67 65 20 65 78 6e 29 0a 20 20 20 20 20 ssage exn).
12a0: 20 20 28 69 66 20 28 3c 20 70 6f 72 74 6e 75 6d (if (< portnum
12b0: 20 36 34 30 30 30 29 0a 09 20 20 20 28 62 65 67 64000).. (beg
12c0: 69 6e 20 0a 09 20 20 20 20 20 28 64 65 62 75 67 in .. (debug
12d0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
12e0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
12f0: 4e 49 4e 47 3a 20 61 74 74 65 6d 70 74 20 74 6f NING: attempt to
1300: 20 73 74 61 72 74 20 73 65 72 76 65 72 20 66 61 start server fa
1310: 69 6c 65 64 2e 20 54 72 79 69 6e 67 20 61 67 61 iled. Trying aga
1320: 69 6e 20 2e 2e 2e 22 29 0a 09 20 20 20 20 20 28 in ...").. (
1330: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
1340: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1350: 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 " message: " ((
1360: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
1370: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
1380: 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 'message) exn))
1390: 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
13a0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
13b0: 6f 67 2d 70 6f 72 74 2a 20 22 65 78 6e 3d 22 20 og-port* "exn="
13c0: 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 (condition->list
13d0: 20 65 78 6e 29 29 0a 09 20 20 20 20 20 28 70 6f exn)).. (po
13e0: 72 74 6c 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 75 rtlogger:open-ru
13f0: 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 67 n-close portlogg
1400: 65 72 3a 73 65 74 2d 66 61 69 6c 65 64 20 70 6f er:set-failed po
1410: 72 74 6e 75 6d 29 0a 09 20 20 20 20 20 28 64 65 rtnum).. (de
1420: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
1430: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1440: 57 41 52 4e 49 4e 47 3a 20 66 61 69 6c 65 64 20 WARNING: failed
1450: 74 6f 20 73 74 61 72 74 20 6f 6e 20 70 6f 72 74 to start on port
1460: 6e 75 6d 3a 20 22 20 70 6f 72 74 6e 75 6d 20 22 num: " portnum "
1470: 2c 20 74 72 79 69 6e 67 20 6e 65 78 74 20 70 6f , trying next po
1480: 72 74 22 29 0a 09 20 20 20 20 20 28 74 68 72 65 rt").. (thre
1490: 61 64 2d 73 6c 65 65 70 21 20 30 2e 31 29 0a 0a ad-sleep! 0.1)..
14a0: 09 20 20 20 20 20 3b 3b 20 67 65 74 5f 6e 65 78 . ;; get_nex
14b0: 74 5f 70 6f 72 74 20 67 6f 65 73 20 68 65 72 65 t_port goes here
14c0: 0a 09 20 20 20 20 20 28 68 74 74 70 2d 74 72 61 .. (http-tra
14d0: 6e 73 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 74 nsport:try-start
14e0: 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 0a 09 -server run-id..
14f0: 09 09 09 09 20 20 20 20 20 20 69 70 61 64 64 72 .... ipaddr
1500: 73 74 72 0a 09 09 09 09 09 20 20 20 20 20 20 28 str...... (
1510: 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 6e 2d portlogger:open-
1520: 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 6c 6f run-close portlo
1530: 67 67 65 72 3a 66 69 6e 64 2d 70 6f 72 74 29 0a gger:find-port).
1540: 09 09 09 09 09 20 20 20 20 20 20 73 65 72 76 65 ..... serve
1550: 72 2d 69 64 29 29 0a 09 20 20 20 28 62 65 67 69 r-id)).. (begi
1560: 6e 0a 09 20 20 20 20 20 28 74 61 73 6b 73 3a 73 n.. (tasks:s
1570: 65 72 76 65 72 2d 66 6f 72 63 65 2d 63 6c 65 61 erver-force-clea
1580: 6e 2d 72 75 6e 2d 72 65 63 6f 72 64 20 28 64 62 n-run-record (db
1590: 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 :delay-if-busy t
15a0: 64 62 64 61 74 29 20 72 75 6e 2d 69 64 20 69 70 dbdat) run-id ip
15b0: 61 64 64 72 73 74 72 20 70 6f 72 74 6e 75 6d 20 addrstr portnum
15c0: 22 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 " http-transport
15d0: 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 76 65 :try-start-serve
15e0: 72 22 29 0a 09 20 20 20 20 20 28 70 72 69 6e 74 r").. (print
15f0: 20 22 45 52 52 4f 52 3a 20 54 72 69 65 64 20 61 "ERROR: Tried a
1600: 6e 64 20 74 72 69 65 64 20 62 75 74 20 63 6f 75 nd tried but cou
1610: 6c 64 20 6e 6f 74 20 73 74 61 72 74 20 74 68 65 ld not start the
1620: 20 73 65 72 76 65 72 22 29 29 29 29 0a 20 20 20 server")))).
1630: 20 20 3b 3b 20 61 6e 79 20 65 72 72 6f 72 20 69 ;; any error i
1640: 6e 20 66 6f 6c 6c 6f 77 69 6e 67 20 73 74 65 70 n following step
1650: 73 20 77 69 6c 6c 20 72 65 73 75 6c 74 20 69 6e s will result in
1660: 20 61 20 72 65 74 72 79 0a 20 20 20 20 20 28 73 a retry. (s
1670: 65 74 21 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f et! *server-info
1680: 2a 20 28 6c 69 73 74 20 69 70 61 64 64 72 73 74 * (list ipaddrst
1690: 72 20 70 6f 72 74 6e 75 6d 29 29 0a 20 20 20 20 r portnum)).
16a0: 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 73 (tasks:server-s
16b0: 65 74 2d 69 6e 74 65 72 66 61 63 65 2d 70 6f 72 et-interface-por
16c0: 74 20 0a 09 09 20 20 20 20 20 28 64 62 3a 64 65 t ... (db:de
16d0: 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 62 64 lay-if-busy tdbd
16e0: 61 74 29 0a 09 09 20 20 20 20 20 73 65 72 76 65 at)... serve
16f0: 72 2d 69 64 20 0a 09 09 20 20 20 20 20 69 70 61 r-id ... ipa
1700: 64 64 72 73 74 72 20 70 6f 72 74 6e 75 6d 29 0a ddrstr portnum).
1710: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1720: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
1730: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 54 72 -port* "INFO: Tr
1740: 79 69 6e 67 20 74 6f 20 73 74 61 72 74 20 73 65 ying to start se
1750: 72 76 65 72 20 6f 6e 20 22 20 69 70 61 64 64 72 rver on " ipaddr
1760: 73 74 72 20 22 3a 22 20 70 6f 72 74 6e 75 6d 29 str ":" portnum)
1770: 0a 20 20 20 20 20 3b 3b 20 54 68 69 73 20 73 74 . ;; This st
1780: 61 72 74 73 20 74 68 65 20 73 70 69 66 66 79 20 arts the spiffy
1790: 73 65 72 76 65 72 0a 20 20 20 20 20 3b 3b 20 4e server. ;; N
17a0: 45 45 44 20 57 41 59 20 54 4f 20 53 45 54 20 49 EED WAY TO SET I
17b0: 50 20 54 4f 20 23 66 20 54 4f 20 42 49 4e 44 20 P TO #f TO BIND
17c0: 41 4c 4c 0a 20 20 20 20 20 3b 3b 20 28 73 74 61 ALL. ;; (sta
17d0: 72 74 2d 73 65 72 76 65 72 20 62 69 6e 64 2d 61 rt-server bind-a
17e0: 64 64 72 65 73 73 3a 20 69 70 61 64 64 72 73 74 ddress: ipaddrst
17f0: 72 20 70 6f 72 74 3a 20 70 6f 72 74 6e 75 6d 29 r port: portnum)
1800: 0a 20 20 20 20 20 28 69 66 20 63 6f 6e 66 69 67 . (if config
1810: 2d 68 6f 73 74 6e 61 6d 65 20 3b 3b 20 74 68 69 -hostname ;; thi
1820: 73 20 69 73 20 61 20 68 69 6e 74 20 74 6f 20 62 s is a hint to b
1830: 69 6e 64 20 64 69 72 65 63 74 6c 79 0a 09 20 28 ind directly.. (
1840: 73 74 61 72 74 2d 73 65 72 76 65 72 20 70 6f 72 start-server por
1850: 74 3a 20 70 6f 72 74 6e 75 6d 20 62 69 6e 64 2d t: portnum bind-
1860: 61 64 64 72 65 73 73 3a 20 28 69 66 20 28 65 71 address: (if (eq
1870: 75 61 6c 3f 20 63 6f 6e 66 69 67 2d 68 6f 73 74 ual? config-host
1880: 6e 61 6d 65 20 22 2d 22 29 0a 09 09 09 09 09 09 name "-").......
1890: 20 20 20 20 20 20 20 69 70 61 64 64 72 73 74 72 ipaddrstr
18a0: 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 63 6f ....... co
18b0: 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 29 29 0a nfig-hostname)).
18c0: 09 20 28 73 74 61 72 74 2d 73 65 72 76 65 72 20 . (start-server
18d0: 70 6f 72 74 3a 20 70 6f 72 74 6e 75 6d 29 29 0a port: portnum)).
18e0: 20 20 20 20 20 3b 3b 20 20 28 70 6f 72 74 6c 6f ;; (portlo
18f0: 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c gger:open-run-cl
1900: 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 73 ose portlogger:s
1910: 65 74 2d 70 6f 72 74 20 70 6f 72 74 6e 75 6d 20 et-port portnum
1920: 22 72 65 6c 65 61 73 65 64 22 29 0a 20 20 20 20 "released").
1930: 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 66 (tasks:server-f
1940: 6f 72 63 65 2d 63 6c 65 61 6e 2d 72 75 6e 2d 72 orce-clean-run-r
1950: 65 63 6f 72 64 20 28 64 62 3a 64 65 6c 61 79 2d ecord (db:delay-
1960: 69 66 2d 62 75 73 79 20 74 64 62 64 61 74 29 20 if-busy tdbdat)
1970: 72 75 6e 2d 69 64 20 69 70 61 64 64 72 73 74 72 run-id ipaddrstr
1980: 20 70 6f 72 74 6e 75 6d 20 22 20 68 74 74 70 2d portnum " http-
1990: 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 74 transport:try-st
19a0: 61 72 74 2d 73 65 72 76 65 72 22 29 0a 20 20 20 art-server").
19b0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
19c0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
19d0: 72 74 2a 20 22 49 4e 46 4f 3a 20 73 65 72 76 65 rt* "INFO: serve
19e0: 72 20 68 61 73 20 62 65 65 6e 20 73 74 6f 70 70 r has been stopp
19f0: 65 64 22 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d ed"))))..;;=====
1a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a40: 3d 0a 3b 3b 20 53 20 45 20 52 20 56 20 45 20 52 =.;; S E R V E R
1a50: 20 20 20 55 20 54 20 49 20 4c 20 49 20 54 20 49 U T I L I T I
1a60: 20 45 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d E S .;;========
1a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
1ab0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
1ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1af0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 20 4c 20 ========.;; C L
1b00: 49 20 45 20 4e 20 54 20 53 0a 3b 3b 3d 3d 3d 3d I E N T S.;;====
1b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b50: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 2a 68 74 74 ==..(define *htt
1b60: 70 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d p-mutex* (make-m
1b70: 75 74 65 78 29 29 0a 0a 3b 3b 20 4e 4f 54 45 3a utex))..;; NOTE:
1b80: 20 4c 61 72 67 65 20 62 6c 6f 63 6b 20 6f 66 20 Large block of
1b90: 63 6f 64 65 20 66 72 6f 6d 20 33 32 34 33 36 62 code from 32436b
1ba0: 34 32 36 31 38 38 30 38 30 66 37 32 66 63 65 62 426188080f72fceb
1bb0: 36 38 39 34 61 66 35 34 31 66 62 61 64 39 39 32 6894af541fbad992
1bc0: 31 65 20 72 65 6d 6f 76 65 64 20 68 65 72 65 0a 1e removed here.
1bd0: 3b 3b 20 20 20 20 20 20 20 49 27 6d 20 70 72 65 ;; I'm pre
1be0: 74 74 79 20 73 75 72 65 20 69 74 20 69 73 20 64 tty sure it is d
1bf0: 65 66 75 6e 63 74 2e 0a 0a 3b 3b 20 54 68 69 73 efunct...;; This
1c00: 20 6e 65 78 74 20 62 6c 6f 63 6b 20 61 6c 6c 20 next block all
1c10: 69 6d 70 6f 72 74 65 64 20 65 6e 2d 6d 61 73 73 imported en-mass
1c20: 20 66 72 6f 6d 20 74 68 65 20 61 70 69 20 62 72 from the api br
1c30: 61 6e 63 68 0a 28 64 65 66 69 6e 65 20 2a 68 74 anch.(define *ht
1c40: 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 tp-requests-in-p
1c50: 72 6f 67 72 65 73 73 2a 20 30 29 0a 28 64 65 66 rogress* 0).(def
1c60: 69 6e 65 20 2a 68 74 74 70 2d 63 6f 6e 6e 65 63 ine *http-connec
1c70: 74 69 6f 6e 73 2d 6e 65 78 74 2d 63 6c 65 61 6e tions-next-clean
1c80: 75 70 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 up* (current-sec
1c90: 6f 6e 64 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 onds))..(define
1ca0: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
1cb0: 67 65 74 2d 74 69 6d 65 2d 74 6f 2d 63 6c 65 61 get-time-to-clea
1cc0: 6e 75 70 29 0a 20 20 28 6c 65 74 20 28 28 72 65 nup). (let ((re
1cd0: 73 20 23 66 29 29 0a 20 20 20 20 28 6d 75 74 65 s #f)). (mute
1ce0: 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 x-lock! *http-mu
1cf0: 74 65 78 2a 29 0a 20 20 20 20 28 73 65 74 21 20 tex*). (set!
1d00: 72 65 73 20 28 3e 20 28 63 75 72 72 65 6e 74 2d res (> (current-
1d10: 73 65 63 6f 6e 64 73 29 20 2a 68 74 74 70 2d 63 seconds) *http-c
1d20: 6f 6e 6e 65 63 74 69 6f 6e 73 2d 6e 65 78 74 2d onnections-next-
1d30: 63 6c 65 61 6e 75 70 2a 29 29 0a 20 20 20 20 28 cleanup*)). (
1d40: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 mutex-unlock! *h
1d50: 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 ttp-mutex*).
1d60: 72 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 res))..(define (
1d70: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 69 http-transport:i
1d80: 6e 63 2d 72 65 71 75 65 73 74 73 2d 63 6f 75 6e nc-requests-coun
1d90: 74 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b t). (mutex-lock
1da0: 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a ! *http-mutex*).
1db0: 20 20 28 73 65 74 21 20 2a 68 74 74 70 2d 72 65 (set! *http-re
1dc0: 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 quests-in-progre
1dd0: 73 73 2a 20 28 2b 20 31 20 2a 68 74 74 70 2d 72 ss* (+ 1 *http-r
1de0: 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 equests-in-progr
1df0: 65 73 73 2a 29 29 0a 20 20 3b 3b 20 55 73 65 20 ess*)). ;; Use
1e00: 74 68 69 73 20 6f 70 70 6f 72 74 75 6e 69 74 79 this opportunity
1e10: 20 74 6f 20 73 6c 6f 77 20 74 68 69 6e 67 73 20 to slow things
1e20: 64 6f 77 6e 20 69 66 66 20 74 68 65 72 65 20 61 down iff there a
1e30: 72 65 20 74 6f 6f 20 6d 61 6e 79 20 72 65 71 75 re too many requ
1e40: 65 73 74 73 20 69 6e 20 66 6c 69 67 68 74 0a 20 ests in flight.
1e50: 20 28 69 66 20 28 3e 20 2a 68 74 74 70 2d 72 65 (if (> *http-re
1e60: 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 quests-in-progre
1e70: 73 73 2a 20 35 29 0a 20 20 20 20 20 20 28 62 65 ss* 5). (be
1e80: 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e gin..(debug:prin
1e90: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
1ea0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 68 6f t-log-port* "Who
1eb0: 61 20 74 68 65 72 65 20 62 75 64 64 79 2c 20 65 a there buddy, e
1ec0: 61 73 65 20 75 70 2e 2e 2e 22 29 0a 09 28 74 68 ase up...")..(th
1ed0: 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 29 29 read-sleep! 1)))
1ee0: 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b . (mutex-unlock
1ef0: 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 29 ! *http-mutex*))
1f00: 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ..(define (http-
1f10: 74 72 61 6e 73 70 6f 72 74 3a 64 65 63 2d 72 65 transport:dec-re
1f20: 71 75 65 73 74 73 2d 63 6f 75 6e 74 20 70 72 6f quests-count pro
1f30: 63 29 20 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 c) . (mutex-loc
1f40: 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 k! *http-mutex*)
1f50: 0a 20 20 28 70 72 6f 63 29 0a 20 20 28 73 65 74 . (proc). (set
1f60: 21 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 ! *http-requests
1f70: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 28 2d -in-progress* (-
1f80: 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d *http-requests-
1f90: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 31 29 29 in-progress* 1))
1fa0: 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b . (mutex-unlock
1fb0: 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 29 ! *http-mutex*))
1fc0: 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ..(define (http-
1fd0: 74 72 61 6e 73 70 6f 72 74 3a 64 65 63 2d 72 65 transport:dec-re
1fe0: 71 75 65 73 74 73 2d 63 6f 75 6e 74 2d 61 6e 64 quests-count-and
1ff0: 2d 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 -close-all-conne
2000: 63 74 69 6f 6e 73 29 0a 20 20 28 73 65 74 21 20 ctions). (set!
2010: 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 *http-requests-i
2020: 6e 2d 70 72 6f 67 72 65 73 73 2a 20 28 2d 20 2a n-progress* (- *
2030: 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e http-requests-in
2040: 2d 70 72 6f 67 72 65 73 73 2a 20 31 29 29 0a 20 -progress* 1)).
2050: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 65 74 69 (let loop ((eti
2060: 6d 65 20 28 2b 20 28 63 75 72 72 65 6e 74 2d 73 me (+ (current-s
2070: 65 63 6f 6e 64 73 29 20 35 29 29 29 20 3b 3b 20 econds) 5))) ;;
2080: 67 69 76 65 20 75 70 20 69 6e 20 66 69 76 65 20 give up in five
2090: 73 65 63 6f 6e 64 73 0a 20 20 20 20 28 69 66 20 seconds. (if
20a0: 28 3e 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 (> *http-request
20b0: 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 30 s-in-progress* 0
20c0: 29 0a 09 28 69 66 20 28 3e 20 65 74 69 6d 65 20 )..(if (> etime
20d0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
20e0: 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 )).. (begin..
20f0: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
2100: 65 65 70 21 20 30 2e 30 35 29 0a 09 20 20 20 20 eep! 0.05)..
2110: 20 20 28 6c 6f 6f 70 20 65 74 69 6d 65 29 29 0a (loop etime)).
2120: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
2130: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
2140: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 lt-log-port* "re
2150: 71 75 65 73 74 73 20 73 74 69 6c 6c 20 69 6e 20 quests still in
2160: 70 72 6f 67 72 65 73 73 20 61 66 74 65 72 20 35 progress after 5
2170: 20 73 65 63 6f 6e 64 73 20 6f 66 20 77 61 69 74 seconds of wait
2180: 69 6e 67 2e 20 49 27 6d 20 67 6f 69 6e 67 20 74 ing. I'm going t
2190: 6f 20 70 61 73 73 20 6f 6e 20 63 6c 65 61 6e 69 o pass on cleani
21a0: 6e 67 20 75 70 20 68 74 74 70 20 63 6f 6e 6e 65 ng up http conne
21b0: 63 74 69 6f 6e 73 22 29 29 0a 09 28 63 6c 6f 73 ctions"))..(clos
21c0: 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e e-all-connection
21d0: 73 21 29 29 29 0a 20 20 28 73 65 74 21 20 2a 68 s!))). (set! *h
21e0: 74 74 70 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 2d ttp-connections-
21f0: 6e 65 78 74 2d 63 6c 65 61 6e 75 70 2a 20 28 2b next-cleanup* (+
2200: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
2210: 73 29 20 31 30 29 29 0a 20 20 28 6d 75 74 65 78 s) 10)). (mutex
2220: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d -unlock! *http-m
2230: 75 74 65 78 2a 29 29 0a 0a 28 64 65 66 69 6e 65 utex*))..(define
2240: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
2250: 3a 69 6e 63 2d 72 65 71 75 65 73 74 73 2d 61 6e :inc-requests-an
2260: 64 2d 70 72 65 70 2d 74 6f 2d 63 6c 6f 73 65 2d d-prep-to-close-
2270: 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 29 all-connections)
2280: 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 . (mutex-lock!
2290: 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 *http-mutex*).
22a0: 28 73 65 74 21 20 2a 68 74 74 70 2d 72 65 71 75 (set! *http-requ
22b0: 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 ests-in-progress
22c0: 2a 20 28 2b 20 31 20 2a 68 74 74 70 2d 72 65 71 * (+ 1 *http-req
22d0: 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 uests-in-progres
22e0: 73 2a 29 29 29 0a 0a 3b 3b 20 53 65 6e 64 20 22 s*)))..;; Send "
22f0: 63 6d 64 22 20 77 69 74 68 20 6a 73 6f 6e 20 70 cmd" with json p
2300: 61 79 6c 6f 61 64 20 22 70 61 72 61 6d 73 22 20 ayload "params"
2310: 74 6f 20 73 65 72 76 65 72 64 61 74 20 61 6e 64 to serverdat and
2320: 20 72 65 63 65 69 76 65 20 72 65 73 75 6c 74 0a receive result.
2330: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 ;;.(define (http
2340: 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e -transport:clien
2350: 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 t-api-send-recei
2360: 76 65 20 72 75 6e 2d 69 64 20 73 65 72 76 65 72 ve run-id server
2370: 64 61 74 20 63 6d 64 20 70 61 72 61 6d 73 20 23 dat cmd params #
2380: 21 6b 65 79 20 28 6e 75 6d 72 65 74 72 69 65 73 !key (numretries
2390: 20 33 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 3)). (let* ((f
23a0: 75 6c 6c 75 72 6c 20 20 20 20 28 69 66 20 28 76 ullurl (if (v
23b0: 65 63 74 6f 72 3f 20 73 65 72 76 65 72 64 61 74 ector? serverdat
23c0: 29 0a 09 09 09 20 28 68 74 74 70 2d 74 72 61 6e ).... (http-tran
23d0: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 sport:server-dat
23e0: 2d 67 65 74 2d 61 70 69 2d 72 65 71 20 73 65 72 -get-api-req ser
23f0: 76 65 72 64 61 74 29 0a 09 09 09 20 28 62 65 67 verdat).... (beg
2400: 69 6e 0a 09 09 09 20 20 20 28 64 65 62 75 67 3a in.... (debug:
2410: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
2420: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 41 54 41 -log-port* "FATA
2430: 4c 20 45 52 52 4f 52 3a 20 68 74 74 70 2d 74 72 L ERROR: http-tr
2440: 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 ansport:client-a
2450: 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 20 pi-send-receive
2460: 63 61 6c 6c 65 64 20 77 69 74 68 20 6e 6f 20 73 called with no s
2470: 65 72 76 65 72 20 69 6e 66 6f 22 29 0a 09 09 09 erver info")....
2480: 20 20 20 28 65 78 69 74 20 31 29 29 29 29 0a 09 (exit 1))))..
2490: 20 28 72 65 73 20 20 20 20 20 20 20 20 23 66 29 (res #f)
24a0: 0a 09 20 28 73 75 63 63 65 73 73 20 20 20 20 23 .. (success #
24b0: 74 29 0a 09 20 28 73 70 61 72 61 6d 73 20 20 20 t).. (sparams
24c0: 20 28 64 62 3a 6f 62 6a 2d 3e 73 74 72 69 6e 67 (db:obj->string
24d0: 20 70 61 72 61 6d 73 20 74 72 61 6e 73 70 6f 72 params transpor
24e0: 74 3a 20 27 68 74 74 70 29 29 29 0a 20 20 20 20 t: 'http))).
24f0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
2500: 69 6e 66 6f 20 31 31 20 2a 64 65 66 61 75 6c 74 info 11 *default
2510: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 75 6c 6c -log-port* "full
2520: 75 72 6c 3d 22 20 66 75 6c 6c 75 72 6c 20 22 2c url=" fullurl ",
2530: 20 63 6d 64 3d 22 20 63 6d 64 20 22 2c 20 70 61 cmd=" cmd ", pa
2540: 72 61 6d 73 3d 22 20 70 61 72 61 6d 73 20 22 2c rams=" params ",
2550: 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 run-id=" run-id
2560: 20 22 5c 6e 22 29 0a 20 20 20 20 20 20 20 3b 3b "\n"). ;;
2570: 20 73 65 74 20 75 70 20 74 68 65 20 68 74 74 70 set up the http
2580: 2d 63 6c 69 65 6e 74 20 68 65 72 65 0a 20 20 20 -client here.
2590: 20 20 20 20 28 6d 61 78 2d 72 65 74 72 79 2d 61 (max-retry-a
25a0: 74 74 65 6d 70 74 73 20 31 29 0a 20 20 20 20 20 ttempts 1).
25b0: 20 20 3b 3b 20 63 6f 6e 73 69 64 65 72 20 61 6c ;; consider al
25c0: 6c 20 72 65 71 75 65 73 74 73 20 69 6e 64 65 6d l requests indem
25d0: 70 6f 74 65 6e 74 0a 20 20 20 20 20 20 20 28 72 potent. (r
25e0: 65 74 72 79 2d 72 65 71 75 65 73 74 3f 20 28 6c etry-request? (l
25f0: 61 6d 62 64 61 20 28 72 65 71 75 65 73 74 29 0a ambda (request).
2600: 09 09 09 20 23 66 29 29 0a 20 20 20 20 20 20 20 ... #f)).
2610: 3b 3b 20 73 65 6e 64 20 74 68 65 20 64 61 74 61 ;; send the data
2620: 20 61 6e 64 20 67 65 74 20 74 68 65 20 72 65 73 and get the res
2630: 70 6f 6e 73 65 0a 20 20 20 20 20 20 20 3b 3b 20 ponse. ;;
2640: 65 78 74 72 61 63 74 20 74 68 65 20 6e 65 65 64 extract the need
2650: 65 64 20 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 ed info from the
2660: 20 68 74 74 70 20 64 61 74 61 20 61 6e 64 20 0a http data and .
2670: 20 20 20 20 20 20 20 3b 3b 20 70 72 6f 63 65 73 ;; proces
2680: 73 20 61 6e 64 20 72 65 74 75 72 6e 20 69 74 2e s and return it.
2690: 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
26a0: 73 65 6e 64 2d 72 65 63 69 65 76 65 20 28 6c 61 send-recieve (la
26b0: 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 mbda ()....
26c0: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 (mutex-lock! *h
26d0: 74 74 70 2d 6d 75 74 65 78 2a 29 0a 09 09 09 20 ttp-mutex*)....
26e0: 20 20 20 20 20 3b 3b 20 28 63 6f 6e 64 69 74 69 ;; (conditi
26f0: 6f 6e 2d 63 61 73 65 20 28 77 69 74 68 2d 69 6e on-case (with-in
2700: 70 75 74 2d 66 72 6f 6d 2d 72 65 71 75 65 73 74 put-from-request
2710: 20 22 68 74 74 70 3a 2f 2f 6c 6f 63 61 6c 68 6f "http://localho
2720: 73 74 22 3b 20 23 66 20 72 65 61 64 2d 6c 69 6e st"; #f read-lin
2730: 65 73 29 0a 09 09 09 20 20 20 20 20 20 3b 3b 09 es).... ;;.
2740: 09 09 09 09 20 20 20 20 20 20 20 28 28 65 78 6e .... ((exn
2750: 20 68 74 74 70 20 63 6c 69 65 6e 74 2d 65 72 72 http client-err
2760: 6f 72 29 20 65 20 28 70 72 69 6e 74 20 65 29 29 or) e (print e))
2770: 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 74 21 ).... (set!
2780: 20 72 65 73 20 28 76 65 63 74 6f 72 0a 09 09 09 res (vector....
2790: 09 09 20 73 75 63 63 65 73 73 0a 09 09 09 09 09 .. success......
27a0: 20 28 64 62 3a 73 74 72 69 6e 67 2d 3e 6f 62 6a (db:string->obj
27b0: 20 0a 09 09 09 09 09 20 20 28 68 61 6e 64 6c 65 ...... (handle
27c0: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 -exceptions.....
27d0: 09 20 20 20 65 78 6e 0a 09 09 09 09 09 20 20 20 . exn......
27e0: 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 20 20 (begin......
27f0: 20 28 73 65 74 21 20 73 75 63 63 65 73 73 20 23 (set! success #
2800: 66 29 0a 09 09 09 09 09 20 20 20 20 20 28 64 65 f)...... (de
2810: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
2820: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
2830: 57 41 52 4e 49 4e 47 3a 20 66 61 69 6c 75 72 65 WARNING: failure
2840: 20 69 6e 20 77 69 74 68 2d 69 6e 70 75 74 2d 66 in with-input-f
2850: 72 6f 6d 2d 72 65 71 75 65 73 74 20 74 6f 20 22 rom-request to "
2860: 20 66 75 6c 6c 75 72 6c 20 22 2e 22 29 0a 09 09 fullurl ".")...
2870: 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ... (debug:p
2880: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
2890: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 log-port* " mess
28a0: 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 age: " ((conditi
28b0: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
28c0: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
28d0: 67 65 29 20 65 78 6e 29 29 0a 09 09 09 09 09 20 ge) exn))......
28e0: 20 20 20 20 28 69 66 20 2a 72 75 6e 72 65 6d 6f (if *runremo
28f0: 74 65 2a 0a 20 20 20 20 20 20 20 20 20 20 20 20 te*.
2900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2920: 20 20 20 20 20 28 72 65 6d 6f 74 65 2d 63 6f 6e (remote-con
2930: 6e 64 61 74 2d 73 65 74 21 20 2a 72 75 6e 72 65 ndat-set! *runre
2940: 6d 6f 74 65 2a 20 23 66 29 29 0a 09 09 09 09 09 mote* #f))......
2950: 20 20 20 20 20 3b 3b 20 4b 69 6c 6c 69 6e 67 20 ;; Killing
2960: 61 73 73 6f 63 69 61 74 65 64 20 73 65 72 76 65 associated serve
2970: 72 20 74 6f 20 61 6c 6c 6f 77 20 63 6c 65 61 6e r to allow clean
2980: 20 72 65 74 72 79 2e 22 29 0a 09 09 09 09 09 20 retry.")......
2990: 20 20 20 20 3b 3b 20 28 74 61 73 6b 73 3a 6b 69 ;; (tasks:ki
29a0: 6c 6c 2d 73 65 72 76 65 72 2d 72 75 6e 2d 69 64 ll-server-run-id
29b0: 20 72 75 6e 2d 69 64 29 20 20 3b 3b 20 62 65 74 run-id) ;; bet
29c0: 74 65 72 20 74 6f 20 6b 69 6c 6c 20 74 68 65 20 ter to kill the
29d0: 73 65 72 76 65 72 20 69 6e 20 74 68 65 20 6c 6f server in the lo
29e0: 67 69 63 20 74 68 61 74 20 63 61 6c 6c 65 64 20 gic that called
29f0: 74 68 69 73 20 72 6f 75 74 69 6e 65 3f 0a 09 09 this routine?...
2a00: 09 09 09 20 20 20 20 20 28 6d 75 74 65 78 2d 75 ... (mutex-u
2a10: 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 nlock! *http-mut
2a20: 65 78 2a 29 0a 09 09 09 09 09 20 20 20 20 20 3b ex*)...... ;
2a30: 3b 3b 20 28 73 69 67 6e 61 6c 20 28 6d 61 6b 65 ;; (signal (make
2a40: 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 6f 6e 64 69 -composite-condi
2a50: 74 69 6f 6e 0a 09 09 09 09 09 20 20 20 20 20 3b tion...... ;
2a60: 3b 3b 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b ;; (mak
2a70: 65 2d 70 72 6f 70 65 72 74 79 2d 63 6f 6e 64 69 e-property-condi
2a80: 74 69 6f 6e 20 27 63 6f 6d 6d 66 61 69 6c 20 27 tion 'commfail '
2a90: 6d 65 73 73 61 67 65 20 22 66 61 69 6c 65 64 20 message "failed
2aa0: 74 6f 20 63 6f 6e 6e 65 63 74 20 74 6f 20 73 65 to connect to se
2ab0: 72 76 65 72 22 29 29 29 0a 09 09 09 09 09 20 20 rver")))......
2ac0: 20 20 20 3b 3b 3b 20 22 63 6f 6d 6d 75 6e 69 63 ;;; "communic
2ad0: 61 74 69 6f 6e 73 20 66 61 69 6c 65 64 22 0a 09 ations failed"..
2ae0: 09 09 09 09 20 20 20 20 20 28 64 62 3a 6f 62 6a .... (db:obj
2af0: 2d 3e 73 74 72 69 6e 67 20 23 66 29 29 0a 09 09 ->string #f))...
2b00: 09 09 09 20 20 20 28 77 69 74 68 2d 69 6e 70 75 ... (with-inpu
2b10: 74 2d 66 72 6f 6d 2d 72 65 71 75 65 73 74 20 3b t-from-request ;
2b20: 3b 20 77 61 73 20 64 61 74 0a 09 09 09 09 09 20 ; was dat......
2b30: 20 20 20 66 75 6c 6c 75 72 6c 20 0a 09 09 09 09 fullurl .....
2b40: 09 20 20 20 20 28 6c 69 73 74 20 28 63 6f 6e 73 . (list (cons
2b50: 20 27 6b 65 79 20 22 74 68 65 6b 65 79 22 29 0a 'key "thekey").
2b60: 09 09 09 09 09 09 20 20 28 63 6f 6e 73 20 27 63 ...... (cons 'c
2b70: 6d 64 20 63 6d 64 29 0a 09 09 09 09 09 09 20 20 md cmd).......
2b80: 28 63 6f 6e 73 20 27 70 61 72 61 6d 73 20 73 70 (cons 'params sp
2b90: 61 72 61 6d 73 29 29 0a 09 09 09 09 09 20 20 20 arams))......
2ba0: 20 72 65 61 64 2d 73 74 72 69 6e 67 29 29 0a 09 read-string))..
2bb0: 09 09 09 09 20 20 74 72 61 6e 73 70 6f 72 74 3a .... transport:
2bc0: 20 27 68 74 74 70 29 0a 20 20 20 20 20 20 20 20 'http).
2bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2bf0: 20 30 29 29 20 3b 3b 20 61 64 64 65 64 20 74 68 0)) ;; added th
2c00: 69 73 20 73 70 65 63 75 6c 61 74 69 76 65 6c 79 is speculatively
2c10: 0a 09 09 09 20 20 20 20 20 20 3b 3b 20 53 68 6f .... ;; Sho
2c20: 75 6c 64 6e 27 74 20 74 68 69 73 20 62 65 20 61 uldn't this be a
2c30: 20 63 61 6c 6c 20 74 6f 20 74 68 65 20 6d 61 6e call to the man
2c40: 61 67 65 64 20 63 61 6c 6c 2d 61 6c 6c 2d 63 6f aged call-all-co
2c50: 6e 6e 65 63 74 69 6f 6e 73 20 73 74 75 66 66 20 nnections stuff
2c60: 61 62 6f 76 65 3f 0a 09 09 09 20 20 20 20 20 20 above?....
2c70: 28 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 (close-all-conne
2c80: 63 74 69 6f 6e 73 21 29 0a 09 09 09 20 20 20 20 ctions!)....
2c90: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
2ca0: 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 09 *http-mutex*)..
2cb0: 09 09 20 20 20 20 20 20 29 29 0a 09 20 20 20 20 .. ))..
2cc0: 20 20 28 74 69 6d 65 2d 6f 75 74 20 20 20 20 20 (time-out
2cd0: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 (lambda ()....
2ce0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
2cf0: 70 21 20 34 35 29 0a 09 09 09 20 20 20 20 20 20 p! 45)....
2d00: 23 66 29 29 0a 09 20 20 20 20 20 20 28 74 68 31 #f)).. (th1
2d10: 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 73 65 (make-thread se
2d20: 6e 64 2d 72 65 63 69 65 76 65 20 22 77 69 74 68 nd-recieve "with
2d30: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 65 71 75 -input-from-requ
2d40: 65 73 74 22 29 29 0a 09 20 20 20 20 20 20 28 74 est")).. (t
2d50: 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 h2 (make-thread
2d60: 74 69 6d 65 2d 6f 75 74 20 20 20 20 20 22 74 69 time-out "ti
2d70: 6d 65 20 6f 75 74 22 29 29 29 0a 09 20 28 74 68 me out"))).. (th
2d80: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 read-start! th1)
2d90: 0a 09 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 .. (thread-start
2da0: 21 20 74 68 32 29 0a 09 20 28 74 68 72 65 61 64 ! th2).. (thread
2db0: 2d 6a 6f 69 6e 21 20 74 68 31 29 0a 09 20 28 74 -join! th1).. (t
2dc0: 68 72 65 61 64 2d 74 65 72 6d 69 6e 61 74 65 21 hread-terminate!
2dd0: 20 74 68 32 29 0a 09 20 28 64 65 62 75 67 3a 70 th2).. (debug:p
2de0: 72 69 6e 74 2d 69 6e 66 6f 20 31 31 20 2a 64 65 rint-info 11 *de
2df0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
2e00: 22 67 6f 74 20 72 65 73 3d 22 20 72 65 73 29 0a "got res=" res).
2e10: 09 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 72 . (if (vector? r
2e20: 65 73 29 0a 09 20 20 20 20 20 28 69 66 20 28 76 es).. (if (v
2e30: 65 63 74 6f 72 2d 72 65 66 20 72 65 73 20 30 29 ector-ref res 0)
2e40: 0a 09 09 20 72 65 73 0a 20 20 20 20 20 20 20 20 ... res.
2e50: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 64 65 (if (de
2e60: 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 bug:debug-mode 1
2e70: 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 1).
2e80: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 3b (begin ;
2e90: 3b 20 6e 6f 74 65 3a 20 74 68 69 73 20 63 6f 64 ; note: this cod
2ea0: 65 20 61 6c 73 6f 20 63 61 6c 6c 65 64 20 69 6e e also called in
2eb0: 20 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 20 nmsg-transport
2ec0: 2d 20 63 6f 6e 73 69 64 65 72 20 63 6f 6e 73 6f - consider conso
2ed0: 6c 69 64 61 74 69 6e 67 20 69 74 0a 20 20 20 20 lidating it.
2ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ef0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
2f00: 65 72 72 6f 72 20 31 31 20 2a 64 65 66 61 75 6c error 11 *defaul
2f10: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 65 72 72 t-log-port* "err
2f20: 6f 72 20 6f 63 63 75 72 65 64 20 61 74 20 73 65 or occured at se
2f30: 72 76 65 72 2c 20 69 6e 66 6f 3d 22 20 28 76 65 rver, info=" (ve
2f40: 63 74 6f 72 2d 72 65 66 20 72 65 73 20 32 29 29 ctor-ref res 2))
2f50: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2f60: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
2f70: 72 69 6e 74 20 31 31 20 2a 64 65 66 61 75 6c 74 rint 11 *default
2f80: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 63 6c 69 -log-port* " cli
2f90: 65 6e 74 20 63 61 6c 6c 20 63 68 61 69 6e 3a 22 ent call chain:"
2fa0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2fb0: 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 2d (print-
2fc0: 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 call-chain (curr
2fd0: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
2fe0: 0a 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 64 65 62 75 67 3a 70 (debug:p
3000: 72 69 6e 74 20 31 31 20 2a 64 65 66 61 75 6c 74 rint 11 *default
3010: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 73 65 72 -log-port* " ser
3020: 76 65 72 20 63 61 6c 6c 20 63 68 61 69 6e 3a 22 ver call chain:"
3030: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3040: 20 20 20 20 20 20 20 20 20 28 70 70 20 28 76 65 (pp (ve
3050: 63 74 6f 72 2d 72 65 66 20 72 65 73 20 31 29 20 ctor-ref res 1)
3060: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
3070: 6f 72 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 ort)).
3080: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 69 (si
3090: 67 6e 61 6c 20 28 76 65 63 74 6f 72 2d 72 65 66 gnal (vector-ref
30a0: 20 72 65 73 20 30 29 29 29 0a 20 20 20 20 20 20 res 0))).
30b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 72 r
30c0: 65 73 29 29 0a 09 20 20 20 20 20 28 73 69 67 6e es)).. (sign
30d0: 61 6c 20 28 6d 61 6b 65 2d 63 6f 6d 70 6f 73 69 al (make-composi
30e0: 74 65 2d 63 6f 6e 64 69 74 69 6f 6e 0a 09 09 20 te-condition...
30f0: 20 20 20 20 20 28 6d 61 6b 65 2d 70 72 6f 70 65 (make-prope
3100: 72 74 79 2d 63 6f 6e 64 69 74 69 6f 6e 20 0a 09 rty-condition ..
3110: 09 20 20 20 20 20 20 20 27 74 69 6d 65 6f 75 74 . 'timeout
3120: 0a 09 09 20 20 20 20 20 20 20 27 6d 65 73 73 61 ... 'messa
3130: 67 65 20 22 6e 6d 73 67 2d 74 72 61 6e 73 70 6f ge "nmsg-transpo
3140: 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 rt:client-api-se
3150: 6e 64 2d 72 65 63 65 69 76 65 2d 72 61 77 20 74 nd-receive-raw t
3160: 69 6d 65 64 20 6f 75 74 20 74 61 6c 6b 69 6e 67 imed out talking
3170: 20 74 6f 20 73 65 72 76 65 72 22 29 29 29 29 29 to server")))))
3180: 29 29 0a 0a 3b 3b 20 63 61 72 65 66 75 6c 20 63 ))..;; careful c
3190: 6c 6f 73 69 6e 67 20 6f 66 20 63 6f 6e 6e 65 63 losing of connec
31a0: 74 69 6f 6e 73 20 73 74 6f 72 65 64 20 69 6e 20 tions stored in
31b0: 2a 72 75 6e 72 65 6d 6f 74 65 2a 0a 3b 3b 0a 28 *runremote*.;;.(
31c0: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
31d0: 6e 73 70 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e nsport:close-con
31e0: 6e 65 63 74 69 6f 6e 73 20 72 75 6e 2d 69 64 29 nections run-id)
31f0: 0a 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 65 . (let* ((serve
3200: 72 2d 64 61 74 20 28 69 66 20 2a 72 75 6e 72 65 r-dat (if *runre
3210: 6d 6f 74 65 2a 0a 20 20 20 20 20 20 20 20 20 20 mote*.
3220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3230: 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 2a remote-conndat *
3240: 72 75 6e 72 65 6d 6f 74 65 2a 29 0a 20 20 20 20 runremote*).
3250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3260: 20 20 20 20 20 23 66 29 29 29 20 3b 3b 20 28 68 #f))) ;; (h
3270: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
3280: 66 61 75 6c 74 20 2a 72 75 6e 72 65 6d 6f 74 65 fault *runremote
3290: 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 29 0a 20 * run-id #f))).
32a0: 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 (if (vector?
32b0: 73 65 72 76 65 72 2d 64 61 74 29 0a 09 28 6c 65 server-dat)..(le
32c0: 74 20 28 28 61 70 69 2d 64 61 74 20 28 68 74 74 t ((api-dat (htt
32d0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 p-transport:serv
32e0: 65 72 2d 64 61 74 2d 67 65 74 2d 61 70 69 2d 75 er-dat-get-api-u
32f0: 72 69 20 73 65 72 76 65 72 2d 64 61 74 29 29 29 ri server-dat)))
3300: 0a 09 20 20 28 63 6c 6f 73 65 2d 63 6f 6e 6e 65 .. (close-conne
3310: 63 74 69 6f 6e 21 20 61 70 69 2d 64 61 74 29 0a ction! api-dat).
3320: 09 20 20 23 74 29 0a 09 23 66 29 29 29 0a 0a 0a . #t)..#f)))...
3330: 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 68 74 (define (make-ht
3340: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
3350: 76 65 72 2d 64 61 74 29 28 6d 61 6b 65 2d 76 65 ver-dat)(make-ve
3360: 63 74 6f 72 20 36 29 29 0a 28 64 65 66 69 6e 65 ctor 6)).(define
3370: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
3380: 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d :server-dat-get-
3390: 69 66 61 63 65 20 20 20 20 20 20 20 20 20 76 65 iface ve
33a0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
33b0: 66 20 20 76 65 63 20 30 29 29 0a 28 64 65 66 69 f vec 0)).(defi
33c0: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
33d0: 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 rt:server-dat-ge
33e0: 74 2d 70 6f 72 74 20 20 20 20 20 20 20 20 20 20 t-port
33f0: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
3400: 72 65 66 20 20 76 65 63 20 31 29 29 0a 28 64 65 ref vec 1)).(de
3410: 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
3420: 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
3430: 67 65 74 2d 61 70 69 2d 75 72 69 20 20 20 20 20 get-api-uri
3440: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
3450: 72 2d 72 65 66 20 20 76 65 63 20 32 29 29 0a 28 r-ref vec 2)).(
3460: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
3470: 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 nsport:server-da
3480: 74 2d 67 65 74 2d 61 70 69 2d 75 72 6c 20 20 20 t-get-api-url
3490: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
34a0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 33 29 29 tor-ref vec 3))
34b0: 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 .(define (http-t
34c0: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
34d0: 64 61 74 2d 67 65 74 2d 61 70 69 2d 72 65 71 20 dat-get-api-req
34e0: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
34f0: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 34 ector-ref vec 4
3500: 29 29 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 )).(define (http
3510: 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 -transport:serve
3520: 72 2d 64 61 74 2d 67 65 74 2d 6c 61 73 74 2d 61 r-dat-get-last-a
3530: 63 63 65 73 73 20 20 20 76 65 63 29 20 20 20 20 ccess vec)
3540: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
3550: 20 35 29 29 0a 28 64 65 66 69 6e 65 20 28 68 74 5)).(define (ht
3560: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
3570: 76 65 72 2d 64 61 74 2d 67 65 74 2d 73 6f 63 6b ver-dat-get-sock
3580: 65 74 20 20 20 20 20 20 20 20 76 65 63 29 20 20 et vec)
3590: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
35a0: 65 63 20 36 29 29 0a 0a 28 64 65 66 69 6e 65 20 ec 6))..(define
35b0: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
35c0: 73 65 72 76 65 72 2d 64 61 74 2d 6d 61 6b 65 2d server-dat-make-
35d0: 75 72 6c 20 76 65 63 29 0a 20 20 28 69 66 20 28 url vec). (if (
35e0: 61 6e 64 20 28 68 74 74 70 2d 74 72 61 6e 73 70 and (http-transp
35f0: 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 ort:server-dat-g
3600: 65 74 2d 69 66 61 63 65 20 76 65 63 29 0a 09 20 et-iface vec)..
3610: 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 (http-transpor
3620: 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 t:server-dat-get
3630: 2d 70 6f 72 74 20 20 76 65 63 29 29 0a 20 20 20 -port vec)).
3640: 20 20 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f (conc "http:/
3650: 2f 22 20 0a 09 20 20 20 20 28 68 74 74 70 2d 74 /" .. (http-t
3660: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
3670: 64 61 74 2d 67 65 74 2d 69 66 61 63 65 20 76 65 dat-get-iface ve
3680: 63 29 0a 09 20 20 20 20 22 3a 22 0a 09 20 20 20 c).. ":"..
3690: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
36a0: 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d :server-dat-get-
36b0: 70 6f 72 74 20 20 76 65 63 29 29 0a 20 20 20 20 port vec)).
36c0: 20 20 23 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 #f))..(define
36d0: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
36e0: 73 65 72 76 65 72 2d 64 61 74 2d 75 70 64 61 74 server-dat-updat
36f0: 65 2d 6c 61 73 74 2d 61 63 63 65 73 73 20 76 65 e-last-access ve
3700: 63 29 0a 20 20 28 69 66 20 28 76 65 63 74 6f 72 c). (if (vector
3710: 3f 20 76 65 63 29 0a 20 20 20 20 20 20 28 76 65 ? vec). (ve
3720: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 35 20 ctor-set! vec 5
3730: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
3740: 29 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a )). (begin.
3750: 09 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 .(print-call-cha
3760: 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f in (current-erro
3770: 72 2d 70 6f 72 74 29 29 0a 09 28 64 65 62 75 67 r-port))..(debug
3780: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
3790: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
37a0: 2a 20 22 63 61 6c 6c 20 74 6f 20 68 74 74 70 2d * "call to http-
37b0: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
37c0: 2d 64 61 74 2d 75 70 64 61 74 65 2d 6c 61 73 74 -dat-update-last
37d0: 2d 61 63 63 65 73 73 20 77 69 74 68 20 6e 6f 6e -access with non
37e0: 2d 76 65 63 74 6f 72 21 21 22 29 29 29 29 0a 0a -vector!!"))))..
37f0: 3b 3b 0a 3b 3b 20 63 6f 6e 6e 65 63 74 0a 3b 3b ;;.;; connect.;;
3800: 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 .(define (http-t
3810: 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d ransport:client-
3820: 63 6f 6e 6e 65 63 74 20 69 66 61 63 65 20 70 6f connect iface po
3830: 72 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 70 rt). (let* ((ap
3840: 69 2d 75 72 6c 20 20 20 20 20 20 28 63 6f 6e 63 i-url (conc
3850: 20 22 68 74 74 70 3a 2f 2f 22 20 69 66 61 63 65 "http://" iface
3860: 20 22 3a 22 20 70 6f 72 74 20 22 2f 61 70 69 22 ":" port "/api"
3870: 29 29 0a 09 20 28 61 70 69 2d 75 72 69 20 20 20 )).. (api-uri
3880: 20 20 20 28 75 72 69 2d 72 65 66 65 72 65 6e 63 (uri-referenc
3890: 65 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f e (conc "http://
38a0: 22 20 69 66 61 63 65 20 22 3a 22 20 70 6f 72 74 " iface ":" port
38b0: 20 22 2f 61 70 69 22 29 29 29 0a 09 20 28 61 70 "/api"))).. (ap
38c0: 69 2d 72 65 71 20 20 20 20 20 20 28 6d 61 6b 65 i-req (make
38d0: 2d 72 65 71 75 65 73 74 20 6d 65 74 68 6f 64 3a -request method:
38e0: 20 27 50 4f 53 54 20 75 72 69 3a 20 61 70 69 2d 'POST uri: api-
38f0: 75 72 69 29 29 0a 09 20 28 73 65 72 76 65 72 2d uri)).. (server-
3900: 64 61 74 20 20 20 28 76 65 63 74 6f 72 20 69 66 dat (vector if
3910: 61 63 65 20 70 6f 72 74 20 61 70 69 2d 75 72 69 ace port api-uri
3920: 20 61 70 69 2d 75 72 6c 20 61 70 69 2d 72 65 71 api-url api-req
3930: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
3940: 73 29 20 27 68 74 74 70 29 29 29 0a 20 20 20 20 s) 'http))).
3950: 73 65 72 76 65 72 2d 64 61 74 29 29 0a 0a 3b 3b server-dat))..;;
3960: 20 72 75 6e 20 68 74 74 70 2d 74 72 61 6e 73 70 run http-transp
3970: 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 ort:keep-running
3980: 20 69 6e 20 61 20 70 61 72 61 6c 6c 65 6c 20 74 in a parallel t
3990: 68 72 65 61 64 20 74 6f 20 6d 6f 6e 69 74 6f 72 hread to monitor
39a0: 20 74 68 61 74 20 74 68 65 20 64 62 20 69 73 20 that the db is
39b0: 62 65 69 6e 67 20 0a 3b 3b 20 75 73 65 64 20 61 being .;; used a
39c0: 6e 64 20 74 6f 20 73 68 75 74 64 6f 77 6e 20 61 nd to shutdown a
39d0: 66 74 65 72 20 73 6f 6d 65 74 69 6d 65 20 69 66 fter sometime if
39e0: 20 69 74 20 69 73 20 6e 6f 74 2e 0a 3b 3b 0a 28 it is not..;;.(
39f0: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
3a00: 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e nsport:keep-runn
3a10: 69 6e 67 20 73 65 72 76 65 72 2d 69 64 20 72 75 ing server-id ru
3a20: 6e 2d 69 64 29 0a 20 20 3b 3b 20 69 66 20 6e 6f n-id). ;; if no
3a30: 6e 65 20 72 75 6e 6e 69 6e 67 20 6f 72 20 69 66 ne running or if
3a40: 20 3e 20 32 30 20 73 65 63 6f 6e 64 73 20 73 69 > 20 seconds si
3a50: 6e 63 65 20 0a 20 20 3b 3b 20 73 65 72 76 65 72 nce . ;; server
3a60: 20 6c 61 73 74 20 75 73 65 64 20 74 68 65 6e 20 last used then
3a70: 73 74 61 72 74 20 73 68 75 74 64 6f 77 6e 0a 20 start shutdown.
3a80: 20 3b 3b 20 54 68 69 73 20 74 68 72 65 61 64 20 ;; This thread
3a90: 77 61 69 74 73 20 66 6f 72 20 74 68 65 20 73 65 waits for the se
3aa0: 72 76 65 72 20 74 6f 20 63 6f 6d 65 20 61 6c 69 rver to come ali
3ab0: 76 65 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e ve. (debug:prin
3ac0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
3ad0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 74 61 t-log-port* "Sta
3ae0: 72 74 69 6e 67 20 74 68 65 20 73 79 6e 63 2d 62 rting the sync-b
3af0: 61 63 6b 2c 20 6b 65 65 70 20 61 6c 69 76 65 20 ack, keep alive
3b00: 74 68 72 65 61 64 20 69 6e 20 73 65 72 76 65 72 thread in server
3b10: 20 66 6f 72 20 72 75 6e 2d 69 64 3d 22 20 72 75 for run-id=" ru
3b20: 6e 2d 69 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 n-id). (let* ((
3b30: 74 64 62 64 61 74 20 20 20 20 20 20 28 74 61 73 tdbdat (tas
3b40: 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 0a 09 20 28 ks:open-db)).. (
3b50: 73 65 72 76 65 72 2d 73 74 61 72 74 2d 74 69 6d server-start-tim
3b60: 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e e (current-secon
3b70: 64 73 29 29 0a 09 20 28 73 65 72 76 65 72 2d 69 ds)).. (server-i
3b80: 6e 66 6f 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 nfo (let loop ((
3b90: 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 start-time (curr
3ba0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 ent-seconds))...
3bb0: 09 09 20 28 63 68 61 6e 67 65 64 20 20 20 20 23 .. (changed #
3bc0: 74 29 0a 09 09 09 09 20 28 6c 61 73 74 2d 73 64 t)..... (last-sd
3bd0: 61 74 20 20 22 6e 6f 74 20 74 68 69 73 22 29 29 at "not this"))
3be0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3bf0: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let ((
3c00: 73 64 61 74 20 23 66 29 29 0a 09 09 09 20 20 28 sdat #f)).... (
3c10: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
3c20: 30 31 29 0a 09 09 09 20 20 28 64 65 62 75 67 3a 01).... (debug:
3c30: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
3c40: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
3c50: 22 57 61 69 74 69 6e 67 20 66 6f 72 20 73 65 72 "Waiting for ser
3c60: 76 65 72 20 61 6c 69 76 65 20 73 69 67 6e 61 74 ver alive signat
3c70: 75 72 65 22 29 0a 20 20 20 20 20 20 20 20 20 20 ure").
3c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c90: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 (mutex-lock! *he
3ca0: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
3cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3cc0: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
3cd0: 73 64 61 74 20 2a 73 65 72 76 65 72 2d 69 6e 66 sdat *server-inf
3ce0: 6f 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 o*).
3cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d (m
3d00: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 utex-unlock! *he
3d10: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
3d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3d30: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 (if (a
3d40: 6e 64 20 73 64 61 74 0a 09 09 09 09 20 20 20 28 nd sdat..... (
3d50: 6e 6f 74 20 63 68 61 6e 67 65 64 29 0a 09 09 09 not changed)....
3d60: 09 20 20 20 28 3e 20 28 2d 20 28 63 75 72 72 65 . (> (- (curre
3d70: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 74 61 72 nt-seconds) star
3d80: 74 2d 74 69 6d 65 29 20 32 29 29 0a 09 09 09 20 t-time) 2))....
3d90: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 (begin.....
3da0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
3db0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
3dc0: 2d 70 6f 72 74 2a 20 22 52 65 63 65 69 76 65 64 -port* "Received
3dd0: 20 73 65 72 76 65 72 20 61 6c 69 76 65 20 73 69 server alive si
3de0: 67 6e 61 74 75 72 65 22 29 0a 09 09 09 09 73 64 gnature").....sd
3df0: 61 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 at).
3e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3e10: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 64 65 (begin.....(de
3e20: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
3e30: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3e40: 72 74 2a 20 22 53 74 69 6c 6c 20 77 61 69 74 69 rt* "Still waiti
3e50: 6e 67 2c 20 6c 61 73 74 2d 73 64 61 74 3d 22 20 ng, last-sdat="
3e60: 6c 61 73 74 2d 73 64 61 74 29 0a 20 20 20 20 20 last-sdat).
3e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3e80: 20 20 20 20 20 20 20 20 20 20 20 28 73 6c 65 65 (slee
3e90: 70 20 34 29 0a 09 09 09 09 28 69 66 20 28 3e 20 p 4).....(if (>
3ea0: 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
3eb0: 6e 64 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 nds) start-time)
3ec0: 20 31 32 30 29 20 3b 3b 20 62 65 65 6e 20 77 61 120) ;; been wa
3ed0: 69 74 69 6e 67 20 66 6f 72 20 74 77 6f 20 6d 69 iting for two mi
3ee0: 6e 75 74 65 73 0a 09 09 09 09 20 20 20 20 28 62 nutes..... (b
3ef0: 65 67 69 6e 0a 09 09 09 09 20 20 20 20 20 20 28 egin..... (
3f00: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
3f10: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
3f20: 2d 70 6f 72 74 2a 20 22 74 72 61 6e 73 70 6f 72 -port* "transpor
3f30: 74 20 61 70 70 65 61 72 73 20 74 6f 20 68 61 76 t appears to hav
3f40: 65 20 64 69 65 64 2c 20 65 78 69 74 69 6e 67 20 e died, exiting
3f50: 73 65 72 76 65 72 20 22 20 73 65 72 76 65 72 2d server " server-
3f60: 69 64 20 22 20 66 6f 72 20 72 75 6e 20 22 20 72 id " for run " r
3f70: 75 6e 2d 69 64 29 0a 09 09 09 09 20 20 20 20 20 un-id).....
3f80: 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 64 (tasks:server-d
3f90: 65 6c 65 74 65 2d 72 65 63 6f 72 64 20 28 64 62 elete-record (db
3fa0: 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 :delay-if-busy t
3fb0: 64 62 64 61 74 29 20 73 65 72 76 65 72 2d 69 64 dbdat) server-id
3fc0: 20 22 66 61 69 6c 65 64 20 74 6f 20 73 74 61 72 "failed to star
3fd0: 74 2c 20 6e 65 76 65 72 20 72 65 63 65 69 76 65 t, never receive
3fe0: 64 20 73 65 72 76 65 72 20 61 6c 69 76 65 20 73 d server alive s
3ff0: 69 67 6e 61 74 75 72 65 22 29 0a 09 09 09 09 20 ignature").....
4000: 20 20 20 20 20 28 65 78 69 74 29 29 0a 09 09 09 (exit))....
4010: 09 20 20 20 20 28 6c 6f 6f 70 20 73 74 61 72 74 . (loop start
4020: 2d 74 69 6d 65 0a 09 09 09 09 09 20 20 28 65 71 -time...... (eq
4030: 75 61 6c 3f 20 73 64 61 74 20 6c 61 73 74 2d 73 ual? sdat last-s
4040: 64 61 74 29 0a 09 09 09 09 09 20 20 73 64 61 74 dat)...... sdat
4050: 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 ))))))).
4060: 20 28 69 66 61 63 65 20 20 20 20 20 20 20 28 63 (iface (c
4070: 61 72 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 29 ar server-info))
4080: 0a 20 20 20 20 20 20 20 20 20 28 70 6f 72 74 20 . (port
4090: 20 20 20 20 20 20 20 28 63 61 64 72 20 73 65 72 (cadr ser
40a0: 76 65 72 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 ver-info)).
40b0: 20 20 20 20 28 6c 61 73 74 2d 61 63 63 65 73 73 (last-access
40c0: 20 30 29 0a 09 20 28 73 65 72 76 65 72 2d 74 69 0).. (server-ti
40d0: 6d 65 6f 75 74 20 28 73 65 72 76 65 72 3a 67 65 meout (server:ge
40e0: 74 2d 74 69 6d 65 6f 75 74 29 29 0a 09 20 28 73 t-timeout)).. (s
40f0: 65 72 76 65 72 2d 67 6f 69 6e 67 20 20 23 66 29 erver-going #f)
4100: 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ). (let loop
4110: 28 28 63 6f 75 6e 74 20 20 20 20 20 20 20 20 20 ((count
4120: 30 29 0a 09 20 20 20 20 20 20 20 28 73 65 72 76 0).. (serv
4130: 65 72 2d 73 74 61 74 65 20 27 61 76 61 69 6c 61 er-state 'availa
4140: 62 6c 65 29 0a 09 20 20 20 20 20 20 20 28 62 61 ble).. (ba
4150: 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 30 29 0a d-sync-count 0).
4160: 09 20 20 20 20 20 20 20 28 73 74 61 72 74 2d 74 . (start-t
4170: 69 6d 65 20 20 20 20 20 28 63 75 72 72 65 6e 74 ime (current
4180: 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 -milliseconds)))
4190: 0a 0a 20 20 20 20 20 20 3b 3b 20 55 73 65 20 74 .. ;; Use t
41a0: 68 69 73 20 6f 70 70 6f 72 74 75 6e 69 74 79 20 his opportunity
41b0: 74 6f 20 73 79 6e 63 20 74 68 65 20 74 6d 70 20 to sync the tmp
41c0: 64 62 20 74 6f 20 6d 65 67 61 74 65 73 74 2e 64 db to megatest.d
41d0: 62 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 b. (if (not
41e0: 20 73 65 72 76 65 72 2d 67 6f 69 6e 67 29 20 3b server-going) ;
41f0: 3b 20 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 20 ; *dbstruct-db*
4200: 0a 09 20 20 20 20 3b 3b 20 52 65 6d 6f 76 65 64 .. ;; Removed
4210: 20 63 6f 64 65 20 69 73 20 70 61 73 74 65 64 20 code is pasted
4220: 62 65 6c 6f 77 20 28 6b 65 65 70 69 6e 67 20 69 below (keeping i
4230: 74 20 61 72 6f 75 6e 64 20 75 6e 74 69 6c 20 77 t around until w
4240: 65 20 61 72 65 20 63 6c 65 61 72 20 69 74 20 69 e are clear it i
4250: 73 20 6e 6f 74 20 6e 65 65 64 65 64 29 2e 0a 09 s not needed)...
4260: 20 20 20 20 3b 3b 20 6e 6f 20 2a 64 62 73 74 72 ;; no *dbstr
4270: 75 63 74 2d 64 62 2a 20 79 65 74 2c 20 73 65 74 uct-db* yet, set
4280: 20 72 75 6e 6e 69 6e 67 20 61 66 74 65 72 20 6f running after o
4290: 75 72 20 66 69 72 73 74 20 70 61 73 73 20 74 68 ur first pass th
42a0: 72 6f 75 67 68 20 61 6e 64 20 73 74 61 72 74 20 rough and start
42b0: 74 68 65 20 64 62 0a 09 20 20 20 20 28 69 66 20 the db.. (if
42c0: 28 65 71 3f 20 73 65 72 76 65 72 2d 73 74 61 74 (eq? server-stat
42d0: 65 20 27 61 76 61 69 6c 61 62 6c 65 29 0a 09 09 e 'available)...
42e0: 28 6c 65 74 20 28 28 6e 65 77 2d 73 65 72 76 65 (let ((new-serve
42f0: 72 2d 69 64 20 28 74 61 73 6b 73 3a 73 65 72 76 r-id (tasks:serv
4300: 65 72 2d 61 6d 2d 69 2d 74 68 65 2d 73 65 72 76 er-am-i-the-serv
4310: 65 72 3f 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 er? (db:delay-if
4320: 2d 62 75 73 79 20 74 64 62 64 61 74 29 20 72 75 -busy tdbdat) ru
4330: 6e 2d 69 64 29 29 29 20 3b 3b 20 74 72 79 20 74 n-id))) ;; try t
4340: 6f 20 65 6e 73 75 72 65 20 6e 6f 20 64 6f 75 62 o ensure no doub
4350: 6c 65 20 72 65 67 69 73 74 65 72 69 6e 67 20 6f le registering o
4360: 66 20 73 65 72 76 65 72 73 0a 09 09 20 20 28 69 f servers... (i
4370: 66 20 28 65 71 75 61 6c 3f 20 6e 65 77 2d 73 65 f (equal? new-se
4380: 72 76 65 72 2d 69 64 20 73 65 72 76 65 72 2d 69 rver-id server-i
4390: 64 29 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 d)... (begi
43a0: 6e 0a 09 09 09 28 74 61 73 6b 73 3a 73 65 72 76 n....(tasks:serv
43b0: 65 72 2d 73 65 74 2d 73 74 61 74 65 21 20 28 64 er-set-state! (d
43c0: 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 b:delay-if-busy
43d0: 74 64 62 64 61 74 29 20 73 65 72 76 65 72 2d 69 tdbdat) server-i
43e0: 64 20 22 64 62 70 72 65 70 22 29 0a 09 09 09 28 d "dbprep")....(
43f0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
4400: 35 29 20 3b 3b 20 67 69 76 65 20 73 6f 6d 65 20 5) ;; give some
4410: 6d 61 72 67 69 6e 20 66 6f 72 20 71 75 65 72 69 margin for queri
4420: 65 73 20 74 6f 20 63 6f 6d 70 6c 65 74 65 20 62 es to complete b
4430: 65 66 6f 72 65 20 73 77 69 74 63 68 69 6e 67 20 efore switching
4440: 66 72 6f 6d 20 66 69 6c 65 20 62 61 73 65 64 20 from file based
4450: 61 63 63 65 73 73 20 74 6f 20 73 65 72 76 65 72 access to server
4460: 20 62 61 73 65 64 20 61 63 63 65 73 73 0a 09 09 based access...
4470: 09 28 73 65 74 21 20 2a 64 62 73 74 72 75 63 74 .(set! *dbstruct
4480: 2d 64 62 2a 20 20 28 64 62 3a 73 65 74 75 70 29 -db* (db:setup)
4490: 29 20 3b 3b 20 20 72 75 6e 2d 69 64 29 29 0a 09 ) ;; run-id))..
44a0: 09 09 28 73 65 74 21 20 73 65 72 76 65 72 2d 67 ..(set! server-g
44b0: 6f 69 6e 67 20 23 74 29 0a 09 09 09 28 74 61 73 oing #t)....(tas
44c0: 6b 73 3a 73 65 72 76 65 72 2d 73 65 74 2d 73 74 ks:server-set-st
44d0: 61 74 65 21 20 28 64 62 3a 64 65 6c 61 79 2d 69 ate! (db:delay-i
44e0: 66 2d 62 75 73 79 20 74 64 62 64 61 74 29 20 73 f-busy tdbdat) s
44f0: 65 72 76 65 72 2d 69 64 20 22 72 75 6e 6e 69 6e erver-id "runnin
4500: 67 22 29 0a 09 09 09 28 73 65 72 76 65 72 3a 77 g")....(server:w
4510: 72 69 74 65 2d 64 6f 74 73 65 72 76 65 72 20 2a rite-dotserver *
4520: 74 6f 70 70 61 74 68 2a 20 28 63 6f 6e 63 20 69 toppath* (conc i
4530: 66 61 63 65 20 22 3a 22 20 70 6f 72 74 29 29 0a face ":" port)).
4540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4550: 20 20 20 20 20 20 20 20 28 73 65 72 76 65 72 3a (server:
4560: 64 6f 74 73 65 72 76 65 72 2d 73 74 61 72 74 69 dotserver-starti
4570: 6e 67 2d 72 65 6d 6f 76 65 29 29 0a 20 20 20 20 ng-remove)).
4580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4590: 20 20 28 62 65 67 69 6e 20 3b 3b 20 67 6f 74 74 (begin ;; gott
45a0: 61 20 65 78 69 74 20 6e 69 63 65 6c 79 0a 09 09 a exit nicely...
45b0: 09 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 73 .(tasks:server-s
45c0: 65 74 2d 73 74 61 74 65 21 20 28 64 62 3a 64 65 et-state! (db:de
45d0: 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 62 64 lay-if-busy tdbd
45e0: 61 74 29 20 73 65 72 76 65 72 2d 69 64 20 22 63 at) server-id "c
45f0: 6f 6c 6c 69 73 69 6f 6e 22 29 0a 09 09 09 28 68 ollision")....(h
4600: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 ttp-transport:se
4610: 72 76 65 72 2d 73 68 75 74 64 6f 77 6e 20 73 65 rver-shutdown se
4620: 72 76 65 72 2d 69 64 20 70 6f 72 74 29 29 29 29 rver-id port))))
4630: 29 29 0a 0a 20 20 20 20 20 20 3b 3b 20 77 68 65 )).. ;; whe
4640: 6e 20 74 68 69 6e 67 73 20 67 6f 20 77 72 6f 6e n things go wron
4650: 67 20 77 65 20 64 6f 6e 27 74 20 77 61 6e 74 20 g we don't want
4660: 74 6f 20 62 65 20 64 6f 69 6e 67 20 74 68 65 20 to be doing the
4670: 76 61 72 69 6f 75 73 20 71 75 65 72 69 65 73 20 various queries
4680: 74 6f 6f 20 6f 66 74 65 6e 0a 20 20 20 20 20 20 too often.
4690: 3b 3b 20 73 6f 20 77 65 20 73 74 72 69 76 65 20 ;; so we strive
46a0: 74 6f 20 72 75 6e 20 74 68 69 73 20 73 74 75 66 to run this stuf
46b0: 66 20 6f 6e 6c 79 20 65 76 65 72 79 20 66 6f 75 f only every fou
46c0: 72 20 73 65 63 6f 6e 64 73 20 6f 72 20 73 6f 2e r seconds or so.
46d0: 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 . (let* ((s
46e0: 79 6e 63 2d 74 69 6d 65 20 28 2d 20 28 63 75 72 ync-time (- (cur
46f0: 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 rent-millisecond
4700: 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 29 0a s) start-time)).
4710: 09 20 20 20 20 28 72 65 6d 2d 74 69 6d 65 20 20 . (rem-time
4720: 28 71 75 6f 74 69 65 6e 74 20 28 2d 20 34 30 30 (quotient (- 400
4730: 30 20 73 79 6e 63 2d 74 69 6d 65 29 20 31 30 30 0 sync-time) 100
4740: 30 29 29 29 0a 09 28 69 66 20 28 61 6e 64 20 28 0)))..(if (and (
4750: 3c 3d 20 72 65 6d 2d 74 69 6d 65 20 34 29 0a 09 <= rem-time 4)..
4760: 09 20 28 3e 20 20 72 65 6d 2d 74 69 6d 65 20 30 . (> rem-time 0
4770: 29 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d )).. (thread-
4780: 73 6c 65 65 70 21 20 72 65 6d 2d 74 69 6d 65 29 sleep! rem-time)
4790: 29 29 0a 20 20 20 20 20 20 0a 20 20 20 20 20 20 )). .
47a0: 28 69 66 20 28 3c 20 63 6f 75 6e 74 20 31 29 20 (if (< count 1)
47b0: 3b 3b 20 33 78 33 20 3d 20 39 20 73 65 63 73 20 ;; 3x3 = 9 secs
47c0: 61 70 72 6f 78 0a 09 20 20 28 6c 6f 6f 70 20 28 aprox.. (loop (
47d0: 2b 20 63 6f 75 6e 74 20 31 29 20 27 72 75 6e 6e + count 1) 'runn
47e0: 69 6e 67 20 62 61 64 2d 73 79 6e 63 2d 63 6f 75 ing bad-sync-cou
47f0: 6e 74 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c nt (current-mill
4800: 69 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 iseconds))).
4810: 20 20 0a 20 20 20 20 20 20 3b 3b 20 43 68 65 63 . ;; Chec
4820: 6b 20 74 68 61 74 20 69 66 61 63 65 20 61 6e 64 k that iface and
4830: 20 70 6f 72 74 20 68 61 76 65 20 6e 6f 74 20 63 port have not c
4840: 68 61 6e 67 65 64 20 28 63 61 6e 20 68 61 70 70 hanged (can happ
4850: 65 6e 20 69 66 20 73 65 72 76 65 72 20 70 6f 72 en if server por
4860: 74 20 63 6f 6c 6c 69 64 65 73 29 0a 20 20 20 20 t collides).
4870: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
4880: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
4890: 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 73 64 ). (set! sd
48a0: 61 74 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a at *server-info*
48b0: 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 ). (mutex-u
48c0: 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 nlock! *heartbea
48d0: 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 t-mutex*).
48e0: 0a 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 . (if (or (
48f0: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 73 64 61 74 not (equal? sdat
4900: 20 28 6c 69 73 74 20 69 66 61 63 65 20 70 6f 72 (list iface por
4910: 74 29 29 29 0a 09 20 20 20 20 20 20 28 6e 6f 74 t))).. (not
4920: 20 73 65 72 76 65 72 2d 69 64 29 29 0a 09 20 20 server-id))..
4930: 28 62 65 67 69 6e 20 0a 09 20 20 20 20 28 64 65 (begin .. (de
4940: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
4950: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4960: 72 74 2a 20 22 69 6e 74 65 72 66 61 63 65 20 63 rt* "interface c
4970: 68 61 6e 67 65 64 2c 20 72 65 66 72 65 73 68 69 hanged, refreshi
4980: 6e 67 20 69 66 61 63 65 20 61 6e 64 20 70 6f 72 ng iface and por
4990: 74 20 69 6e 66 6f 22 29 0a 09 20 20 20 20 28 73 t info").. (s
49a0: 65 74 21 20 69 66 61 63 65 20 28 63 61 72 20 73 et! iface (car s
49b0: 64 61 74 29 29 0a 09 20 20 20 20 28 73 65 74 21 dat)).. (set!
49c0: 20 70 6f 72 74 20 20 28 63 61 64 72 20 73 64 61 port (cadr sda
49d0: 74 29 29 29 29 0a 20 20 20 20 20 20 0a 20 20 20 t)))). .
49e0: 20 20 20 3b 3b 20 54 72 61 6e 73 66 65 72 20 2a ;; Transfer *
49f0: 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 db-last-access*
4a00: 74 6f 20 6c 61 73 74 2d 61 63 63 65 73 73 20 74 to last-access t
4a10: 6f 20 75 73 65 20 69 6e 20 63 68 65 63 6b 69 6e o use in checkin
4a20: 67 20 74 68 61 74 20 77 65 20 61 72 65 20 73 74 g that we are st
4a30: 69 6c 6c 20 61 6c 69 76 65 0a 20 20 20 20 20 20 ill alive.
4a40: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 (mutex-lock! *he
4a50: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
4a60: 20 20 20 20 20 20 28 73 65 74 21 20 6c 61 73 74 (set! last
4a70: 2d 61 63 63 65 73 73 20 2a 64 62 2d 6c 61 73 74 -access *db-last
4a80: 2d 61 63 63 65 73 73 2a 29 0a 20 20 20 20 20 20 -access*).
4a90: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
4aa0: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
4ab0: 29 0a 0a 20 20 20 20 20 20 3b 3b 20 28 64 65 62 ).. ;; (deb
4ac0: 75 67 3a 70 72 69 6e 74 20 31 31 20 2a 64 65 66 ug:print 11 *def
4ad0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4ae0: 6c 61 73 74 2d 61 63 63 65 73 73 3d 22 20 6c 61 last-access=" la
4af0: 73 74 2d 61 63 63 65 73 73 20 22 2c 20 73 65 72 st-access ", ser
4b00: 76 65 72 2d 74 69 6d 65 6f 75 74 3d 22 20 73 65 ver-timeout=" se
4b10: 72 76 65 72 2d 74 69 6d 65 6f 75 74 29 0a 20 20 rver-timeout).
4b20: 20 20 20 20 3b 3b 0a 20 20 20 20 20 20 3b 3b 20 ;;. ;;
4b30: 6e 6f 5f 74 72 61 66 66 69 63 2c 20 6e 6f 20 72 no_traffic, no r
4b40: 75 6e 6e 69 6e 67 20 74 65 73 74 73 2c 20 69 66 unning tests, if
4b50: 20 73 65 72 76 65 72 20 30 2c 20 6e 6f 20 72 75 server 0, no ru
4b60: 6e 6e 69 6e 67 20 73 65 72 76 65 72 73 0a 20 20 nning servers.
4b70: 20 20 20 20 3b 3b 0a 20 20 20 20 20 20 3b 3b 20 ;;. ;;
4b80: 28 6c 65 74 20 28 28 77 61 69 74 2d 6f 6e 2d 72 (let ((wait-on-r
4b90: 75 6e 6e 69 6e 67 20 28 63 6f 6e 66 69 67 66 3a unning (configf:
4ba0: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
4bb0: 74 2a 20 22 73 65 72 76 65 72 22 20 62 22 77 61 t* "server" b"wa
4bc0: 69 74 2d 6f 6e 2d 72 75 6e 6e 69 6e 67 22 29 29 it-on-running"))
4bd0: 29 20 3b 3b 20 77 61 69 74 20 6f 6e 20 72 75 6e ) ;; wait on run
4be0: 6e 69 6e 67 20 74 61 73 6b 73 20 28 69 66 20 6e ning tasks (if n
4bf0: 6f 74 20 74 72 75 65 20 74 68 65 6e 20 65 78 69 ot true then exi
4c00: 74 20 6f 6e 20 74 69 6d 65 20 6f 75 74 29 0a 20 t on time out).
4c10: 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 20 28 6c ;;. (l
4c20: 65 74 2a 20 28 28 68 72 73 2d 73 69 6e 63 65 2d et* ((hrs-since-
4c30: 73 74 61 72 74 20 20 28 2f 20 28 2d 20 28 63 75 start (/ (- (cu
4c40: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 rrent-seconds) s
4c50: 65 72 76 65 72 2d 73 74 61 72 74 2d 74 69 6d 65 erver-start-time
4c60: 29 20 33 36 30 30 29 29 0a 09 20 20 20 20 20 28 ) 3600)).. (
4c70: 61 64 6a 75 73 74 65 64 2d 74 69 6d 65 6f 75 74 adjusted-timeout
4c80: 20 28 69 66 20 28 3e 20 68 72 73 2d 73 69 6e 63 (if (> hrs-sinc
4c90: 65 2d 73 74 61 72 74 20 31 29 0a 09 09 09 09 20 e-start 1).....
4ca0: 20 20 28 2d 20 73 65 72 76 65 72 2d 74 69 6d 65 (- server-time
4cb0: 6f 75 74 20 28 69 6e 65 78 61 63 74 2d 3e 65 78 out (inexact->ex
4cc0: 61 63 74 20 28 72 6f 75 6e 64 20 28 2a 20 68 72 act (round (* hr
4cd0: 73 2d 73 69 6e 63 65 2d 73 74 61 72 74 20 36 30 s-since-start 60
4ce0: 29 29 29 29 20 20 3b 3b 20 73 75 62 74 72 61 63 )))) ;; subtrac
4cf0: 74 20 36 30 20 73 65 63 6f 6e 64 73 20 70 65 72 t 60 seconds per
4d00: 20 68 6f 75 72 0a 09 09 09 09 20 20 20 73 65 72 hour..... ser
4d10: 76 65 72 2d 74 69 6d 65 6f 75 74 29 29 29 0a 09 ver-timeout)))..
4d20: 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d (if (common:low-
4d30: 6e 6f 69 73 65 2d 70 72 69 6e 74 20 31 32 30 20 noise-print 120
4d40: 22 73 65 72 76 65 72 20 74 69 6d 65 6f 75 74 22 "server timeout"
4d50: 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
4d60: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
4d70: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 41 ult-log-port* "A
4d80: 64 6a 75 73 74 65 64 20 73 65 72 76 65 72 20 74 djusted server t
4d90: 69 6d 65 6f 75 74 3a 20 22 20 61 64 6a 75 73 74 imeout: " adjust
4da0: 65 64 2d 74 69 6d 65 6f 75 74 29 29 0a 09 28 69 ed-timeout))..(i
4db0: 66 20 28 61 6e 64 20 2a 73 65 72 76 65 72 2d 72 f (and *server-r
4dc0: 75 6e 2a 0a 09 09 20 28 3e 20 28 2b 20 6c 61 73 un*... (> (+ las
4dd0: 74 2d 61 63 63 65 73 73 20 73 65 72 76 65 72 2d t-access server-
4de0: 74 69 6d 65 6f 75 74 29 0a 09 09 20 20 20 20 28 timeout)... (
4df0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
4e00: 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 )).. (begin..
4e10: 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f (if (commo
4e20: 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e n:low-noise-prin
4e30: 74 20 31 32 30 20 22 73 65 72 76 65 72 20 63 6f t 120 "server co
4e40: 6e 74 69 6e 75 69 6e 67 22 29 0a 09 09 20 20 28 ntinuing")... (
4e50: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
4e60: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
4e70: 70 6f 72 74 2a 20 22 53 65 72 76 65 72 20 63 6f port* "Server co
4e80: 6e 74 69 6e 75 69 6e 67 2c 20 73 65 63 6f 6e 64 ntinuing, second
4e90: 73 20 73 69 6e 63 65 20 6c 61 73 74 20 64 62 20 s since last db
4ea0: 61 63 63 65 73 73 3a 20 22 20 28 2d 20 28 63 75 access: " (- (cu
4eb0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c rrent-seconds) l
4ec0: 61 73 74 2d 61 63 63 65 73 73 29 29 29 0a 09 20 ast-access)))..
4ed0: 20 20 20 20 20 3b 3b 0a 09 20 20 20 20 20 20 3b ;;.. ;
4ee0: 3b 20 43 6f 6e 73 69 64 65 72 20 69 6d 70 6c 65 ; Consider imple
4ef0: 6d 65 6e 74 69 6e 67 20 73 6f 6d 65 20 73 6d 61 menting some sma
4f00: 72 74 73 20 68 65 72 65 20 74 6f 20 72 65 2d 69 rts here to re-i
4f10: 6e 73 65 72 74 20 74 68 65 20 72 65 63 6f 72 64 nsert the record
4f20: 20 6f 72 20 6b 69 6c 6c 20 73 65 6c 66 20 69 73 or kill self is
4f30: 0a 09 20 20 20 20 20 20 3b 3b 20 74 68 65 20 64 .. ;; the d
4f40: 62 20 69 6e 64 69 63 61 74 65 73 20 73 6f 0a 09 b indicates so..
4f50: 20 20 20 20 20 20 3b 3b 0a 09 20 20 20 20 20 20 ;;..
4f60: 3b 3b 20 28 69 66 20 28 74 61 73 6b 73 3a 73 65 ;; (if (tasks:se
4f70: 72 76 65 72 2d 61 6d 2d 69 2d 74 68 65 2d 73 65 rver-am-i-the-se
4f80: 72 76 65 72 3f 20 74 64 62 20 72 75 6e 2d 69 64 rver? tdb run-id
4f90: 29 0a 09 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ).. ;;
4fa0: 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 73 65 (tasks:server-se
4fb0: 74 2d 73 74 61 74 65 21 20 74 64 62 20 73 65 72 t-state! tdb ser
4fc0: 76 65 72 2d 69 64 20 22 72 75 6e 6e 69 6e 67 22 ver-id "running"
4fd0: 29 29 0a 09 20 20 20 20 20 20 3b 3b 0a 09 20 20 )).. ;;..
4fe0: 20 20 20 20 28 6c 6f 6f 70 20 30 20 73 65 72 76 (loop 0 serv
4ff0: 65 72 2d 73 74 61 74 65 20 62 61 64 2d 73 79 6e er-state bad-syn
5000: 63 2d 63 6f 75 6e 74 20 28 63 75 72 72 65 6e 74 c-count (current
5010: 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 -milliseconds)))
5020: 0a 09 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e .. (http-tran
5030: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 73 68 75 sport:server-shu
5040: 74 64 6f 77 6e 20 73 65 72 76 65 72 2d 69 64 20 tdown server-id
5050: 70 6f 72 74 29 29 29 29 29 29 0a 0a 3b 3b 20 63 port))))))..;; c
5060: 6f 64 65 20 63 75 74 20 6f 75 74 20 66 72 6f 6d ode cut out from
5070: 20 61 62 6f 76 65 0a 3b 3b 0a 3b 3b 20 28 63 6f above.;;.;; (co
5080: 6e 64 69 74 69 6f 6e 2d 63 61 73 65 0a 3b 3b 20 ndition-case.;;
5090: 20 3b 3b 20 28 69 66 20 28 61 6e 64 20 28 6d 65 ;; (if (and (me
50a0: 6d 62 65 72 20 28 6d 75 74 65 78 2d 73 74 61 74 mber (mutex-stat
50b0: 65 20 2a 64 62 2d 73 79 6e 63 2d 6d 75 74 65 78 e *db-sync-mutex
50c0: 2a 29 20 27 28 61 62 61 6e 64 6f 6e 65 64 20 6e *) '(abandoned n
50d0: 6f 74 2d 61 62 61 6e 64 6f 6e 65 64 29 29 0a 3b ot-abandoned)).;
50e0: 3b 20 20 3b 3b 09 20 20 20 20 20 20 28 3e 20 28 ; ;;. (> (
50f0: 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
5100: 64 73 29 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e ds) *db-last-syn
5110: 63 2a 29 20 35 29 29 20 3b 3b 20 69 66 20 6e 6f c*) 5)) ;; if no
5120: 74 20 63 75 72 72 65 6e 74 6c 79 20 62 65 69 6e t currently bein
5130: 67 20 73 79 6e 63 65 64 20 6e 6f 72 20 72 65 63 g synced nor rec
5140: 65 6e 74 6c 79 20 73 79 6e 63 65 64 0a 3b 3b 20 ently synced.;;
5150: 20 28 64 62 3a 73 79 6e 63 2d 74 6f 75 63 68 65 (db:sync-touche
5160: 64 20 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 20 d *dbstruct-db*
5170: 2a 72 75 6e 2d 69 64 2a 20 66 6f 72 63 65 2d 73 *run-id* force-s
5180: 79 6e 63 3a 20 23 74 29 20 3b 3b 20 75 73 75 61 ync: #t) ;; usua
5190: 6c 6c 79 20 64 6f 6e 65 20 69 6e 20 74 68 65 20 lly done in the
51a0: 77 61 74 63 68 64 6f 67 2c 20 6e 6f 74 20 68 65 watchdog, not he
51b0: 72 65 2e 0a 3b 3b 20 20 28 28 73 79 6e 63 2d 66 re..;; ((sync-f
51c0: 61 69 6c 65 64 29 28 63 6f 6e 64 0a 3b 3b 20 09 ailed)(cond.;; .
51d0: 09 20 20 20 20 28 28 3e 20 62 61 64 2d 73 79 6e . ((> bad-syn
51e0: 63 2d 63 6f 75 6e 74 20 31 30 29 20 3b 3b 20 74 c-count 10) ;; t
51f0: 69 6d 65 20 74 6f 20 67 69 76 65 20 75 70 0a 3b ime to give up.;
5200: 3b 20 09 09 20 20 20 20 20 28 68 74 74 70 2d 74 ; .. (http-t
5210: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
5220: 73 68 75 74 64 6f 77 6e 20 73 65 72 76 65 72 2d shutdown server-
5230: 69 64 20 70 6f 72 74 29 29 0a 3b 3b 20 09 09 20 id port)).;; ..
5240: 20 20 20 28 65 6c 73 65 20 3b 3b 20 28 3e 20 62 (else ;; (> b
5250: 61 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 30 29 ad-sync-count 0)
5260: 20 20 3b 3b 20 77 65 27 76 65 20 68 61 64 20 61 ;; we've had a
5270: 20 66 61 69 6c 20 6f 72 20 74 77 6f 2c 20 64 65 fail or two, de
5280: 6c 61 79 20 61 6e 64 20 6c 6f 6f 70 0a 3b 3b 20 lay and loop.;;
5290: 09 09 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 .. (thread-s
52a0: 6c 65 65 70 21 20 35 29 0a 3b 3b 20 09 09 20 20 leep! 5).;; ..
52b0: 20 20 20 28 6c 6f 6f 70 20 63 6f 75 6e 74 20 73 (loop count s
52c0: 65 72 76 65 72 2d 73 74 61 74 65 20 28 2b 20 62 erver-state (+ b
52d0: 61 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 31 29 ad-sync-count 1)
52e0: 29 29 29 29 0a 3b 3b 20 20 28 28 65 78 6e 29 0a )))).;; ((exn).
52f0: 3b 3b 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
5300: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
5310: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 65 72 lt-log-port* "er
5320: 72 6f 72 20 66 72 6f 6d 20 73 79 6e 63 20 63 6f ror from sync co
5330: 64 65 20 6f 74 68 65 72 20 74 68 61 6e 20 27 73 de other than 's
5340: 79 6e 63 2d 66 61 69 6c 65 64 2e 20 41 74 74 65 ync-failed. Atte
5350: 6d 70 74 69 6e 67 20 74 6f 20 67 72 61 63 65 66 mpting to gracef
5360: 75 6c 6c 79 20 73 68 75 74 64 6f 77 6e 20 74 68 ully shutdown th
5370: 65 20 73 65 72 76 65 72 22 29 0a 3b 3b 20 20 20 e server").;;
5380: 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 64 65 (tasks:server-de
5390: 6c 65 74 65 2d 72 65 63 6f 72 64 20 28 64 62 3a lete-record (db:
53a0: 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 delay-if-busy td
53b0: 62 64 61 74 29 20 73 65 72 76 65 72 2d 69 64 20 bdat) server-id
53c0: 22 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 " http-transport
53d0: 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 63 72 :keep-running cr
53e0: 61 73 68 65 64 22 29 0a 3b 3b 20 20 20 28 65 78 ashed").;; (ex
53f0: 69 74 29 29 29 0a 3b 3b 20 28 73 65 74 21 20 73 it))).;; (set! s
5400: 79 6e 63 2d 74 69 6d 65 20 20 28 2d 20 28 63 75 ync-time (- (cu
5410: 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e rrent-millisecon
5420: 64 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 29 ds) start-time))
5430: 0a 3b 3b 20 28 73 65 74 21 20 72 65 6d 2d 74 69 .;; (set! rem-ti
5440: 6d 65 20 28 71 75 6f 74 69 65 6e 74 20 28 2d 20 me (quotient (-
5450: 34 30 30 30 20 73 79 6e 63 2d 74 69 6d 65 29 20 4000 sync-time)
5460: 31 30 30 30 29 29 0a 3b 3b 20 28 64 65 62 75 67 1000)).;; (debug
5470: 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c :print 4 *defaul
5480: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 59 4e t-log-port* "SYN
5490: 43 3a 20 74 69 6d 65 3d 20 22 20 73 79 6e 63 2d C: time= " sync-
54a0: 74 69 6d 65 20 22 2c 20 72 65 6d 2d 74 69 6d 65 time ", rem-time
54b0: 3d 22 20 72 65 6d 2d 74 69 6d 65 29 0a 3b 3b 20 =" rem-time).;;
54c0: 0a 3b 3b 20 28 69 66 20 28 61 6e 64 20 28 3c 3d .;; (if (and (<=
54d0: 20 72 65 6d 2d 74 69 6d 65 20 34 29 0a 3b 3b 20 rem-time 4).;;
54e0: 09 20 20 20 20 20 28 3e 20 72 65 6d 2d 74 69 6d . (> rem-tim
54f0: 65 20 30 29 29 0a 3b 3b 20 09 28 74 68 72 65 61 e 0)).;; .(threa
5500: 64 2d 73 6c 65 65 70 21 20 72 65 6d 2d 74 69 6d d-sleep! rem-tim
5510: 65 29 0a 3b 3b 20 09 28 74 68 72 65 61 64 2d 73 e).;; .(thread-s
5520: 6c 65 65 70 21 20 34 29 29 29 20 3b 3b 20 66 61 leep! 4))) ;; fa
5530: 6c 6c 62 61 63 6b 20 66 6f 72 20 69 66 20 74 68 llback for if th
5540: 65 20 6d 61 74 68 20 69 73 20 63 68 61 6e 67 65 e math is change
5550: 64 20 2e 2e 2e 0a 0a 28 64 65 66 69 6e 65 20 28 d .....(define (
5560: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
5570: 65 72 76 65 72 2d 73 68 75 74 64 6f 77 6e 20 73 erver-shutdown s
5580: 65 72 76 65 72 2d 69 64 20 70 6f 72 74 29 0a 20 erver-id port).
5590: 20 28 6c 65 74 20 28 28 74 64 62 64 61 74 20 28 (let ((tdbdat (
55a0: 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 29 tasks:open-db)))
55b0: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
55c0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
55d0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 74 61 t-log-port* "Sta
55e0: 72 74 69 6e 67 20 74 6f 20 73 68 75 74 64 6f 77 rting to shutdow
55f0: 6e 20 74 68 65 20 73 65 72 76 65 72 2e 22 29 0a n the server.").
5600: 20 20 20 20 3b 3b 0a 20 20 20 20 3b 3b 20 73 74 ;;. ;; st
5610: 61 72 74 5f 73 68 75 74 64 6f 77 6e 0a 20 20 20 art_shutdown.
5620: 20 3b 3b 0a 20 20 20 20 28 74 61 73 6b 73 3a 73 ;;. (tasks:s
5630: 65 72 76 65 72 2d 73 65 74 2d 73 74 61 74 65 21 erver-set-state!
5640: 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 (db:delay-if-bu
5650: 73 79 20 74 64 62 64 61 74 29 20 73 65 72 76 65 sy tdbdat) serve
5660: 72 2d 69 64 20 22 73 68 75 74 74 69 6e 67 2d 64 r-id "shutting-d
5670: 6f 77 6e 22 29 0a 20 20 20 20 28 73 65 74 21 20 own"). (set!
5680: 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 *time-to-exit* #
5690: 74 29 20 3b 3b 20 74 65 6c 6c 20 6f 6e 2d 65 78 t) ;; tell on-ex
56a0: 69 74 20 74 6f 20 62 65 20 66 61 73 74 20 61 73 it to be fast as
56b0: 20 77 65 27 76 65 20 61 6c 72 65 61 64 79 20 63 we've already c
56c0: 6c 65 61 6e 65 64 20 75 70 0a 20 20 20 20 28 70 leaned up. (p
56d0: 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 ortlogger:open-r
56e0: 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 un-close portlog
56f0: 67 65 72 3a 73 65 74 2d 70 6f 72 74 20 70 6f 72 ger:set-port por
5700: 74 20 22 72 65 6c 65 61 73 65 64 22 29 0a 20 20 t "released").
5710: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
5720: 20 35 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 5). (debug:p
5730: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
5740: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5750: 4d 61 78 20 63 61 63 68 65 64 20 71 75 65 72 69 Max cached queri
5760: 65 73 20 77 61 73 20 20 20 20 22 20 2a 6d 61 78 es was " *max
5770: 2d 63 61 63 68 65 2d 73 69 7a 65 2a 29 0a 20 20 -cache-size*).
5780: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
5790: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
57a0: 6f 67 2d 70 6f 72 74 2a 20 22 4e 75 6d 62 65 72 og-port* "Number
57b0: 20 6f 66 20 63 61 63 68 65 64 20 77 72 69 74 65 of cached write
57c0: 73 20 20 20 22 20 2a 6e 75 6d 62 65 72 2d 6f 66 s " *number-of
57d0: 2d 77 72 69 74 65 73 2a 29 0a 20 20 20 20 28 64 -writes*). (d
57e0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
57f0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
5800: 6f 72 74 2a 20 22 41 76 65 72 61 67 65 20 63 61 ort* "Average ca
5810: 63 68 65 64 20 77 72 69 74 65 20 74 69 6d 65 20 ched write time
5820: 22 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 65 "... (if (e
5830: 71 3f 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 q? *number-of-wr
5840: 69 74 65 73 2a 20 30 29 0a 09 09 09 20 20 22 6e ites* 0).... "n
5850: 2f 61 20 28 6e 6f 20 77 72 69 74 65 73 29 22 0a /a (no writes)".
5860: 09 09 09 20 20 28 2f 20 2a 77 72 69 74 65 73 2d ... (/ *writes-
5870: 74 6f 74 61 6c 2d 64 65 6c 61 79 2a 0a 09 09 09 total-delay*....
5880: 20 20 20 20 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d *number-of-
5890: 77 72 69 74 65 73 2a 29 29 0a 09 09 20 20 20 20 writes*))...
58a0: 20 20 22 20 6d 73 22 29 0a 20 20 20 20 28 64 65 " ms"). (de
58b0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
58c0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
58d0: 72 74 2a 20 22 4e 75 6d 62 65 72 20 6e 6f 6e 2d rt* "Number non-
58e0: 63 61 63 68 65 64 20 71 75 65 72 69 65 73 20 22 cached queries "
58f0: 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 *number-non-wr
5900: 69 74 65 2d 71 75 65 72 69 65 73 2a 29 0a 20 20 ite-queries*).
5910: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
5920: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
5930: 6f 67 2d 70 6f 72 74 2a 20 22 41 76 65 72 61 67 og-port* "Averag
5940: 65 20 6e 6f 6e 2d 63 61 63 68 65 64 20 74 69 6d e non-cached tim
5950: 65 20 20 20 22 0a 09 09 20 20 20 20 20 20 28 69 e "... (i
5960: 66 20 28 65 71 3f 20 2a 6e 75 6d 62 65 72 2d 6e f (eq? *number-n
5970: 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 73 on-write-queries
5980: 2a 20 30 29 0a 09 09 09 20 20 22 6e 2f 61 20 28 * 0).... "n/a (
5990: 6e 6f 20 71 75 65 72 69 65 73 29 22 0a 09 09 09 no queries)"....
59a0: 20 20 28 2f 20 2a 74 6f 74 61 6c 2d 6e 6f 6e 2d (/ *total-non-
59b0: 77 72 69 74 65 2d 64 65 6c 61 79 2a 20 0a 09 09 write-delay* ...
59c0: 09 20 20 20 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f . *number-no
59d0: 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a n-write-queries*
59e0: 29 29 0a 09 09 20 20 20 20 20 20 22 20 6d 73 22 ))... " ms"
59f0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
5a00: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
5a10: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 lt-log-port* "Se
5a20: 72 76 65 72 20 73 68 75 74 64 6f 77 6e 20 63 6f rver shutdown co
5a30: 6d 70 6c 65 74 65 2e 20 45 78 69 74 69 6e 67 22 mplete. Exiting"
5a40: 29 0a 20 20 20 20 28 74 61 73 6b 73 3a 73 65 72 ). (tasks:ser
5a50: 76 65 72 2d 64 65 6c 65 74 65 2d 72 65 63 6f 72 ver-delete-recor
5a60: 64 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 d (db:delay-if-b
5a70: 75 73 79 20 74 64 62 64 61 74 29 20 73 65 72 76 usy tdbdat) serv
5a80: 65 72 2d 69 64 20 22 20 68 74 74 70 2d 74 72 61 er-id " http-tra
5a90: 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e nsport:keep-runn
5aa0: 69 6e 67 20 63 6f 6d 70 6c 65 74 65 22 29 0a 20 ing complete").
5ab0: 20 20 20 3b 3b 20 69 66 20 74 68 65 20 2e 73 65 ;; if the .se
5ac0: 72 76 65 72 20 66 69 6c 65 20 63 6f 6e 74 61 69 rver file contai
5ad0: 6e 65 64 20 3a 6d 79 70 6f 72 74 20 74 68 65 6e ned :myport then
5ae0: 20 77 65 20 63 61 6e 20 72 65 6d 6f 76 65 20 69 we can remove i
5af0: 74 0a 20 20 20 20 28 73 65 72 76 65 72 3a 72 65 t. (server:re
5b00: 6d 6f 76 65 2d 64 6f 74 73 65 72 76 65 72 2d 66 move-dotserver-f
5b10: 69 6c 65 20 2a 74 6f 70 70 61 74 68 2a 20 70 6f ile *toppath* po
5b20: 72 74 29 0a 20 20 20 20 28 65 78 69 74 29 29 29 rt). (exit)))
5b30: 0a 0a 3b 3b 20 61 6c 6c 20 72 6f 75 74 65 73 20 ..;; all routes
5b40: 74 68 6f 75 67 68 20 68 65 72 65 20 65 6e 64 20 though here end
5b50: 69 6e 20 65 78 69 74 20 2e 2e 2e 0a 3b 3b 0a 3b in exit ....;;.;
5b60: 3b 20 73 74 61 72 74 5f 73 65 72 76 65 72 3f 20 ; start_server?
5b70: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 74 .;;.(define (htt
5b80: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e p-transport:laun
5b90: 63 68 20 72 75 6e 2d 69 64 29 0a 20 20 28 73 65 ch run-id). (se
5ba0: 72 76 65 72 3a 64 6f 74 73 65 72 76 65 72 2d 73 rver:dotserver-s
5bb0: 74 61 72 74 69 6e 67 29 0a 20 20 28 6c 65 74 2a tarting). (let*
5bc0: 20 28 28 74 64 62 64 61 74 20 28 74 61 73 6b 73 ((tdbdat (tasks
5bd0: 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 20 20 20 :open-db))).
5be0: 28 73 65 74 21 20 2a 72 75 6e 2d 69 64 2a 20 20 (set! *run-id*
5bf0: 20 72 75 6e 2d 69 64 29 0a 20 20 20 20 28 69 66 run-id). (if
5c00: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
5c10: 2d 64 61 65 6d 6f 6e 69 7a 65 22 29 0a 09 28 62 -daemonize")..(b
5c20: 65 67 69 6e 0a 09 20 20 28 64 61 65 6d 6f 6e 3a egin.. (daemon:
5c30: 69 7a 65 29 0a 09 20 20 28 69 66 20 2a 61 6c 74 ize).. (if *alt
5c40: 2d 6c 6f 67 2d 66 69 6c 65 2a 20 3b 3b 20 77 65 -log-file* ;; we
5c50: 20 73 68 6f 75 6c 64 20 72 65 2d 63 6f 6e 6e 65 should re-conne
5c60: 63 74 20 74 6f 20 74 68 69 73 20 70 6f 72 74 2c ct to this port,
5c70: 20 49 20 74 68 69 6e 6b 20 64 61 65 6d 6f 6e 3a I think daemon:
5c80: 69 7a 65 20 64 69 73 72 75 70 74 73 20 69 74 0a ize disrupts it.
5c90: 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 . (begin...
5ca0: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
5cb0: 6f 72 74 20 2a 61 6c 74 2d 6c 6f 67 2d 66 69 6c ort *alt-log-fil
5cc0: 65 2a 29 0a 09 09 28 63 75 72 72 65 6e 74 2d 6f e*)...(current-o
5cd0: 75 74 70 75 74 2d 70 6f 72 74 20 2a 61 6c 74 2d utput-port *alt-
5ce0: 6c 6f 67 2d 66 69 6c 65 2a 29 29 29 29 29 0a 20 log-file*))))).
5cf0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 73 65 72 (if (and (ser
5d00: 76 65 72 3a 72 65 61 64 2d 64 6f 74 73 65 72 76 ver:read-dotserv
5d10: 65 72 20 2a 74 6f 70 70 61 74 68 2a 29 0a 20 20 er *toppath*).
5d20: 20 20 20 20 20 20 20 20 20 20 20 28 73 65 72 76 (serv
5d30: 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e er:check-if-runn
5d40: 69 6e 67 20 72 75 6e 2d 69 64 29 29 0a 09 28 62 ing run-id))..(b
5d50: 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 egin.. (debug:p
5d60: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
5d70: 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a log-port* "INFO:
5d80: 20 53 65 72 76 65 72 20 66 6f 72 20 72 75 6e 2d Server for run-
5d90: 69 64 20 22 20 72 75 6e 2d 69 64 20 22 20 61 6c id " run-id " al
5da0: 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 22 29 0a ready running").
5db0: 09 20 20 28 65 78 69 74 20 30 29 29 0a 09 28 62 . (exit 0))..(b
5dc0: 65 67 69 6e 20 3b 3b 20 6f 6b 2c 20 6e 6f 20 73 egin ;; ok, no s
5dd0: 65 72 76 65 72 20 64 65 74 65 63 74 65 64 2c 20 erver detected,
5de0: 63 6c 65 61 6e 20 6f 75 74 20 61 6e 79 20 6c 69 clean out any li
5df0: 6e 67 65 72 69 6e 67 20 72 65 63 6f 72 64 73 0a ngering records.
5e00: 09 20 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 . (tasks:serve
5e10: 72 2d 66 6f 72 63 65 2d 63 6c 65 61 6e 2d 72 75 r-force-clean-ru
5e20: 6e 6e 69 6e 67 2d 72 65 63 6f 72 64 73 2d 66 6f nning-records-fo
5e30: 72 2d 72 75 6e 2d 69 64 20 20 28 64 62 3a 64 65 r-run-id (db:de
5e40: 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 62 64 lay-if-busy tdbd
5e50: 61 74 29 20 72 75 6e 2d 69 64 20 22 6e 6f 74 72 at) run-id "notr
5e60: 65 73 70 6f 6e 64 69 6e 67 22 29 29 29 0a 20 20 esponding"))).
5e70: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 73 65 (let loop ((se
5e80: 72 76 65 72 2d 69 64 20 28 74 61 73 6b 73 3a 73 rver-id (tasks:s
5e90: 65 72 76 65 72 2d 6c 6f 63 6b 2d 73 6c 6f 74 20 erver-lock-slot
5ea0: 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 (db:delay-if-bus
5eb0: 79 20 74 64 62 64 61 74 29 20 72 75 6e 2d 69 64 y tdbdat) run-id
5ec0: 20 27 68 74 74 70 29 29 0a 09 20 20 20 20 20 20 'http))..
5ed0: 20 28 72 65 6d 74 72 69 65 73 20 20 34 29 29 0a (remtries 4)).
5ee0: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 (if (not s
5ef0: 65 72 76 65 72 2d 69 64 29 0a 09 20 20 28 69 66 erver-id).. (if
5f00: 20 28 3e 20 72 65 6d 74 72 69 65 73 20 30 29 0a (> remtries 0).
5f10: 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 . (begin...
5f20: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 (thread-sleep! 2
5f30: 29 0a 09 09 28 6c 6f 6f 70 20 28 74 61 73 6b 73 )...(loop (tasks
5f40: 3a 73 65 72 76 65 72 2d 6c 6f 63 6b 2d 73 6c 6f :server-lock-slo
5f50: 74 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 t (db:delay-if-b
5f60: 75 73 79 20 74 64 62 64 61 74 29 20 72 75 6e 2d usy tdbdat) run-
5f70: 69 64 20 27 68 74 74 70 29 0a 09 09 20 20 20 20 id 'http)...
5f80: 20 20 28 2d 20 72 65 6d 74 72 69 65 73 20 31 29 (- remtries 1)
5f90: 29 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e )).. (begin
5fa0: 0a 09 09 3b 3b 20 73 69 6e 63 65 20 77 65 20 64 ...;; since we d
5fb0: 69 64 6e 27 74 20 67 65 74 20 74 68 65 20 73 65 idn't get the se
5fc0: 72 76 65 72 20 6c 6f 63 6b 20 77 65 20 61 72 65 rver lock we are
5fd0: 20 67 6f 69 6e 67 20 74 6f 20 63 6c 65 61 6e 20 going to clean
5fe0: 75 70 20 61 6e 64 20 62 61 69 6c 20 6f 75 74 0a up and bail out.
5ff0: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
6000: 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 2 *default-l
6010: 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 og-port* "INFO:
6020: 73 65 72 76 65 72 20 70 69 64 3d 22 20 28 63 75 server pid=" (cu
6030: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
6040: 29 20 22 2c 20 68 6f 73 74 6e 61 6d 65 3d 22 20 ) ", hostname="
6050: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 (get-host-name)
6060: 22 20 6e 6f 74 20 73 74 61 72 74 69 6e 67 20 64 " not starting d
6070: 75 65 20 74 6f 20 6f 74 68 65 72 20 63 61 6e 64 ue to other cand
6080: 69 64 61 74 65 73 20 61 68 65 61 64 20 69 6e 20 idates ahead in
6090: 73 74 61 72 74 20 71 75 65 75 65 22 29 0a 09 09 start queue")...
60a0: 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 64 65 (tasks:server-de
60b0: 6c 65 74 65 2d 72 65 63 6f 72 64 73 2d 66 6f 72 lete-records-for
60c0: 2d 74 68 69 73 2d 70 69 64 20 28 64 62 3a 64 65 -this-pid (db:de
60d0: 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 62 64 lay-if-busy tdbd
60e0: 61 74 29 20 22 20 68 74 74 70 2d 74 72 61 6e 73 at) " http-trans
60f0: 70 6f 72 74 3a 6c 61 75 6e 63 68 22 29 0a 20 20 port:launch").
6100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 .
6110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6120: 73 65 72 76 65 72 3a 64 6f 74 73 65 72 76 65 72 server:dotserver
6130: 2d 73 74 61 72 74 69 6e 67 2d 72 65 6d 6f 76 65 -starting-remove
6140: 29 0a 09 09 29 29 0a 09 20 20 28 6c 65 74 2a 20 )...)).. (let*
6150: 28 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 ((th2 (make-thre
6160: 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 ad (lambda ()...
6170: 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
6180: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
6190: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 ult-log-port* "S
61a0: 65 72 76 65 72 20 72 75 6e 20 74 68 72 65 61 64 erver run thread
61b0: 20 73 74 61 72 74 65 64 22 29 0a 09 09 09 09 20 started").....
61c0: 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 (http-transp
61d0: 6f 72 74 3a 72 75 6e 20 0a 09 09 09 09 20 20 20 ort:run .....
61e0: 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 (if (args:get
61f0: 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a -arg "-server").
6200: 09 09 09 09 09 20 20 28 61 72 67 73 3a 67 65 74 ..... (args:get
6210: 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a -arg "-server").
6220: 09 09 09 09 09 20 20 22 2d 22 29 0a 09 09 09 09 ..... "-").....
6230: 20 20 20 20 20 20 72 75 6e 2d 69 64 0a 09 09 09 run-id....
6240: 09 20 20 20 20 20 20 73 65 72 76 65 72 2d 69 64 . server-id
6250: 29 29 20 22 53 65 72 76 65 72 20 72 75 6e 22 29 )) "Server run")
6260: 29 0a 09 09 20 28 74 68 33 20 28 6d 61 6b 65 2d )... (th3 (make-
6270: 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 thread (lambda (
6280: 29 0a 09 09 09 09 20 20 20 20 20 28 64 65 62 75 )..... (debu
6290: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
62a0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
62b0: 2a 20 22 53 65 72 76 65 72 20 6d 6f 6e 69 74 6f * "Server monito
62c0: 72 20 74 68 72 65 61 64 20 73 74 61 72 74 65 64 r thread started
62d0: 22 29 0a 09 09 09 09 20 20 20 20 20 28 68 74 74 ")..... (htt
62e0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6b 65 65 70 p-transport:keep
62f0: 2d 72 75 6e 6e 69 6e 67 20 73 65 72 76 65 72 2d -running server-
6300: 69 64 20 72 75 6e 2d 69 64 29 29 0a 09 09 09 09 id run-id)).....
6310: 20 20 20 22 4b 65 65 70 20 72 75 6e 6e 69 6e 67 "Keep running
6320: 22 29 29 29 0a 09 20 20 20 20 28 74 68 72 65 61 "))).. (threa
6330: 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a 09 20 d-start! th2)..
6340: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
6350: 21 20 30 2e 32 35 29 20 3b 3b 20 67 69 76 65 20 ! 0.25) ;; give
6360: 74 68 65 20 73 65 72 76 65 72 20 74 69 6d 65 20 the server time
6370: 74 6f 20 73 65 74 74 6c 65 20 62 65 66 6f 72 65 to settle before
6380: 20 73 74 61 72 74 69 6e 67 20 74 68 65 20 6b 65 starting the ke
6390: 65 70 2d 72 75 6e 6e 69 6e 67 20 6d 6f 6e 69 74 ep-running monit
63a0: 6f 72 2e 0a 09 20 20 20 20 28 74 68 72 65 61 64 or... (thread
63b0: 2d 73 74 61 72 74 21 20 74 68 33 29 0a 09 20 20 -start! th3)..
63c0: 20 20 28 73 65 74 21 20 2a 64 69 64 73 6f 6d 65 (set! *didsome
63d0: 74 68 69 6e 67 2a 20 23 74 29 0a 09 20 20 20 20 thing* #t)..
63e0: 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 (thread-join! th
63f0: 32 29 0a 09 20 20 20 20 28 65 78 69 74 29 29 29 2).. (exit)))
6400: 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 )))..;; (define
6410: 28 68 74 74 70 3a 70 69 6e 67 20 72 75 6e 2d 69 (http:ping run-i
6420: 64 20 68 6f 73 74 2d 70 6f 72 74 29 0a 3b 3b 20 d host-port).;;
6430: 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 65 72 (let* ((server
6440: 2d 64 61 74 20 28 68 74 74 70 2d 74 72 61 6e 73 -dat (http-trans
6450: 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e port:client-conn
6460: 65 63 74 20 28 63 61 72 20 68 6f 73 74 2d 70 6f ect (car host-po
6470: 72 74 29 28 63 61 64 72 20 68 6f 73 74 2d 70 6f rt)(cadr host-po
6480: 72 74 29 29 29 0a 3b 3b 20 09 20 28 6c 6f 67 69 rt))).;; . (logi
6490: 6e 2d 72 65 73 20 20 28 72 6d 74 3a 6c 6f 67 69 n-res (rmt:logi
64a0: 6e 2d 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 n-no-auto-client
64b0: 2d 73 65 74 75 70 20 73 65 72 76 65 72 2d 64 61 -setup server-da
64c0: 74 20 72 75 6e 2d 69 64 29 29 29 0a 3b 3b 20 20 t run-id))).;;
64d0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 6c 69 73 (if (and (lis
64e0: 74 3f 20 6c 6f 67 69 6e 2d 72 65 73 29 0a 3b 3b t? login-res).;;
64f0: 20 09 20 20 20 20 20 28 63 61 72 20 6c 6f 67 69 . (car logi
6500: 6e 2d 72 65 73 29 29 0a 3b 3b 20 09 28 62 65 67 n-res)).;; .(beg
6510: 69 6e 0a 3b 3b 20 09 20 20 28 70 72 69 6e 74 20 in.;; . (print
6520: 22 4c 4f 47 49 4e 5f 4f 4b 22 29 0a 3b 3b 20 09 "LOGIN_OK").;; .
6530: 20 20 28 65 78 69 74 20 30 29 29 0a 3b 3b 20 09 (exit 0)).;; .
6540: 28 62 65 67 69 6e 0a 3b 3b 20 09 20 20 28 70 72 (begin.;; . (pr
6550: 69 6e 74 20 22 4c 4f 47 49 4e 5f 46 41 49 4c 45 int "LOGIN_FAILE
6560: 44 22 29 0a 3b 3b 20 09 20 20 28 65 78 69 74 20 D").;; . (exit
6570: 31 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 1)))))..(define
6580: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
6590: 73 65 72 76 65 72 2d 73 69 67 6e 61 6c 2d 68 61 server-signal-ha
65a0: 6e 64 6c 65 72 20 73 69 67 6e 75 6d 29 0a 20 20 ndler signum).
65b0: 28 73 69 67 6e 61 6c 2d 6d 61 73 6b 21 20 73 69 (signal-mask! si
65c0: 67 6e 75 6d 29 0a 20 20 28 68 61 6e 64 6c 65 2d gnum). (handle-
65d0: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 exceptions. ex
65e0: 6e 0a 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e n. (debug:prin
65f0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
6600: 2d 70 6f 72 74 2a 20 22 20 2e 2e 2e 20 65 78 69 -port* " ... exi
6610: 74 69 6e 67 20 2e 2e 2e 22 29 0a 20 20 20 28 6c ting ..."). (l
6620: 65 74 20 28 28 74 68 31 20 28 6d 61 6b 65 2d 74 et ((th1 (make-t
6630: 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 hread (lambda ()
6640: 0a 09 09 09 20 20 20 20 20 28 74 68 72 65 61 64 .... (thread
6650: 2d 73 6c 65 65 70 21 20 31 29 29 0a 09 09 09 20 -sleep! 1))....
6660: 20 20 22 65 61 74 20 72 65 73 70 6f 6e 73 65 22 "eat response"
6670: 29 29 0a 09 20 28 74 68 32 20 28 6d 61 6b 65 2d )).. (th2 (make-
6680: 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 thread (lambda (
6690: 29 0a 09 09 09 20 20 20 20 20 28 64 65 62 75 67 ).... (debug
66a0: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
66b0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
66c0: 2a 20 22 52 65 63 65 69 76 65 64 20 5e 43 2c 20 * "Received ^C,
66d0: 61 74 74 65 6d 70 74 69 6e 67 20 63 6c 65 61 6e attempting clean
66e0: 20 65 78 69 74 2e 20 50 6c 65 61 73 65 20 62 65 exit. Please be
66f0: 20 70 61 74 69 65 6e 74 20 61 6e 64 20 77 61 69 patient and wai
6700: 74 20 61 20 66 65 77 20 73 65 63 6f 6e 64 73 20 t a few seconds
6710: 62 65 66 6f 72 65 20 68 69 74 74 69 6e 67 20 5e before hitting ^
6720: 43 20 61 67 61 69 6e 2e 22 29 0a 09 09 09 20 20 C again.")....
6730: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
6740: 21 20 33 29 20 3b 3b 20 67 69 76 65 20 74 68 65 ! 3) ;; give the
6750: 20 66 6c 75 73 68 20 74 68 72 65 65 20 73 65 63 flush three sec
6760: 6f 6e 64 73 20 74 6f 20 64 6f 20 69 74 27 73 20 onds to do it's
6770: 73 74 75 66 66 0a 09 09 09 20 20 20 20 20 28 64 stuff.... (d
6780: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
6790: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
67a0: 22 20 20 20 20 20 20 20 44 6f 6e 65 2e 22 29 0a " Done.").
67b0: 09 09 09 20 20 20 20 20 28 65 78 69 74 20 34 29 ... (exit 4)
67c0: 29 0a 09 09 09 20 20 20 22 65 78 69 74 20 6f 6e ).... "exit on
67d0: 20 5e 43 20 74 69 6d 65 72 22 29 29 29 0a 20 20 ^C timer"))).
67e0: 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 (thread-start
67f0: 21 20 74 68 32 29 0a 20 20 20 20 20 28 74 68 72 ! th2). (thr
6800: 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a ead-start! th1).
6810: 20 20 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 (thread-joi
6820: 6e 21 20 74 68 32 29 29 29 29 0a 0a 3b 3b 3d 3d n! th2))))..;;==
6830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6870: 3d 3d 3d 3d 0a 3b 3b 20 77 65 62 20 70 61 67 65 ====.;; web page
6880: 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
6890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
68a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
68b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
68c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
68d0: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
68e0: 6f 72 74 3a 6d 61 69 6e 2d 70 61 67 65 29 0a 20 ort:main-page).
68f0: 20 28 6c 65 74 20 28 28 6c 69 6e 6b 70 61 74 68 (let ((linkpath
6900: 20 28 72 6f 6f 74 2d 70 61 74 68 29 29 29 0a 20 (root-path))).
6910: 20 20 20 28 63 6f 6e 63 20 22 3c 68 65 61 64 3e (conc "<head>
6920: 3c 68 31 3e 22 20 28 70 61 74 68 6e 61 6d 65 2d <h1>" (pathname-
6930: 73 74 72 69 70 2d 64 69 72 65 63 74 6f 72 79 20 strip-directory
6940: 2a 74 6f 70 70 61 74 68 2a 29 20 22 3c 2f 68 31 *toppath*) "</h1
6950: 3e 3c 2f 68 65 61 64 3e 22 0a 09 20 20 22 3c 62 ></head>".. "<b
6960: 6f 64 79 3e 22 0a 09 20 20 22 52 75 6e 20 61 72 ody>".. "Run ar
6970: 65 61 3a 20 22 20 2a 74 6f 70 70 61 74 68 2a 0a ea: " *toppath*.
6980: 09 20 20 22 3c 68 32 3e 53 65 72 76 65 72 20 53 . "<h2>Server S
6990: 74 61 74 73 3c 2f 68 32 3e 22 0a 09 20 20 28 68 tats</h2>".. (h
69a0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 74 ttp-transport:st
69b0: 61 74 73 2d 74 61 62 6c 65 29 20 0a 09 20 20 22 ats-table) .. "
69c0: 3c 68 72 3e 22 0a 09 20 20 28 68 74 74 70 2d 74 <hr>".. (http-t
69d0: 72 61 6e 73 70 6f 72 74 3a 72 75 6e 73 20 6c 69 ransport:runs li
69e0: 6e 6b 70 61 74 68 29 0a 09 20 20 22 3c 68 72 3e nkpath).. "<hr>
69f0: 22 0a 09 20 20 28 68 74 74 70 2d 74 72 61 6e 73 ".. (http-trans
6a00: 70 6f 72 74 3a 72 75 6e 2d 73 74 61 74 73 29 0a port:run-stats).
6a10: 09 20 20 22 3c 2f 62 6f 64 79 3e 22 0a 09 20 20 . "</body>"..
6a20: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 )))..(define (ht
6a30: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 74 61 tp-transport:sta
6a40: 74 73 2d 74 61 62 6c 65 29 0a 20 20 28 6d 75 74 ts-table). (mut
6a50: 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 ex-lock! *heartb
6a60: 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 28 6c eat-mutex*). (l
6a70: 65 74 20 28 28 72 65 73 20 0a 09 20 28 63 6f 6e et ((res .. (con
6a80: 63 20 22 3c 74 61 62 6c 65 3e 22 0a 09 20 20 20 c "<table>"..
6a90: 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4d 61 78 "<tr><td>Max
6aa0: 20 63 61 63 68 65 64 20 71 75 65 72 69 65 73 3c cached queries<
6ab0: 2f 74 64 3e 20 20 20 20 20 20 20 20 3c 74 64 3e /td> <td>
6ac0: 22 20 2a 6d 61 78 2d 63 61 63 68 65 2d 73 69 7a " *max-cache-siz
6ad0: 65 2a 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a e* "</td></tr>".
6ae0: 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 . "<tr><td
6af0: 3e 4e 75 6d 62 65 72 20 6f 66 20 63 61 63 68 65 >Number of cache
6b00: 64 20 77 72 69 74 65 73 3c 2f 74 64 3e 20 20 20 d writes</td>
6b10: 3c 74 64 3e 22 20 2a 6e 75 6d 62 65 72 2d 6f 66 <td>" *number-of
6b20: 2d 77 72 69 74 65 73 2a 20 22 3c 2f 74 64 3e 3c -writes* "</td><
6b30: 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c /tr>".. "<
6b40: 74 72 3e 3c 74 64 3e 41 76 65 72 61 67 65 20 63 tr><td>Average c
6b50: 61 63 68 65 64 20 77 72 69 74 65 20 74 69 6d 65 ached write time
6b60: 3c 2f 74 64 3e 20 3c 74 64 3e 22 20 28 69 66 20 </td> <td>" (if
6b70: 28 65 71 3f 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d (eq? *number-of-
6b80: 77 72 69 74 65 73 2a 20 30 29 0a 09 09 09 09 09 writes* 0)......
6b90: 09 09 09 20 22 6e 2f 61 20 28 6e 6f 20 77 72 69 ... "n/a (no wri
6ba0: 74 65 73 29 22 0a 09 09 09 09 09 09 09 09 20 28 tes)"......... (
6bb0: 2f 20 2a 77 72 69 74 65 73 2d 74 6f 74 61 6c 2d / *writes-total-
6bc0: 64 65 6c 61 79 2a 0a 09 09 09 09 09 09 09 09 20 delay*.........
6bd0: 20 20 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 *number-of-wr
6be0: 69 74 65 73 2a 29 29 0a 09 20 20 20 20 20 20 20 ites*))..
6bf0: 22 20 6d 73 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a " ms</td></tr>".
6c00: 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 . "<tr><td
6c10: 3e 4e 75 6d 62 65 72 20 6e 6f 6e 2d 63 61 63 68 >Number non-cach
6c20: 65 64 20 71 75 65 72 69 65 73 3c 2f 74 64 3e 20 ed queries</td>
6c30: 3c 74 64 3e 22 20 20 2a 6e 75 6d 62 65 72 2d 6e <td>" *number-n
6c40: 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 73 on-write-queries
6c50: 2a 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 * "</td></tr>"..
6c60: 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e "<tr><td>
6c70: 41 76 65 72 61 67 65 20 6e 6f 6e 2d 63 61 63 68 Average non-cach
6c80: 65 64 20 74 69 6d 65 3c 2f 74 64 3e 20 20 20 3c ed time</td> <
6c90: 74 64 3e 22 20 28 69 66 20 28 65 71 3f 20 2a 6e td>" (if (eq? *n
6ca0: 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d umber-non-write-
6cb0: 71 75 65 72 69 65 73 2a 20 30 29 0a 09 09 09 09 queries* 0).....
6cc0: 09 09 09 09 20 22 6e 2f 61 20 28 6e 6f 20 71 75 .... "n/a (no qu
6cd0: 65 72 69 65 73 29 22 0a 09 09 09 09 09 09 09 09 eries)".........
6ce0: 20 28 2f 20 2a 74 6f 74 61 6c 2d 6e 6f 6e 2d 77 (/ *total-non-w
6cf0: 72 69 74 65 2d 64 65 6c 61 79 2a 20 0a 09 09 09 rite-delay* ....
6d00: 09 09 09 09 09 20 20 20 20 2a 6e 75 6d 62 65 72 ..... *number
6d10: 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 -non-write-queri
6d20: 65 73 2a 29 29 0a 09 20 20 20 20 20 20 20 22 20 es*)).. "
6d30: 6d 73 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 ms</td></tr>"..
6d40: 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4c "<tr><td>L
6d50: 61 73 74 20 61 63 63 65 73 73 3c 2f 74 64 3e 3c ast access</td><
6d60: 74 64 3e 22 20 20 20 20 20 20 20 20 20 20 20 20 td>"
6d70: 20 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 (seconds->time
6d80: 2d 73 74 72 69 6e 67 20 2a 6c 61 73 74 2d 64 62 -string *last-db
6d90: 2d 61 63 63 65 73 73 2a 29 20 22 3c 2f 74 64 3e -access*) "</td>
6da0: 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 </tr>".. "
6db0: 3c 2f 74 61 62 6c 65 3e 22 29 29 29 0a 20 20 20 </table>"))).
6dc0: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
6dd0: 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 *heartbeat-mutex
6de0: 2a 29 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 64 *). res))..(d
6df0: 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e efine (http-tran
6e00: 73 70 6f 72 74 3a 72 75 6e 73 20 6c 69 6e 6b 70 sport:runs linkp
6e10: 61 74 68 29 0a 20 20 28 63 6f 6e 63 20 22 3c 68 ath). (conc "<h
6e20: 33 3e 52 75 6e 73 3c 2f 68 33 3e 22 0a 09 28 73 3>Runs</h3>"..(s
6e30: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
6e40: 65 0a 09 20 28 6c 65 74 20 28 28 66 69 6c 65 73 e.. (let ((files
6e50: 20 28 6d 61 70 20 70 61 74 68 6e 61 6d 65 2d 73 (map pathname-s
6e60: 74 72 69 70 2d 64 69 72 65 63 74 6f 72 79 20 28 trip-directory (
6e70: 67 6c 6f 62 20 28 63 6f 6e 63 20 6c 69 6e 6b 70 glob (conc linkp
6e80: 61 74 68 20 22 2f 2a 22 29 29 29 29 29 0a 09 20 ath "/*")))))..
6e90: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
6ea0: 70 29 0a 09 09 20 20 28 63 6f 6e 63 20 22 3c 61 p)... (conc "<a
6eb0: 20 68 72 65 66 3d 5c 22 22 20 70 20 22 5c 22 3e href=\"" p "\">
6ec0: 22 20 70 20 22 3c 2f 61 3e 3c 62 72 3e 22 29 29 " p "</a><br>"))
6ed0: 0a 09 09 66 69 6c 65 73 29 29 0a 09 20 22 20 22 ...files)).. " "
6ee0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 )))..(define (ht
6ef0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e tp-transport:run
6f00: 2d 73 74 61 74 73 29 0a 20 20 28 6c 65 74 20 28 -stats). (let (
6f10: 28 73 74 61 74 73 20 28 6f 70 65 6e 2d 72 75 6e (stats (open-run
6f20: 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 72 75 -close db:get-ru
6f30: 6e 6e 69 6e 67 2d 73 74 61 74 73 20 23 66 29 29 nning-stats #f))
6f40: 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 3c 74 61 ). (conc "<ta
6f50: 62 6c 65 3e 22 0a 09 20 20 28 73 74 72 69 6e 67 ble>".. (string
6f60: 2d 69 6e 74 65 72 73 70 65 72 73 65 0a 09 20 20 -intersperse..
6f70: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 73 (map (lambda (s
6f80: 74 61 74 29 0a 09 09 20 20 28 63 6f 6e 63 20 22 tat)... (conc "
6f90: 3c 74 72 3e 3c 74 64 3e 22 20 28 63 61 72 20 73 <tr><td>" (car s
6fa0: 74 61 74 29 20 22 3c 2f 74 64 3e 3c 74 64 3e 22 tat) "</td><td>"
6fb0: 20 28 63 61 64 72 20 73 74 61 74 29 20 22 3c 2f (cadr stat) "</
6fc0: 74 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 73 74 td></tr>"))...st
6fd0: 61 74 73 29 0a 09 20 20 20 22 20 22 29 0a 09 20 ats).. " ")..
6fe0: 20 22 3c 2f 74 61 62 6c 65 3e 22 29 29 29 0a "</table>"))).