Artifact
a60bbd8be7846a37a4ea2a95f25f0777ae885fd0:
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 0a 28 69 6e 63 rtlogger))..(inc
03b0: 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 lude "common_rec
03c0: 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c ords.scm").(incl
03d0: 75 64 65 20 22 64 62 5f 72 65 63 6f 72 64 73 2e ude "db_records.
03e0: 73 63 6d 22 29 0a 0a 28 64 65 66 69 6e 65 20 28 scm")..(define (
03f0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6d http-transport:m
0400: 61 6b 65 2d 73 65 72 76 65 72 2d 75 72 6c 20 68 ake-server-url h
0410: 6f 73 74 70 6f 72 74 29 0a 20 20 28 69 66 20 28 ostport). (if (
0420: 6e 6f 74 20 68 6f 73 74 70 6f 72 74 29 0a 20 20 not hostport).
0430: 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 63 6f #f. (co
0440: 6e 63 20 22 68 74 74 70 3a 2f 2f 22 20 28 63 61 nc "http://" (ca
0450: 72 20 68 6f 73 74 70 6f 72 74 29 20 22 3a 22 20 r hostport) ":"
0460: 28 63 61 64 72 20 68 6f 73 74 70 6f 72 74 29 29 (cadr hostport))
0470: 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 73 65 72 ))..(define *ser
0480: 76 65 72 2d 6c 6f 6f 70 2d 68 65 61 72 74 2d 62 ver-loop-heart-b
0490: 65 61 74 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 eat* (current-se
04a0: 63 6f 6e 64 73 29 29 0a 28 64 65 66 69 6e 65 20 conds)).(define
04b0: 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 *heartbeat-mutex
04c0: 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a * (make-mutex)).
04d0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
04e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 =========.;; S E
0520: 20 52 20 56 20 45 20 52 0a 3b 3b 3d 3d 3d 3d 3d R V E R.;;=====
0530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0570: 3d 0a 0a 3b 3b 20 43 61 6c 6c 20 74 68 69 73 20 =..;; Call this
0580: 74 6f 20 73 74 61 72 74 20 74 68 65 20 61 63 74 to start the act
0590: 75 61 6c 20 73 65 72 76 65 72 0a 3b 3b 0a 0a 28 ual server.;;..(
05a0: 64 65 66 69 6e 65 20 2a 64 62 3a 70 72 6f 63 65 define *db:proce
05b0: 73 73 2d 71 75 65 75 65 2d 6d 75 74 65 78 2a 20 ss-queue-mutex*
05c0: 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 28 (make-mutex))..(
05d0: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
05e0: 6e 73 70 6f 72 74 3a 72 75 6e 20 68 6f 73 74 6e nsport:run hostn
05f0: 20 72 75 6e 2d 69 64 20 73 65 72 76 65 72 2d 69 run-id server-i
0600: 64 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e d). (debug:prin
0610: 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 2 *default-log
0620: 2d 70 6f 72 74 2a 20 22 41 74 74 65 6d 70 74 69 -port* "Attempti
0630: 6e 67 20 74 6f 20 73 74 61 72 74 20 74 68 65 20 ng to start the
0640: 73 65 72 76 65 72 20 2e 2e 2e 22 29 0a 20 20 28 server ..."). (
0650: 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 let* ((db
0660: 20 20 20 20 20 20 20 23 66 29 20 3b 3b 20 20 20 #f) ;;
0670: 20 20 20 20 20 28 6f 70 65 6e 2d 64 62 29 29 20 (open-db))
0680: 3b 3b 20 77 65 20 64 6f 6e 27 74 20 77 61 6e 74 ;; we don't want
0690: 20 74 68 65 20 73 65 72 76 65 72 20 74 6f 20 62 the server to b
06a0: 65 20 6f 70 65 6e 69 6e 67 20 61 6e 64 20 63 6c e opening and cl
06b0: 6f 73 69 6e 67 20 74 68 65 20 64 62 20 75 6e 6e osing the db unn
06c0: 65 63 65 73 61 72 69 6c 79 0a 09 20 28 68 6f 73 ecesarily.. (hos
06d0: 74 6e 61 6d 65 20 20 20 20 20 20 20 20 28 67 65 tname (ge
06e0: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 t-host-name))..
06f0: 28 69 70 61 64 64 72 73 74 72 20 20 20 20 20 20 (ipaddrstr
0700: 20 28 6c 65 74 20 28 28 69 70 73 74 72 20 28 69 (let ((ipstr (i
0710: 66 20 28 73 74 72 69 6e 67 3d 3f 20 22 2d 22 20 f (string=? "-"
0720: 68 6f 73 74 6e 29 0a 09 09 09 09 09 20 20 20 3b hostn)...... ;
0730: 3b 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 ; (string-inters
0740: 70 65 72 73 65 20 28 6d 61 70 20 6e 75 6d 62 65 perse (map numbe
0750: 72 2d 3e 73 74 72 69 6e 67 20 28 75 38 76 65 63 r->string (u8vec
0760: 74 6f 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 6e tor->list (hostn
0770: 61 6d 65 2d 3e 69 70 20 68 6f 73 74 6e 61 6d 65 ame->ip hostname
0780: 29 29 29 20 22 2e 22 29 0a 09 09 09 09 09 20 20 ))) ".")......
0790: 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 (server:get-bes
07a0: 74 2d 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 t-guess-address
07b0: 68 6f 73 74 6e 61 6d 65 29 0a 09 09 09 09 09 20 hostname)......
07c0: 20 20 23 66 29 29 29 0a 09 09 09 20 20 20 20 28 #f))).... (
07d0: 69 66 20 69 70 73 74 72 20 69 70 73 74 72 20 68 if ipstr ipstr h
07e0: 6f 73 74 6e 29 29 29 20 3b 3b 20 68 6f 73 74 6e ostn))) ;; hostn
07f0: 61 6d 65 29 29 29 20 0a 09 20 28 73 74 61 72 74 ame))) .. (start
0800: 2d 70 6f 72 74 20 20 20 20 20 20 28 70 6f 72 74 -port (port
0810: 6c 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d logger:open-run-
0820: 63 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 close portlogger
0830: 3a 66 69 6e 64 2d 70 6f 72 74 29 29 0a 09 20 28 :find-port)).. (
0840: 6c 69 6e 6b 2d 74 72 65 65 2d 70 61 74 68 20 20 link-tree-path
0850: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
0860: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 *configdat* "set
0870: 75 70 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 up" "linktree"))
0880: 29 0a 20 20 20 20 3b 3b 20 28 73 65 74 21 20 64 ). ;; (set! d
0890: 62 20 2a 69 6e 6d 65 6d 64 62 2a 29 0a 20 20 20 b *inmemdb*).
08a0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
08b0: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
08c0: 67 2d 70 6f 72 74 2a 20 22 70 6f 72 74 6c 6f 67 g-port* "portlog
08d0: 67 65 72 20 72 65 63 6f 6d 6d 65 6e 64 65 64 20 ger recommended
08e0: 70 6f 72 74 3a 20 22 20 73 74 61 72 74 2d 70 6f port: " start-po
08f0: 72 74 29 0a 20 20 20 20 28 72 6f 6f 74 2d 70 61 rt). (root-pa
0900: 74 68 20 20 20 20 20 28 69 66 20 6c 69 6e 6b 2d th (if link-
0910: 74 72 65 65 2d 70 61 74 68 20 0a 09 09 20 20 20 tree-path ...
0920: 20 20 20 20 6c 69 6e 6b 2d 74 72 65 65 2d 70 61 link-tree-pa
0930: 74 68 0a 09 09 20 20 20 20 20 20 20 28 63 75 72 th... (cur
0940: 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 rent-directory))
0950: 29 20 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 53 45 ) ;; WARNING: SE
0960: 43 55 52 49 54 59 20 48 4f 4c 45 2e 20 46 49 58 CURITY HOLE. FIX
0970: 20 41 53 41 50 21 0a 20 20 20 20 28 68 61 6e 64 ASAP!. (hand
0980: 6c 65 2d 64 69 72 65 63 74 6f 72 79 20 73 70 69 le-directory spi
0990: 66 66 79 2d 64 69 72 65 63 74 6f 72 79 2d 6c 69 ffy-directory-li
09a0: 73 74 69 6e 67 29 0a 20 20 20 20 28 68 61 6e 64 sting). (hand
09b0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 20 28 6c 61 le-exception (la
09c0: 6d 62 64 61 20 28 65 78 6e 20 63 68 61 69 6e 29 mbda (exn chain)
09d0: 0a 09 09 09 28 73 69 67 6e 61 6c 20 28 6d 61 6b ....(signal (mak
09e0: 65 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 6f 6e 64 e-composite-cond
09f0: 69 74 69 6f 6e 0a 09 09 09 09 20 28 6d 61 6b 65 ition..... (make
0a00: 2d 70 72 6f 70 65 72 74 79 2d 63 6f 6e 64 69 74 -property-condit
0a10: 69 6f 6e 20 0a 09 09 09 09 20 20 27 73 65 72 76 ion ..... 'serv
0a20: 65 72 0a 09 09 09 09 20 20 27 6d 65 73 73 61 67 er..... 'messag
0a30: 65 20 22 73 65 72 76 65 72 20 65 72 72 6f 72 22 e "server error"
0a40: 29 29 29 29 29 0a 0a 20 20 20 20 3b 3b 20 68 74 ))))).. ;; ht
0a50: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 68 61 6e tp-transport:han
0a60: 64 6c 65 2d 64 69 72 65 63 74 6f 72 79 29 20 3b dle-directory) ;
0a70: 3b 20 73 69 6d 70 6c 65 2d 64 69 72 65 63 74 6f ; simple-directo
0a80: 72 79 2d 68 61 6e 64 6c 65 72 29 0a 20 20 20 20 ry-handler).
0a90: 3b 3b 20 53 65 74 75 70 20 74 68 65 20 77 65 62 ;; Setup the web
0aa0: 20 73 65 72 76 65 72 20 61 6e 64 20 61 20 2f 63 server and a /c
0ab0: 74 72 6c 20 69 6e 74 65 72 66 61 63 65 0a 20 20 trl interface.
0ac0: 20 20 3b 3b 0a 20 20 20 20 28 76 68 6f 73 74 2d ;;. (vhost-
0ad0: 6d 61 70 20 60 28 28 28 2a 20 61 6e 79 29 20 2e map `(((* any) .
0ae0: 20 2c 28 6c 61 6d 62 64 61 20 28 63 6f 6e 74 69 ,(lambda (conti
0af0: 6e 75 65 29 0a 09 09 09 20 20 20 20 20 20 20 3b nue).... ;
0b00: 3b 20 6f 70 65 6e 20 74 68 65 20 64 62 20 6f 6e ; open the db on
0b10: 20 74 68 65 20 66 69 72 73 74 20 63 61 6c 6c 20 the first call
0b20: 0a 09 09 09 09 20 3b 3b 20 54 68 69 73 20 69 73 ..... ;; This is
0b30: 20 77 65 72 65 20 77 65 20 73 65 74 20 75 70 20 were we set up
0b40: 74 68 65 20 64 61 74 61 62 61 73 65 20 63 6f 6e the database con
0b50: 6e 65 63 74 69 6f 6e 73 0a 09 09 09 20 20 20 20 nections....
0b60: 20 20 20 28 6c 65 74 2a 20 28 28 24 20 20 20 28 (let* (($ (
0b70: 72 65 71 75 65 73 74 2d 76 61 72 73 20 73 6f 75 request-vars sou
0b80: 72 63 65 3a 20 27 62 6f 74 68 29 29 0a 09 09 09 rce: 'both))....
0b90: 09 20 20 20 20 20 20 28 64 61 74 20 28 24 20 27 . (dat ($ '
0ba0: 64 61 74 29 29 0a 09 09 09 09 20 20 20 20 20 20 dat)).....
0bb0: 28 72 65 73 20 23 66 29 29 0a 09 09 09 09 20 28 (res #f))..... (
0bc0: 63 6f 6e 64 0a 09 09 09 09 20 20 28 28 65 71 75 cond..... ((equ
0bd0: 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 al? (uri-path (r
0be0: 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 equest-uri (curr
0bf0: 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 0a 09 ent-request)))..
0c00: 09 09 09 09 20 20 20 27 28 2f 20 22 61 70 69 22 .... '(/ "api"
0c10: 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e 64 2d ))..... (send-
0c20: 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 20 response body:
0c30: 20 20 28 61 70 69 3a 70 72 6f 63 65 73 73 2d 72 (api:process-r
0c40: 65 71 75 65 73 74 20 2a 69 6e 6d 65 6d 64 62 2a equest *inmemdb*
0c50: 20 24 29 20 3b 3b 20 74 68 65 20 24 20 69 73 20 $) ;; the $ is
0c60: 74 68 65 20 72 65 71 75 65 73 74 20 76 61 72 73 the request vars
0c70: 20 70 72 6f 63 0a 09 09 09 09 09 09 20 20 68 65 proc....... he
0c80: 61 64 65 72 73 3a 20 27 28 28 63 6f 6e 74 65 6e aders: '((conten
0c90: 74 2d 74 79 70 65 20 74 65 78 74 2f 70 6c 61 69 t-type text/plai
0ca0: 6e 29 29 29 0a 09 09 09 09 20 20 20 28 6d 75 74 n)))..... (mut
0cb0: 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 ex-lock! *heartb
0cc0: 65 61 74 2d 6d 75 74 65 78 2a 29 0a 09 09 09 09 eat-mutex*).....
0cd0: 20 20 20 28 73 65 74 21 20 2a 6c 61 73 74 2d 64 (set! *last-d
0ce0: 62 2d 61 63 63 65 73 73 2a 20 28 63 75 72 72 65 b-access* (curre
0cf0: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 09 nt-seconds))....
0d00: 09 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 . (mutex-unloc
0d10: 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 k! *heartbeat-mu
0d20: 74 65 78 2a 29 29 0a 09 09 09 09 20 20 28 28 65 tex*))..... ((e
0d30: 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 qual? (uri-path
0d40: 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 (request-uri (cu
0d50: 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 rrent-request)))
0d60: 20 0a 09 09 09 09 09 20 20 20 27 28 2f 20 22 22 ...... '(/ ""
0d70: 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e 64 2d ))..... (send-
0d80: 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 28 response body: (
0d90: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6d http-transport:m
0da0: 61 69 6e 2d 70 61 67 65 29 29 29 0a 09 09 09 09 ain-page))).....
0db0: 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 69 2d ((equal? (uri-
0dc0: 70 61 74 68 20 28 72 65 71 75 65 73 74 2d 75 72 path (request-ur
0dd0: 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 75 65 i (current-reque
0de0: 73 74 29 29 29 20 0a 09 09 09 09 09 20 20 20 27 st))) ...... '
0df0: 28 2f 20 22 6a 73 6f 6e 5f 61 70 69 22 29 29 0a (/ "json_api")).
0e00: 09 09 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 .... (send-res
0e10: 70 6f 6e 73 65 20 62 6f 64 79 3a 20 28 68 74 74 ponse body: (htt
0e20: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e p-transport:main
0e30: 2d 70 61 67 65 29 29 29 0a 09 09 09 09 20 20 28 -page)))..... (
0e40: 28 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 (equal? (uri-pat
0e50: 68 20 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 h (request-uri (
0e60: 63 75 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 current-request)
0e70: 29 29 20 0a 09 09 09 09 09 20 20 20 27 28 2f 20 )) ...... '(/
0e80: 22 72 75 6e 73 22 29 29 0a 09 09 09 09 20 20 20 "runs")).....
0e90: 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 (send-response b
0ea0: 6f 64 79 3a 20 28 68 74 74 70 2d 74 72 61 6e 73 ody: (http-trans
0eb0: 70 6f 72 74 3a 6d 61 69 6e 2d 70 61 67 65 29 29 port:main-page))
0ec0: 29 0a 09 09 09 09 20 20 28 28 65 71 75 61 6c 3f )..... ((equal?
0ed0: 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 (uri-path (requ
0ee0: 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 est-uri (current
0ef0: 2d 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 09 -request))) ....
0f00: 09 09 20 20 20 27 28 2f 20 61 6e 79 29 29 0a 09 .. '(/ any))..
0f10: 09 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 ... (send-resp
0f20: 6f 6e 73 65 20 62 6f 64 79 3a 20 22 68 65 79 20 onse body: "hey
0f30: 74 68 65 72 65 21 5c 6e 22 0a 09 09 09 09 09 09 there!\n".......
0f40: 20 20 68 65 61 64 65 72 73 3a 20 27 28 28 63 6f headers: '((co
0f50: 6e 74 65 6e 74 2d 74 79 70 65 20 74 65 78 74 2f ntent-type text/
0f60: 70 6c 61 69 6e 29 29 29 29 0a 09 09 09 09 20 20 plain)))).....
0f70: 28 28 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 ((equal? (uri-pa
0f80: 74 68 20 28 72 65 71 75 65 73 74 2d 75 72 69 20 th (request-uri
0f90: 28 63 75 72 72 65 6e 74 2d 72 65 71 75 65 73 74 (current-request
0fa0: 29 29 29 20 0a 09 09 09 09 09 20 20 20 27 28 2f ))) ...... '(/
0fb0: 20 22 68 65 79 22 29 29 0a 09 09 09 09 20 20 20 "hey")).....
0fc0: 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 (send-response b
0fd0: 6f 64 79 3a 20 22 68 65 79 20 74 68 65 72 65 21 ody: "hey there!
0fe0: 5c 6e 22 0a 09 09 09 09 09 09 20 20 68 65 61 64 \n"....... head
0ff0: 65 72 73 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d ers: '((content-
1000: 74 79 70 65 20 74 65 78 74 2f 70 6c 61 69 6e 29 type text/plain)
1010: 29 29 29 0a 09 09 09 09 20 20 28 65 6c 73 65 20 )))..... (else
1020: 28 63 6f 6e 74 69 6e 75 65 29 29 29 29 29 29 29 (continue)))))))
1030: 29 0a 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e ). (http-tran
1040: 73 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 74 2d sport:try-start-
1050: 73 65 72 76 65 72 20 72 75 6e 2d 69 64 20 69 70 server run-id ip
1060: 61 64 64 72 73 74 72 20 73 74 61 72 74 2d 70 6f addrstr start-po
1070: 72 74 20 73 65 72 76 65 72 2d 69 64 29 29 29 0a rt server-id))).
1080: 0a 3b 3b 20 54 68 69 73 20 69 73 20 72 65 63 75 .;; This is recu
1090: 72 73 69 76 65 6c 79 20 72 75 6e 20 62 79 20 68 rsively run by h
10a0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 ttp-transport:ru
10b0: 6e 20 75 6e 74 69 6c 20 73 75 63 65 73 73 66 75 n until sucessfu
10c0: 6c 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 l.;;.(define (ht
10d0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 tp-transport:try
10e0: 2d 73 74 61 72 74 2d 73 65 72 76 65 72 20 72 75 -start-server ru
10f0: 6e 2d 69 64 20 69 70 61 64 64 72 73 74 72 20 70 n-id ipaddrstr p
1100: 6f 72 74 6e 75 6d 20 73 65 72 76 65 72 2d 69 64 ortnum server-id
1110: 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 6e 66 69 ). (let ((confi
1120: 67 2d 68 6f 73 74 6e 61 6d 65 20 28 63 6f 6e 66 g-hostname (conf
1130: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
1140: 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 igdat* "server"
1150: 22 68 6f 73 74 6e 61 6d 65 22 29 29 0a 09 28 74 "hostname"))..(t
1160: 64 62 64 61 74 20 20 20 20 20 20 20 20 20 20 28 dbdat (
1170: 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 29 tasks:open-db)))
1180: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
1190: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
11a0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 68 74 74 t-log-port* "htt
11b0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d p-transport:try-
11c0: 73 74 61 72 74 2d 73 65 72 76 65 72 20 72 75 6e start-server run
11d0: 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 20 69 -id=" run-id " i
11e0: 70 61 64 64 72 73 73 74 72 3d 22 20 69 70 61 64 paddrsstr=" ipad
11f0: 64 72 73 74 72 20 22 20 70 6f 72 74 6e 75 6d 3d drstr " portnum=
1200: 22 20 70 6f 72 74 6e 75 6d 20 22 20 73 65 72 76 " portnum " serv
1210: 65 72 2d 69 64 3d 22 20 73 65 72 76 65 72 2d 69 er-id=" server-i
1220: 64 20 22 20 63 6f 6e 66 69 67 2d 68 6f 73 74 6e d " config-hostn
1230: 61 6d 65 3d 22 20 63 6f 6e 66 69 67 2d 68 6f 73 ame=" config-hos
1240: 74 6e 61 6d 65 29 0a 20 20 20 20 28 68 61 6e 64 tname). (hand
1250: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 le-exceptions.
1260: 20 20 20 65 78 6e 0a 20 20 20 20 20 28 62 65 67 exn. (beg
1270: 69 6e 0a 20 20 20 20 20 20 20 28 70 72 69 6e 74 in. (print
1280: 2d 65 72 72 6f 72 2d 6d 65 73 73 61 67 65 20 65 -error-message e
1290: 78 6e 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 xn). (if (
12a0: 3c 20 70 6f 72 74 6e 75 6d 20 36 34 30 30 30 29 < portnum 64000)
12b0: 0a 09 20 20 20 28 62 65 67 69 6e 20 0a 09 20 20 .. (begin ..
12c0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
12d0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
12e0: 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 61 ort* "WARNING: a
12f0: 74 74 65 6d 70 74 20 74 6f 20 73 74 61 72 74 20 ttempt to start
1300: 73 65 72 76 65 72 20 66 61 69 6c 65 64 2e 20 54 server failed. T
1310: 72 79 69 6e 67 20 61 67 61 69 6e 20 2e 2e 2e 22 rying again ..."
1320: 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ).. (debug:p
1330: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
1340: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 log-port* " mess
1350: 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 age: " ((conditi
1360: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
1370: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
1380: 67 65 29 20 65 78 6e 29 29 0a 09 20 20 20 20 20 ge) exn))..
1390: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
13a0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
13b0: 2a 20 22 65 78 6e 3d 22 20 28 63 6f 6e 64 69 74 * "exn=" (condit
13c0: 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 0a ion->list exn)).
13d0: 09 20 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 65 . (portlogge
13e0: 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 r:open-run-close
13f0: 20 70 6f 72 74 6c 6f 67 67 65 72 3a 73 65 74 2d portlogger:set-
1400: 66 61 69 6c 65 64 20 70 6f 72 74 6e 75 6d 29 0a failed portnum).
1410: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
1420: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
1430: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
1440: 3a 20 66 61 69 6c 65 64 20 74 6f 20 73 74 61 72 : failed to star
1450: 74 20 6f 6e 20 70 6f 72 74 6e 75 6d 3a 20 22 20 t on portnum: "
1460: 70 6f 72 74 6e 75 6d 20 22 2c 20 74 72 79 69 6e portnum ", tryin
1470: 67 20 6e 65 78 74 20 70 6f 72 74 22 29 0a 09 20 g next port")..
1480: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
1490: 70 21 20 30 2e 31 29 0a 0a 09 20 20 20 20 20 3b p! 0.1)... ;
14a0: 3b 20 67 65 74 5f 6e 65 78 74 5f 70 6f 72 74 20 ; get_next_port
14b0: 67 6f 65 73 20 68 65 72 65 0a 09 20 20 20 20 20 goes here..
14c0: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
14d0: 74 72 79 2d 73 74 61 72 74 2d 73 65 72 76 65 72 try-start-server
14e0: 20 72 75 6e 2d 69 64 0a 09 09 09 09 09 20 20 20 run-id......
14f0: 20 20 20 69 70 61 64 64 72 73 74 72 0a 09 09 09 ipaddrstr....
1500: 09 09 20 20 20 20 20 20 28 70 6f 72 74 6c 6f 67 .. (portlog
1510: 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f ger:open-run-clo
1520: 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 66 69 se portlogger:fi
1530: 6e 64 2d 70 6f 72 74 29 0a 09 09 09 09 09 20 20 nd-port)......
1540: 20 20 20 20 73 65 72 76 65 72 2d 69 64 29 29 0a server-id)).
1550: 09 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 . (begin..
1560: 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 66 (tasks:server-f
1570: 6f 72 63 65 2d 63 6c 65 61 6e 2d 72 75 6e 2d 72 orce-clean-run-r
1580: 65 63 6f 72 64 20 28 64 62 3a 64 65 6c 61 79 2d ecord (db:delay-
1590: 69 66 2d 62 75 73 79 20 74 64 62 64 61 74 29 20 if-busy tdbdat)
15a0: 72 75 6e 2d 69 64 20 69 70 61 64 64 72 73 74 72 run-id ipaddrstr
15b0: 20 70 6f 72 74 6e 75 6d 20 22 20 68 74 74 70 2d portnum " http-
15c0: 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 74 transport:try-st
15d0: 61 72 74 2d 73 65 72 76 65 72 22 29 0a 09 20 20 art-server")..
15e0: 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 (print "ERROR
15f0: 3a 20 54 72 69 65 64 20 61 6e 64 20 74 72 69 65 : Tried and trie
1600: 64 20 62 75 74 20 63 6f 75 6c 64 20 6e 6f 74 20 d but could not
1610: 73 74 61 72 74 20 74 68 65 20 73 65 72 76 65 72 start the server
1620: 22 29 29 29 29 0a 20 20 20 20 20 3b 3b 20 61 6e ")))). ;; an
1630: 79 20 65 72 72 6f 72 20 69 6e 20 66 6f 6c 6c 6f y error in follo
1640: 77 69 6e 67 20 73 74 65 70 73 20 77 69 6c 6c 20 wing steps will
1650: 72 65 73 75 6c 74 20 69 6e 20 61 20 72 65 74 72 result in a retr
1660: 79 0a 20 20 20 20 20 28 73 65 74 21 20 2a 73 65 y. (set! *se
1670: 72 76 65 72 2d 69 6e 66 6f 2a 20 28 6c 69 73 74 rver-info* (list
1680: 20 69 70 61 64 64 72 73 74 72 20 70 6f 72 74 6e ipaddrstr portn
1690: 75 6d 29 29 0a 20 20 20 20 20 28 74 61 73 6b 73 um)). (tasks
16a0: 3a 73 65 72 76 65 72 2d 73 65 74 2d 69 6e 74 65 :server-set-inte
16b0: 72 66 61 63 65 2d 70 6f 72 74 20 0a 09 09 20 20 rface-port ...
16c0: 20 20 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d (db:delay-if-
16d0: 62 75 73 79 20 74 64 62 64 61 74 29 0a 09 09 20 busy tdbdat)...
16e0: 20 20 20 20 73 65 72 76 65 72 2d 69 64 20 0a 09 server-id ..
16f0: 09 20 20 20 20 20 69 70 61 64 64 72 73 74 72 20 . ipaddrstr
1700: 70 6f 72 74 6e 75 6d 29 0a 20 20 20 20 20 28 64 portnum). (d
1710: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
1720: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1730: 22 49 4e 46 4f 3a 20 54 72 79 69 6e 67 20 74 6f "INFO: Trying to
1740: 20 73 74 61 72 74 20 73 65 72 76 65 72 20 6f 6e start server on
1750: 20 22 20 69 70 61 64 64 72 73 74 72 20 22 3a 22 " ipaddrstr ":"
1760: 20 70 6f 72 74 6e 75 6d 29 0a 20 20 20 20 20 3b portnum). ;
1770: 3b 20 54 68 69 73 20 73 74 61 72 74 73 20 74 68 ; This starts th
1780: 65 20 73 70 69 66 66 79 20 73 65 72 76 65 72 0a e spiffy server.
1790: 20 20 20 20 20 3b 3b 20 4e 45 45 44 20 57 41 59 ;; NEED WAY
17a0: 20 54 4f 20 53 45 54 20 49 50 20 54 4f 20 23 66 TO SET IP TO #f
17b0: 20 54 4f 20 42 49 4e 44 20 41 4c 4c 0a 20 20 20 TO BIND ALL.
17c0: 20 20 3b 3b 20 28 73 74 61 72 74 2d 73 65 72 76 ;; (start-serv
17d0: 65 72 20 62 69 6e 64 2d 61 64 64 72 65 73 73 3a er bind-address:
17e0: 20 69 70 61 64 64 72 73 74 72 20 70 6f 72 74 3a ipaddrstr port:
17f0: 20 70 6f 72 74 6e 75 6d 29 0a 20 20 20 20 20 28 portnum). (
1800: 69 66 20 63 6f 6e 66 69 67 2d 68 6f 73 74 6e 61 if config-hostna
1810: 6d 65 20 3b 3b 20 74 68 69 73 20 69 73 20 61 20 me ;; this is a
1820: 68 69 6e 74 20 74 6f 20 62 69 6e 64 20 64 69 72 hint to bind dir
1830: 65 63 74 6c 79 0a 09 20 28 73 74 61 72 74 2d 73 ectly.. (start-s
1840: 65 72 76 65 72 20 70 6f 72 74 3a 20 70 6f 72 74 erver port: port
1850: 6e 75 6d 20 62 69 6e 64 2d 61 64 64 72 65 73 73 num bind-address
1860: 3a 20 28 69 66 20 28 65 71 75 61 6c 3f 20 63 6f : (if (equal? co
1870: 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 20 22 2d nfig-hostname "-
1880: 22 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 ").......
1890: 69 70 61 64 64 72 73 74 72 0a 09 09 09 09 09 09 ipaddrstr.......
18a0: 20 20 20 20 20 20 20 63 6f 6e 66 69 67 2d 68 6f config-ho
18b0: 73 74 6e 61 6d 65 29 29 0a 09 20 28 73 74 61 72 stname)).. (star
18c0: 74 2d 73 65 72 76 65 72 20 70 6f 72 74 3a 20 70 t-server port: p
18d0: 6f 72 74 6e 75 6d 29 29 0a 20 20 20 20 20 3b 3b ortnum)). ;;
18e0: 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 (portlogger:op
18f0: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 en-run-close por
1900: 74 6c 6f 67 67 65 72 3a 73 65 74 2d 70 6f 72 74 tlogger:set-port
1910: 20 70 6f 72 74 6e 75 6d 20 22 72 65 6c 65 61 73 portnum "releas
1920: 65 64 22 29 0a 20 20 20 20 20 28 74 61 73 6b 73 ed"). (tasks
1930: 3a 73 65 72 76 65 72 2d 66 6f 72 63 65 2d 63 6c :server-force-cl
1940: 65 61 6e 2d 72 75 6e 2d 72 65 63 6f 72 64 20 28 ean-run-record (
1950: 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 db:delay-if-busy
1960: 20 74 64 62 64 61 74 29 20 72 75 6e 2d 69 64 20 tdbdat) run-id
1970: 69 70 61 64 64 72 73 74 72 20 70 6f 72 74 6e 75 ipaddrstr portnu
1980: 6d 20 22 20 68 74 74 70 2d 74 72 61 6e 73 70 6f m " http-transpo
1990: 72 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 rt:try-start-ser
19a0: 76 65 72 22 29 0a 20 20 20 20 20 28 64 65 62 75 ver"). (debu
19b0: 67 3a 70 72 69 6e 74 20 31 20 2a 64 65 66 61 75 g:print 1 *defau
19c0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e lt-log-port* "IN
19d0: 46 4f 3a 20 73 65 72 76 65 72 20 68 61 73 20 62 FO: server has b
19e0: 65 65 6e 20 73 74 6f 70 70 65 64 22 29 29 29 29 een stopped"))))
19f0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
1a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 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 0a 3b 3b 20 53 20 ==========.;; S
1a40: 45 20 52 20 56 20 45 20 52 20 20 20 55 20 54 20 E R V E R U T
1a50: 49 20 4c 20 49 20 54 20 49 20 45 20 53 20 0a 3b I L I T I E S .;
1a60: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
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 0a 0a 3b 3b 3d 3d 3d 3d 3d =======..;;=====
1ab0: 3d 3d 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 0a 3b 3b 20 43 20 4c 20 49 20 45 20 4e 20 54 =.;; C L I E N T
1b00: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 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 0a 0a 28 64 65 ===========..(de
1b50: 66 69 6e 65 20 2a 68 74 74 70 2d 6d 75 74 65 78 fine *http-mutex
1b60: 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a * (make-mutex)).
1b70: 0a 3b 3b 20 4e 4f 54 45 3a 20 4c 61 72 67 65 20 .;; NOTE: Large
1b80: 62 6c 6f 63 6b 20 6f 66 20 63 6f 64 65 20 66 72 block of code fr
1b90: 6f 6d 20 33 32 34 33 36 62 34 32 36 31 38 38 30 om 32436b4261880
1ba0: 38 30 66 37 32 66 63 65 62 36 38 39 34 61 66 35 80f72fceb6894af5
1bb0: 34 31 66 62 61 64 39 39 32 31 65 20 72 65 6d 6f 41fbad9921e remo
1bc0: 76 65 64 20 68 65 72 65 0a 3b 3b 20 20 20 20 20 ved here.;;
1bd0: 20 20 49 27 6d 20 70 72 65 74 74 79 20 73 75 72 I'm pretty sur
1be0: 65 20 69 74 20 69 73 20 64 65 66 75 6e 63 74 2e e it is defunct.
1bf0: 0a 0a 3b 3b 20 54 68 69 73 20 6e 65 78 74 20 62 ..;; This next b
1c00: 6c 6f 63 6b 20 61 6c 6c 20 69 6d 70 6f 72 74 65 lock all importe
1c10: 64 20 65 6e 2d 6d 61 73 73 20 66 72 6f 6d 20 74 d en-mass from t
1c20: 68 65 20 61 70 69 20 62 72 61 6e 63 68 0a 28 64 he api branch.(d
1c30: 65 66 69 6e 65 20 2a 68 74 74 70 2d 72 65 71 75 efine *http-requ
1c40: 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 ests-in-progress
1c50: 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 2a 68 74 * 0).(define *ht
1c60: 74 70 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 2d 6e tp-connections-n
1c70: 65 78 74 2d 63 6c 65 61 6e 75 70 2a 20 28 63 75 ext-cleanup* (cu
1c80: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
1c90: 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 .(define (http-t
1ca0: 72 61 6e 73 70 6f 72 74 3a 67 65 74 2d 74 69 6d ransport:get-tim
1cb0: 65 2d 74 6f 2d 63 6c 65 61 6e 75 70 29 0a 20 20 e-to-cleanup).
1cc0: 28 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 0a (let ((res #f)).
1cd0: 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 (mutex-lock!
1ce0: 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 *http-mutex*).
1cf0: 20 20 20 28 73 65 74 21 20 72 65 73 20 28 3e 20 (set! res (>
1d00: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
1d10: 29 20 2a 68 74 74 70 2d 63 6f 6e 6e 65 63 74 69 ) *http-connecti
1d20: 6f 6e 73 2d 6e 65 78 74 2d 63 6c 65 61 6e 75 70 ons-next-cleanup
1d30: 2a 29 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 *)). (mutex-u
1d40: 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 nlock! *http-mut
1d50: 65 78 2a 29 0a 20 20 20 20 72 65 73 29 29 0a 0a ex*). res))..
1d60: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
1d70: 61 6e 73 70 6f 72 74 3a 69 6e 63 2d 72 65 71 75 ansport:inc-requ
1d80: 65 73 74 73 2d 63 6f 75 6e 74 29 0a 20 20 28 6d ests-count). (m
1d90: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 utex-lock! *http
1da0: 2d 6d 75 74 65 78 2a 29 0a 20 20 28 73 65 74 21 -mutex*). (set!
1db0: 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d *http-requests-
1dc0: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 28 2b 20 in-progress* (+
1dd0: 31 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 1 *http-requests
1de0: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 29 29 0a -in-progress*)).
1df0: 20 20 3b 3b 20 55 73 65 20 74 68 69 73 20 6f 70 ;; Use this op
1e00: 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 73 6c 6f portunity to slo
1e10: 77 20 74 68 69 6e 67 73 20 64 6f 77 6e 20 69 66 w things down if
1e20: 66 20 74 68 65 72 65 20 61 72 65 20 74 6f 6f 20 f there are too
1e30: 6d 61 6e 79 20 72 65 71 75 65 73 74 73 20 69 6e many requests in
1e40: 20 66 6c 69 67 68 74 0a 20 20 28 69 66 20 28 3e flight. (if (>
1e50: 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d *http-requests-
1e60: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 35 29 0a in-progress* 5).
1e70: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 64 (begin..(d
1e80: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
1e90: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
1ea0: 6f 72 74 2a 20 22 57 68 6f 61 20 74 68 65 72 65 ort* "Whoa there
1eb0: 20 62 75 64 64 79 2c 20 65 61 73 65 20 75 70 2e buddy, ease up.
1ec0: 2e 2e 22 29 0a 09 28 74 68 72 65 61 64 2d 73 6c ..")..(thread-sl
1ed0: 65 65 70 21 20 31 29 29 29 0a 20 20 28 6d 75 74 eep! 1))). (mut
1ee0: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 ex-unlock! *http
1ef0: 2d 6d 75 74 65 78 2a 29 29 0a 0a 28 64 65 66 69 -mutex*))..(defi
1f00: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
1f10: 72 74 3a 64 65 63 2d 72 65 71 75 65 73 74 73 2d rt:dec-requests-
1f20: 63 6f 75 6e 74 20 70 72 6f 63 29 20 0a 20 20 28 count proc) . (
1f30: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 mutex-lock! *htt
1f40: 70 2d 6d 75 74 65 78 2a 29 0a 20 20 28 70 72 6f p-mutex*). (pro
1f50: 63 29 0a 20 20 28 73 65 74 21 20 2a 68 74 74 70 c). (set! *http
1f60: 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f -requests-in-pro
1f70: 67 72 65 73 73 2a 20 28 2d 20 2a 68 74 74 70 2d gress* (- *http-
1f80: 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 requests-in-prog
1f90: 72 65 73 73 2a 20 31 29 29 0a 20 20 28 6d 75 74 ress* 1)). (mut
1fa0: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 ex-unlock! *http
1fb0: 2d 6d 75 74 65 78 2a 29 29 0a 0a 28 64 65 66 69 -mutex*))..(defi
1fc0: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
1fd0: 72 74 3a 64 65 63 2d 72 65 71 75 65 73 74 73 2d rt:dec-requests-
1fe0: 63 6f 75 6e 74 2d 61 6e 64 2d 63 6c 6f 73 65 2d count-and-close-
1ff0: 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 29 all-connections)
2000: 0a 20 20 28 73 65 74 21 20 2a 68 74 74 70 2d 72 . (set! *http-r
2010: 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 equests-in-progr
2020: 65 73 73 2a 20 28 2d 20 2a 68 74 74 70 2d 72 65 ess* (- *http-re
2030: 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 quests-in-progre
2040: 73 73 2a 20 31 29 29 0a 20 20 28 6c 65 74 20 6c ss* 1)). (let l
2050: 6f 6f 70 20 28 28 65 74 69 6d 65 20 28 2b 20 28 oop ((etime (+ (
2060: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
2070: 20 35 29 29 29 20 3b 3b 20 67 69 76 65 20 75 70 5))) ;; give up
2080: 20 69 6e 20 66 69 76 65 20 73 65 63 6f 6e 64 73 in five seconds
2090: 0a 20 20 20 20 28 69 66 20 28 3e 20 2a 68 74 74 . (if (> *htt
20a0: 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 p-requests-in-pr
20b0: 6f 67 72 65 73 73 2a 20 30 29 0a 09 28 69 66 20 ogress* 0)..(if
20c0: 28 3e 20 65 74 69 6d 65 20 28 63 75 72 72 65 6e (> etime (curren
20d0: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 20 t-seconds))..
20e0: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
20f0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
2100: 30 35 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 05).. (loop
2110: 20 65 74 69 6d 65 29 29 0a 09 20 20 20 20 28 64 etime)).. (d
2120: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
2130: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
2140: 70 6f 72 74 2a 20 22 72 65 71 75 65 73 74 73 20 port* "requests
2150: 73 74 69 6c 6c 20 69 6e 20 70 72 6f 67 72 65 73 still in progres
2160: 73 20 61 66 74 65 72 20 35 20 73 65 63 6f 6e 64 s after 5 second
2170: 73 20 6f 66 20 77 61 69 74 69 6e 67 2e 20 49 27 s of waiting. I'
2180: 6d 20 67 6f 69 6e 67 20 74 6f 20 70 61 73 73 20 m going to pass
2190: 6f 6e 20 63 6c 65 61 6e 69 6e 67 20 75 70 20 68 on cleaning up h
21a0: 74 74 70 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 22 ttp connections"
21b0: 29 29 0a 09 28 63 6c 6f 73 65 2d 61 6c 6c 2d 63 ))..(close-all-c
21c0: 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 29 29 0a 20 onnections!))).
21d0: 20 28 73 65 74 21 20 2a 68 74 74 70 2d 63 6f 6e (set! *http-con
21e0: 6e 65 63 74 69 6f 6e 73 2d 6e 65 78 74 2d 63 6c nections-next-cl
21f0: 65 61 6e 75 70 2a 20 28 2b 20 28 63 75 72 72 65 eanup* (+ (curre
2200: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 31 30 29 29 nt-seconds) 10))
2210: 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b . (mutex-unlock
2220: 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 29 ! *http-mutex*))
2230: 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ..(define (http-
2240: 74 72 61 6e 73 70 6f 72 74 3a 69 6e 63 2d 72 65 transport:inc-re
2250: 71 75 65 73 74 73 2d 61 6e 64 2d 70 72 65 70 2d quests-and-prep-
2260: 74 6f 2d 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e to-close-all-con
2270: 6e 65 63 74 69 6f 6e 73 29 0a 20 20 28 6d 75 74 nections). (mut
2280: 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d ex-lock! *http-m
2290: 75 74 65 78 2a 29 0a 20 20 28 73 65 74 21 20 2a utex*). (set! *
22a0: 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e http-requests-in
22b0: 2d 70 72 6f 67 72 65 73 73 2a 20 28 2b 20 31 20 -progress* (+ 1
22c0: 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 *http-requests-i
22d0: 6e 2d 70 72 6f 67 72 65 73 73 2a 29 29 29 0a 0a n-progress*)))..
22e0: 3b 3b 20 53 65 6e 64 20 22 63 6d 64 22 20 77 69 ;; Send "cmd" wi
22f0: 74 68 20 6a 73 6f 6e 20 70 61 79 6c 6f 61 64 20 th json payload
2300: 22 70 61 72 61 6d 73 22 20 74 6f 20 73 65 72 76 "params" to serv
2310: 65 72 64 61 74 20 61 6e 64 20 72 65 63 65 69 76 erdat and receiv
2320: 65 20 72 65 73 75 6c 74 0a 3b 3b 0a 28 64 65 66 e result.;;.(def
2330: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
2340: 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 ort:client-api-s
2350: 65 6e 64 2d 72 65 63 65 69 76 65 20 72 75 6e 2d end-receive run-
2360: 69 64 20 73 65 72 76 65 72 64 61 74 20 63 6d 64 id serverdat cmd
2370: 20 70 61 72 61 6d 73 20 23 21 6b 65 79 20 28 6e params #!key (n
2380: 75 6d 72 65 74 72 69 65 73 20 33 29 29 0a 20 20 umretries 3)).
2390: 28 6c 65 74 2a 20 28 28 66 75 6c 6c 75 72 6c 20 (let* ((fullurl
23a0: 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 (if (vector?
23b0: 73 65 72 76 65 72 64 61 74 29 0a 09 09 09 20 28 serverdat).... (
23c0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
23d0: 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 61 70 erver-dat-get-ap
23e0: 69 2d 72 65 71 20 73 65 72 76 65 72 64 61 74 29 i-req serverdat)
23f0: 0a 09 09 09 20 28 62 65 67 69 6e 0a 09 09 09 20 .... (begin....
2400: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
2410: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
2420: 72 74 2a 20 22 46 41 54 41 4c 20 45 52 52 4f 52 rt* "FATAL ERROR
2430: 3a 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 : http-transport
2440: 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 :client-api-send
2450: 2d 72 65 63 65 69 76 65 20 63 61 6c 6c 65 64 20 -receive called
2460: 77 69 74 68 20 6e 6f 20 73 65 72 76 65 72 20 69 with no server i
2470: 6e 66 6f 22 29 0a 09 09 09 20 20 20 28 65 78 69 nfo").... (exi
2480: 74 20 31 29 29 29 29 0a 09 20 28 72 65 73 20 20 t 1)))).. (res
2490: 20 20 20 20 20 20 23 66 29 0a 09 20 28 73 75 63 #f).. (suc
24a0: 63 65 73 73 20 20 20 20 23 74 29 0a 09 20 28 73 cess #t).. (s
24b0: 70 61 72 61 6d 73 20 20 20 20 28 64 62 3a 6f 62 params (db:ob
24c0: 6a 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d 73 j->string params
24d0: 20 74 72 61 6e 73 70 6f 72 74 3a 20 27 68 74 74 transport: 'htt
24e0: 70 29 29 29 0a 3b 3b 20 20 20 20 28 63 6f 6e 64 p))).;; (cond
24f0: 69 74 69 6f 6e 2d 63 61 73 65 0a 3b 3b 20 20 20 ition-case.;;
2500: 20 20 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 handle-excepti
2510: 6f 6e 73 0a 3b 3b 20 20 20 20 20 65 78 6e 0a 3b ons.;; exn.;
2520: 3b 20 20 20 20 20 28 69 66 20 28 3e 20 6e 75 6d ; (if (> num
2530: 72 65 74 72 69 65 73 20 30 29 0a 3b 3b 09 20 28 retries 0).;;. (
2540: 62 65 67 69 6e 0a 3b 3b 09 20 20 20 28 6d 75 74 begin.;;. (mut
2550: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 ex-unlock! *http
2560: 2d 6d 75 74 65 78 2a 29 0a 3b 3b 09 20 20 20 28 -mutex*).;;. (
2570: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
2580: 0a 3b 3b 09 20 20 20 28 68 61 6e 64 6c 65 2d 65 .;;. (handle-e
2590: 78 63 65 70 74 69 6f 6e 73 0a 3b 3b 09 20 20 20 xceptions.;;.
25a0: 20 65 78 6e 0a 3b 3b 09 20 20 20 20 28 64 65 62 exn.;;. (deb
25b0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
25c0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
25d0: 41 52 4e 49 4e 47 3a 20 63 6c 6f 73 69 6e 67 20 ARNING: closing
25e0: 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 66 61 69 6c connections fail
25f0: 65 64 2e 20 53 65 72 76 65 72 20 61 74 20 22 20 ed. Server at "
2600: 66 75 6c 6c 75 72 6c 20 22 20 61 6c 6d 6f 73 74 fullurl " almost
2610: 20 63 65 72 74 61 69 6e 6c 79 20 64 65 61 64 22 certainly dead"
2620: 29 0a 3b 3b 09 20 20 20 20 28 63 6c 6f 73 65 2d ).;;. (close-
2630: 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 all-connections!
2640: 29 29 0a 3b 3b 09 20 20 20 28 64 65 62 75 67 3a )).;;. (debug:
2650: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
2660: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e -log-port* "WARN
2670: 49 4e 47 3a 20 46 61 69 6c 65 64 20 74 6f 20 63 ING: Failed to c
2680: 6f 6d 6d 75 6e 69 63 61 74 65 20 77 69 74 68 20 ommunicate with
2690: 73 65 72 76 65 72 2c 20 74 72 79 69 6e 67 20 61 server, trying a
26a0: 67 61 69 6e 2c 20 6e 75 6d 72 65 74 72 69 65 73 gain, numretries
26b0: 20 6c 65 66 74 3a 20 22 20 6e 75 6d 72 65 74 72 left: " numretr
26c0: 69 65 73 29 0a 3b 3b 09 20 20 20 28 68 74 74 70 ies).;;. (http
26d0: 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e -transport:clien
26e0: 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 t-api-send-recei
26f0: 76 65 20 72 75 6e 2d 69 64 20 73 65 72 76 65 72 ve run-id server
2700: 64 61 74 20 63 6d 64 20 73 70 61 72 61 6d 73 20 dat cmd sparams
2710: 6e 75 6d 72 65 74 72 69 65 73 3a 20 28 2d 20 6e numretries: (- n
2720: 75 6d 72 65 74 72 69 65 73 20 31 29 29 29 0a 3b umretries 1))).;
2730: 3b 09 20 28 62 65 67 69 6e 0a 3b 3b 09 20 20 20 ;. (begin.;;.
2740: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
2750: 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 3b 3b 09 http-mutex*).;;.
2760: 20 20 20 28 74 61 73 6b 73 3a 6b 69 6c 6c 2d 73 (tasks:kill-s
2770: 65 72 76 65 72 2d 72 75 6e 2d 69 64 20 72 75 6e erver-run-id run
2780: 2d 69 64 29 0a 3b 3b 09 20 20 20 23 66 29 29 0a -id).;;. #f)).
2790: 3b 3b 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 ;; (begin.
27a0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
27b0: 74 2d 69 6e 66 6f 20 31 31 20 2a 64 65 66 61 75 t-info 11 *defau
27c0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 75 lt-log-port* "fu
27d0: 6c 6c 75 72 6c 3d 22 20 66 75 6c 6c 75 72 6c 20 llurl=" fullurl
27e0: 22 2c 20 63 6d 64 3d 22 20 63 6d 64 20 22 2c 20 ", cmd=" cmd ",
27f0: 70 61 72 61 6d 73 3d 22 20 70 61 72 61 6d 73 20 params=" params
2800: 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d ", run-id=" run-
2810: 69 64 20 22 5c 6e 22 29 0a 20 20 20 20 20 20 20 id "\n").
2820: 3b 3b 20 73 65 74 20 75 70 20 74 68 65 20 68 74 ;; set up the ht
2830: 74 70 2d 63 6c 69 65 6e 74 20 68 65 72 65 0a 20 tp-client here.
2840: 20 20 20 20 20 20 28 6d 61 78 2d 72 65 74 72 79 (max-retry
2850: 2d 61 74 74 65 6d 70 74 73 20 31 29 0a 20 20 20 -attempts 1).
2860: 20 20 20 20 3b 3b 20 63 6f 6e 73 69 64 65 72 20 ;; consider
2870: 61 6c 6c 20 72 65 71 75 65 73 74 73 20 69 6e 64 all requests ind
2880: 65 6d 70 6f 74 65 6e 74 0a 20 20 20 20 20 20 20 empotent.
2890: 28 72 65 74 72 79 2d 72 65 71 75 65 73 74 3f 20 (retry-request?
28a0: 28 6c 61 6d 62 64 61 20 28 72 65 71 75 65 73 74 (lambda (request
28b0: 29 0a 09 09 09 20 23 66 29 29 0a 20 20 20 20 20 ).... #f)).
28c0: 20 20 3b 3b 20 73 65 6e 64 20 74 68 65 20 64 61 ;; send the da
28d0: 74 61 20 61 6e 64 20 67 65 74 20 74 68 65 20 72 ta and get the r
28e0: 65 73 70 6f 6e 73 65 0a 20 20 20 20 20 20 20 3b esponse. ;
28f0: 3b 20 65 78 74 72 61 63 74 20 74 68 65 20 6e 65 ; extract the ne
2900: 65 64 65 64 20 69 6e 66 6f 20 66 72 6f 6d 20 74 eded info from t
2910: 68 65 20 68 74 74 70 20 64 61 74 61 20 61 6e 64 he http data and
2920: 20 0a 20 20 20 20 20 20 20 3b 3b 20 70 72 6f 63 . ;; proc
2930: 65 73 73 20 61 6e 64 20 72 65 74 75 72 6e 20 69 ess and return i
2940: 74 2e 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 t.. (let*
2950: 28 28 73 65 6e 64 2d 72 65 63 69 65 76 65 20 28 ((send-recieve (
2960: 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 lambda ()....
2970: 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 (mutex-lock!
2980: 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 09 09 *http-mutex*)...
2990: 09 20 20 20 20 20 20 3b 3b 20 28 63 6f 6e 64 69 . ;; (condi
29a0: 74 69 6f 6e 2d 63 61 73 65 20 28 77 69 74 68 2d tion-case (with-
29b0: 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 65 71 75 65 input-from-reque
29c0: 73 74 20 22 68 74 74 70 3a 2f 2f 6c 6f 63 61 6c st "http://local
29d0: 68 6f 73 74 22 3b 20 23 66 20 72 65 61 64 2d 6c host"; #f read-l
29e0: 69 6e 65 73 29 0a 09 09 09 20 20 20 20 20 20 3b ines).... ;
29f0: 3b 09 09 09 09 09 20 20 20 20 20 20 20 28 28 65 ;..... ((e
2a00: 78 6e 20 68 74 74 70 20 63 6c 69 65 6e 74 2d 65 xn http client-e
2a10: 72 72 6f 72 29 20 65 20 28 70 72 69 6e 74 20 65 rror) e (print e
2a20: 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 ))).... (se
2a30: 74 21 20 72 65 73 20 28 76 65 63 74 6f 72 0a 09 t! res (vector..
2a40: 09 09 09 09 20 73 75 63 63 65 73 73 0a 09 09 09 .... success....
2a50: 09 09 20 28 64 62 3a 73 74 72 69 6e 67 2d 3e 6f .. (db:string->o
2a60: 62 6a 20 0a 09 09 09 09 09 20 20 28 68 61 6e 64 bj ...... (hand
2a70: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
2a80: 09 09 09 20 20 20 65 78 6e 0a 09 09 09 09 09 20 ... exn......
2a90: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 (begin......
2aa0: 20 20 20 28 73 65 74 21 20 73 75 63 63 65 73 73 (set! success
2ab0: 20 23 66 29 0a 09 09 09 09 09 20 20 20 20 20 28 #f)...... (
2ac0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
2ad0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2ae0: 20 22 57 41 52 4e 49 4e 47 3a 20 66 61 69 6c 75 "WARNING: failu
2af0: 72 65 20 69 6e 20 77 69 74 68 2d 69 6e 70 75 74 re in with-input
2b00: 2d 66 72 6f 6d 2d 72 65 71 75 65 73 74 20 74 6f -from-request to
2b10: 20 22 20 66 75 6c 6c 75 72 6c 20 22 2e 22 29 0a " fullurl ".").
2b20: 09 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 ..... (debug
2b30: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
2b40: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 t-log-port* " me
2b50: 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 ssage: " ((condi
2b60: 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 tion-property-ac
2b70: 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 cessor 'exn 'mes
2b80: 73 61 67 65 29 20 65 78 6e 29 29 0a 09 09 09 09 sage) exn)).....
2b90: 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c . (hash-tabl
2ba0: 65 2d 64 65 6c 65 74 65 21 20 2a 72 75 6e 72 65 e-delete! *runre
2bb0: 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 29 0a 09 09 mote* run-id)...
2bc0: 09 09 09 20 20 20 20 20 3b 3b 20 4b 69 6c 6c 69 ... ;; Killi
2bd0: 6e 67 20 61 73 73 6f 63 69 61 74 65 64 20 73 65 ng associated se
2be0: 72 76 65 72 20 74 6f 20 61 6c 6c 6f 77 20 63 6c rver to allow cl
2bf0: 65 61 6e 20 72 65 74 72 79 2e 22 29 0a 09 09 09 ean retry.")....
2c00: 09 09 20 20 20 20 20 3b 3b 20 28 74 61 73 6b 73 .. ;; (tasks
2c10: 3a 6b 69 6c 6c 2d 73 65 72 76 65 72 2d 72 75 6e :kill-server-run
2c20: 2d 69 64 20 72 75 6e 2d 69 64 29 20 20 3b 3b 20 -id run-id) ;;
2c30: 62 65 74 74 65 72 20 74 6f 20 6b 69 6c 6c 20 74 better to kill t
2c40: 68 65 20 73 65 72 76 65 72 20 69 6e 20 74 68 65 he server in the
2c50: 20 6c 6f 67 69 63 20 74 68 61 74 20 63 61 6c 6c logic that call
2c60: 65 64 20 74 68 69 73 20 72 6f 75 74 69 6e 65 3f ed this routine?
2c70: 0a 09 09 09 09 09 20 20 20 20 20 28 6d 75 74 65 ...... (mute
2c80: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d x-unlock! *http-
2c90: 6d 75 74 65 78 2a 29 0a 09 09 09 09 09 20 20 20 mutex*)......
2ca0: 20 20 3b 3b 3b 20 28 73 69 67 6e 61 6c 20 28 6d ;;; (signal (m
2cb0: 61 6b 65 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 6f ake-composite-co
2cc0: 6e 64 69 74 69 6f 6e 0a 09 09 09 09 09 20 20 20 ndition......
2cd0: 20 20 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 28 ;;; (
2ce0: 6d 61 6b 65 2d 70 72 6f 70 65 72 74 79 2d 63 6f make-property-co
2cf0: 6e 64 69 74 69 6f 6e 20 27 63 6f 6d 6d 66 61 69 ndition 'commfai
2d00: 6c 20 27 6d 65 73 73 61 67 65 20 22 66 61 69 6c l 'message "fail
2d10: 65 64 20 74 6f 20 63 6f 6e 6e 65 63 74 20 74 6f ed to connect to
2d20: 20 73 65 72 76 65 72 22 29 29 29 0a 09 09 09 09 server"))).....
2d30: 09 20 20 20 20 20 3b 3b 3b 20 22 63 6f 6d 6d 75 . ;;; "commu
2d40: 6e 69 63 61 74 69 6f 6e 73 20 66 61 69 6c 65 64 nications failed
2d50: 22 0a 09 09 09 09 09 20 20 20 20 20 28 64 62 3a "...... (db:
2d60: 6f 62 6a 2d 3e 73 74 72 69 6e 67 20 23 66 29 29 obj->string #f))
2d70: 0a 09 09 09 09 09 20 20 20 28 77 69 74 68 2d 69 ...... (with-i
2d80: 6e 70 75 74 2d 66 72 6f 6d 2d 72 65 71 75 65 73 nput-from-reques
2d90: 74 20 3b 3b 20 77 61 73 20 64 61 74 0a 09 09 09 t ;; was dat....
2da0: 09 09 20 20 20 20 66 75 6c 6c 75 72 6c 20 0a 09 .. fullurl ..
2db0: 09 09 09 09 20 20 20 20 28 6c 69 73 74 20 28 63 .... (list (c
2dc0: 6f 6e 73 20 27 6b 65 79 20 22 74 68 65 6b 65 79 ons 'key "thekey
2dd0: 22 29 0a 09 09 09 09 09 09 20 20 28 63 6f 6e 73 ")....... (cons
2de0: 20 27 63 6d 64 20 63 6d 64 29 0a 09 09 09 09 09 'cmd cmd)......
2df0: 09 20 20 28 63 6f 6e 73 20 27 70 61 72 61 6d 73 . (cons 'params
2e00: 20 73 70 61 72 61 6d 73 29 29 0a 09 09 09 09 09 sparams))......
2e10: 20 20 20 20 72 65 61 64 2d 73 74 72 69 6e 67 29 read-string)
2e20: 29 0a 09 09 09 09 09 20 20 74 72 61 6e 73 70 6f )...... transpo
2e30: 72 74 3a 20 27 68 74 74 70 29 29 29 0a 09 09 09 rt: 'http)))....
2e40: 20 20 20 20 20 20 3b 3b 20 53 68 6f 75 6c 64 6e ;; Shouldn
2e50: 27 74 20 74 68 69 73 20 62 65 20 61 20 63 61 6c 't this be a cal
2e60: 6c 20 74 6f 20 74 68 65 20 6d 61 6e 61 67 65 64 l to the managed
2e70: 20 63 61 6c 6c 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 call-all-connec
2e80: 74 69 6f 6e 73 20 73 74 75 66 66 20 61 62 6f 76 tions stuff abov
2e90: 65 3f 0a 09 09 09 20 20 20 20 20 20 28 63 6c 6f e?.... (clo
2ea0: 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f se-all-connectio
2eb0: 6e 73 21 29 0a 09 09 09 20 20 20 20 20 20 28 6d ns!).... (m
2ec0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 utex-unlock! *ht
2ed0: 74 70 2d 6d 75 74 65 78 2a 29 0a 09 09 09 20 20 tp-mutex*)....
2ee0: 20 20 20 20 29 29 0a 09 20 20 20 20 20 20 28 74 )).. (t
2ef0: 69 6d 65 2d 6f 75 74 20 20 20 20 20 28 6c 61 6d ime-out (lam
2f00: 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 bda ()....
2f10: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 34 (thread-sleep! 4
2f20: 35 29 0a 09 09 09 20 20 20 20 20 20 23 66 29 29 5).... #f))
2f30: 0a 09 20 20 20 20 20 20 28 74 68 31 20 28 6d 61 .. (th1 (ma
2f40: 6b 65 2d 74 68 72 65 61 64 20 73 65 6e 64 2d 72 ke-thread send-r
2f50: 65 63 69 65 76 65 20 22 77 69 74 68 2d 69 6e 70 ecieve "with-inp
2f60: 75 74 2d 66 72 6f 6d 2d 72 65 71 75 65 73 74 22 ut-from-request"
2f70: 29 29 0a 09 20 20 20 20 20 20 28 74 68 32 20 28 )).. (th2 (
2f80: 6d 61 6b 65 2d 74 68 72 65 61 64 20 74 69 6d 65 make-thread time
2f90: 2d 6f 75 74 20 20 20 20 20 22 74 69 6d 65 20 6f -out "time o
2fa0: 75 74 22 29 29 29 0a 09 20 28 74 68 72 65 61 64 ut"))).. (thread
2fb0: 2d 73 74 61 72 74 21 20 74 68 31 29 0a 09 20 28 -start! th1).. (
2fc0: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th
2fd0: 32 29 0a 09 20 28 74 68 72 65 61 64 2d 6a 6f 69 2).. (thread-joi
2fe0: 6e 21 20 74 68 31 29 0a 09 20 28 74 68 72 65 61 n! th1).. (threa
2ff0: 64 2d 74 65 72 6d 69 6e 61 74 65 21 20 74 68 32 d-terminate! th2
3000: 29 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ).. (debug:print
3010: 2d 69 6e 66 6f 20 31 31 20 2a 64 65 66 61 75 6c -info 11 *defaul
3020: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 67 6f 74 t-log-port* "got
3030: 20 72 65 73 3d 22 20 72 65 73 29 0a 09 20 28 69 res=" res).. (i
3040: 66 20 28 76 65 63 74 6f 72 3f 20 72 65 73 29 0a f (vector? res).
3050: 09 20 20 20 20 20 28 69 66 20 28 76 65 63 74 6f . (if (vecto
3060: 72 2d 72 65 66 20 72 65 73 20 30 29 0a 09 09 20 r-ref res 0)...
3070: 72 65 73 0a 09 09 20 28 62 65 67 69 6e 20 3b 3b res... (begin ;;
3080: 20 6e 6f 74 65 3a 20 74 68 69 73 20 63 6f 64 65 note: this code
3090: 20 61 6c 73 6f 20 63 61 6c 6c 65 64 20 69 6e 20 also called in
30a0: 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 20 2d nmsg-transport -
30b0: 20 63 6f 6e 73 69 64 65 72 20 63 6f 6e 73 6f 6c consider consol
30c0: 69 64 61 74 69 6e 67 20 69 74 0a 09 09 20 20 20 idating it...
30d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
30e0: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
30f0: 67 2d 70 6f 72 74 2a 20 22 65 72 72 6f 72 20 6f g-port* "error o
3100: 63 63 75 72 65 64 20 61 74 20 73 65 72 76 65 72 ccured at server
3110: 2c 20 69 6e 66 6f 3d 22 20 28 76 65 63 74 6f 72 , info=" (vector
3120: 2d 72 65 66 20 72 65 73 20 32 29 29 0a 09 09 20 -ref res 2))...
3130: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
3140: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3150: 72 74 2a 20 22 20 63 6c 69 65 6e 74 20 63 61 6c rt* " client cal
3160: 6c 20 63 68 61 69 6e 3a 22 29 0a 09 09 20 20 20 l chain:")...
3170: 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 (print-call-chai
3180: 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 n (current-error
3190: 2d 70 6f 72 74 29 29 0a 09 09 20 20 20 28 64 65 -port))... (de
31a0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
31b0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
31c0: 20 73 65 72 76 65 72 20 63 61 6c 6c 20 63 68 61 server call cha
31d0: 69 6e 3a 22 29 0a 09 09 20 20 20 28 70 70 20 28 in:")... (pp (
31e0: 76 65 63 74 6f 72 2d 72 65 66 20 72 65 73 20 31 vector-ref res 1
31f0: 29 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 ) (current-error
3200: 2d 70 6f 72 74 29 29 0a 09 09 20 20 20 28 73 69 -port))... (si
3210: 67 6e 61 6c 20 28 76 65 63 74 6f 72 2d 72 65 66 gnal (vector-ref
3220: 20 72 65 73 75 6c 74 20 30 29 29 29 29 0a 09 20 result 0))))..
3230: 20 20 20 20 28 73 69 67 6e 61 6c 20 28 6d 61 6b (signal (mak
3240: 65 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 6f 6e 64 e-composite-cond
3250: 69 74 69 6f 6e 0a 09 09 20 20 20 20 20 20 28 6d ition... (m
3260: 61 6b 65 2d 70 72 6f 70 65 72 74 79 2d 63 6f 6e ake-property-con
3270: 64 69 74 69 6f 6e 20 0a 09 09 20 20 20 20 20 20 dition ...
3280: 20 27 74 69 6d 65 6f 75 74 0a 09 09 20 20 20 20 'timeout...
3290: 20 20 20 27 6d 65 73 73 61 67 65 20 22 6e 6d 73 'message "nms
32a0: 67 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 g-transport:clie
32b0: 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 nt-api-send-rece
32c0: 69 76 65 2d 72 61 77 20 74 69 6d 65 64 20 6f 75 ive-raw timed ou
32d0: 74 20 74 61 6c 6b 69 6e 67 20 74 6f 20 73 65 72 t talking to ser
32e0: 76 65 72 22 29 29 29 29 29 29 29 0a 0a 3b 3b 20 ver")))))))..;;
32f0: 63 61 72 65 66 75 6c 20 63 6c 6f 73 69 6e 67 20 careful closing
3300: 6f 66 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 73 of connections s
3310: 74 6f 72 65 64 20 69 6e 20 2a 72 75 6e 72 65 6d tored in *runrem
3320: 6f 74 65 2a 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ote*.;;.(define
3330: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
3340: 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 6f 6e close-connection
3350: 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 74 s run-id). (let
3360: 2a 20 28 28 73 65 72 76 65 72 2d 64 61 74 20 28 * ((server-dat (
3370: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
3380: 65 66 61 75 6c 74 20 2a 72 75 6e 72 65 6d 6f 74 efault *runremot
3390: 65 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 29 0a e* run-id #f))).
33a0: 20 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f (if (vector?
33b0: 20 73 65 72 76 65 72 2d 64 61 74 29 0a 09 28 6c server-dat)..(l
33c0: 65 74 20 28 28 61 70 69 2d 64 61 74 20 28 68 74 et ((api-dat (ht
33d0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
33e0: 76 65 72 2d 64 61 74 2d 67 65 74 2d 61 70 69 2d ver-dat-get-api-
33f0: 75 72 69 20 73 65 72 76 65 72 2d 64 61 74 29 29 uri server-dat))
3400: 29 0a 09 20 20 28 63 6c 6f 73 65 2d 63 6f 6e 6e ).. (close-conn
3410: 65 63 74 69 6f 6e 21 20 61 70 69 2d 64 61 74 29 ection! api-dat)
3420: 0a 09 20 20 23 74 29 0a 09 23 66 29 29 29 0a 0a .. #t)..#f)))..
3430: 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 68 .(define (make-h
3440: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 ttp-transport:se
3450: 72 76 65 72 2d 64 61 74 29 28 6d 61 6b 65 2d 76 rver-dat)(make-v
3460: 65 63 74 6f 72 20 36 29 29 0a 28 64 65 66 69 6e ector 6)).(defin
3470: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
3480: 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 t:server-dat-get
3490: 2d 69 66 61 63 65 20 20 20 20 20 20 20 20 20 76 -iface v
34a0: 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ec) (vector-r
34b0: 65 66 20 20 76 65 63 20 30 29 29 0a 28 64 65 66 ef vec 0)).(def
34c0: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
34d0: 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 ort:server-dat-g
34e0: 65 74 2d 70 6f 72 74 20 20 20 20 20 20 20 20 20 et-port
34f0: 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 vec) (vector
3500: 2d 72 65 66 20 20 76 65 63 20 31 29 29 0a 28 64 -ref vec 1)).(d
3510: 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e efine (http-tran
3520: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 sport:server-dat
3530: 2d 67 65 74 2d 61 70 69 2d 75 72 69 20 20 20 20 -get-api-uri
3540: 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 vec) (vect
3550: 6f 72 2d 72 65 66 20 20 76 65 63 20 32 29 29 0a or-ref vec 2)).
3560: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
3570: 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 ansport:server-d
3580: 61 74 2d 67 65 74 2d 61 70 69 2d 75 72 6c 20 20 at-get-api-url
3590: 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 vec) (ve
35a0: 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 33 29 ctor-ref vec 3)
35b0: 29 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ).(define (http-
35c0: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
35d0: 2d 64 61 74 2d 67 65 74 2d 61 70 69 2d 72 65 71 -dat-get-api-req
35e0: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
35f0: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
3600: 34 29 29 0a 28 64 65 66 69 6e 65 20 28 68 74 74 4)).(define (htt
3610: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 p-transport:serv
3620: 65 72 2d 64 61 74 2d 67 65 74 2d 6c 61 73 74 2d er-dat-get-last-
3630: 61 63 63 65 73 73 20 20 20 76 65 63 29 20 20 20 access vec)
3640: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
3650: 63 20 35 29 29 0a 28 64 65 66 69 6e 65 20 28 68 c 5)).(define (h
3660: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 ttp-transport:se
3670: 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 73 6f 63 rver-dat-get-soc
3680: 6b 65 74 20 20 20 20 20 20 20 20 76 65 63 29 20 ket vec)
3690: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
36a0: 76 65 63 20 36 29 29 0a 0a 28 64 65 66 69 6e 65 vec 6))..(define
36b0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
36c0: 3a 73 65 72 76 65 72 2d 64 61 74 2d 6d 61 6b 65 :server-dat-make
36d0: 2d 75 72 6c 20 76 65 63 29 0a 20 20 28 69 66 20 -url vec). (if
36e0: 28 61 6e 64 20 28 68 74 74 70 2d 74 72 61 6e 73 (and (http-trans
36f0: 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
3700: 67 65 74 2d 69 66 61 63 65 20 76 65 63 29 0a 09 get-iface vec)..
3710: 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f (http-transpo
3720: 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 rt:server-dat-ge
3730: 74 2d 70 6f 72 74 20 20 76 65 63 29 29 0a 20 20 t-port vec)).
3740: 20 20 20 20 28 63 6f 6e 63 20 22 68 74 74 70 3a (conc "http:
3750: 2f 2f 22 20 0a 09 20 20 20 20 28 68 74 74 70 2d //" .. (http-
3760: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
3770: 2d 64 61 74 2d 67 65 74 2d 69 66 61 63 65 20 76 -dat-get-iface v
3780: 65 63 29 0a 09 20 20 20 20 22 3a 22 0a 09 20 20 ec).. ":"..
3790: 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 (http-transpor
37a0: 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 t:server-dat-get
37b0: 2d 70 6f 72 74 20 20 76 65 63 29 29 0a 20 20 20 -port vec)).
37c0: 20 20 20 23 66 29 29 0a 0a 28 64 65 66 69 6e 65 #f))..(define
37d0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
37e0: 3a 73 65 72 76 65 72 2d 64 61 74 2d 75 70 64 61 :server-dat-upda
37f0: 74 65 2d 6c 61 73 74 2d 61 63 63 65 73 73 20 76 te-last-access v
3800: 65 63 29 0a 20 20 28 69 66 20 28 76 65 63 74 6f ec). (if (vecto
3810: 72 3f 20 76 65 63 29 0a 20 20 20 20 20 20 28 76 r? vec). (v
3820: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 35 ector-set! vec 5
3830: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
3840: 73 29 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e s)). (begin
3850: 0a 09 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 ..(print-call-ch
3860: 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 ain (current-err
3870: 6f 72 2d 70 6f 72 74 29 29 0a 09 28 64 65 62 75 or-port))..(debu
3880: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
3890: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
38a0: 74 2a 20 22 63 61 6c 6c 20 74 6f 20 68 74 74 70 t* "call to http
38b0: 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 -transport:serve
38c0: 72 2d 64 61 74 2d 75 70 64 61 74 65 2d 6c 61 73 r-dat-update-las
38d0: 74 2d 61 63 63 65 73 73 20 77 69 74 68 20 6e 6f t-access with no
38e0: 6e 2d 76 65 63 74 6f 72 21 21 22 29 29 29 29 0a n-vector!!")))).
38f0: 0a 3b 3b 0a 3b 3b 20 63 6f 6e 6e 65 63 74 0a 3b .;;.;; connect.;
3900: 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ;.(define (http-
3910: 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 transport:client
3920: 2d 63 6f 6e 6e 65 63 74 20 69 66 61 63 65 20 70 -connect iface p
3930: 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 61 ort). (let* ((a
3940: 70 69 2d 75 72 6c 20 20 20 20 20 20 28 63 6f 6e pi-url (con
3950: 63 20 22 68 74 74 70 3a 2f 2f 22 20 69 66 61 63 c "http://" ifac
3960: 65 20 22 3a 22 20 70 6f 72 74 20 22 2f 61 70 69 e ":" port "/api
3970: 22 29 29 0a 09 20 28 61 70 69 2d 75 72 69 20 20 ")).. (api-uri
3980: 20 20 20 20 28 75 72 69 2d 72 65 66 65 72 65 6e (uri-referen
3990: 63 65 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f ce (conc "http:/
39a0: 2f 22 20 69 66 61 63 65 20 22 3a 22 20 70 6f 72 /" iface ":" por
39b0: 74 20 22 2f 61 70 69 22 29 29 29 0a 09 20 28 61 t "/api"))).. (a
39c0: 70 69 2d 72 65 71 20 20 20 20 20 20 28 6d 61 6b pi-req (mak
39d0: 65 2d 72 65 71 75 65 73 74 20 6d 65 74 68 6f 64 e-request method
39e0: 3a 20 27 50 4f 53 54 20 75 72 69 3a 20 61 70 69 : 'POST uri: api
39f0: 2d 75 72 69 29 29 0a 09 20 28 73 65 72 76 65 72 -uri)).. (server
3a00: 2d 64 61 74 20 20 20 28 76 65 63 74 6f 72 20 69 -dat (vector i
3a10: 66 61 63 65 20 70 6f 72 74 20 61 70 69 2d 75 72 face port api-ur
3a20: 69 20 61 70 69 2d 75 72 6c 20 61 70 69 2d 72 65 i api-url api-re
3a30: 71 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e q (current-secon
3a40: 64 73 29 29 29 29 0a 20 20 20 20 73 65 72 76 65 ds)))). serve
3a50: 72 2d 64 61 74 29 29 0a 0a 3b 3b 20 72 75 6e 20 r-dat))..;; run
3a60: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6b http-transport:k
3a70: 65 65 70 2d 72 75 6e 6e 69 6e 67 20 69 6e 20 61 eep-running in a
3a80: 20 70 61 72 61 6c 6c 65 6c 20 74 68 72 65 61 64 parallel thread
3a90: 20 74 6f 20 6d 6f 6e 69 74 6f 72 20 74 68 61 74 to monitor that
3aa0: 20 74 68 65 20 64 62 20 69 73 20 62 65 69 6e 67 the db is being
3ab0: 20 0a 3b 3b 20 75 73 65 64 20 61 6e 64 20 74 6f .;; used and to
3ac0: 20 73 68 75 74 64 6f 77 6e 20 61 66 74 65 72 20 shutdown after
3ad0: 73 6f 6d 65 74 69 6d 65 20 69 66 20 69 74 20 69 sometime if it i
3ae0: 73 20 6e 6f 74 2e 0a 3b 3b 0a 28 64 65 66 69 6e s not..;;.(defin
3af0: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
3b00: 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 73 t:keep-running s
3b10: 65 72 76 65 72 2d 69 64 20 72 75 6e 2d 69 64 29 erver-id run-id)
3b20: 0a 20 20 3b 3b 20 69 66 20 6e 6f 6e 65 20 72 75 . ;; if none ru
3b30: 6e 6e 69 6e 67 20 6f 72 20 69 66 20 3e 20 32 30 nning or if > 20
3b40: 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 0a seconds since .
3b50: 20 20 3b 3b 20 73 65 72 76 65 72 20 6c 61 73 74 ;; server last
3b60: 20 75 73 65 64 20 74 68 65 6e 20 73 74 61 72 74 used then start
3b70: 20 73 68 75 74 64 6f 77 6e 0a 20 20 3b 3b 20 54 shutdown. ;; T
3b80: 68 69 73 20 74 68 72 65 61 64 20 77 61 69 74 73 his thread waits
3b90: 20 66 6f 72 20 74 68 65 20 73 65 72 76 65 72 20 for the server
3ba0: 74 6f 20 63 6f 6d 65 20 61 6c 69 76 65 0a 20 20 to come alive.
3bb0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
3bc0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
3bd0: 2d 70 6f 72 74 2a 20 22 53 74 61 72 74 69 6e 67 -port* "Starting
3be0: 20 74 68 65 20 73 79 6e 63 2d 62 61 63 6b 2c 20 the sync-back,
3bf0: 6b 65 65 70 20 61 6c 69 76 65 20 74 68 72 65 61 keep alive threa
3c00: 64 20 69 6e 20 73 65 72 76 65 72 20 66 6f 72 20 d in server for
3c10: 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 29 run-id=" run-id)
3c20: 0a 20 20 28 6c 65 74 2a 20 28 28 74 64 62 64 61 . (let* ((tdbda
3c30: 74 20 20 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 t (tasks:op
3c40: 65 6e 2d 64 62 29 29 0a 09 20 28 73 65 72 76 65 en-db)).. (serve
3c50: 72 2d 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 r-start-time (cu
3c60: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
3c70: 09 20 28 73 65 72 76 65 72 2d 69 6e 66 6f 20 28 . (server-info (
3c80: 6c 65 74 20 6c 6f 6f 70 20 28 28 73 74 61 72 74 let loop ((start
3c90: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 -time (current-s
3ca0: 65 63 6f 6e 64 73 29 29 0a 09 09 09 09 20 28 63 econds))..... (c
3cb0: 68 61 6e 67 65 64 20 20 20 20 23 74 29 0a 09 09 hanged #t)...
3cc0: 09 09 20 28 6c 61 73 74 2d 73 64 61 74 20 20 22 .. (last-sdat "
3cd0: 6e 6f 74 20 74 68 69 73 22 29 29 0a 20 20 20 20 not this")).
3ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3cf0: 20 20 20 20 28 6c 65 74 20 28 28 73 64 61 74 20 (let ((sdat
3d00: 23 66 29 29 0a 09 09 09 20 20 28 74 68 72 65 61 #f)).... (threa
3d10: 64 2d 73 6c 65 65 70 21 20 30 2e 30 31 29 0a 09 d-sleep! 0.01)..
3d20: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
3d30: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
3d40: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 61 69 74 -log-port* "Wait
3d50: 69 6e 67 20 66 6f 72 20 73 65 72 76 65 72 20 61 ing for server a
3d60: 6c 69 76 65 20 73 69 67 6e 61 74 75 72 65 22 29 live signature")
3d70: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3d80: 20 20 20 20 20 20 20 20 20 20 20 28 6d 75 74 65 (mute
3d90: 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 x-lock! *heartbe
3da0: 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 at-mutex*).
3db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3dc0: 20 20 20 20 20 28 73 65 74 21 20 73 64 61 74 20 (set! sdat
3dd0: 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 29 0a 20 *server-info*).
3de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3df0: 20 20 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d (mutex-
3e00: 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 unlock! *heartbe
3e10: 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 at-mutex*).
3e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3e30: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 73 64 (if (and sd
3e40: 61 74 0a 09 09 09 09 20 20 20 28 6e 6f 74 20 63 at..... (not c
3e50: 68 61 6e 67 65 64 29 0a 09 09 09 09 20 20 20 28 hanged)..... (
3e60: 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 > (- (current-se
3e70: 63 6f 6e 64 73 29 20 73 74 61 72 74 2d 74 69 6d conds) start-tim
3e80: 65 29 20 32 29 29 0a 09 09 09 20 20 20 20 20 20 e) 2))....
3e90: 73 64 61 74 0a 20 20 20 20 20 20 20 20 20 20 20 sdat.
3ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3eb0: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 64 (begin.....(d
3ec0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3ed0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
3ee0: 6f 72 74 2a 20 22 53 74 69 6c 6c 20 77 61 69 74 ort* "Still wait
3ef0: 69 6e 67 2c 20 6c 61 73 74 2d 73 64 61 74 3d 22 ing, last-sdat="
3f00: 20 6c 61 73 74 2d 73 64 61 74 29 0a 20 20 20 20 last-sdat).
3f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3f20: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 6c 65 (sle
3f30: 65 70 20 34 29 0a 09 09 09 09 28 69 66 20 28 3e ep 4).....(if (>
3f40: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
3f50: 6f 6e 64 73 29 20 73 74 61 72 74 2d 74 69 6d 65 onds) start-time
3f60: 29 20 31 32 30 29 20 3b 3b 20 62 65 65 6e 20 77 ) 120) ;; been w
3f70: 61 69 74 69 6e 67 20 66 6f 72 20 74 77 6f 20 6d aiting for two m
3f80: 69 6e 75 74 65 73 0a 09 09 09 09 20 20 20 20 28 inutes..... (
3f90: 62 65 67 69 6e 0a 09 09 09 09 20 20 20 20 20 20 begin.....
3fa0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
3fb0: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
3fc0: 67 2d 70 6f 72 74 2a 20 22 74 72 61 6e 73 70 6f g-port* "transpo
3fd0: 72 74 20 61 70 70 65 61 72 73 20 74 6f 20 68 61 rt appears to ha
3fe0: 76 65 20 64 69 65 64 2c 20 65 78 69 74 69 6e 67 ve died, exiting
3ff0: 20 73 65 72 76 65 72 20 22 20 73 65 72 76 65 72 server " server
4000: 2d 69 64 20 22 20 66 6f 72 20 72 75 6e 20 22 20 -id " for run "
4010: 72 75 6e 2d 69 64 29 0a 09 09 09 09 20 20 20 20 run-id).....
4020: 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d (tasks:server-
4030: 64 65 6c 65 74 65 2d 72 65 63 6f 72 64 20 28 64 delete-record (d
4040: 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 b:delay-if-busy
4050: 74 64 62 64 61 74 29 20 73 65 72 76 65 72 2d 69 tdbdat) server-i
4060: 64 20 22 66 61 69 6c 65 64 20 74 6f 20 73 74 61 d "failed to sta
4070: 72 74 2c 20 6e 65 76 65 72 20 72 65 63 65 69 76 rt, never receiv
4080: 65 64 20 73 65 72 76 65 72 20 61 6c 69 76 65 20 ed server alive
4090: 73 69 67 6e 61 74 75 72 65 22 29 0a 09 09 09 09 signature").....
40a0: 20 20 20 20 20 20 28 65 78 69 74 29 29 0a 09 09 (exit))...
40b0: 09 09 20 20 20 20 28 6c 6f 6f 70 20 73 74 61 72 .. (loop star
40c0: 74 2d 74 69 6d 65 0a 09 09 09 09 09 20 20 28 65 t-time...... (e
40d0: 71 75 61 6c 3f 20 73 64 61 74 20 6c 61 73 74 2d qual? sdat last-
40e0: 73 64 61 74 29 0a 09 09 09 09 09 20 20 73 64 61 sdat)...... sda
40f0: 74 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 t))))))).
4100: 20 20 28 69 66 61 63 65 20 20 20 20 20 20 20 28 (iface (
4110: 63 61 72 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 car server-info)
4120: 29 0a 20 20 20 20 20 20 20 20 20 28 70 6f 72 74 ). (port
4130: 20 20 20 20 20 20 20 20 28 63 61 64 72 20 73 65 (cadr se
4140: 72 76 65 72 2d 69 6e 66 6f 29 29 0a 20 20 20 20 rver-info)).
4150: 20 20 20 20 20 28 6c 61 73 74 2d 61 63 63 65 73 (last-acces
4160: 73 20 30 29 0a 09 20 28 73 65 72 76 65 72 2d 74 s 0).. (server-t
4170: 69 6d 65 6f 75 74 20 28 73 65 72 76 65 72 3a 67 imeout (server:g
4180: 65 74 2d 74 69 6d 65 6f 75 74 29 29 29 0a 20 20 et-timeout))).
4190: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 63 6f (let loop ((co
41a0: 75 6e 74 20 20 20 20 20 20 20 20 20 30 29 0a 09 unt 0)..
41b0: 20 20 20 20 20 20 20 28 73 65 72 76 65 72 2d 73 (server-s
41c0: 74 61 74 65 20 27 61 76 61 69 6c 61 62 6c 65 29 tate 'available)
41d0: 0a 09 20 20 20 20 20 20 20 28 62 61 64 2d 73 79 .. (bad-sy
41e0: 6e 63 2d 63 6f 75 6e 74 20 30 29 29 0a 0a 20 20 nc-count 0))..
41f0: 20 20 20 20 3b 3b 20 55 73 65 20 74 68 69 73 20 ;; Use this
4200: 6f 70 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 73 opportunity to s
4210: 79 6e 63 20 74 68 65 20 69 6e 6d 65 6d 64 62 20 ync the inmemdb
4220: 74 6f 20 64 62 0a 20 20 20 20 20 20 28 69 66 20 to db. (if
4230: 2a 69 6e 6d 65 6d 64 62 2a 20 0a 09 20 20 28 6c *inmemdb* .. (l
4240: 65 74 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 et ((start-time
4250: 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 (current-millise
4260: 63 6f 6e 64 73 29 29 0a 09 09 28 73 79 6e 63 2d conds))...(sync-
4270: 74 69 6d 65 20 20 23 66 29 0a 09 09 28 72 65 6d time #f)...(rem
4280: 2d 74 69 6d 65 20 20 20 23 66 29 29 0a 09 20 20 -time #f))..
4290: 20 20 3b 3b 20 69 6e 6d 65 6d 64 62 20 69 73 20 ;; inmemdb is
42a0: 61 20 64 62 73 74 72 75 63 74 0a 09 20 20 20 20 a dbstruct..
42b0: 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 0a (condition-case.
42c0: 09 20 20 20 20 20 28 64 62 3a 73 79 6e 63 2d 74 . (db:sync-t
42d0: 6f 75 63 68 65 64 20 2a 69 6e 6d 65 6d 64 62 2a ouched *inmemdb*
42e0: 20 2a 72 75 6e 2d 69 64 2a 20 66 6f 72 63 65 2d *run-id* force-
42f0: 73 79 6e 63 3a 20 23 74 29 0a 09 20 20 20 20 20 sync: #t)..
4300: 28 28 73 79 6e 63 2d 66 61 69 6c 65 64 29 28 63 ((sync-failed)(c
4310: 6f 6e 64 0a 09 09 09 20 20 20 20 28 28 3e 20 62 ond.... ((> b
4320: 61 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 31 30 ad-sync-count 10
4330: 29 20 3b 3b 20 74 69 6d 65 20 74 6f 20 67 69 76 ) ;; time to giv
4340: 65 20 75 70 0a 09 09 09 20 20 20 20 20 28 68 74 e up.... (ht
4350: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
4360: 76 65 72 2d 73 68 75 74 64 6f 77 6e 20 73 65 72 ver-shutdown ser
4370: 76 65 72 2d 69 64 20 70 6f 72 74 29 29 0a 09 09 ver-id port))...
4380: 09 20 20 20 20 28 65 6c 73 65 20 3b 3b 20 28 3e . (else ;; (>
4390: 20 62 61 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 bad-sync-count
43a0: 30 29 20 20 3b 3b 20 77 65 27 76 65 20 68 61 64 0) ;; we've had
43b0: 20 61 20 66 61 69 6c 20 6f 72 20 74 77 6f 2c 20 a fail or two,
43c0: 64 65 6c 61 79 20 61 6e 64 20 6c 6f 6f 70 0a 09 delay and loop..
43d0: 09 09 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 .. (thread-s
43e0: 6c 65 65 70 21 20 35 29 0a 09 09 09 20 20 20 20 leep! 5)....
43f0: 20 28 6c 6f 6f 70 20 63 6f 75 6e 74 20 73 65 72 (loop count ser
4400: 76 65 72 2d 73 74 61 74 65 20 28 2b 20 62 61 64 ver-state (+ bad
4410: 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 31 29 29 29 -sync-count 1)))
4420: 29 29 0a 09 20 20 20 20 20 28 28 65 78 6e 29 0a )).. ((exn).
4430: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
4440: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
4450: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4460: 65 72 72 6f 72 20 66 72 6f 6d 20 73 79 6e 63 20 error from sync
4470: 63 6f 64 65 20 6f 74 68 65 72 20 74 68 61 6e 20 code other than
4480: 27 73 79 6e 63 2d 66 61 69 6c 65 64 2e 20 41 74 'sync-failed. At
4490: 74 65 6d 70 74 69 6e 67 20 74 6f 20 67 72 61 63 tempting to grac
44a0: 65 66 75 6c 6c 79 20 73 68 75 74 64 6f 77 6e 20 efully shutdown
44b0: 74 68 65 20 73 65 72 76 65 72 22 29 0a 09 20 20 the server")..
44c0: 20 20 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 (tasks:serve
44d0: 72 2d 64 65 6c 65 74 65 2d 72 65 63 6f 72 64 20 r-delete-record
44e0: 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 (db:delay-if-bus
44f0: 79 20 74 64 62 64 61 74 29 20 73 65 72 76 65 72 y tdbdat) server
4500: 2d 69 64 20 22 20 68 74 74 70 2d 74 72 61 6e 73 -id " http-trans
4510: 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e port:keep-runnin
4520: 67 20 63 72 61 73 68 65 64 22 29 0a 09 20 20 20 g crashed")..
4530: 20 20 20 28 65 78 69 74 29 29 29 0a 09 20 20 20 (exit)))..
4540: 20 28 73 65 74 21 20 73 79 6e 63 2d 74 69 6d 65 (set! sync-time
4550: 20 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 (- (current-mi
4560: 6c 6c 69 73 65 63 6f 6e 64 73 29 20 73 74 61 72 lliseconds) star
4570: 74 2d 74 69 6d 65 29 29 0a 09 20 20 20 20 28 73 t-time)).. (s
4580: 65 74 21 20 72 65 6d 2d 74 69 6d 65 20 28 71 75 et! rem-time (qu
4590: 6f 74 69 65 6e 74 20 28 2d 20 34 30 30 30 20 73 otient (- 4000 s
45a0: 79 6e 63 2d 74 69 6d 65 29 20 31 30 30 30 29 29 ync-time) 1000))
45b0: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
45c0: 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 4 *default-lo
45d0: 67 2d 70 6f 72 74 2a 20 22 53 59 4e 43 3a 20 74 g-port* "SYNC: t
45e0: 69 6d 65 3d 20 22 20 73 79 6e 63 2d 74 69 6d 65 ime= " sync-time
45f0: 20 22 2c 20 72 65 6d 2d 74 69 6d 65 3d 22 20 72 ", rem-time=" r
4600: 65 6d 2d 74 69 6d 65 29 0a 09 20 20 20 20 0a 09 em-time).. ..
4610: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 3c 3d (if (and (<=
4620: 20 72 65 6d 2d 74 69 6d 65 20 34 29 0a 09 09 20 rem-time 4)...
4630: 20 20 20 20 28 3e 20 72 65 6d 2d 74 69 6d 65 20 (> rem-time
4640: 30 29 29 0a 09 09 28 74 68 72 65 61 64 2d 73 6c 0))...(thread-sl
4650: 65 65 70 21 20 72 65 6d 2d 74 69 6d 65 29 0a 09 eep! rem-time)..
4660: 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 .(thread-sleep!
4670: 34 29 29 29 20 3b 3b 20 66 61 6c 6c 62 61 63 6b 4))) ;; fallback
4680: 20 66 6f 72 20 69 66 20 74 68 65 20 6d 61 74 68 for if the math
4690: 20 69 73 20 63 68 61 6e 67 65 64 20 2e 2e 2e 0a is changed ....
46a0: 0a 09 20 20 3b 3b 0a 09 20 20 3b 3b 20 6e 6f 20 .. ;;.. ;; no
46b0: 2a 69 6e 6d 65 6d 64 62 2a 20 79 65 74 2c 20 73 *inmemdb* yet, s
46c0: 65 74 20 72 75 6e 6e 69 6e 67 20 61 66 74 65 72 et running after
46d0: 20 6f 75 72 20 66 69 72 73 74 20 70 61 73 73 20 our first pass
46e0: 74 68 72 6f 75 67 68 20 61 6e 64 20 73 74 61 72 through and star
46f0: 74 20 74 68 65 20 64 62 0a 09 20 20 3b 3b 0a 09 t the db.. ;;..
4700: 20 20 28 69 66 20 28 65 71 3f 20 73 65 72 76 65 (if (eq? serve
4710: 72 2d 73 74 61 74 65 20 27 61 76 61 69 6c 61 62 r-state 'availab
4720: 6c 65 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 le).. (let
4730: 28 28 6e 65 77 2d 73 65 72 76 65 72 2d 69 64 20 ((new-server-id
4740: 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 61 6d (tasks:server-am
4750: 2d 69 2d 74 68 65 2d 73 65 72 76 65 72 3f 20 28 -i-the-server? (
4760: 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 db:delay-if-busy
4770: 20 74 64 62 64 61 74 29 20 72 75 6e 2d 69 64 29 tdbdat) run-id)
4780: 29 29 20 3b 3b 20 74 72 79 20 74 6f 20 65 6e 73 )) ;; try to ens
4790: 75 72 65 20 6e 6f 20 64 6f 75 62 6c 65 20 72 65 ure no double re
47a0: 67 69 73 74 65 72 69 6e 67 20 6f 66 20 73 65 72 gistering of ser
47b0: 76 65 72 73 0a 09 09 28 69 66 20 28 65 71 75 61 vers...(if (equa
47c0: 6c 3f 20 6e 65 77 2d 73 65 72 76 65 72 2d 69 64 l? new-server-id
47d0: 20 73 65 72 76 65 72 2d 69 64 29 0a 09 09 20 20 server-id)...
47e0: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 (begin...
47f0: 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 73 (tasks:server-s
4800: 65 74 2d 73 74 61 74 65 21 20 28 64 62 3a 64 65 et-state! (db:de
4810: 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 62 64 lay-if-busy tdbd
4820: 61 74 29 20 73 65 72 76 65 72 2d 69 64 20 22 64 at) server-id "d
4830: 62 70 72 65 70 22 29 0a 09 09 20 20 20 20 20 20 bprep")...
4840: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
4850: 2e 35 29 20 3b 3b 20 67 69 76 65 20 73 6f 6d 65 .5) ;; give some
4860: 20 6d 61 72 67 69 6e 20 66 6f 72 20 71 75 65 72 margin for quer
4870: 69 65 73 20 74 6f 20 63 6f 6d 70 6c 65 74 65 20 ies to complete
4880: 62 65 66 6f 72 65 20 73 77 69 74 63 68 69 6e 67 before switching
4890: 20 66 72 6f 6d 20 66 69 6c 65 20 62 61 73 65 64 from file based
48a0: 20 61 63 63 65 73 73 20 74 6f 20 73 65 72 76 65 access to serve
48b0: 72 20 62 61 73 65 64 20 61 63 63 65 73 73 0a 09 r based access..
48c0: 09 20 20 20 20 20 20 28 73 65 74 21 20 2a 69 6e . (set! *in
48d0: 6d 65 6d 64 62 2a 20 20 28 64 62 3a 73 65 74 75 memdb* (db:setu
48e0: 70 29 29 20 3b 3b 20 20 72 75 6e 2d 69 64 29 29 p)) ;; run-id))
48f0: 0a 09 09 20 20 20 20 20 20 3b 3b 20 66 6f 72 63 ... ;; forc
4900: 65 20 69 6e 69 74 69 61 6c 69 7a 61 74 69 6f 6e e initialization
4910: 0a 09 09 20 20 20 20 20 20 3b 3b 20 28 64 62 3a ... ;; (db:
4920: 67 65 74 2d 64 62 20 2a 69 6e 6d 65 6d 64 62 2a get-db *inmemdb*
4930: 20 23 74 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 #t)... ;;
4940: 28 64 62 3a 67 65 74 2d 64 62 20 2a 69 6e 6d 65 (db:get-db *inme
4950: 6d 64 62 2a 20 72 75 6e 2d 69 64 29 0a 09 09 20 mdb* run-id)...
4960: 20 20 20 20 20 28 74 61 73 6b 73 3a 73 65 72 76 (tasks:serv
4970: 65 72 2d 73 65 74 2d 73 74 61 74 65 21 20 28 64 er-set-state! (d
4980: 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 b:delay-if-busy
4990: 74 64 62 64 61 74 29 20 73 65 72 76 65 72 2d 69 tdbdat) server-i
49a0: 64 20 22 72 75 6e 6e 69 6e 67 22 29 29 0a 09 09 d "running"))...
49b0: 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 67 6f (begin ;; go
49c0: 74 74 61 20 65 78 69 74 20 6e 69 63 65 6c 79 0a tta exit nicely.
49d0: 09 09 20 20 20 20 20 20 28 74 61 73 6b 73 3a 73 .. (tasks:s
49e0: 65 72 76 65 72 2d 73 65 74 2d 73 74 61 74 65 21 erver-set-state!
49f0: 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 (db:delay-if-bu
4a00: 73 79 20 74 64 62 64 61 74 29 20 73 65 72 76 65 sy tdbdat) serve
4a10: 72 2d 69 64 20 22 63 6f 6c 6c 69 73 69 6f 6e 22 r-id "collision"
4a20: 29 0a 09 09 20 20 20 20 20 20 28 68 74 74 70 2d )... (http-
4a30: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
4a40: 2d 73 68 75 74 64 6f 77 6e 20 73 65 72 76 65 72 -shutdown server
4a50: 2d 69 64 20 70 6f 72 74 29 29 29 29 29 29 0a 20 -id port)))))).
4a60: 20 20 20 20 20 0a 20 20 20 20 20 20 28 69 66 20 . (if
4a70: 28 3c 20 63 6f 75 6e 74 20 31 29 20 3b 3b 20 33 (< count 1) ;; 3
4a80: 78 33 20 3d 20 39 20 73 65 63 73 20 61 70 72 6f x3 = 9 secs apro
4a90: 78 0a 09 20 20 28 6c 6f 6f 70 20 28 2b 20 63 6f x.. (loop (+ co
4aa0: 75 6e 74 20 31 29 20 27 72 75 6e 6e 69 6e 67 20 unt 1) 'running
4ab0: 62 61 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 29 29 bad-sync-count))
4ac0: 0a 20 20 20 20 20 20 0a 20 20 20 20 20 20 3b 3b . . ;;
4ad0: 20 43 68 65 63 6b 20 74 68 61 74 20 69 66 61 63 Check that ifac
4ae0: 65 20 61 6e 64 20 70 6f 72 74 20 68 61 76 65 20 e and port have
4af0: 6e 6f 74 20 63 68 61 6e 67 65 64 20 28 63 61 6e not changed (can
4b00: 20 68 61 70 70 65 6e 20 69 66 20 73 65 72 76 65 happen if serve
4b10: 72 20 70 6f 72 74 20 63 6f 6c 6c 69 64 65 73 29 r port collides)
4b20: 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f . (mutex-lo
4b30: 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
4b40: 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 73 65 utex*). (se
4b50: 74 21 20 73 64 61 74 20 2a 73 65 72 76 65 72 2d t! sdat *server-
4b60: 69 6e 66 6f 2a 29 0a 20 20 20 20 20 20 28 6d 75 info*). (mu
4b70: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 tex-unlock! *hea
4b80: 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 rtbeat-mutex*).
4b90: 20 20 20 20 20 0a 20 20 20 20 20 20 28 69 66 20 . (if
4ba0: 28 6f 72 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f (or (not (equal?
4bb0: 20 73 64 61 74 20 28 6c 69 73 74 20 69 66 61 63 sdat (list ifac
4bc0: 65 20 70 6f 72 74 29 29 29 0a 09 20 20 20 20 20 e port)))..
4bd0: 20 28 6e 6f 74 20 73 65 72 76 65 72 2d 69 64 29 (not server-id)
4be0: 29 0a 09 20 20 28 62 65 67 69 6e 20 0a 09 20 20 ).. (begin ..
4bf0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
4c00: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
4c10: 6f 67 2d 70 6f 72 74 2a 20 22 69 6e 74 65 72 66 og-port* "interf
4c20: 61 63 65 20 63 68 61 6e 67 65 64 2c 20 72 65 66 ace changed, ref
4c30: 72 65 73 68 69 6e 67 20 69 66 61 63 65 20 61 6e reshing iface an
4c40: 64 20 70 6f 72 74 20 69 6e 66 6f 22 29 0a 09 20 d port info")..
4c50: 20 20 20 28 73 65 74 21 20 69 66 61 63 65 20 28 (set! iface (
4c60: 63 61 72 20 73 64 61 74 29 29 0a 09 20 20 20 20 car sdat))..
4c70: 28 73 65 74 21 20 70 6f 72 74 20 20 28 63 61 64 (set! port (cad
4c80: 72 20 73 64 61 74 29 29 29 29 0a 20 20 20 20 20 r sdat)))).
4c90: 20 0a 20 20 20 20 20 20 3b 3b 20 54 72 61 6e 73 . ;; Trans
4ca0: 66 65 72 20 2a 6c 61 73 74 2d 64 62 2d 61 63 63 fer *last-db-acc
4cb0: 65 73 73 2a 20 74 6f 20 6c 61 73 74 2d 61 63 63 ess* to last-acc
4cc0: 65 73 73 20 74 6f 20 75 73 65 20 69 6e 20 63 68 ess to use in ch
4cd0: 65 63 6b 69 6e 67 20 74 68 61 74 20 77 65 20 61 ecking that we a
4ce0: 72 65 20 73 74 69 6c 6c 20 61 6c 69 76 65 0a 20 re still alive.
4cf0: 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b (mutex-lock
4d00: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
4d10: 65 78 2a 29 0a 20 20 20 20 20 20 28 73 65 74 21 ex*). (set!
4d20: 20 6c 61 73 74 2d 61 63 63 65 73 73 20 2a 6c 61 last-access *la
4d30: 73 74 2d 64 62 2d 61 63 63 65 73 73 2a 29 0a 20 st-db-access*).
4d40: 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f (mutex-unlo
4d50: 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
4d60: 75 74 65 78 2a 29 0a 0a 20 20 20 20 20 20 3b 3b utex*).. ;;
4d70: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 31 (debug:print 11
4d80: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4d90: 72 74 2a 20 22 6c 61 73 74 2d 61 63 63 65 73 73 rt* "last-access
4da0: 3d 22 20 6c 61 73 74 2d 61 63 63 65 73 73 20 22 =" last-access "
4db0: 2c 20 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 , server-timeout
4dc0: 3d 22 20 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 =" server-timeou
4dd0: 74 29 0a 20 20 20 20 20 20 3b 3b 0a 20 20 20 20 t). ;;.
4de0: 20 20 3b 3b 20 6e 6f 5f 74 72 61 66 66 69 63 2c ;; no_traffic,
4df0: 20 6e 6f 20 72 75 6e 6e 69 6e 67 20 74 65 73 74 no running test
4e00: 73 2c 20 69 66 20 73 65 72 76 65 72 20 30 2c 20 s, if server 0,
4e10: 6e 6f 20 72 75 6e 6e 69 6e 67 20 73 65 72 76 65 no running serve
4e20: 72 73 0a 20 20 20 20 20 20 3b 3b 0a 20 20 20 20 rs. ;;.
4e30: 20 20 3b 3b 20 28 6c 65 74 20 28 28 77 61 69 74 ;; (let ((wait
4e40: 2d 6f 6e 2d 72 75 6e 6e 69 6e 67 20 28 63 6f 6e -on-running (con
4e50: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
4e60: 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 figdat* "server"
4e70: 20 62 22 77 61 69 74 2d 6f 6e 2d 72 75 6e 6e 69 b"wait-on-runni
4e80: 6e 67 22 29 29 29 20 3b 3b 20 77 61 69 74 20 6f ng"))) ;; wait o
4e90: 6e 20 72 75 6e 6e 69 6e 67 20 74 61 73 6b 73 20 n running tasks
4ea0: 28 69 66 20 6e 6f 74 20 74 72 75 65 20 74 68 65 (if not true the
4eb0: 6e 20 65 78 69 74 20 6f 6e 20 74 69 6d 65 20 6f n exit on time o
4ec0: 75 74 29 0a 20 20 20 20 20 20 3b 3b 0a 20 20 20 ut). ;;.
4ed0: 20 20 20 28 6c 65 74 2a 20 28 28 68 72 73 2d 73 (let* ((hrs-s
4ee0: 69 6e 63 65 2d 73 74 61 72 74 20 20 28 2f 20 28 ince-start (/ (
4ef0: 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
4f00: 64 73 29 20 73 65 72 76 65 72 2d 73 74 61 72 74 ds) server-start
4f10: 2d 74 69 6d 65 29 20 33 36 30 30 29 29 0a 09 20 -time) 3600))..
4f20: 20 20 20 20 28 61 64 6a 75 73 74 65 64 2d 74 69 (adjusted-ti
4f30: 6d 65 6f 75 74 20 28 69 66 20 28 3e 20 68 72 73 meout (if (> hrs
4f40: 2d 73 69 6e 63 65 2d 73 74 61 72 74 20 31 29 0a -since-start 1).
4f50: 09 09 09 09 20 20 20 28 2d 20 73 65 72 76 65 72 .... (- server
4f60: 2d 74 69 6d 65 6f 75 74 20 28 69 6e 65 78 61 63 -timeout (inexac
4f70: 74 2d 3e 65 78 61 63 74 20 28 72 6f 75 6e 64 20 t->exact (round
4f80: 28 2a 20 68 72 73 2d 73 69 6e 63 65 2d 73 74 61 (* hrs-since-sta
4f90: 72 74 20 36 30 29 29 29 29 20 20 3b 3b 20 73 75 rt 60)))) ;; su
4fa0: 62 74 72 61 63 74 20 36 30 20 73 65 63 6f 6e 64 btract 60 second
4fb0: 73 20 70 65 72 20 68 6f 75 72 0a 09 09 09 09 20 s per hour.....
4fc0: 20 20 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 server-timeout
4fd0: 29 29 29 0a 09 28 69 66 20 28 63 6f 6d 6d 6f 6e )))..(if (common
4fe0: 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 :low-noise-print
4ff0: 20 31 32 30 20 22 73 65 72 76 65 72 20 74 69 6d 120 "server tim
5000: 65 6f 75 74 22 29 0a 09 20 20 20 20 28 64 65 62 eout").. (deb
5010: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
5020: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
5030: 74 2a 20 22 41 64 6a 75 73 74 65 64 20 73 65 72 t* "Adjusted ser
5040: 76 65 72 20 74 69 6d 65 6f 75 74 3a 20 22 20 61 ver timeout: " a
5050: 64 6a 75 73 74 65 64 2d 74 69 6d 65 6f 75 74 29 djusted-timeout)
5060: 29 0a 09 28 69 66 20 28 61 6e 64 20 2a 73 65 72 )..(if (and *ser
5070: 76 65 72 2d 72 75 6e 2a 0a 09 09 20 28 3e 20 28 ver-run*... (> (
5080: 2b 20 6c 61 73 74 2d 61 63 63 65 73 73 20 73 65 + last-access se
5090: 72 76 65 72 2d 74 69 6d 65 6f 75 74 29 0a 09 09 rver-timeout)...
50a0: 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (current-sec
50b0: 6f 6e 64 73 29 29 29 0a 09 20 20 20 20 28 62 65 onds))).. (be
50c0: 67 69 6e 0a 09 20 20 20 20 20 20 28 69 66 20 28 gin.. (if (
50d0: 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 common:low-noise
50e0: 2d 70 72 69 6e 74 20 31 32 30 20 22 73 65 72 76 -print 120 "serv
50f0: 65 72 20 63 6f 6e 74 69 6e 75 69 6e 67 22 29 0a er continuing").
5100: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
5110: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
5120: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 76 -log-port* "Serv
5130: 65 72 20 63 6f 6e 74 69 6e 75 69 6e 67 2c 20 73 er continuing, s
5140: 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 6c 61 73 econds since las
5150: 74 20 64 62 20 61 63 63 65 73 73 3a 20 22 20 28 t db access: " (
5160: 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
5170: 64 73 29 20 6c 61 73 74 2d 61 63 63 65 73 73 29 ds) last-access)
5180: 29 29 0a 09 20 20 20 20 20 20 3b 3b 0a 09 20 20 )).. ;;..
5190: 20 20 20 20 3b 3b 20 43 6f 6e 73 69 64 65 72 20 ;; Consider
51a0: 69 6d 70 6c 65 6d 65 6e 74 69 6e 67 20 73 6f 6d implementing som
51b0: 65 20 73 6d 61 72 74 73 20 68 65 72 65 20 74 6f e smarts here to
51c0: 20 72 65 2d 69 6e 73 65 72 74 20 74 68 65 20 72 re-insert the r
51d0: 65 63 6f 72 64 20 6f 72 20 6b 69 6c 6c 20 73 65 ecord or kill se
51e0: 6c 66 20 69 73 0a 09 20 20 20 20 20 20 3b 3b 20 lf is.. ;;
51f0: 74 68 65 20 64 62 20 69 6e 64 69 63 61 74 65 73 the db indicates
5200: 20 73 6f 0a 09 20 20 20 20 20 20 3b 3b 0a 09 20 so.. ;;..
5210: 20 20 20 20 20 3b 3b 20 28 69 66 20 28 74 61 73 ;; (if (tas
5220: 6b 73 3a 73 65 72 76 65 72 2d 61 6d 2d 69 2d 74 ks:server-am-i-t
5230: 68 65 2d 73 65 72 76 65 72 3f 20 74 64 62 20 72 he-server? tdb r
5240: 75 6e 2d 69 64 29 0a 09 20 20 20 20 20 20 3b 3b un-id).. ;;
5250: 20 20 20 20 20 28 74 61 73 6b 73 3a 73 65 72 76 (tasks:serv
5260: 65 72 2d 73 65 74 2d 73 74 61 74 65 21 20 74 64 er-set-state! td
5270: 62 20 73 65 72 76 65 72 2d 69 64 20 22 72 75 6e b server-id "run
5280: 6e 69 6e 67 22 29 29 0a 09 20 20 20 20 20 20 3b ning")).. ;
5290: 3b 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 30 ;.. (loop 0
52a0: 20 73 65 72 76 65 72 2d 73 74 61 74 65 20 62 61 server-state ba
52b0: 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 29 29 0a 09 d-sync-count))..
52c0: 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 (http-transp
52d0: 6f 72 74 3a 73 65 72 76 65 72 2d 73 68 75 74 64 ort:server-shutd
52e0: 6f 77 6e 20 73 65 72 76 65 72 2d 69 64 20 70 6f own server-id po
52f0: 72 74 29 29 29 29 29 29 0a 20 20 0a 28 64 65 66 rt)))))). .(def
5300: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
5310: 6f 72 74 3a 73 65 72 76 65 72 2d 73 68 75 74 64 ort:server-shutd
5320: 6f 77 6e 20 73 65 72 76 65 72 2d 69 64 20 70 6f own server-id po
5330: 72 74 29 0a 20 20 28 6c 65 74 20 28 28 74 64 62 rt). (let ((tdb
5340: 64 61 74 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d dat (tasks:open-
5350: 64 62 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 db))). (debug
5360: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
5370: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
5380: 20 22 53 74 61 72 74 69 6e 67 20 74 6f 20 73 68 "Starting to sh
5390: 75 74 64 6f 77 6e 20 74 68 65 20 73 65 72 76 65 utdown the serve
53a0: 72 2e 22 29 0a 20 20 20 20 3b 3b 20 6e 65 65 64 r."). ;; need
53b0: 20 74 6f 20 64 65 6c 65 74 65 20 6f 6e 6c 79 20 to delete only
53c0: 2a 6d 79 2a 20 73 65 72 76 65 72 20 65 6e 74 72 *my* server entr
53d0: 79 20 28 66 75 74 75 72 65 20 75 73 65 29 0a 20 y (future use).
53e0: 20 20 20 28 73 65 74 21 20 2a 74 69 6d 65 2d 74 (set! *time-t
53f0: 6f 2d 65 78 69 74 2a 20 23 74 29 0a 20 20 20 20 o-exit* #t).
5400: 28 69 66 20 2a 69 6e 6d 65 6d 64 62 2a 20 28 64 (if *inmemdb* (d
5410: 62 3a 73 79 6e 63 2d 74 6f 75 63 68 65 64 20 2a b:sync-touched *
5420: 69 6e 6d 65 6d 64 62 2a 20 2a 72 75 6e 2d 69 64 inmemdb* *run-id
5430: 2a 20 66 6f 72 63 65 2d 73 79 6e 63 3a 20 23 74 * force-sync: #t
5440: 29 29 0a 20 20 20 20 3b 3b 0a 20 20 20 20 3b 3b )). ;;. ;;
5450: 20 73 74 61 72 74 5f 73 68 75 74 64 6f 77 6e 0a start_shutdown.
5460: 20 20 20 20 3b 3b 0a 20 20 20 20 28 74 61 73 6b ;;. (task
5470: 73 3a 73 65 72 76 65 72 2d 73 65 74 2d 73 74 61 s:server-set-sta
5480: 74 65 21 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 te! (db:delay-if
5490: 2d 62 75 73 79 20 74 64 62 64 61 74 29 20 73 65 -busy tdbdat) se
54a0: 72 76 65 72 2d 69 64 20 22 73 68 75 74 74 69 6e rver-id "shuttin
54b0: 67 2d 64 6f 77 6e 22 29 0a 20 20 20 20 28 70 6f g-down"). (po
54c0: 72 74 6c 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 75 rtlogger:open-ru
54d0: 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 67 n-close portlogg
54e0: 65 72 3a 73 65 74 2d 70 6f 72 74 20 70 6f 72 74 er:set-port port
54f0: 20 22 72 65 6c 65 61 73 65 64 22 29 0a 20 20 20 "released").
5500: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
5510: 35 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 5). (debug:pr
5520: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
5530: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4d ult-log-port* "M
5540: 61 78 20 63 61 63 68 65 64 20 71 75 65 72 69 65 ax cached querie
5550: 73 20 77 61 73 20 20 20 20 22 20 2a 6d 61 78 2d s was " *max-
5560: 63 61 63 68 65 2d 73 69 7a 65 2a 29 0a 20 20 20 cache-size*).
5570: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
5580: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
5590: 67 2d 70 6f 72 74 2a 20 22 4e 75 6d 62 65 72 20 g-port* "Number
55a0: 6f 66 20 63 61 63 68 65 64 20 77 72 69 74 65 73 of cached writes
55b0: 20 20 20 22 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d " *number-of-
55c0: 77 72 69 74 65 73 2a 29 0a 20 20 20 20 28 64 65 writes*). (de
55d0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
55e0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
55f0: 72 74 2a 20 22 41 76 65 72 61 67 65 20 63 61 63 rt* "Average cac
5600: 68 65 64 20 77 72 69 74 65 20 74 69 6d 65 20 22 hed write time "
5610: 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 65 71 ... (if (eq
5620: 3f 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 ? *number-of-wri
5630: 74 65 73 2a 20 30 29 0a 09 09 09 20 20 22 6e 2f tes* 0).... "n/
5640: 61 20 28 6e 6f 20 77 72 69 74 65 73 29 22 0a 09 a (no writes)"..
5650: 09 09 20 20 28 2f 20 2a 77 72 69 74 65 73 2d 74 .. (/ *writes-t
5660: 6f 74 61 6c 2d 64 65 6c 61 79 2a 0a 09 09 09 20 otal-delay*....
5670: 20 20 20 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 *number-of-w
5680: 72 69 74 65 73 2a 29 29 0a 09 09 20 20 20 20 20 rites*))...
5690: 20 22 20 6d 73 22 29 0a 20 20 20 20 28 64 65 62 " ms"). (deb
56a0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
56b0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
56c0: 74 2a 20 22 4e 75 6d 62 65 72 20 6e 6f 6e 2d 63 t* "Number non-c
56d0: 61 63 68 65 64 20 71 75 65 72 69 65 73 20 22 20 ached queries "
56e0: 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 *number-non-wri
56f0: 74 65 2d 71 75 65 72 69 65 73 2a 29 0a 20 20 20 te-queries*).
5700: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
5710: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
5720: 67 2d 70 6f 72 74 2a 20 22 41 76 65 72 61 67 65 g-port* "Average
5730: 20 6e 6f 6e 2d 63 61 63 68 65 64 20 74 69 6d 65 non-cached time
5740: 20 20 20 22 0a 09 09 20 20 20 20 20 20 28 69 66 "... (if
5750: 20 28 65 71 3f 20 2a 6e 75 6d 62 65 72 2d 6e 6f (eq? *number-no
5760: 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a n-write-queries*
5770: 20 30 29 0a 09 09 09 20 20 22 6e 2f 61 20 28 6e 0).... "n/a (n
5780: 6f 20 71 75 65 72 69 65 73 29 22 0a 09 09 09 20 o queries)"....
5790: 20 28 2f 20 2a 74 6f 74 61 6c 2d 6e 6f 6e 2d 77 (/ *total-non-w
57a0: 72 69 74 65 2d 64 65 6c 61 79 2a 20 0a 09 09 09 rite-delay* ....
57b0: 20 20 20 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e *number-non
57c0: 2d 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a 29 -write-queries*)
57d0: 29 0a 09 09 20 20 20 20 20 20 22 20 6d 73 22 29 )... " ms")
57e0: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
57f0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
5800: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 t-log-port* "Ser
5810: 76 65 72 20 73 68 75 74 64 6f 77 6e 20 63 6f 6d ver shutdown com
5820: 70 6c 65 74 65 2e 20 45 78 69 74 69 6e 67 22 29 plete. Exiting")
5830: 0a 20 20 20 20 28 74 61 73 6b 73 3a 73 65 72 76 . (tasks:serv
5840: 65 72 2d 64 65 6c 65 74 65 2d 72 65 63 6f 72 64 er-delete-record
5850: 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 (db:delay-if-bu
5860: 73 79 20 74 64 62 64 61 74 29 20 73 65 72 76 65 sy tdbdat) serve
5870: 72 2d 69 64 20 22 20 68 74 74 70 2d 74 72 61 6e r-id " http-tran
5880: 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 sport:keep-runni
5890: 6e 67 20 63 6f 6d 70 6c 65 74 65 22 29 0a 20 20 ng complete").
58a0: 20 20 28 65 78 69 74 29 29 29 0a 0a 3b 3b 20 61 (exit)))..;; a
58b0: 6c 6c 20 72 6f 75 74 65 73 20 74 68 6f 75 67 68 ll routes though
58c0: 20 68 65 72 65 20 65 6e 64 20 69 6e 20 65 78 69 here end in exi
58d0: 74 20 2e 2e 2e 0a 3b 3b 0a 3b 3b 20 73 74 61 72 t ....;;.;; star
58e0: 74 5f 73 65 72 76 65 72 3f 20 0a 3b 3b 0a 28 64 t_server? .;;.(d
58f0: 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e efine (http-tran
5900: 73 70 6f 72 74 3a 6c 61 75 6e 63 68 20 72 75 6e sport:launch run
5910: 2d 69 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 -id). (let* ((t
5920: 64 62 64 61 74 20 28 74 61 73 6b 73 3a 6f 70 65 dbdat (tasks:ope
5930: 6e 2d 64 62 29 29 29 0a 20 20 20 20 28 73 65 74 n-db))). (set
5940: 21 20 2a 72 75 6e 2d 69 64 2a 20 20 20 72 75 6e ! *run-id* run
5950: 2d 69 64 29 0a 20 20 20 20 28 69 66 20 28 61 72 -id). (if (ar
5960: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 64 61 65 gs:get-arg "-dae
5970: 6d 6f 6e 69 7a 65 22 29 0a 09 28 62 65 67 69 6e monize")..(begin
5980: 0a 09 20 20 28 64 61 65 6d 6f 6e 3a 69 7a 65 29 .. (daemon:ize)
5990: 0a 09 20 20 28 69 66 20 2a 61 6c 74 2d 6c 6f 67 .. (if *alt-log
59a0: 2d 66 69 6c 65 2a 20 3b 3b 20 77 65 20 73 68 6f -file* ;; we sho
59b0: 75 6c 64 20 72 65 2d 63 6f 6e 6e 65 63 74 20 74 uld re-connect t
59c0: 6f 20 74 68 69 73 20 70 6f 72 74 2c 20 49 20 74 o this port, I t
59d0: 68 69 6e 6b 20 64 61 65 6d 6f 6e 3a 69 7a 65 20 hink daemon:ize
59e0: 64 69 73 72 75 70 74 73 20 69 74 0a 09 20 20 20 disrupts it..
59f0: 20 20 20 28 62 65 67 69 6e 0a 09 09 28 63 75 72 (begin...(cur
5a00: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 20 rent-error-port
5a10: 2a 61 6c 74 2d 6c 6f 67 2d 66 69 6c 65 2a 29 0a *alt-log-file*).
5a20: 09 09 28 63 75 72 72 65 6e 74 2d 6f 75 74 70 75 ..(current-outpu
5a30: 74 2d 70 6f 72 74 20 2a 61 6c 74 2d 6c 6f 67 2d t-port *alt-log-
5a40: 66 69 6c 65 2a 29 29 29 29 29 0a 20 20 20 20 28 file*))))). (
5a50: 69 66 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b if (server:check
5a60: 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 72 75 6e 2d -if-running run-
5a70: 69 64 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 id)..(begin.. (
5a80: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
5a90: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
5aa0: 20 22 49 4e 46 4f 3a 20 53 65 72 76 65 72 20 66 "INFO: Server f
5ab0: 6f 72 20 72 75 6e 2d 69 64 20 22 20 72 75 6e 2d or run-id " run-
5ac0: 69 64 20 22 20 61 6c 72 65 61 64 79 20 72 75 6e id " already run
5ad0: 6e 69 6e 67 22 29 0a 09 20 20 28 65 78 69 74 20 ning").. (exit
5ae0: 30 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 0))). (let lo
5af0: 6f 70 20 28 28 73 65 72 76 65 72 2d 69 64 20 28 op ((server-id (
5b00: 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 6c 6f 63 tasks:server-loc
5b10: 6b 2d 73 6c 6f 74 20 28 64 62 3a 64 65 6c 61 79 k-slot (db:delay
5b20: 2d 69 66 2d 62 75 73 79 20 74 64 62 64 61 74 29 -if-busy tdbdat)
5b30: 20 72 75 6e 2d 69 64 29 29 0a 09 20 20 20 20 20 run-id))..
5b40: 20 20 28 72 65 6d 74 72 69 65 73 20 20 34 29 29 (remtries 4))
5b50: 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 . (if (not
5b60: 73 65 72 76 65 72 2d 69 64 29 0a 09 20 20 28 69 server-id).. (i
5b70: 66 20 28 3e 20 72 65 6d 74 72 69 65 73 20 30 29 f (> remtries 0)
5b80: 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 .. (begin..
5b90: 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 .(thread-sleep!
5ba0: 32 29 0a 09 09 28 6c 6f 6f 70 20 28 74 61 73 6b 2)...(loop (task
5bb0: 73 3a 73 65 72 76 65 72 2d 6c 6f 63 6b 2d 73 6c s:server-lock-sl
5bc0: 6f 74 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d ot (db:delay-if-
5bd0: 62 75 73 79 20 74 64 62 64 61 74 29 20 72 75 6e busy tdbdat) run
5be0: 2d 69 64 29 0a 09 09 20 20 20 20 20 20 28 2d 20 -id)... (-
5bf0: 72 65 6d 74 72 69 65 73 20 31 29 29 29 0a 09 20 remtries 1)))..
5c00: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 3b 3b (begin...;;
5c10: 20 73 69 6e 63 65 20 77 65 20 64 69 64 6e 27 74 since we didn't
5c20: 20 67 65 74 20 74 68 65 20 73 65 72 76 65 72 20 get the server
5c30: 6c 6f 63 6b 20 77 65 20 61 72 65 20 67 6f 69 6e lock we are goin
5c40: 67 20 74 6f 20 63 6c 65 61 6e 20 75 70 20 61 6e g to clean up an
5c50: 64 20 62 61 69 6c 20 6f 75 74 0a 09 09 28 64 65 d bail out...(de
5c60: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 bug:print-info 2
5c70: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5c80: 72 74 2a 20 22 49 4e 46 4f 3a 20 73 65 72 76 65 rt* "INFO: serve
5c90: 72 20 70 69 64 3d 22 20 28 63 75 72 72 65 6e 74 r pid=" (current
5ca0: 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 22 2c 20 -process-id) ",
5cb0: 68 6f 73 74 6e 61 6d 65 3d 22 20 28 67 65 74 2d hostname=" (get-
5cc0: 68 6f 73 74 2d 6e 61 6d 65 29 20 22 20 6e 6f 74 host-name) " not
5cd0: 20 73 74 61 72 74 69 6e 67 20 64 75 65 20 74 6f starting due to
5ce0: 20 6f 74 68 65 72 20 63 61 6e 64 69 64 61 74 65 other candidate
5cf0: 73 20 61 68 65 61 64 20 69 6e 20 73 74 61 72 74 s ahead in start
5d00: 20 71 75 65 75 65 22 29 0a 09 09 28 74 61 73 6b queue")...(task
5d10: 73 3a 73 65 72 76 65 72 2d 64 65 6c 65 74 65 2d s:server-delete-
5d20: 72 65 63 6f 72 64 73 2d 66 6f 72 2d 74 68 69 73 records-for-this
5d30: 2d 70 69 64 20 28 64 62 3a 64 65 6c 61 79 2d 69 -pid (db:delay-i
5d40: 66 2d 62 75 73 79 20 74 64 62 64 61 74 29 20 22 f-busy tdbdat) "
5d50: 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a http-transport:
5d60: 6c 61 75 6e 63 68 22 29 0a 09 09 29 29 0a 09 20 launch")...))..
5d70: 20 28 6c 65 74 2a 20 28 28 74 68 32 20 28 6d 61 (let* ((th2 (ma
5d80: 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 ke-thread (lambd
5d90: 61 20 28 29 0a 09 09 09 09 20 20 20 20 20 28 64 a ()..... (d
5da0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
5db0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
5dc0: 6f 72 74 2a 20 22 53 65 72 76 65 72 20 72 75 6e ort* "Server run
5dd0: 20 74 68 72 65 61 64 20 73 74 61 72 74 65 64 22 thread started"
5de0: 29 0a 09 09 09 09 20 20 20 20 20 28 68 74 74 70 )..... (http
5df0: 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 20 0a -transport:run .
5e00: 09 09 09 09 20 20 20 20 20 20 28 69 66 20 28 61 .... (if (a
5e10: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 rgs:get-arg "-se
5e20: 72 76 65 72 22 29 0a 09 09 09 09 09 20 20 28 61 rver")...... (a
5e30: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 rgs:get-arg "-se
5e40: 72 76 65 72 22 29 0a 09 09 09 09 09 20 20 22 2d rver")...... "-
5e50: 22 29 0a 09 09 09 09 20 20 20 20 20 20 72 75 6e ")..... run
5e60: 2d 69 64 0a 09 09 09 09 20 20 20 20 20 20 73 65 -id..... se
5e70: 72 76 65 72 2d 69 64 29 29 20 22 53 65 72 76 65 rver-id)) "Serve
5e80: 72 20 72 75 6e 22 29 29 0a 09 09 20 28 74 68 33 r run"))... (th3
5e90: 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c (make-thread (l
5ea0: 61 6d 62 64 61 20 28 29 0a 09 09 09 09 20 20 20 ambda ().....
5eb0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
5ec0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
5ed0: 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 72 og-port* "Server
5ee0: 20 6d 6f 6e 69 74 6f 72 20 74 68 72 65 61 64 20 monitor thread
5ef0: 73 74 61 72 74 65 64 22 29 0a 09 09 09 09 20 20 started").....
5f00: 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f (http-transpo
5f10: 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 rt:keep-running
5f20: 73 65 72 76 65 72 2d 69 64 20 72 75 6e 2d 69 64 server-id run-id
5f30: 29 29 0a 09 09 09 09 20 20 20 22 4b 65 65 70 20 ))..... "Keep
5f40: 72 75 6e 6e 69 6e 67 22 29 29 29 0a 09 20 20 20 running")))..
5f50: 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 (thread-start!
5f60: 74 68 32 29 0a 09 20 20 20 20 28 74 68 72 65 61 th2).. (threa
5f70: 64 2d 73 6c 65 65 70 21 20 30 2e 32 35 29 20 3b d-sleep! 0.25) ;
5f80: 3b 20 67 69 76 65 20 74 68 65 20 73 65 72 76 65 ; give the serve
5f90: 72 20 74 69 6d 65 20 74 6f 20 73 65 74 74 6c 65 r time to settle
5fa0: 20 62 65 66 6f 72 65 20 73 74 61 72 74 69 6e 67 before starting
5fb0: 20 74 68 65 20 6b 65 65 70 2d 72 75 6e 6e 69 6e the keep-runnin
5fc0: 67 20 6d 6f 6e 69 74 6f 72 2e 0a 09 20 20 20 20 g monitor...
5fd0: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
5fe0: 68 33 29 0a 09 20 20 20 20 28 73 65 74 21 20 2a h3).. (set! *
5ff0: 64 69 64 73 6f 6d 65 74 68 69 6e 67 2a 20 23 74 didsomething* #t
6000: 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d 6a ).. (thread-j
6010: 6f 69 6e 21 20 74 68 32 29 0a 09 20 20 20 20 28 oin! th2).. (
6020: 65 78 69 74 29 29 29 29 29 29 0a 0a 28 64 65 66 exit))))))..(def
6030: 69 6e 65 20 28 68 74 74 70 3a 70 69 6e 67 20 72 ine (http:ping r
6040: 75 6e 2d 69 64 20 68 6f 73 74 2d 70 6f 72 74 29 un-id host-port)
6050: 0a 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 65 . (let* ((serve
6060: 72 2d 64 61 74 20 28 68 74 74 70 2d 74 72 61 6e r-dat (http-tran
6070: 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e sport:client-con
6080: 6e 65 63 74 20 28 63 61 72 20 68 6f 73 74 2d 70 nect (car host-p
6090: 6f 72 74 29 28 63 61 64 72 20 68 6f 73 74 2d 70 ort)(cadr host-p
60a0: 6f 72 74 29 29 29 0a 09 20 28 6c 6f 67 69 6e 2d ort))).. (login-
60b0: 72 65 73 20 20 28 72 6d 74 3a 6c 6f 67 69 6e 2d res (rmt:login-
60c0: 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 2d 73 no-auto-client-s
60d0: 65 74 75 70 20 73 65 72 76 65 72 2d 64 61 74 20 etup server-dat
60e0: 72 75 6e 2d 69 64 29 29 29 0a 20 20 20 20 28 69 run-id))). (i
60f0: 66 20 28 61 6e 64 20 28 6c 69 73 74 3f 20 6c 6f f (and (list? lo
6100: 67 69 6e 2d 72 65 73 29 0a 09 20 20 20 20 20 28 gin-res).. (
6110: 63 61 72 20 6c 6f 67 69 6e 2d 72 65 73 29 29 0a car login-res)).
6120: 09 28 62 65 67 69 6e 0a 09 20 20 28 70 72 69 6e .(begin.. (prin
6130: 74 20 22 4c 4f 47 49 4e 5f 4f 4b 22 29 0a 09 20 t "LOGIN_OK")..
6140: 20 28 65 78 69 74 20 30 29 29 0a 09 28 62 65 67 (exit 0))..(beg
6150: 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 4c 4f in.. (print "LO
6160: 47 49 4e 5f 46 41 49 4c 45 44 22 29 0a 09 20 20 GIN_FAILED")..
6170: 28 65 78 69 74 20 31 29 29 29 29 29 0a 0a 28 64 (exit 1)))))..(d
6180: 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e efine (http-tran
6190: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 73 69 67 sport:server-sig
61a0: 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 69 67 6e nal-handler sign
61b0: 75 6d 29 0a 20 20 28 73 69 67 6e 61 6c 2d 6d 61 um). (signal-ma
61c0: 73 6b 21 20 73 69 67 6e 75 6d 29 0a 20 20 28 68 sk! signum). (h
61d0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
61e0: 0a 20 20 20 65 78 6e 0a 20 20 20 28 64 65 62 75 . exn. (debu
61f0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
6200: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 2e lt-log-port* " .
6210: 2e 2e 20 65 78 69 74 69 6e 67 20 2e 2e 2e 22 29 .. exiting ...")
6220: 0a 20 20 20 28 6c 65 74 20 28 28 74 68 31 20 28 . (let ((th1 (
6230: 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d make-thread (lam
6240: 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 bda ().... (
6250: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
6260: 29 0a 09 09 09 20 20 20 22 65 61 74 20 72 65 73 ).... "eat res
6270: 70 6f 6e 73 65 22 29 29 0a 09 20 28 74 68 32 20 ponse")).. (th2
6280: 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 (make-thread (la
6290: 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 mbda ()....
62a0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
62b0: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
62c0: 67 2d 70 6f 72 74 2a 20 22 52 65 63 65 69 76 65 g-port* "Receive
62d0: 64 20 5e 43 2c 20 61 74 74 65 6d 70 74 69 6e 67 d ^C, attempting
62e0: 20 63 6c 65 61 6e 20 65 78 69 74 2e 20 50 6c 65 clean exit. Ple
62f0: 61 73 65 20 62 65 20 70 61 74 69 65 6e 74 20 61 ase be patient a
6300: 6e 64 20 77 61 69 74 20 61 20 66 65 77 20 73 65 nd wait a few se
6310: 63 6f 6e 64 73 20 62 65 66 6f 72 65 20 68 69 74 conds before hit
6320: 74 69 6e 67 20 5e 43 20 61 67 61 69 6e 2e 22 29 ting ^C again.")
6330: 0a 09 09 09 20 20 20 20 20 28 74 68 72 65 61 64 .... (thread
6340: 2d 73 6c 65 65 70 21 20 33 29 20 3b 3b 20 67 69 -sleep! 3) ;; gi
6350: 76 65 20 74 68 65 20 66 6c 75 73 68 20 74 68 72 ve the flush thr
6360: 65 65 20 73 65 63 6f 6e 64 73 20 74 6f 20 64 6f ee seconds to do
6370: 20 69 74 27 73 20 73 74 75 66 66 0a 09 09 09 20 it's stuff....
6380: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
6390: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
63a0: 70 6f 72 74 2a 20 22 20 20 20 20 20 20 20 44 6f port* " Do
63b0: 6e 65 2e 22 29 0a 09 09 09 20 20 20 20 20 28 65 ne.").... (e
63c0: 78 69 74 20 34 29 29 0a 09 09 09 20 20 20 22 65 xit 4)).... "e
63d0: 78 69 74 20 6f 6e 20 5e 43 20 74 69 6d 65 72 22 xit on ^C timer"
63e0: 29 29 29 0a 20 20 20 20 20 28 74 68 72 65 61 64 ))). (thread
63f0: 2d 73 74 61 72 74 21 20 74 68 32 29 0a 20 20 20 -start! th2).
6400: 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 (thread-start!
6410: 20 74 68 31 29 0a 20 20 20 20 20 28 74 68 72 65 th1). (thre
6420: 61 64 2d 6a 6f 69 6e 21 20 74 68 32 29 29 29 29 ad-join! th2))))
6430: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
6440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 77 65 ==========.;; we
6480: 62 20 70 61 67 65 73 0a 3b 3b 3d 3d 3d 3d 3d 3d b pages.;;======
6490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
64a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
64b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
64c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
64d0: 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ..(define (http-
64e0: 74 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 transport:main-p
64f0: 61 67 65 29 0a 20 20 28 6c 65 74 20 28 28 6c 69 age). (let ((li
6500: 6e 6b 70 61 74 68 20 28 72 6f 6f 74 2d 70 61 74 nkpath (root-pat
6510: 68 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 h))). (conc "
6520: 3c 68 65 61 64 3e 3c 68 31 3e 22 20 28 70 61 74 <head><h1>" (pat
6530: 68 6e 61 6d 65 2d 73 74 72 69 70 2d 64 69 72 65 hname-strip-dire
6540: 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 ctory *toppath*)
6550: 20 22 3c 2f 68 31 3e 3c 2f 68 65 61 64 3e 22 0a "</h1></head>".
6560: 09 20 20 22 3c 62 6f 64 79 3e 22 0a 09 20 20 22 . "<body>".. "
6570: 52 75 6e 20 61 72 65 61 3a 20 22 20 2a 74 6f 70 Run area: " *top
6580: 70 61 74 68 2a 0a 09 20 20 22 3c 68 32 3e 53 65 path*.. "<h2>Se
6590: 72 76 65 72 20 53 74 61 74 73 3c 2f 68 32 3e 22 rver Stats</h2>"
65a0: 0a 09 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 .. (http-transp
65b0: 6f 72 74 3a 73 74 61 74 73 2d 74 61 62 6c 65 29 ort:stats-table)
65c0: 20 0a 09 20 20 22 3c 68 72 3e 22 0a 09 20 20 28 .. "<hr>".. (
65d0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 http-transport:r
65e0: 75 6e 73 20 6c 69 6e 6b 70 61 74 68 29 0a 09 20 uns linkpath)..
65f0: 20 22 3c 68 72 3e 22 0a 09 20 20 28 68 74 74 70 "<hr>".. (http
6600: 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 2d 73 -transport:run-s
6610: 74 61 74 73 29 0a 09 20 20 22 3c 2f 62 6f 64 79 tats).. "</body
6620: 3e 22 0a 09 20 20 29 29 29 0a 0a 28 64 65 66 69 >".. )))..(defi
6630: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
6640: 72 74 3a 73 74 61 74 73 2d 74 61 62 6c 65 29 0a rt:stats-table).
6650: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
6660: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
6670: 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 0a ). (let ((res .
6680: 09 20 28 63 6f 6e 63 20 22 3c 74 61 62 6c 65 3e . (conc "<table>
6690: 22 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c ".. "<tr><
66a0: 74 64 3e 4d 61 78 20 63 61 63 68 65 64 20 71 75 td>Max cached qu
66b0: 65 72 69 65 73 3c 2f 74 64 3e 20 20 20 20 20 20 eries</td>
66c0: 20 20 3c 74 64 3e 22 20 2a 6d 61 78 2d 63 61 63 <td>" *max-cac
66d0: 68 65 2d 73 69 7a 65 2a 20 22 3c 2f 74 64 3e 3c he-size* "</td><
66e0: 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c /tr>".. "<
66f0: 74 72 3e 3c 74 64 3e 4e 75 6d 62 65 72 20 6f 66 tr><td>Number of
6700: 20 63 61 63 68 65 64 20 77 72 69 74 65 73 3c 2f cached writes</
6710: 74 64 3e 20 20 20 3c 74 64 3e 22 20 2a 6e 75 6d td> <td>" *num
6720: 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a 20 22 ber-of-writes* "
6730: 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 </td></tr>"..
6740: 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 41 76 65 "<tr><td>Ave
6750: 72 61 67 65 20 63 61 63 68 65 64 20 77 72 69 74 rage cached writ
6760: 65 20 74 69 6d 65 3c 2f 74 64 3e 20 3c 74 64 3e e time</td> <td>
6770: 22 20 28 69 66 20 28 65 71 3f 20 2a 6e 75 6d 62 " (if (eq? *numb
6780: 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a 20 30 29 er-of-writes* 0)
6790: 0a 09 09 09 09 09 09 09 09 20 22 6e 2f 61 20 28 ......... "n/a (
67a0: 6e 6f 20 77 72 69 74 65 73 29 22 0a 09 09 09 09 no writes)".....
67b0: 09 09 09 09 20 28 2f 20 2a 77 72 69 74 65 73 2d .... (/ *writes-
67c0: 74 6f 74 61 6c 2d 64 65 6c 61 79 2a 0a 09 09 09 total-delay*....
67d0: 09 09 09 09 09 20 20 20 20 2a 6e 75 6d 62 65 72 ..... *number
67e0: 2d 6f 66 2d 77 72 69 74 65 73 2a 29 29 0a 09 20 -of-writes*))..
67f0: 20 20 20 20 20 20 22 20 6d 73 3c 2f 74 64 3e 3c " ms</td><
6800: 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c /tr>".. "<
6810: 74 72 3e 3c 74 64 3e 4e 75 6d 62 65 72 20 6e 6f tr><td>Number no
6820: 6e 2d 63 61 63 68 65 64 20 71 75 65 72 69 65 73 n-cached queries
6830: 3c 2f 74 64 3e 20 3c 74 64 3e 22 20 20 2a 6e 75 </td> <td>" *nu
6840: 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 mber-non-write-q
6850: 75 65 72 69 65 73 2a 20 22 3c 2f 74 64 3e 3c 2f ueries* "</td></
6860: 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c 74 tr>".. "<t
6870: 72 3e 3c 74 64 3e 41 76 65 72 61 67 65 20 6e 6f r><td>Average no
6880: 6e 2d 63 61 63 68 65 64 20 74 69 6d 65 3c 2f 74 n-cached time</t
6890: 64 3e 20 20 20 3c 74 64 3e 22 20 28 69 66 20 28 d> <td>" (if (
68a0: 65 71 3f 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d eq? *number-non-
68b0: 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a 20 30 write-queries* 0
68c0: 29 0a 09 09 09 09 09 09 09 09 20 22 6e 2f 61 20 )......... "n/a
68d0: 28 6e 6f 20 71 75 65 72 69 65 73 29 22 0a 09 09 (no queries)"...
68e0: 09 09 09 09 09 09 20 28 2f 20 2a 74 6f 74 61 6c ...... (/ *total
68f0: 2d 6e 6f 6e 2d 77 72 69 74 65 2d 64 65 6c 61 79 -non-write-delay
6900: 2a 20 0a 09 09 09 09 09 09 09 09 20 20 20 20 2a * ......... *
6910: 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 number-non-write
6920: 2d 71 75 65 72 69 65 73 2a 29 29 0a 09 20 20 20 -queries*))..
6930: 20 20 20 20 22 20 6d 73 3c 2f 74 64 3e 3c 2f 74 " ms</td></t
6940: 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c 74 72 r>".. "<tr
6950: 3e 3c 74 64 3e 4c 61 73 74 20 61 63 63 65 73 73 ><td>Last access
6960: 3c 2f 74 64 3e 3c 74 64 3e 22 20 20 20 20 20 20 </td><td>"
6970: 20 20 20 20 20 20 20 20 28 73 65 63 6f 6e 64 73 (seconds
6980: 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 2a 6c ->time-string *l
6990: 61 73 74 2d 64 62 2d 61 63 63 65 73 73 2a 29 20 ast-db-access*)
69a0: 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 "</td></tr>"..
69b0: 20 20 20 20 20 22 3c 2f 74 61 62 6c 65 3e 22 29 "</table>")
69c0: 29 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 6e )). (mutex-un
69d0: 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 lock! *heartbeat
69e0: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 72 65 73 -mutex*). res
69f0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 ))..(define (htt
6a00: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 73 p-transport:runs
6a10: 20 6c 69 6e 6b 70 61 74 68 29 0a 20 20 28 63 6f linkpath). (co
6a20: 6e 63 20 22 3c 68 33 3e 52 75 6e 73 3c 2f 68 33 nc "<h3>Runs</h3
6a30: 3e 22 0a 09 28 73 74 72 69 6e 67 2d 69 6e 74 65 >"..(string-inte
6a40: 72 73 70 65 72 73 65 0a 09 20 28 6c 65 74 20 28 rsperse.. (let (
6a50: 28 66 69 6c 65 73 20 28 6d 61 70 20 70 61 74 68 (files (map path
6a60: 6e 61 6d 65 2d 73 74 72 69 70 2d 64 69 72 65 63 name-strip-direc
6a70: 74 6f 72 79 20 28 67 6c 6f 62 20 28 63 6f 6e 63 tory (glob (conc
6a80: 20 6c 69 6e 6b 70 61 74 68 20 22 2f 2a 22 29 29 linkpath "/*"))
6a90: 29 29 29 0a 09 20 20 20 28 6d 61 70 20 28 6c 61 ))).. (map (la
6aa0: 6d 62 64 61 20 28 70 29 0a 09 09 20 20 28 63 6f mbda (p)... (co
6ab0: 6e 63 20 22 3c 61 20 68 72 65 66 3d 5c 22 22 20 nc "<a href=\""
6ac0: 70 20 22 5c 22 3e 22 20 70 20 22 3c 2f 61 3e 3c p "\">" p "</a><
6ad0: 62 72 3e 22 29 29 0a 09 09 66 69 6c 65 73 29 29 br>"))...files))
6ae0: 0a 09 20 22 20 22 29 29 29 0a 0a 28 64 65 66 69 .. " ")))..(defi
6af0: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
6b00: 72 74 3a 72 75 6e 2d 73 74 61 74 73 29 0a 20 20 rt:run-stats).
6b10: 28 6c 65 74 20 28 28 73 74 61 74 73 20 28 6f 70 (let ((stats (op
6b20: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a en-run-close db:
6b30: 67 65 74 2d 72 75 6e 6e 69 6e 67 2d 73 74 61 74 get-running-stat
6b40: 73 20 23 66 29 29 29 0a 20 20 20 20 28 63 6f 6e s #f))). (con
6b50: 63 20 22 3c 74 61 62 6c 65 3e 22 0a 09 20 20 28 c "<table>".. (
6b60: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
6b70: 73 65 0a 09 20 20 20 28 6d 61 70 20 28 6c 61 6d se.. (map (lam
6b80: 62 64 61 20 28 73 74 61 74 29 0a 09 09 20 20 28 bda (stat)... (
6b90: 63 6f 6e 63 20 22 3c 74 72 3e 3c 74 64 3e 22 20 conc "<tr><td>"
6ba0: 28 63 61 72 20 73 74 61 74 29 20 22 3c 2f 74 64 (car stat) "</td
6bb0: 3e 3c 74 64 3e 22 20 28 63 61 64 72 20 73 74 61 ><td>" (cadr sta
6bc0: 74 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 t) "</td></tr>")
6bd0: 29 0a 09 09 73 74 61 74 73 29 0a 09 20 20 20 22 )...stats).. "
6be0: 20 22 29 0a 09 20 20 22 3c 2f 74 61 62 6c 65 3e ").. "</table>
6bf0: 22 29 29 29 0a "))).