Artifact
bb0436ebfa316c736dfef32998bbae1febfe36f9:
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 22 41 74 74 65 6d 70 74 69 6e 67 20 t 2 "Attempting
0620: 74 6f 20 73 74 61 72 74 20 74 68 65 20 73 65 72 to start the ser
0630: 76 65 72 20 2e 2e 2e 22 29 0a 20 20 28 6c 65 74 ver ..."). (let
0640: 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 20 * ((db
0650: 20 20 20 20 23 66 29 20 3b 3b 20 20 20 20 20 20 #f) ;;
0660: 20 20 28 6f 70 65 6e 2d 64 62 29 29 20 3b 3b 20 (open-db)) ;;
0670: 77 65 20 64 6f 6e 27 74 20 77 61 6e 74 20 74 68 we don't want th
0680: 65 20 73 65 72 76 65 72 20 74 6f 20 62 65 20 6f e server to be o
0690: 70 65 6e 69 6e 67 20 61 6e 64 20 63 6c 6f 73 69 pening and closi
06a0: 6e 67 20 74 68 65 20 64 62 20 75 6e 6e 65 63 65 ng the db unnece
06b0: 73 61 72 69 6c 79 0a 09 20 28 68 6f 73 74 6e 61 sarily.. (hostna
06c0: 6d 65 20 20 20 20 20 20 20 20 28 67 65 74 2d 68 me (get-h
06d0: 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 69 70 ost-name)).. (ip
06e0: 61 64 64 72 73 74 72 20 20 20 20 20 20 20 28 6c addrstr (l
06f0: 65 74 20 28 28 69 70 73 74 72 20 28 69 66 20 28 et ((ipstr (if (
0700: 73 74 72 69 6e 67 3d 3f 20 22 2d 22 20 68 6f 73 string=? "-" hos
0710: 74 6e 29 0a 09 09 09 09 09 20 20 20 3b 3b 20 28 tn)...... ;; (
0720: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
0730: 73 65 20 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e se (map number->
0740: 73 74 72 69 6e 67 20 28 75 38 76 65 63 74 6f 72 string (u8vector
0750: 2d 3e 6c 69 73 74 20 28 68 6f 73 74 6e 61 6d 65 ->list (hostname
0760: 2d 3e 69 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 ->ip hostname)))
0770: 20 22 2e 22 29 0a 09 09 09 09 09 20 20 20 28 73 ".")...... (s
0780: 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 erver:get-best-g
0790: 75 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f 73 uess-address hos
07a0: 74 6e 61 6d 65 29 0a 09 09 09 09 09 20 20 20 23 tname)...... #
07b0: 66 29 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 f))).... (if
07c0: 69 70 73 74 72 20 69 70 73 74 72 20 68 6f 73 74 ipstr ipstr host
07d0: 6e 29 29 29 20 3b 3b 20 68 6f 73 74 6e 61 6d 65 n))) ;; hostname
07e0: 29 29 29 20 0a 09 20 28 73 74 61 72 74 2d 70 6f ))) .. (start-po
07f0: 72 74 20 20 20 20 20 20 28 70 6f 72 74 6c 6f 67 rt (portlog
0800: 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f ger:open-run-clo
0810: 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 66 69 se portlogger:fi
0820: 6e 64 2d 70 6f 72 74 29 29 0a 09 20 28 6c 69 6e nd-port)).. (lin
0830: 6b 2d 74 72 65 65 2d 70 61 74 68 20 20 28 63 6f k-tree-path (co
0840: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
0850: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
0860: 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 29 0a 20 "linktree"))).
0870: 20 20 20 3b 3b 20 28 73 65 74 21 20 64 62 20 2a ;; (set! db *
0880: 69 6e 6d 65 6d 64 62 2a 29 0a 20 20 20 20 28 64 inmemdb*). (d
0890: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
08a0: 30 20 22 70 6f 72 74 6c 6f 67 67 65 72 20 72 65 0 "portlogger re
08b0: 63 6f 6d 6d 65 6e 64 65 64 20 70 6f 72 74 3a 20 commended port:
08c0: 22 20 73 74 61 72 74 2d 70 6f 72 74 29 0a 20 20 " start-port).
08d0: 20 20 28 72 6f 6f 74 2d 70 61 74 68 20 20 20 20 (root-path
08e0: 20 28 69 66 20 6c 69 6e 6b 2d 74 72 65 65 2d 70 (if link-tree-p
08f0: 61 74 68 20 0a 09 09 20 20 20 20 20 20 20 6c 69 ath ... li
0900: 6e 6b 2d 74 72 65 65 2d 70 61 74 68 0a 09 09 20 nk-tree-path...
0910: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 64 (current-d
0920: 69 72 65 63 74 6f 72 79 29 29 29 20 3b 3b 20 57 irectory))) ;; W
0930: 41 52 4e 49 4e 47 3a 20 53 45 43 55 52 49 54 59 ARNING: SECURITY
0940: 20 48 4f 4c 45 2e 20 46 49 58 20 41 53 41 50 21 HOLE. FIX ASAP!
0950: 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d 64 69 72 . (handle-dir
0960: 65 63 74 6f 72 79 20 73 70 69 66 66 79 2d 64 69 ectory spiffy-di
0970: 72 65 63 74 6f 72 79 2d 6c 69 73 74 69 6e 67 29 rectory-listing)
0980: 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 . (handle-exc
0990: 65 70 74 69 6f 6e 20 28 6c 61 6d 62 64 61 20 28 eption (lambda (
09a0: 65 78 6e 20 63 68 61 69 6e 29 0a 09 09 09 28 73 exn chain)....(s
09b0: 69 67 6e 61 6c 20 28 6d 61 6b 65 2d 63 6f 6d 70 ignal (make-comp
09c0: 6f 73 69 74 65 2d 63 6f 6e 64 69 74 69 6f 6e 0a osite-condition.
09d0: 09 09 09 09 20 28 6d 61 6b 65 2d 70 72 6f 70 65 .... (make-prope
09e0: 72 74 79 2d 63 6f 6e 64 69 74 69 6f 6e 20 0a 09 rty-condition ..
09f0: 09 09 09 20 20 27 73 65 72 76 65 72 0a 09 09 09 ... 'server....
0a00: 09 20 20 27 6d 65 73 73 61 67 65 20 22 73 65 72 . 'message "ser
0a10: 76 65 72 20 65 72 72 6f 72 22 29 29 29 29 29 0a ver error"))))).
0a20: 0a 20 20 20 20 3b 3b 20 68 74 74 70 2d 74 72 61 . ;; http-tra
0a30: 6e 73 70 6f 72 74 3a 68 61 6e 64 6c 65 2d 64 69 nsport:handle-di
0a40: 72 65 63 74 6f 72 79 29 20 3b 3b 20 73 69 6d 70 rectory) ;; simp
0a50: 6c 65 2d 64 69 72 65 63 74 6f 72 79 2d 68 61 6e le-directory-han
0a60: 64 6c 65 72 29 0a 20 20 20 20 3b 3b 20 53 65 74 dler). ;; Set
0a70: 75 70 20 74 68 65 20 77 65 62 20 73 65 72 76 65 up the web serve
0a80: 72 20 61 6e 64 20 61 20 2f 63 74 72 6c 20 69 6e r and a /ctrl in
0a90: 74 65 72 66 61 63 65 0a 20 20 20 20 3b 3b 0a 20 terface. ;;.
0aa0: 20 20 20 28 76 68 6f 73 74 2d 6d 61 70 20 60 28 (vhost-map `(
0ab0: 28 28 2a 20 61 6e 79 29 20 2e 20 2c 28 6c 61 6d ((* any) . ,(lam
0ac0: 62 64 61 20 28 63 6f 6e 74 69 6e 75 65 29 0a 09 bda (continue)..
0ad0: 09 09 20 20 20 20 20 20 20 3b 3b 20 6f 70 65 6e .. ;; open
0ae0: 20 74 68 65 20 64 62 20 6f 6e 20 74 68 65 20 66 the db on the f
0af0: 69 72 73 74 20 63 61 6c 6c 20 0a 09 09 09 09 20 irst call .....
0b00: 3b 3b 20 54 68 69 73 20 69 73 20 77 65 72 65 20 ;; This is were
0b10: 77 65 20 73 65 74 20 75 70 20 74 68 65 20 64 61 we set up the da
0b20: 74 61 62 61 73 65 20 63 6f 6e 6e 65 63 74 69 6f tabase connectio
0b30: 6e 73 0a 09 09 09 20 20 20 20 20 20 20 28 6c 65 ns.... (le
0b40: 74 2a 20 28 28 24 20 20 20 28 72 65 71 75 65 73 t* (($ (reques
0b50: 74 2d 76 61 72 73 20 73 6f 75 72 63 65 3a 20 27 t-vars source: '
0b60: 62 6f 74 68 29 29 0a 09 09 09 09 20 20 20 20 20 both)).....
0b70: 20 28 64 61 74 20 28 24 20 27 64 61 74 29 29 0a (dat ($ 'dat)).
0b80: 09 09 09 09 20 20 20 20 20 20 28 72 65 73 20 23 .... (res #
0b90: 66 29 29 0a 09 09 09 09 20 28 63 6f 6e 64 0a 09 f))..... (cond..
0ba0: 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 ... ((equal? (u
0bb0: 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 ri-path (request
0bc0: 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 -uri (current-re
0bd0: 71 75 65 73 74 29 29 29 0a 09 09 09 09 09 20 20 quest)))......
0be0: 20 27 28 2f 20 22 61 70 69 22 29 29 0a 09 09 09 '(/ "api"))....
0bf0: 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e . (send-respon
0c00: 73 65 20 62 6f 64 79 3a 20 20 20 20 28 61 70 69 se body: (api
0c10: 3a 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 :process-request
0c20: 20 2a 69 6e 6d 65 6d 64 62 2a 20 24 29 20 3b 3b *inmemdb* $) ;;
0c30: 20 74 68 65 20 24 20 69 73 20 74 68 65 20 72 65 the $ is the re
0c40: 71 75 65 73 74 20 76 61 72 73 20 70 72 6f 63 0a quest vars proc.
0c50: 09 09 09 09 09 09 20 20 68 65 61 64 65 72 73 3a ...... headers:
0c60: 20 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 65 '((content-type
0c70: 20 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 0a 09 text/plain)))..
0c80: 09 09 09 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 ... (mutex-loc
0c90: 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 k! *heartbeat-mu
0ca0: 74 65 78 2a 29 0a 09 09 09 09 20 20 20 28 73 65 tex*)..... (se
0cb0: 74 21 20 2a 6c 61 73 74 2d 64 62 2d 61 63 63 65 t! *last-db-acce
0cc0: 73 73 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ss* (current-sec
0cd0: 6f 6e 64 73 29 29 0a 09 09 09 09 20 20 20 28 6d onds))..... (m
0ce0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 utex-unlock! *he
0cf0: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 29 artbeat-mutex*))
0d00: 0a 09 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 ..... ((equal?
0d10: 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 (uri-path (reque
0d20: 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d st-uri (current-
0d30: 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 09 09 request))) .....
0d40: 09 20 20 20 27 28 2f 20 22 22 29 29 0a 09 09 09 . '(/ ""))....
0d50: 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e . (send-respon
0d60: 73 65 20 62 6f 64 79 3a 20 28 68 74 74 70 2d 74 se body: (http-t
0d70: 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 61 ransport:main-pa
0d80: 67 65 29 29 29 0a 09 09 09 09 20 20 28 28 65 71 ge)))..... ((eq
0d90: 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 28 ual? (uri-path (
0da0: 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 72 request-uri (cur
0db0: 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 20 rent-request)))
0dc0: 0a 09 09 09 09 09 20 20 20 27 28 2f 20 22 6a 73 ...... '(/ "js
0dd0: 6f 6e 5f 61 70 69 22 29 29 0a 09 09 09 09 20 20 on_api")).....
0de0: 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 (send-response
0df0: 62 6f 64 79 3a 20 28 68 74 74 70 2d 74 72 61 6e body: (http-tran
0e00: 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 61 67 65 29 sport:main-page)
0e10: 29 29 0a 09 09 09 09 20 20 28 28 65 71 75 61 6c ))..... ((equal
0e20: 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 ? (uri-path (req
0e30: 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e uest-uri (curren
0e40: 74 2d 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 t-request))) ...
0e50: 09 09 09 20 20 20 27 28 2f 20 22 72 75 6e 73 22 ... '(/ "runs"
0e60: 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e 64 2d ))..... (send-
0e70: 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 28 response body: (
0e80: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6d http-transport:m
0e90: 61 69 6e 2d 70 61 67 65 29 29 29 0a 09 09 09 09 ain-page))).....
0ea0: 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 69 2d ((equal? (uri-
0eb0: 70 61 74 68 20 28 72 65 71 75 65 73 74 2d 75 72 path (request-ur
0ec0: 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 75 65 i (current-reque
0ed0: 73 74 29 29 29 20 0a 09 09 09 09 09 20 20 20 27 st))) ...... '
0ee0: 28 2f 20 61 6e 79 29 29 0a 09 09 09 09 20 20 20 (/ any)).....
0ef0: 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 (send-response b
0f00: 6f 64 79 3a 20 22 68 65 79 20 74 68 65 72 65 21 ody: "hey there!
0f10: 5c 6e 22 0a 09 09 09 09 09 09 20 20 68 65 61 64 \n"....... head
0f20: 65 72 73 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d ers: '((content-
0f30: 74 79 70 65 20 74 65 78 74 2f 70 6c 61 69 6e 29 type text/plain)
0f40: 29 29 29 0a 09 09 09 09 20 20 28 28 65 71 75 61 )))..... ((equa
0f50: 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 l? (uri-path (re
0f60: 71 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 quest-uri (curre
0f70: 6e 74 2d 72 65 71 75 65 73 74 29 29 29 20 0a 09 nt-request))) ..
0f80: 09 09 09 09 20 20 20 27 28 2f 20 22 68 65 79 22 .... '(/ "hey"
0f90: 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e 64 2d ))..... (send-
0fa0: 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 22 response body: "
0fb0: 68 65 79 20 74 68 65 72 65 21 5c 6e 22 0a 09 09 hey there!\n"...
0fc0: 09 09 09 09 20 20 68 65 61 64 65 72 73 3a 20 27 .... headers: '
0fd0: 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 ((content-type t
0fe0: 65 78 74 2f 70 6c 61 69 6e 29 29 29 29 0a 09 09 ext/plain))))...
0ff0: 09 09 20 20 28 65 6c 73 65 20 28 63 6f 6e 74 69 .. (else (conti
1000: 6e 75 65 29 29 29 29 29 29 29 29 0a 20 20 20 20 nue)))))))).
1010: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
1020: 74 72 79 2d 73 74 61 72 74 2d 73 65 72 76 65 72 try-start-server
1030: 20 72 75 6e 2d 69 64 20 69 70 61 64 64 72 73 74 run-id ipaddrst
1040: 72 20 73 74 61 72 74 2d 70 6f 72 74 20 73 65 72 r start-port ser
1050: 76 65 72 2d 69 64 29 29 29 0a 0a 3b 3b 20 54 68 ver-id)))..;; Th
1060: 69 73 20 69 73 20 72 65 63 75 72 73 69 76 65 6c is is recursivel
1070: 79 20 72 75 6e 20 62 79 20 68 74 74 70 2d 74 72 y run by http-tr
1080: 61 6e 73 70 6f 72 74 3a 72 75 6e 20 75 6e 74 69 ansport:run unti
1090: 6c 20 73 75 63 65 73 73 66 75 6c 0a 3b 3b 0a 28 l sucessful.;;.(
10a0: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
10b0: 6e 73 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 74 nsport:try-start
10c0: 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 20 69 -server run-id i
10d0: 70 61 64 64 72 73 74 72 20 70 6f 72 74 6e 75 6d paddrstr portnum
10e0: 20 73 65 72 76 65 72 2d 69 64 29 0a 20 20 28 6c server-id). (l
10f0: 65 74 20 28 28 63 6f 6e 66 69 67 2d 68 6f 73 74 et ((config-host
1100: 6e 61 6d 65 20 28 63 6f 6e 66 69 67 66 3a 6c 6f name (configf:lo
1110: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
1120: 20 22 73 65 72 76 65 72 22 20 22 68 6f 73 74 6e "server" "hostn
1130: 61 6d 65 22 29 29 0a 09 28 74 64 62 64 61 74 20 ame"))..(tdbdat
1140: 20 20 20 20 20 20 20 20 20 28 74 61 73 6b 73 3a (tasks:
1150: 6f 70 65 6e 2d 64 62 29 29 29 0a 20 20 20 20 28 open-db))). (
1160: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
1170: 20 30 20 22 68 74 74 70 2d 74 72 61 6e 73 70 6f 0 "http-transpo
1180: 72 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 rt:try-start-ser
1190: 76 65 72 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e ver run-id=" run
11a0: 2d 69 64 20 22 20 69 70 61 64 64 72 73 73 74 72 -id " ipaddrsstr
11b0: 3d 22 20 69 70 61 64 64 72 73 74 72 20 22 20 70 =" ipaddrstr " p
11c0: 6f 72 74 6e 75 6d 3d 22 20 70 6f 72 74 6e 75 6d ortnum=" portnum
11d0: 20 22 20 73 65 72 76 65 72 2d 69 64 3d 22 20 73 " server-id=" s
11e0: 65 72 76 65 72 2d 69 64 20 22 20 63 6f 6e 66 69 erver-id " confi
11f0: 67 2d 68 6f 73 74 6e 61 6d 65 3d 22 20 63 6f 6e g-hostname=" con
1200: 66 69 67 2d 68 6f 73 74 6e 61 6d 65 29 0a 20 20 fig-hostname).
1210: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
1220: 69 6f 6e 73 0a 20 20 20 20 20 65 78 6e 0a 20 20 ions. exn.
1230: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
1240: 20 28 70 72 69 6e 74 2d 65 72 72 6f 72 2d 6d 65 (print-error-me
1250: 73 73 61 67 65 20 65 78 6e 29 0a 20 20 20 20 20 ssage exn).
1260: 20 20 28 69 66 20 28 3c 20 70 6f 72 74 6e 75 6d (if (< portnum
1270: 20 36 34 30 30 30 29 0a 09 20 20 20 28 62 65 67 64000).. (beg
1280: 69 6e 20 0a 09 20 20 20 20 20 28 64 65 62 75 67 in .. (debug
1290: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
12a0: 47 3a 20 61 74 74 65 6d 70 74 20 74 6f 20 73 74 G: attempt to st
12b0: 61 72 74 20 73 65 72 76 65 72 20 66 61 69 6c 65 art server faile
12c0: 64 2e 20 54 72 79 69 6e 67 20 61 67 61 69 6e 20 d. Trying again
12d0: 2e 2e 2e 22 29 0a 09 20 20 20 20 20 28 64 65 62 ...").. (deb
12e0: 75 67 3a 70 72 69 6e 74 20 30 20 22 20 6d 65 73 ug:print 0 " mes
12f0: 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 sage: " ((condit
1300: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
1310: 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
1320: 61 67 65 29 20 65 78 6e 29 29 0a 09 20 20 20 20 age) exn))..
1330: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
1340: 22 65 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 6f "exn=" (conditio
1350: 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 0a 09 20 n->list exn))..
1360: 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a (portlogger:
1370: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 open-run-close p
1380: 6f 72 74 6c 6f 67 67 65 72 3a 73 65 74 2d 66 61 ortlogger:set-fa
1390: 69 6c 65 64 20 70 6f 72 74 6e 75 6d 29 0a 09 20 iled portnum)..
13a0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
13b0: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 66 61 69 0 "WARNING: fai
13c0: 6c 65 64 20 74 6f 20 73 74 61 72 74 20 6f 6e 20 led to start on
13d0: 70 6f 72 74 6e 75 6d 3a 20 22 20 70 6f 72 74 6e portnum: " portn
13e0: 75 6d 20 22 2c 20 74 72 79 69 6e 67 20 6e 65 78 um ", trying nex
13f0: 74 20 70 6f 72 74 22 29 0a 09 20 20 20 20 20 28 t port").. (
1400: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
1410: 31 29 0a 0a 09 20 20 20 20 20 3b 3b 20 67 65 74 1)... ;; get
1420: 5f 6e 65 78 74 5f 70 6f 72 74 20 67 6f 65 73 20 _next_port goes
1430: 68 65 72 65 0a 09 20 20 20 20 20 28 68 74 74 70 here.. (http
1440: 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 -transport:try-s
1450: 74 61 72 74 2d 73 65 72 76 65 72 20 72 75 6e 2d tart-server run-
1460: 69 64 0a 09 09 09 09 09 20 20 20 20 20 20 69 70 id...... ip
1470: 61 64 64 72 73 74 72 0a 09 09 09 09 09 20 20 20 addrstr......
1480: 20 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f (portlogger:o
1490: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f pen-run-close po
14a0: 72 74 6c 6f 67 67 65 72 3a 66 69 6e 64 2d 70 6f rtlogger:find-po
14b0: 72 74 29 0a 09 09 09 09 09 20 20 20 20 20 20 73 rt)...... s
14c0: 65 72 76 65 72 2d 69 64 29 29 0a 09 20 20 20 28 erver-id)).. (
14d0: 62 65 67 69 6e 0a 09 20 20 20 20 20 28 74 61 73 begin.. (tas
14e0: 6b 73 3a 73 65 72 76 65 72 2d 66 6f 72 63 65 2d ks:server-force-
14f0: 63 6c 65 61 6e 2d 72 75 6e 2d 72 65 63 6f 72 64 clean-run-record
1500: 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 (db:delay-if-bu
1510: 73 79 20 74 64 62 64 61 74 29 20 72 75 6e 2d 69 sy tdbdat) run-i
1520: 64 20 69 70 61 64 64 72 73 74 72 20 70 6f 72 74 d ipaddrstr port
1530: 6e 75 6d 20 22 20 68 74 74 70 2d 74 72 61 6e 73 num " http-trans
1540: 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 port:try-start-s
1550: 65 72 76 65 72 22 29 0a 09 20 20 20 20 20 28 70 erver").. (p
1560: 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 54 72 69 rint "ERROR: Tri
1570: 65 64 20 61 6e 64 20 74 72 69 65 64 20 62 75 74 ed and tried but
1580: 20 63 6f 75 6c 64 20 6e 6f 74 20 73 74 61 72 74 could not start
1590: 20 74 68 65 20 73 65 72 76 65 72 22 29 29 29 29 the server"))))
15a0: 0a 20 20 20 20 20 3b 3b 20 61 6e 79 20 65 72 72 . ;; any err
15b0: 6f 72 20 69 6e 20 66 6f 6c 6c 6f 77 69 6e 67 20 or in following
15c0: 73 74 65 70 73 20 77 69 6c 6c 20 72 65 73 75 6c steps will resul
15d0: 74 20 69 6e 20 61 20 72 65 74 72 79 0a 20 20 20 t in a retry.
15e0: 20 20 28 73 65 74 21 20 2a 73 65 72 76 65 72 2d (set! *server-
15f0: 69 6e 66 6f 2a 20 28 6c 69 73 74 20 69 70 61 64 info* (list ipad
1600: 64 72 73 74 72 20 70 6f 72 74 6e 75 6d 29 29 0a drstr portnum)).
1610: 20 20 20 20 20 28 74 61 73 6b 73 3a 73 65 72 76 (tasks:serv
1620: 65 72 2d 73 65 74 2d 69 6e 74 65 72 66 61 63 65 er-set-interface
1630: 2d 70 6f 72 74 20 0a 09 09 20 20 20 20 20 28 64 -port ... (d
1640: 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 b:delay-if-busy
1650: 74 64 62 64 61 74 29 0a 09 09 20 20 20 20 20 73 tdbdat)... s
1660: 65 72 76 65 72 2d 69 64 20 0a 09 09 20 20 20 20 erver-id ...
1670: 20 69 70 61 64 64 72 73 74 72 20 70 6f 72 74 6e ipaddrstr portn
1680: 75 6d 29 0a 20 20 20 20 20 28 64 65 62 75 67 3a um). (debug:
1690: 70 72 69 6e 74 20 30 20 22 49 4e 46 4f 3a 20 54 print 0 "INFO: T
16a0: 72 79 69 6e 67 20 74 6f 20 73 74 61 72 74 20 73 rying to start s
16b0: 65 72 76 65 72 20 6f 6e 20 22 20 69 70 61 64 64 erver on " ipadd
16c0: 72 73 74 72 20 22 3a 22 20 70 6f 72 74 6e 75 6d rstr ":" portnum
16d0: 29 0a 20 20 20 20 20 3b 3b 20 54 68 69 73 20 73 ). ;; This s
16e0: 74 61 72 74 73 20 74 68 65 20 73 70 69 66 66 79 tarts the spiffy
16f0: 20 73 65 72 76 65 72 0a 20 20 20 20 20 3b 3b 20 server. ;;
1700: 4e 45 45 44 20 57 41 59 20 54 4f 20 53 45 54 20 NEED WAY TO SET
1710: 49 50 20 54 4f 20 23 66 20 54 4f 20 42 49 4e 44 IP TO #f TO BIND
1720: 20 41 4c 4c 0a 20 20 20 20 20 3b 3b 20 28 73 74 ALL. ;; (st
1730: 61 72 74 2d 73 65 72 76 65 72 20 62 69 6e 64 2d art-server bind-
1740: 61 64 64 72 65 73 73 3a 20 69 70 61 64 64 72 73 address: ipaddrs
1750: 74 72 20 70 6f 72 74 3a 20 70 6f 72 74 6e 75 6d tr port: portnum
1760: 29 0a 20 20 20 20 20 28 69 66 20 63 6f 6e 66 69 ). (if confi
1770: 67 2d 68 6f 73 74 6e 61 6d 65 20 3b 3b 20 74 68 g-hostname ;; th
1780: 69 73 20 69 73 20 61 20 68 69 6e 74 20 74 6f 20 is is a hint to
1790: 62 69 6e 64 20 64 69 72 65 63 74 6c 79 0a 09 20 bind directly..
17a0: 28 73 74 61 72 74 2d 73 65 72 76 65 72 20 70 6f (start-server po
17b0: 72 74 3a 20 70 6f 72 74 6e 75 6d 20 62 69 6e 64 rt: portnum bind
17c0: 2d 61 64 64 72 65 73 73 3a 20 28 69 66 20 28 65 -address: (if (e
17d0: 71 75 61 6c 3f 20 63 6f 6e 66 69 67 2d 68 6f 73 qual? config-hos
17e0: 74 6e 61 6d 65 20 22 2d 22 29 0a 09 09 09 09 09 tname "-")......
17f0: 09 20 20 20 20 20 20 20 69 70 61 64 64 72 73 74 . ipaddrst
1800: 72 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 63 r....... c
1810: 6f 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 29 29 onfig-hostname))
1820: 0a 09 20 28 73 74 61 72 74 2d 73 65 72 76 65 72 .. (start-server
1830: 20 70 6f 72 74 3a 20 70 6f 72 74 6e 75 6d 29 29 port: portnum))
1840: 0a 20 20 20 20 20 3b 3b 20 20 28 70 6f 72 74 6c . ;; (portl
1850: 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 ogger:open-run-c
1860: 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a lose portlogger:
1870: 73 65 74 2d 70 6f 72 74 20 70 6f 72 74 6e 75 6d set-port portnum
1880: 20 22 72 65 6c 65 61 73 65 64 22 29 0a 20 20 20 "released").
1890: 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d (tasks:server-
18a0: 66 6f 72 63 65 2d 63 6c 65 61 6e 2d 72 75 6e 2d force-clean-run-
18b0: 72 65 63 6f 72 64 20 28 64 62 3a 64 65 6c 61 79 record (db:delay
18c0: 2d 69 66 2d 62 75 73 79 20 74 64 62 64 61 74 29 -if-busy tdbdat)
18d0: 20 72 75 6e 2d 69 64 20 69 70 61 64 64 72 73 74 run-id ipaddrst
18e0: 72 20 70 6f 72 74 6e 75 6d 20 22 20 68 74 74 70 r portnum " http
18f0: 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 -transport:try-s
1900: 74 61 72 74 2d 73 65 72 76 65 72 22 29 0a 20 20 tart-server").
1910: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
1920: 31 20 22 49 4e 46 4f 3a 20 73 65 72 76 65 72 20 1 "INFO: server
1930: 68 61 73 20 62 65 65 6e 20 73 74 6f 70 70 65 64 has been stopped
1940: 22 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d "))))..;;=======
1950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
1990: 3b 3b 20 53 20 45 20 52 20 56 20 45 20 52 20 20 ;; S E R V E R
19a0: 20 55 20 54 20 49 20 4c 20 49 20 54 20 49 20 45 U T I L I T I E
19b0: 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S .;;==========
19c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
1a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a40: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 20 4c 20 49 20 ======.;; C L I
1a50: 45 20 4e 20 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d E N T S.;;======
1a60: 3d 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: 0a 0a 28 64 65 66 69 6e 65 20 2a 68 74 74 70 2d ..(define *http-
1ab0: 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 mutex* (make-mut
1ac0: 65 78 29 29 0a 0a 3b 3b 20 4e 4f 54 45 3a 20 4c ex))..;; NOTE: L
1ad0: 61 72 67 65 20 62 6c 6f 63 6b 20 6f 66 20 63 6f arge block of co
1ae0: 64 65 20 66 72 6f 6d 20 33 32 34 33 36 62 34 32 de from 32436b42
1af0: 36 31 38 38 30 38 30 66 37 32 66 63 65 62 36 38 6188080f72fceb68
1b00: 39 34 61 66 35 34 31 66 62 61 64 39 39 32 31 65 94af541fbad9921e
1b10: 20 72 65 6d 6f 76 65 64 20 68 65 72 65 0a 3b 3b removed here.;;
1b20: 20 20 20 20 20 20 20 49 27 6d 20 70 72 65 74 74 I'm prett
1b30: 79 20 73 75 72 65 20 69 74 20 69 73 20 64 65 66 y sure it is def
1b40: 75 6e 63 74 2e 0a 0a 3b 3b 20 54 68 69 73 20 6e unct...;; This n
1b50: 65 78 74 20 62 6c 6f 63 6b 20 61 6c 6c 20 69 6d ext block all im
1b60: 70 6f 72 74 65 64 20 65 6e 2d 6d 61 73 73 20 66 ported en-mass f
1b70: 72 6f 6d 20 74 68 65 20 61 70 69 20 62 72 61 6e rom the api bran
1b80: 63 68 0a 28 64 65 66 69 6e 65 20 2a 68 74 74 70 ch.(define *http
1b90: 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f -requests-in-pro
1ba0: 67 72 65 73 73 2a 20 30 29 0a 28 64 65 66 69 6e gress* 0).(defin
1bb0: 65 20 2a 68 74 74 70 2d 63 6f 6e 6e 65 63 74 69 e *http-connecti
1bc0: 6f 6e 73 2d 6e 65 78 74 2d 63 6c 65 61 6e 75 70 ons-next-cleanup
1bd0: 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e * (current-secon
1be0: 64 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 ds))..(define (h
1bf0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 67 65 ttp-transport:ge
1c00: 74 2d 74 69 6d 65 2d 74 6f 2d 63 6c 65 61 6e 75 t-time-to-cleanu
1c10: 70 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 p). (let ((res
1c20: 23 66 29 29 0a 20 20 20 20 28 6d 75 74 65 78 2d #f)). (mutex-
1c30: 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 lock! *http-mute
1c40: 78 2a 29 0a 20 20 20 20 28 73 65 74 21 20 72 65 x*). (set! re
1c50: 73 20 28 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 s (> (current-se
1c60: 63 6f 6e 64 73 29 20 2a 68 74 74 70 2d 63 6f 6e conds) *http-con
1c70: 6e 65 63 74 69 6f 6e 73 2d 6e 65 78 74 2d 63 6c nections-next-cl
1c80: 65 61 6e 75 70 2a 29 29 0a 20 20 20 20 28 6d 75 eanup*)). (mu
1c90: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 tex-unlock! *htt
1ca0: 70 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 72 65 p-mutex*). re
1cb0: 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 s))..(define (ht
1cc0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 69 6e 63 tp-transport:inc
1cd0: 2d 72 65 71 75 65 73 74 73 2d 63 6f 75 6e 74 29 -requests-count)
1ce0: 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 . (mutex-lock!
1cf0: 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 *http-mutex*).
1d00: 28 73 65 74 21 20 2a 68 74 74 70 2d 72 65 71 75 (set! *http-requ
1d10: 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 ests-in-progress
1d20: 2a 20 28 2b 20 31 20 2a 68 74 74 70 2d 72 65 71 * (+ 1 *http-req
1d30: 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 uests-in-progres
1d40: 73 2a 29 29 0a 20 20 3b 3b 20 55 73 65 20 74 68 s*)). ;; Use th
1d50: 69 73 20 6f 70 70 6f 72 74 75 6e 69 74 79 20 74 is opportunity t
1d60: 6f 20 73 6c 6f 77 20 74 68 69 6e 67 73 20 64 6f o slow things do
1d70: 77 6e 20 69 66 66 20 74 68 65 72 65 20 61 72 65 wn iff there are
1d80: 20 74 6f 6f 20 6d 61 6e 79 20 72 65 71 75 65 73 too many reques
1d90: 74 73 20 69 6e 20 66 6c 69 67 68 74 0a 20 20 28 ts in flight. (
1da0: 69 66 20 28 3e 20 2a 68 74 74 70 2d 72 65 71 75 if (> *http-requ
1db0: 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 ests-in-progress
1dc0: 2a 20 35 29 0a 20 20 20 20 20 20 28 62 65 67 69 * 5). (begi
1dd0: 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d n..(debug:print-
1de0: 69 6e 66 6f 20 30 20 22 57 68 6f 61 20 74 68 65 info 0 "Whoa the
1df0: 72 65 20 62 75 64 64 79 2c 20 65 61 73 65 20 75 re buddy, ease u
1e00: 70 2e 2e 2e 22 29 0a 09 28 74 68 72 65 61 64 2d p...")..(thread-
1e10: 73 6c 65 65 70 21 20 31 29 29 29 0a 20 20 28 6d sleep! 1))). (m
1e20: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 utex-unlock! *ht
1e30: 74 70 2d 6d 75 74 65 78 2a 29 29 0a 0a 28 64 65 tp-mutex*))..(de
1e40: 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
1e50: 70 6f 72 74 3a 64 65 63 2d 72 65 71 75 65 73 74 port:dec-request
1e60: 73 2d 63 6f 75 6e 74 20 70 72 6f 63 29 20 0a 20 s-count proc) .
1e70: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 (mutex-lock! *h
1e80: 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 28 70 ttp-mutex*). (p
1e90: 72 6f 63 29 0a 20 20 28 73 65 74 21 20 2a 68 74 roc). (set! *ht
1ea0: 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 tp-requests-in-p
1eb0: 72 6f 67 72 65 73 73 2a 20 28 2d 20 2a 68 74 74 rogress* (- *htt
1ec0: 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 p-requests-in-pr
1ed0: 6f 67 72 65 73 73 2a 20 31 29 29 0a 20 20 28 6d ogress* 1)). (m
1ee0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 utex-unlock! *ht
1ef0: 74 70 2d 6d 75 74 65 78 2a 29 29 0a 0a 28 64 65 tp-mutex*))..(de
1f00: 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
1f10: 70 6f 72 74 3a 64 65 63 2d 72 65 71 75 65 73 74 port:dec-request
1f20: 73 2d 63 6f 75 6e 74 2d 61 6e 64 2d 63 6c 6f 73 s-count-and-clos
1f30: 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e e-all-connection
1f40: 73 29 0a 20 20 28 73 65 74 21 20 2a 68 74 74 70 s). (set! *http
1f50: 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f -requests-in-pro
1f60: 67 72 65 73 73 2a 20 28 2d 20 2a 68 74 74 70 2d gress* (- *http-
1f70: 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 requests-in-prog
1f80: 72 65 73 73 2a 20 31 29 29 0a 20 20 28 6c 65 74 ress* 1)). (let
1f90: 20 6c 6f 6f 70 20 28 28 65 74 69 6d 65 20 28 2b loop ((etime (+
1fa0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
1fb0: 73 29 20 35 29 29 29 20 3b 3b 20 67 69 76 65 20 s) 5))) ;; give
1fc0: 75 70 20 69 6e 20 66 69 76 65 20 73 65 63 6f 6e up in five secon
1fd0: 64 73 0a 20 20 20 20 28 69 66 20 28 3e 20 2a 68 ds. (if (> *h
1fe0: 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d ttp-requests-in-
1ff0: 70 72 6f 67 72 65 73 73 2a 20 30 29 0a 09 28 69 progress* 0)..(i
2000: 66 20 28 3e 20 65 74 69 6d 65 20 28 63 75 72 72 f (> etime (curr
2010: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 ent-seconds))..
2020: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
2030: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
2040: 30 2e 30 35 29 0a 09 20 20 20 20 20 20 28 6c 6f 0.05).. (lo
2050: 6f 70 20 65 74 69 6d 65 29 29 0a 09 20 20 20 20 op etime))..
2060: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
2070: 45 52 52 4f 52 3a 20 72 65 71 75 65 73 74 73 20 ERROR: requests
2080: 73 74 69 6c 6c 20 69 6e 20 70 72 6f 67 72 65 73 still in progres
2090: 73 20 61 66 74 65 72 20 35 20 73 65 63 6f 6e 64 s after 5 second
20a0: 73 20 6f 66 20 77 61 69 74 69 6e 67 2e 20 49 27 s of waiting. I'
20b0: 6d 20 67 6f 69 6e 67 20 74 6f 20 70 61 73 73 20 m going to pass
20c0: 6f 6e 20 63 6c 65 61 6e 69 6e 67 20 75 70 20 68 on cleaning up h
20d0: 74 74 70 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 22 ttp connections"
20e0: 29 29 0a 09 28 63 6c 6f 73 65 2d 61 6c 6c 2d 63 ))..(close-all-c
20f0: 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 29 29 0a 20 onnections!))).
2100: 20 28 73 65 74 21 20 2a 68 74 74 70 2d 63 6f 6e (set! *http-con
2110: 6e 65 63 74 69 6f 6e 73 2d 6e 65 78 74 2d 63 6c nections-next-cl
2120: 65 61 6e 75 70 2a 20 28 2b 20 28 63 75 72 72 65 eanup* (+ (curre
2130: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 31 30 29 29 nt-seconds) 10))
2140: 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b . (mutex-unlock
2150: 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 29 ! *http-mutex*))
2160: 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ..(define (http-
2170: 74 72 61 6e 73 70 6f 72 74 3a 69 6e 63 2d 72 65 transport:inc-re
2180: 71 75 65 73 74 73 2d 61 6e 64 2d 70 72 65 70 2d quests-and-prep-
2190: 74 6f 2d 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e to-close-all-con
21a0: 6e 65 63 74 69 6f 6e 73 29 0a 20 20 28 6d 75 74 nections). (mut
21b0: 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d ex-lock! *http-m
21c0: 75 74 65 78 2a 29 0a 20 20 28 73 65 74 21 20 2a utex*). (set! *
21d0: 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e http-requests-in
21e0: 2d 70 72 6f 67 72 65 73 73 2a 20 28 2b 20 31 20 -progress* (+ 1
21f0: 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 *http-requests-i
2200: 6e 2d 70 72 6f 67 72 65 73 73 2a 29 29 29 0a 0a n-progress*)))..
2210: 3b 3b 20 53 65 6e 64 20 22 63 6d 64 22 20 77 69 ;; Send "cmd" wi
2220: 74 68 20 6a 73 6f 6e 20 70 61 79 6c 6f 61 64 20 th json payload
2230: 22 70 61 72 61 6d 73 22 20 74 6f 20 73 65 72 76 "params" to serv
2240: 65 72 64 61 74 20 61 6e 64 20 72 65 63 65 69 76 erdat and receiv
2250: 65 20 72 65 73 75 6c 74 0a 3b 3b 0a 28 64 65 66 e result.;;.(def
2260: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
2270: 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 ort:client-api-s
2280: 65 6e 64 2d 72 65 63 65 69 76 65 20 72 75 6e 2d end-receive run-
2290: 69 64 20 73 65 72 76 65 72 64 61 74 20 63 6d 64 id serverdat cmd
22a0: 20 70 61 72 61 6d 73 20 23 21 6b 65 79 20 28 6e params #!key (n
22b0: 75 6d 72 65 74 72 69 65 73 20 33 29 29 0a 20 20 umretries 3)).
22c0: 28 6c 65 74 2a 20 28 28 66 75 6c 6c 75 72 6c 20 (let* ((fullurl
22d0: 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 (if (vector?
22e0: 73 65 72 76 65 72 64 61 74 29 0a 09 09 09 20 28 serverdat).... (
22f0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
2300: 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 61 70 erver-dat-get-ap
2310: 69 2d 72 65 71 20 73 65 72 76 65 72 64 61 74 29 i-req serverdat)
2320: 0a 09 09 09 20 28 62 65 67 69 6e 0a 09 09 09 20 .... (begin....
2330: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
2340: 20 22 46 41 54 41 4c 20 45 52 52 4f 52 3a 20 68 "FATAL ERROR: h
2350: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c ttp-transport:cl
2360: 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 ient-api-send-re
2370: 63 65 69 76 65 20 63 61 6c 6c 65 64 20 77 69 74 ceive called wit
2380: 68 20 6e 6f 20 73 65 72 76 65 72 20 69 6e 66 6f h no server info
2390: 22 29 0a 09 09 09 20 20 20 28 65 78 69 74 20 31 ").... (exit 1
23a0: 29 29 29 29 0a 09 20 28 72 65 73 20 20 20 20 20 )))).. (res
23b0: 20 20 20 23 66 29 0a 09 20 28 73 75 63 63 65 73 #f).. (succes
23c0: 73 20 20 20 20 23 74 29 0a 09 20 28 73 70 61 72 s #t).. (spar
23d0: 61 6d 73 20 20 20 20 28 64 62 3a 6f 62 6a 2d 3e ams (db:obj->
23e0: 73 74 72 69 6e 67 20 70 61 72 61 6d 73 20 74 72 string params tr
23f0: 61 6e 73 70 6f 72 74 3a 20 27 68 74 74 70 29 29 ansport: 'http))
2400: 29 0a 3b 3b 20 20 20 20 28 63 6f 6e 64 69 74 69 ).;; (conditi
2410: 6f 6e 2d 63 61 73 65 0a 3b 3b 20 20 20 20 20 68 on-case.;; h
2420: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
2430: 0a 3b 3b 20 20 20 20 20 65 78 6e 0a 3b 3b 20 20 .;; exn.;;
2440: 20 20 20 28 69 66 20 28 3e 20 6e 75 6d 72 65 74 (if (> numret
2450: 72 69 65 73 20 30 29 0a 3b 3b 09 20 28 62 65 67 ries 0).;;. (beg
2460: 69 6e 0a 3b 3b 09 20 20 20 28 6d 75 74 65 78 2d in.;;. (mutex-
2470: 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 unlock! *http-mu
2480: 74 65 78 2a 29 0a 3b 3b 09 20 20 20 28 74 68 72 tex*).;;. (thr
2490: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 3b 3b ead-sleep! 1).;;
24a0: 09 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 . (handle-exce
24b0: 70 74 69 6f 6e 73 0a 3b 3b 09 20 20 20 20 65 78 ptions.;;. ex
24c0: 6e 0a 3b 3b 09 20 20 20 20 28 64 65 62 75 67 3a n.;;. (debug:
24d0: 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING
24e0: 3a 20 63 6c 6f 73 69 6e 67 20 63 6f 6e 6e 65 63 : closing connec
24f0: 74 69 6f 6e 73 20 66 61 69 6c 65 64 2e 20 53 65 tions failed. Se
2500: 72 76 65 72 20 61 74 20 22 20 66 75 6c 6c 75 72 rver at " fullur
2510: 6c 20 22 20 61 6c 6d 6f 73 74 20 63 65 72 74 61 l " almost certa
2520: 69 6e 6c 79 20 64 65 61 64 22 29 0a 3b 3b 09 20 inly dead").;;.
2530: 20 20 20 28 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f (close-all-co
2540: 6e 6e 65 63 74 69 6f 6e 73 21 29 29 0a 3b 3b 09 nnections!)).;;.
2550: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
2560: 30 20 22 57 41 52 4e 49 4e 47 3a 20 46 61 69 6c 0 "WARNING: Fail
2570: 65 64 20 74 6f 20 63 6f 6d 6d 75 6e 69 63 61 74 ed to communicat
2580: 65 20 77 69 74 68 20 73 65 72 76 65 72 2c 20 74 e with server, t
2590: 72 79 69 6e 67 20 61 67 61 69 6e 2c 20 6e 75 6d rying again, num
25a0: 72 65 74 72 69 65 73 20 6c 65 66 74 3a 20 22 20 retries left: "
25b0: 6e 75 6d 72 65 74 72 69 65 73 29 0a 3b 3b 09 20 numretries).;;.
25c0: 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 (http-transpor
25d0: 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e t:client-api-sen
25e0: 64 2d 72 65 63 65 69 76 65 20 72 75 6e 2d 69 64 d-receive run-id
25f0: 20 73 65 72 76 65 72 64 61 74 20 63 6d 64 20 73 serverdat cmd s
2600: 70 61 72 61 6d 73 20 6e 75 6d 72 65 74 72 69 65 params numretrie
2610: 73 3a 20 28 2d 20 6e 75 6d 72 65 74 72 69 65 73 s: (- numretries
2620: 20 31 29 29 29 0a 3b 3b 09 20 28 62 65 67 69 6e 1))).;;. (begin
2630: 0a 3b 3b 09 20 20 20 28 6d 75 74 65 78 2d 75 6e .;;. (mutex-un
2640: 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 lock! *http-mute
2650: 78 2a 29 0a 3b 3b 09 20 20 20 28 74 61 73 6b 73 x*).;;. (tasks
2660: 3a 6b 69 6c 6c 2d 73 65 72 76 65 72 2d 72 75 6e :kill-server-run
2670: 2d 69 64 20 72 75 6e 2d 69 64 29 0a 3b 3b 09 20 -id run-id).;;.
2680: 20 20 23 66 29 29 0a 3b 3b 20 20 20 20 20 28 62 #f)).;; (b
2690: 65 67 69 6e 0a 20 20 20 20 20 20 20 28 64 65 62 egin. (deb
26a0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 31 ug:print-info 11
26b0: 20 22 66 75 6c 6c 75 72 6c 3d 22 20 66 75 6c 6c "fullurl=" full
26c0: 75 72 6c 20 22 2c 20 63 6d 64 3d 22 20 63 6d 64 url ", cmd=" cmd
26d0: 20 22 2c 20 70 61 72 61 6d 73 3d 22 20 70 61 72 ", params=" par
26e0: 61 6d 73 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 ams ", run-id="
26f0: 72 75 6e 2d 69 64 20 22 5c 6e 22 29 0a 20 20 20 run-id "\n").
2700: 20 20 20 20 3b 3b 20 73 65 74 20 75 70 20 74 68 ;; set up th
2710: 65 20 68 74 74 70 2d 63 6c 69 65 6e 74 20 68 65 e http-client he
2720: 72 65 0a 20 20 20 20 20 20 20 28 6d 61 78 2d 72 re. (max-r
2730: 65 74 72 79 2d 61 74 74 65 6d 70 74 73 20 31 29 etry-attempts 1)
2740: 0a 20 20 20 20 20 20 20 3b 3b 20 63 6f 6e 73 69 . ;; consi
2750: 64 65 72 20 61 6c 6c 20 72 65 71 75 65 73 74 73 der all requests
2760: 20 69 6e 64 65 6d 70 6f 74 65 6e 74 0a 20 20 20 indempotent.
2770: 20 20 20 20 28 72 65 74 72 79 2d 72 65 71 75 65 (retry-reque
2780: 73 74 3f 20 28 6c 61 6d 62 64 61 20 28 72 65 71 st? (lambda (req
2790: 75 65 73 74 29 0a 09 09 09 20 23 66 29 29 0a 20 uest).... #f)).
27a0: 20 20 20 20 20 20 3b 3b 20 73 65 6e 64 20 74 68 ;; send th
27b0: 65 20 64 61 74 61 20 61 6e 64 20 67 65 74 20 74 e data and get t
27c0: 68 65 20 72 65 73 70 6f 6e 73 65 0a 20 20 20 20 he response.
27d0: 20 20 20 3b 3b 20 65 78 74 72 61 63 74 20 74 68 ;; extract th
27e0: 65 20 6e 65 65 64 65 64 20 69 6e 66 6f 20 66 72 e needed info fr
27f0: 6f 6d 20 74 68 65 20 68 74 74 70 20 64 61 74 61 om the http data
2800: 20 61 6e 64 20 0a 20 20 20 20 20 20 20 3b 3b 20 and . ;;
2810: 70 72 6f 63 65 73 73 20 61 6e 64 20 72 65 74 75 process and retu
2820: 72 6e 20 69 74 2e 0a 20 20 20 20 20 20 20 28 6c rn it.. (l
2830: 65 74 2a 20 28 28 73 65 6e 64 2d 72 65 63 69 65 et* ((send-recie
2840: 76 65 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 ve (lambda ()...
2850: 09 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f . (mutex-lo
2860: 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a ck! *http-mutex*
2870: 29 0a 09 09 09 20 20 20 20 20 20 3b 3b 20 28 63 ).... ;; (c
2880: 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 20 28 77 ondition-case (w
2890: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 ith-input-from-r
28a0: 65 71 75 65 73 74 20 22 68 74 74 70 3a 2f 2f 6c equest "http://l
28b0: 6f 63 61 6c 68 6f 73 74 22 3b 20 23 66 20 72 65 ocalhost"; #f re
28c0: 61 64 2d 6c 69 6e 65 73 29 0a 09 09 09 20 20 20 ad-lines)....
28d0: 20 20 20 3b 3b 09 09 09 09 09 20 20 20 20 20 20 ;;.....
28e0: 20 28 28 65 78 6e 20 68 74 74 70 20 63 6c 69 65 ((exn http clie
28f0: 6e 74 2d 65 72 72 6f 72 29 20 65 20 28 70 72 69 nt-error) e (pri
2900: 6e 74 20 65 29 29 29 0a 09 09 09 20 20 20 20 20 nt e)))....
2910: 20 28 73 65 74 21 20 72 65 73 20 28 76 65 63 74 (set! res (vect
2920: 6f 72 0a 09 09 09 09 09 20 73 75 63 63 65 73 73 or...... success
2930: 0a 09 09 09 09 09 20 28 64 62 3a 73 74 72 69 6e ...... (db:strin
2940: 67 2d 3e 6f 62 6a 20 0a 09 09 09 09 09 20 20 28 g->obj ...... (
2950: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
2960: 73 0a 09 09 09 09 09 20 20 20 65 78 6e 0a 09 09 s...... exn...
2970: 09 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 09 ... (begin....
2980: 09 09 20 20 20 20 20 28 73 65 74 21 20 73 75 63 .. (set! suc
2990: 63 65 73 73 20 23 66 29 0a 09 09 09 09 09 20 20 cess #f)......
29a0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
29b0: 30 20 22 57 41 52 4e 49 4e 47 3a 20 66 61 69 6c 0 "WARNING: fail
29c0: 75 72 65 20 69 6e 20 77 69 74 68 2d 69 6e 70 75 ure in with-inpu
29d0: 74 2d 66 72 6f 6d 2d 72 65 71 75 65 73 74 20 74 t-from-request t
29e0: 6f 20 22 20 66 75 6c 6c 75 72 6c 20 22 2e 22 29 o " fullurl ".")
29f0: 0a 09 09 09 09 09 20 20 20 20 20 28 64 65 62 75 ...... (debu
2a00: 67 3a 70 72 69 6e 74 20 30 20 22 20 6d 65 73 73 g:print 0 " mess
2a10: 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 age: " ((conditi
2a20: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
2a30: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
2a40: 67 65 29 20 65 78 6e 29 29 0a 09 09 09 09 09 20 ge) exn))......
2a50: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
2a60: 64 65 6c 65 74 65 21 20 2a 72 75 6e 72 65 6d 6f delete! *runremo
2a70: 74 65 2a 20 72 75 6e 2d 69 64 29 0a 09 09 09 09 te* run-id).....
2a80: 09 20 20 20 20 20 3b 3b 20 4b 69 6c 6c 69 6e 67 . ;; Killing
2a90: 20 61 73 73 6f 63 69 61 74 65 64 20 73 65 72 76 associated serv
2aa0: 65 72 20 74 6f 20 61 6c 6c 6f 77 20 63 6c 65 61 er to allow clea
2ab0: 6e 20 72 65 74 72 79 2e 22 29 0a 09 09 09 09 09 n retry.")......
2ac0: 20 20 20 20 20 3b 3b 20 28 74 61 73 6b 73 3a 6b ;; (tasks:k
2ad0: 69 6c 6c 2d 73 65 72 76 65 72 2d 72 75 6e 2d 69 ill-server-run-i
2ae0: 64 20 72 75 6e 2d 69 64 29 20 20 3b 3b 20 62 65 d run-id) ;; be
2af0: 74 74 65 72 20 74 6f 20 6b 69 6c 6c 20 74 68 65 tter to kill the
2b00: 20 73 65 72 76 65 72 20 69 6e 20 74 68 65 20 6c server in the l
2b10: 6f 67 69 63 20 74 68 61 74 20 63 61 6c 6c 65 64 ogic that called
2b20: 20 74 68 69 73 20 72 6f 75 74 69 6e 65 3f 0a 09 this routine?..
2b30: 09 09 09 09 20 20 20 20 20 28 6d 75 74 65 78 2d .... (mutex-
2b40: 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 unlock! *http-mu
2b50: 74 65 78 2a 29 0a 09 09 09 09 09 20 20 20 20 20 tex*)......
2b60: 3b 3b 3b 20 28 73 69 67 6e 61 6c 20 28 6d 61 6b ;;; (signal (mak
2b70: 65 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 6f 6e 64 e-composite-cond
2b80: 69 74 69 6f 6e 0a 09 09 09 09 09 20 20 20 20 20 ition......
2b90: 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 28 6d 61 ;;; (ma
2ba0: 6b 65 2d 70 72 6f 70 65 72 74 79 2d 63 6f 6e 64 ke-property-cond
2bb0: 69 74 69 6f 6e 20 27 63 6f 6d 6d 66 61 69 6c 20 ition 'commfail
2bc0: 27 6d 65 73 73 61 67 65 20 22 66 61 69 6c 65 64 'message "failed
2bd0: 20 74 6f 20 63 6f 6e 6e 65 63 74 20 74 6f 20 73 to connect to s
2be0: 65 72 76 65 72 22 29 29 29 0a 09 09 09 09 09 20 erver")))......
2bf0: 20 20 20 20 3b 3b 3b 20 22 63 6f 6d 6d 75 6e 69 ;;; "communi
2c00: 63 61 74 69 6f 6e 73 20 66 61 69 6c 65 64 22 0a cations failed".
2c10: 09 09 09 09 09 20 20 20 20 20 28 64 62 3a 6f 62 ..... (db:ob
2c20: 6a 2d 3e 73 74 72 69 6e 67 20 23 66 29 29 0a 09 j->string #f))..
2c30: 09 09 09 09 20 20 20 28 77 69 74 68 2d 69 6e 70 .... (with-inp
2c40: 75 74 2d 66 72 6f 6d 2d 72 65 71 75 65 73 74 20 ut-from-request
2c50: 3b 3b 20 77 61 73 20 64 61 74 0a 09 09 09 09 09 ;; was dat......
2c60: 20 20 20 20 66 75 6c 6c 75 72 6c 20 0a 09 09 09 fullurl ....
2c70: 09 09 20 20 20 20 28 6c 69 73 74 20 28 63 6f 6e .. (list (con
2c80: 73 20 27 6b 65 79 20 22 74 68 65 6b 65 79 22 29 s 'key "thekey")
2c90: 0a 09 09 09 09 09 09 20 20 28 63 6f 6e 73 20 27 ....... (cons '
2ca0: 63 6d 64 20 63 6d 64 29 0a 09 09 09 09 09 09 20 cmd cmd).......
2cb0: 20 28 63 6f 6e 73 20 27 70 61 72 61 6d 73 20 73 (cons 'params s
2cc0: 70 61 72 61 6d 73 29 29 0a 09 09 09 09 09 20 20 params))......
2cd0: 20 20 72 65 61 64 2d 73 74 72 69 6e 67 29 29 0a read-string)).
2ce0: 09 09 09 09 09 20 20 74 72 61 6e 73 70 6f 72 74 ..... transport
2cf0: 3a 20 27 68 74 74 70 29 29 29 0a 09 09 09 20 20 : 'http)))....
2d00: 20 20 20 20 3b 3b 20 53 68 6f 75 6c 64 6e 27 74 ;; Shouldn't
2d10: 20 74 68 69 73 20 62 65 20 61 20 63 61 6c 6c 20 this be a call
2d20: 74 6f 20 74 68 65 20 6d 61 6e 61 67 65 64 20 63 to the managed c
2d30: 61 6c 6c 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 all-all-connecti
2d40: 6f 6e 73 20 73 74 75 66 66 20 61 62 6f 76 65 3f ons stuff above?
2d50: 0a 09 09 09 20 20 20 20 20 20 28 63 6c 6f 73 65 .... (close
2d60: 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 -all-connections
2d70: 21 29 0a 09 09 09 20 20 20 20 20 20 28 6d 75 74 !).... (mut
2d80: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 ex-unlock! *http
2d90: 2d 6d 75 74 65 78 2a 29 0a 09 09 09 20 20 20 20 -mutex*)....
2da0: 20 20 29 29 0a 09 20 20 20 20 20 20 28 74 69 6d )).. (tim
2db0: 65 2d 6f 75 74 20 20 20 20 20 28 6c 61 6d 62 64 e-out (lambd
2dc0: 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 28 74 a ().... (t
2dd0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 34 35 29 hread-sleep! 45)
2de0: 0a 09 09 09 20 20 20 20 20 20 23 66 29 29 0a 09 .... #f))..
2df0: 20 20 20 20 20 20 28 74 68 31 20 28 6d 61 6b 65 (th1 (make
2e00: 2d 74 68 72 65 61 64 20 73 65 6e 64 2d 72 65 63 -thread send-rec
2e10: 69 65 76 65 20 22 77 69 74 68 2d 69 6e 70 75 74 ieve "with-input
2e20: 2d 66 72 6f 6d 2d 72 65 71 75 65 73 74 22 29 29 -from-request"))
2e30: 0a 09 20 20 20 20 20 20 28 74 68 32 20 28 6d 61 .. (th2 (ma
2e40: 6b 65 2d 74 68 72 65 61 64 20 74 69 6d 65 2d 6f ke-thread time-o
2e50: 75 74 20 20 20 20 20 22 74 69 6d 65 20 6f 75 74 ut "time out
2e60: 22 29 29 29 0a 09 20 28 74 68 72 65 61 64 2d 73 "))).. (thread-s
2e70: 74 61 72 74 21 20 74 68 31 29 0a 09 20 28 74 68 tart! th1).. (th
2e80: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 read-start! th2)
2e90: 0a 09 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 .. (thread-join!
2ea0: 20 74 68 31 29 0a 09 20 28 74 68 72 65 61 64 2d th1).. (thread-
2eb0: 74 65 72 6d 69 6e 61 74 65 21 20 74 68 32 29 0a terminate! th2).
2ec0: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 . (debug:print-i
2ed0: 6e 66 6f 20 31 31 20 22 67 6f 74 20 72 65 73 3d nfo 11 "got res=
2ee0: 22 20 72 65 73 29 0a 09 20 28 69 66 20 28 76 65 " res).. (if (ve
2ef0: 63 74 6f 72 3f 20 72 65 73 29 0a 09 20 20 20 20 ctor? res)..
2f00: 20 28 69 66 20 28 76 65 63 74 6f 72 2d 72 65 66 (if (vector-ref
2f10: 20 72 65 73 20 30 29 0a 09 09 20 72 65 73 0a 09 res 0)... res..
2f20: 09 20 28 62 65 67 69 6e 20 3b 3b 20 6e 6f 74 65 . (begin ;; note
2f30: 3a 20 74 68 69 73 20 63 6f 64 65 20 61 6c 73 6f : this code also
2f40: 20 63 61 6c 6c 65 64 20 69 6e 20 6e 6d 73 67 2d called in nmsg-
2f50: 74 72 61 6e 73 70 6f 72 74 20 2d 20 63 6f 6e 73 transport - cons
2f60: 69 64 65 72 20 63 6f 6e 73 6f 6c 69 64 61 74 69 ider consolidati
2f70: 6e 67 20 69 74 0a 09 09 20 20 20 28 64 65 62 75 ng it... (debu
2f80: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
2f90: 3a 20 65 72 72 6f 72 20 6f 63 63 75 72 65 64 20 : error occured
2fa0: 61 74 20 73 65 72 76 65 72 2c 20 69 6e 66 6f 3d at server, info=
2fb0: 22 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 " (vector-ref re
2fc0: 73 20 32 29 29 0a 09 09 20 20 20 28 64 65 62 75 s 2))... (debu
2fd0: 67 3a 70 72 69 6e 74 20 30 20 22 20 63 6c 69 65 g:print 0 " clie
2fe0: 6e 74 20 63 61 6c 6c 20 63 68 61 69 6e 3a 22 29 nt call chain:")
2ff0: 0a 09 09 20 20 20 28 70 72 69 6e 74 2d 63 61 6c ... (print-cal
3000: 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 l-chain (current
3010: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 09 -error-port))...
3020: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
3030: 30 20 22 20 73 65 72 76 65 72 20 63 61 6c 6c 20 0 " server call
3040: 63 68 61 69 6e 3a 22 29 0a 09 09 20 20 20 28 70 chain:")... (p
3050: 70 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 p (vector-ref re
3060: 73 20 31 29 20 28 63 75 72 72 65 6e 74 2d 65 72 s 1) (current-er
3070: 72 6f 72 2d 70 6f 72 74 29 29 0a 09 09 20 20 20 ror-port))...
3080: 28 73 69 67 6e 61 6c 20 28 76 65 63 74 6f 72 2d (signal (vector-
3090: 72 65 66 20 72 65 73 75 6c 74 20 30 29 29 29 29 ref result 0))))
30a0: 0a 09 20 20 20 20 20 28 73 69 67 6e 61 6c 20 28 .. (signal (
30b0: 6d 61 6b 65 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 make-composite-c
30c0: 6f 6e 64 69 74 69 6f 6e 0a 09 09 20 20 20 20 20 ondition...
30d0: 20 28 6d 61 6b 65 2d 70 72 6f 70 65 72 74 79 2d (make-property-
30e0: 63 6f 6e 64 69 74 69 6f 6e 20 0a 09 09 20 20 20 condition ...
30f0: 20 20 20 20 27 74 69 6d 65 6f 75 74 0a 09 09 20 'timeout...
3100: 20 20 20 20 20 20 27 6d 65 73 73 61 67 65 20 22 'message "
3110: 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 3a 63 nmsg-transport:c
3120: 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 lient-api-send-r
3130: 65 63 65 69 76 65 2d 72 61 77 20 74 69 6d 65 64 eceive-raw timed
3140: 20 6f 75 74 20 74 61 6c 6b 69 6e 67 20 74 6f 20 out talking to
3150: 73 65 72 76 65 72 22 29 29 29 29 29 29 29 0a 0a server")))))))..
3160: 3b 3b 20 63 61 72 65 66 75 6c 20 63 6c 6f 73 69 ;; careful closi
3170: 6e 67 20 6f 66 20 63 6f 6e 6e 65 63 74 69 6f 6e ng of connection
3180: 73 20 73 74 6f 72 65 64 20 69 6e 20 2a 72 75 6e s stored in *run
3190: 72 65 6d 6f 74 65 2a 0a 3b 3b 0a 28 64 65 66 69 remote*.;;.(defi
31a0: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
31b0: 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 rt:close-connect
31c0: 69 6f 6e 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 ions run-id). (
31d0: 6c 65 74 2a 20 28 28 73 65 72 76 65 72 2d 64 61 let* ((server-da
31e0: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
31f0: 66 2f 64 65 66 61 75 6c 74 20 2a 72 75 6e 72 65 f/default *runre
3200: 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 23 66 29 mote* run-id #f)
3210: 29 29 0a 20 20 20 20 28 69 66 20 28 76 65 63 74 )). (if (vect
3220: 6f 72 3f 20 73 65 72 76 65 72 2d 64 61 74 29 0a or? server-dat).
3230: 09 28 6c 65 74 20 28 28 61 70 69 2d 64 61 74 20 .(let ((api-dat
3240: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
3250: 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 61 server-dat-get-a
3260: 70 69 2d 75 72 69 20 73 65 72 76 65 72 2d 64 61 pi-uri server-da
3270: 74 29 29 29 0a 09 20 20 28 63 6c 6f 73 65 2d 63 t))).. (close-c
3280: 6f 6e 6e 65 63 74 69 6f 6e 21 20 61 70 69 2d 64 onnection! api-d
3290: 61 74 29 0a 09 20 20 23 74 29 0a 09 23 66 29 29 at).. #t)..#f))
32a0: 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b )...(define (mak
32b0: 65 2d 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 e-http-transport
32c0: 3a 73 65 72 76 65 72 2d 64 61 74 29 28 6d 61 6b :server-dat)(mak
32d0: 65 2d 76 65 63 74 6f 72 20 36 29 29 0a 28 64 65 e-vector 6)).(de
32e0: 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
32f0: 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
3300: 67 65 74 2d 69 66 61 63 65 20 20 20 20 20 20 20 get-iface
3310: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
3320: 72 2d 72 65 66 20 20 76 65 63 20 30 29 29 0a 28 r-ref vec 0)).(
3330: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
3340: 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 nsport:server-da
3350: 74 2d 67 65 74 2d 70 6f 72 74 20 20 20 20 20 20 t-get-port
3360: 20 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 vec) (vec
3370: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 31 29 29 tor-ref vec 1))
3380: 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 .(define (http-t
3390: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
33a0: 64 61 74 2d 67 65 74 2d 61 70 69 2d 75 72 69 20 dat-get-api-uri
33b0: 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 76 vec) (v
33c0: 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 32 ector-ref vec 2
33d0: 29 29 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 )).(define (http
33e0: 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 -transport:serve
33f0: 72 2d 64 61 74 2d 67 65 74 2d 61 70 69 2d 75 72 r-dat-get-api-ur
3400: 6c 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 l vec)
3410: 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 (vector-ref vec
3420: 20 33 29 29 0a 28 64 65 66 69 6e 65 20 28 68 74 3)).(define (ht
3430: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
3440: 76 65 72 2d 64 61 74 2d 67 65 74 2d 61 70 69 2d ver-dat-get-api-
3450: 72 65 71 20 20 20 20 20 20 20 76 65 63 29 20 20 req vec)
3460: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
3470: 65 63 20 34 29 29 0a 28 64 65 66 69 6e 65 20 28 ec 4)).(define (
3480: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
3490: 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 6c 61 erver-dat-get-la
34a0: 73 74 2d 61 63 63 65 73 73 20 20 20 76 65 63 29 st-access vec)
34b0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
34c0: 20 76 65 63 20 35 29 29 0a 28 64 65 66 69 6e 65 vec 5)).(define
34d0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
34e0: 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d :server-dat-get-
34f0: 73 6f 63 6b 65 74 20 20 20 20 20 20 20 20 76 65 socket ve
3500: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
3510: 66 20 20 76 65 63 20 36 29 29 0a 0a 28 64 65 66 f vec 6))..(def
3520: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
3530: 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 6d ort:server-dat-m
3540: 61 6b 65 2d 75 72 6c 20 76 65 63 29 0a 20 20 28 ake-url vec). (
3550: 69 66 20 28 61 6e 64 20 28 68 74 74 70 2d 74 72 if (and (http-tr
3560: 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 ansport:server-d
3570: 61 74 2d 67 65 74 2d 69 66 61 63 65 20 76 65 63 at-get-iface vec
3580: 29 0a 09 20 20 20 28 68 74 74 70 2d 74 72 61 6e ).. (http-tran
3590: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 sport:server-dat
35a0: 2d 67 65 74 2d 70 6f 72 74 20 20 76 65 63 29 29 -get-port vec))
35b0: 0a 20 20 20 20 20 20 28 63 6f 6e 63 20 22 68 74 . (conc "ht
35c0: 74 70 3a 2f 2f 22 20 0a 09 20 20 20 20 28 68 74 tp://" .. (ht
35d0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
35e0: 76 65 72 2d 64 61 74 2d 67 65 74 2d 69 66 61 63 ver-dat-get-ifac
35f0: 65 20 76 65 63 29 0a 09 20 20 20 20 22 3a 22 0a e vec).. ":".
3600: 09 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 . (http-trans
3610: 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
3620: 67 65 74 2d 70 6f 72 74 20 20 76 65 63 29 29 0a get-port vec)).
3630: 20 20 20 20 20 20 23 66 29 29 0a 0a 28 64 65 66 #f))..(def
3640: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
3650: 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 75 ort:server-dat-u
3660: 70 64 61 74 65 2d 6c 61 73 74 2d 61 63 63 65 73 pdate-last-acces
3670: 73 20 76 65 63 29 0a 20 20 28 69 66 20 28 76 65 s vec). (if (ve
3680: 63 74 6f 72 3f 20 76 65 63 29 0a 20 20 20 20 20 ctor? vec).
3690: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 (vector-set! ve
36a0: 63 20 35 20 28 63 75 72 72 65 6e 74 2d 73 65 63 c 5 (current-sec
36b0: 6f 6e 64 73 29 29 0a 20 20 20 20 20 20 28 62 65 onds)). (be
36c0: 67 69 6e 0a 09 28 70 72 69 6e 74 2d 63 61 6c 6c gin..(print-call
36d0: 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d -chain (current-
36e0: 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 28 64 error-port))..(d
36f0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
3700: 52 4f 52 3a 20 63 61 6c 6c 20 74 6f 20 68 74 74 ROR: call to htt
3710: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 p-transport:serv
3720: 65 72 2d 64 61 74 2d 75 70 64 61 74 65 2d 6c 61 er-dat-update-la
3730: 73 74 2d 61 63 63 65 73 73 20 77 69 74 68 20 6e st-access with n
3740: 6f 6e 2d 76 65 63 74 6f 72 21 21 22 29 29 29 29 on-vector!!"))))
3750: 0a 0a 3b 3b 0a 3b 3b 20 63 6f 6e 6e 65 63 74 0a ..;;.;; connect.
3760: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 ;;.(define (http
3770: 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e -transport:clien
3780: 74 2d 63 6f 6e 6e 65 63 74 20 69 66 61 63 65 20 t-connect iface
3790: 70 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 port). (let* ((
37a0: 61 70 69 2d 75 72 6c 20 20 20 20 20 20 28 63 6f api-url (co
37b0: 6e 63 20 22 68 74 74 70 3a 2f 2f 22 20 69 66 61 nc "http://" ifa
37c0: 63 65 20 22 3a 22 20 70 6f 72 74 20 22 2f 61 70 ce ":" port "/ap
37d0: 69 22 29 29 0a 09 20 28 61 70 69 2d 75 72 69 20 i")).. (api-uri
37e0: 20 20 20 20 20 28 75 72 69 2d 72 65 66 65 72 65 (uri-refere
37f0: 6e 63 65 20 28 63 6f 6e 63 20 22 68 74 74 70 3a nce (conc "http:
3800: 2f 2f 22 20 69 66 61 63 65 20 22 3a 22 20 70 6f //" iface ":" po
3810: 72 74 20 22 2f 61 70 69 22 29 29 29 0a 09 20 28 rt "/api"))).. (
3820: 61 70 69 2d 72 65 71 20 20 20 20 20 20 28 6d 61 api-req (ma
3830: 6b 65 2d 72 65 71 75 65 73 74 20 6d 65 74 68 6f ke-request metho
3840: 64 3a 20 27 50 4f 53 54 20 75 72 69 3a 20 61 70 d: 'POST uri: ap
3850: 69 2d 75 72 69 29 29 0a 09 20 28 73 65 72 76 65 i-uri)).. (serve
3860: 72 2d 64 61 74 20 20 20 28 76 65 63 74 6f 72 20 r-dat (vector
3870: 69 66 61 63 65 20 70 6f 72 74 20 61 70 69 2d 75 iface port api-u
3880: 72 69 20 61 70 69 2d 75 72 6c 20 61 70 69 2d 72 ri api-url api-r
3890: 65 71 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f eq (current-seco
38a0: 6e 64 73 29 29 29 29 0a 20 20 20 20 73 65 72 76 nds)))). serv
38b0: 65 72 2d 64 61 74 29 29 0a 0a 3b 3b 20 72 75 6e er-dat))..;; run
38c0: 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a http-transport:
38d0: 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 69 6e 20 keep-running in
38e0: 61 20 70 61 72 61 6c 6c 65 6c 20 74 68 72 65 61 a parallel threa
38f0: 64 20 74 6f 20 6d 6f 6e 69 74 6f 72 20 74 68 61 d to monitor tha
3900: 74 20 74 68 65 20 64 62 20 69 73 20 62 65 69 6e t the db is bein
3910: 67 20 0a 3b 3b 20 75 73 65 64 20 61 6e 64 20 74 g .;; used and t
3920: 6f 20 73 68 75 74 64 6f 77 6e 20 61 66 74 65 72 o shutdown after
3930: 20 73 6f 6d 65 74 69 6d 65 20 69 66 20 69 74 20 sometime if it
3940: 69 73 20 6e 6f 74 2e 0a 3b 3b 0a 28 64 65 66 69 is not..;;.(defi
3950: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
3960: 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 rt:keep-running
3970: 73 65 72 76 65 72 2d 69 64 20 72 75 6e 2d 69 64 server-id run-id
3980: 29 0a 20 20 3b 3b 20 69 66 20 6e 6f 6e 65 20 72 ). ;; if none r
3990: 75 6e 6e 69 6e 67 20 6f 72 20 69 66 20 3e 20 32 unning or if > 2
39a0: 30 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 0 seconds since
39b0: 0a 20 20 3b 3b 20 73 65 72 76 65 72 20 6c 61 73 . ;; server las
39c0: 74 20 75 73 65 64 20 74 68 65 6e 20 73 74 61 72 t used then star
39d0: 74 20 73 68 75 74 64 6f 77 6e 0a 20 20 3b 3b 20 t shutdown. ;;
39e0: 54 68 69 73 20 74 68 72 65 61 64 20 77 61 69 74 This thread wait
39f0: 73 20 66 6f 72 20 74 68 65 20 73 65 72 76 65 72 s for the server
3a00: 20 74 6f 20 63 6f 6d 65 20 61 6c 69 76 65 0a 20 to come alive.
3a10: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
3a20: 66 6f 20 30 20 22 53 74 61 72 74 69 6e 67 20 74 fo 0 "Starting t
3a30: 68 65 20 73 79 6e 63 2d 62 61 63 6b 2c 20 6b 65 he sync-back, ke
3a40: 65 70 20 61 6c 69 76 65 20 74 68 72 65 61 64 20 ep alive thread
3a50: 69 6e 20 73 65 72 76 65 72 20 66 6f 72 20 72 75 in server for ru
3a60: 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 29 0a 20 n-id=" run-id).
3a70: 20 28 6c 65 74 2a 20 28 28 74 64 62 64 61 74 20 (let* ((tdbdat
3a80: 20 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 6e (tasks:open
3a90: 2d 64 62 29 29 0a 09 20 28 73 65 72 76 65 72 2d -db)).. (server-
3aa0: 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 start-time (curr
3ab0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 ent-seconds))..
3ac0: 28 73 65 72 76 65 72 2d 69 6e 66 6f 20 28 6c 65 (server-info (le
3ad0: 74 20 6c 6f 6f 70 20 28 28 73 74 61 72 74 2d 74 t loop ((start-t
3ae0: 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ime (current-sec
3af0: 6f 6e 64 73 29 29 0a 09 09 09 09 20 28 63 68 61 onds))..... (cha
3b00: 6e 67 65 64 20 20 20 20 23 74 29 0a 09 09 09 09 nged #t).....
3b10: 20 28 6c 61 73 74 2d 73 64 61 74 20 20 22 6e 6f (last-sdat "no
3b20: 74 20 74 68 69 73 22 29 29 0a 20 20 20 20 20 20 t this")).
3b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b40: 20 20 28 6c 65 74 20 28 28 73 64 61 74 20 23 66 (let ((sdat #f
3b50: 29 29 0a 09 09 09 20 20 28 74 68 72 65 61 64 2d )).... (thread-
3b60: 73 6c 65 65 70 21 20 30 2e 30 31 29 0a 09 09 09 sleep! 0.01)....
3b70: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
3b80: 6e 66 6f 20 30 20 22 57 61 69 74 69 6e 67 20 66 nfo 0 "Waiting f
3b90: 6f 72 20 73 65 72 76 65 72 20 61 6c 69 76 65 20 or server alive
3ba0: 73 69 67 6e 61 74 75 72 65 22 29 0a 20 20 20 20 signature").
3bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3bc0: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 (mutex-loc
3bd0: 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 k! *heartbeat-mu
3be0: 74 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 20 tex*).
3bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c00: 28 73 65 74 21 20 73 64 61 74 20 2a 73 65 72 76 (set! sdat *serv
3c10: 65 72 2d 69 6e 66 6f 2a 29 0a 20 20 20 20 20 20 er-info*).
3c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c30: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
3c40: 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 k! *heartbeat-mu
3c50: 74 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 20 tex*).
3c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c70: 28 69 66 20 28 61 6e 64 20 73 64 61 74 0a 09 09 (if (and sdat...
3c80: 09 09 20 20 20 28 6e 6f 74 20 63 68 61 6e 67 65 .. (not change
3c90: 64 29 0a 09 09 09 09 20 20 20 28 3e 20 28 2d 20 d)..... (> (-
3ca0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
3cb0: 29 20 73 74 61 72 74 2d 74 69 6d 65 29 20 32 29 ) start-time) 2)
3cc0: 29 0a 09 09 09 20 20 20 20 20 20 73 64 61 74 0a ).... sdat.
3cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
3cf0: 65 67 69 6e 0a 09 09 09 09 28 64 65 62 75 67 3a egin.....(debug:
3d00: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 53 74 print-info 0 "St
3d10: 69 6c 6c 20 77 61 69 74 69 6e 67 2c 20 6c 61 73 ill waiting, las
3d20: 74 2d 73 64 61 74 3d 22 20 6c 61 73 74 2d 73 64 t-sdat=" last-sd
3d30: 61 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 at).
3d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3d50: 20 20 20 20 28 73 6c 65 65 70 20 34 29 0a 09 09 (sleep 4)...
3d60: 09 09 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 ..(if (> (- (cur
3d70: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 74 rent-seconds) st
3d80: 61 72 74 2d 74 69 6d 65 29 20 31 32 30 29 20 3b art-time) 120) ;
3d90: 3b 20 62 65 65 6e 20 77 61 69 74 69 6e 67 20 66 ; been waiting f
3da0: 6f 72 20 74 77 6f 20 6d 69 6e 75 74 65 73 0a 09 or two minutes..
3db0: 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 ... (begin...
3dc0: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
3dd0: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 rint 0 "ERROR: t
3de0: 72 61 6e 73 70 6f 72 74 20 61 70 70 65 61 72 73 ransport appears
3df0: 20 74 6f 20 68 61 76 65 20 64 69 65 64 2c 20 65 to have died, e
3e00: 78 69 74 69 6e 67 20 73 65 72 76 65 72 20 22 20 xiting server "
3e10: 73 65 72 76 65 72 2d 69 64 20 22 20 66 6f 72 20 server-id " for
3e20: 72 75 6e 20 22 20 72 75 6e 2d 69 64 29 0a 09 09 run " run-id)...
3e30: 09 09 20 20 20 20 20 20 28 74 61 73 6b 73 3a 73 .. (tasks:s
3e40: 65 72 76 65 72 2d 64 65 6c 65 74 65 2d 72 65 63 erver-delete-rec
3e50: 6f 72 64 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 ord (db:delay-if
3e60: 2d 62 75 73 79 20 74 64 62 64 61 74 29 20 73 65 -busy tdbdat) se
3e70: 72 76 65 72 2d 69 64 20 22 66 61 69 6c 65 64 20 rver-id "failed
3e80: 74 6f 20 73 74 61 72 74 2c 20 6e 65 76 65 72 20 to start, never
3e90: 72 65 63 65 69 76 65 64 20 73 65 72 76 65 72 20 received server
3ea0: 61 6c 69 76 65 20 73 69 67 6e 61 74 75 72 65 22 alive signature"
3eb0: 29 0a 09 09 09 09 20 20 20 20 20 20 28 65 78 69 )..... (exi
3ec0: 74 29 29 0a 09 09 09 09 20 20 20 20 28 6c 6f 6f t))..... (loo
3ed0: 70 20 73 74 61 72 74 2d 74 69 6d 65 0a 09 09 09 p start-time....
3ee0: 09 09 20 20 28 65 71 75 61 6c 3f 20 73 64 61 74 .. (equal? sdat
3ef0: 20 6c 61 73 74 2d 73 64 61 74 29 0a 09 09 09 09 last-sdat).....
3f00: 09 20 20 73 64 61 74 29 29 29 29 29 29 29 0a 20 . sdat))))))).
3f10: 20 20 20 20 20 20 20 20 28 69 66 61 63 65 20 20 (iface
3f20: 20 20 20 20 20 28 63 61 72 20 73 65 72 76 65 72 (car server
3f30: 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 -info)).
3f40: 20 28 70 6f 72 74 20 20 20 20 20 20 20 20 28 63 (port (c
3f50: 61 64 72 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 adr server-info)
3f60: 29 0a 20 20 20 20 20 20 20 20 20 28 6c 61 73 74 ). (last
3f70: 2d 61 63 63 65 73 73 20 30 29 0a 09 20 28 73 65 -access 0).. (se
3f80: 72 76 65 72 2d 74 69 6d 65 6f 75 74 20 28 73 65 rver-timeout (se
3f90: 72 76 65 72 3a 67 65 74 2d 74 69 6d 65 6f 75 74 rver:get-timeout
3fa0: 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f ))). (let loo
3fb0: 70 20 28 28 63 6f 75 6e 74 20 20 20 20 20 20 20 p ((count
3fc0: 20 20 30 29 0a 09 20 20 20 20 20 20 20 28 73 65 0).. (se
3fd0: 72 76 65 72 2d 73 74 61 74 65 20 27 61 76 61 69 rver-state 'avai
3fe0: 6c 61 62 6c 65 29 0a 09 20 20 20 20 20 20 20 28 lable).. (
3ff0: 62 61 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 30 bad-sync-count 0
4000: 29 29 0a 0a 20 20 20 20 20 20 3b 3b 20 55 73 65 )).. ;; Use
4010: 20 74 68 69 73 20 6f 70 70 6f 72 74 75 6e 69 74 this opportunit
4020: 79 20 74 6f 20 73 79 6e 63 20 74 68 65 20 69 6e y to sync the in
4030: 6d 65 6d 64 62 20 74 6f 20 64 62 0a 20 20 20 20 memdb to db.
4040: 20 20 28 69 66 20 2a 69 6e 6d 65 6d 64 62 2a 20 (if *inmemdb*
4050: 0a 09 20 20 28 6c 65 74 20 28 28 73 74 61 72 74 .. (let ((start
4060: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d -time (current-m
4070: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 09 09 illiseconds))...
4080: 28 73 79 6e 63 2d 74 69 6d 65 20 20 23 66 29 0a (sync-time #f).
4090: 09 09 28 72 65 6d 2d 74 69 6d 65 20 20 20 23 66 ..(rem-time #f
40a0: 29 29 0a 09 20 20 20 20 3b 3b 20 69 6e 6d 65 6d )).. ;; inmem
40b0: 64 62 20 69 73 20 61 20 64 62 73 74 72 75 63 74 db is a dbstruct
40c0: 0a 09 20 20 20 20 28 63 6f 6e 64 69 74 69 6f 6e .. (condition
40d0: 2d 63 61 73 65 0a 09 20 20 20 20 20 28 64 62 3a -case.. (db:
40e0: 73 79 6e 63 2d 74 6f 75 63 68 65 64 20 2a 69 6e sync-touched *in
40f0: 6d 65 6d 64 62 2a 20 2a 72 75 6e 2d 69 64 2a 20 memdb* *run-id*
4100: 66 6f 72 63 65 2d 73 79 6e 63 3a 20 23 74 29 0a force-sync: #t).
4110: 09 20 20 20 20 20 28 28 73 79 6e 63 2d 66 61 69 . ((sync-fai
4120: 6c 65 64 29 28 63 6f 6e 64 0a 09 09 09 20 20 20 led)(cond....
4130: 20 28 28 3e 20 62 61 64 2d 73 79 6e 63 2d 63 6f ((> bad-sync-co
4140: 75 6e 74 20 31 30 29 20 3b 3b 20 74 69 6d 65 20 unt 10) ;; time
4150: 74 6f 20 67 69 76 65 20 75 70 0a 09 09 09 20 20 to give up....
4160: 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f (http-transpo
4170: 72 74 3a 73 65 72 76 65 72 2d 73 68 75 74 64 6f rt:server-shutdo
4180: 77 6e 20 73 65 72 76 65 72 2d 69 64 20 70 6f 72 wn server-id por
4190: 74 29 29 0a 09 09 09 20 20 20 20 28 65 6c 73 65 t)).... (else
41a0: 20 3b 3b 20 28 3e 20 62 61 64 2d 73 79 6e 63 2d ;; (> bad-sync-
41b0: 63 6f 75 6e 74 20 30 29 20 20 3b 3b 20 77 65 27 count 0) ;; we'
41c0: 76 65 20 68 61 64 20 61 20 66 61 69 6c 20 6f 72 ve had a fail or
41d0: 20 74 77 6f 2c 20 64 65 6c 61 79 20 61 6e 64 20 two, delay and
41e0: 6c 6f 6f 70 0a 09 09 09 20 20 20 20 20 28 74 68 loop.... (th
41f0: 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 0a 09 read-sleep! 5)..
4200: 09 09 20 20 20 20 20 28 6c 6f 6f 70 20 63 6f 75 .. (loop cou
4210: 6e 74 20 73 65 72 76 65 72 2d 73 74 61 74 65 20 nt server-state
4220: 28 2b 20 62 61 64 2d 73 79 6e 63 2d 63 6f 75 6e (+ bad-sync-coun
4230: 74 20 31 29 29 29 29 29 0a 09 20 20 20 20 20 28 t 1))))).. (
4240: 28 65 78 6e 29 0a 09 20 20 20 20 20 20 28 64 65 (exn).. (de
4250: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
4260: 4f 52 3a 20 65 72 72 6f 72 20 66 72 6f 6d 20 73 OR: error from s
4270: 79 6e 63 20 63 6f 64 65 20 6f 74 68 65 72 20 74 ync code other t
4280: 68 61 6e 20 27 73 79 6e 63 2d 66 61 69 6c 65 64 han 'sync-failed
4290: 2e 20 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 . Attempting to
42a0: 67 72 61 63 65 66 75 6c 6c 79 20 73 68 75 74 64 gracefully shutd
42b0: 6f 77 6e 20 74 68 65 20 73 65 72 76 65 72 22 29 own the server")
42c0: 0a 09 20 20 20 20 20 20 28 74 61 73 6b 73 3a 73 .. (tasks:s
42d0: 65 72 76 65 72 2d 64 65 6c 65 74 65 2d 72 65 63 erver-delete-rec
42e0: 6f 72 64 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 ord (db:delay-if
42f0: 2d 62 75 73 79 20 74 64 62 64 61 74 29 20 73 65 -busy tdbdat) se
4300: 72 76 65 72 2d 69 64 20 22 20 68 74 74 70 2d 74 rver-id " http-t
4310: 72 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 ransport:keep-ru
4320: 6e 6e 69 6e 67 20 63 72 61 73 68 65 64 22 29 0a nning crashed").
4330: 09 20 20 20 20 20 20 28 65 78 69 74 29 29 29 0a . (exit))).
4340: 09 20 20 20 20 28 73 65 74 21 20 73 79 6e 63 2d . (set! sync-
4350: 74 69 6d 65 20 20 28 2d 20 28 63 75 72 72 65 6e time (- (curren
4360: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 t-milliseconds)
4370: 73 74 61 72 74 2d 74 69 6d 65 29 29 0a 09 20 20 start-time))..
4380: 20 20 28 73 65 74 21 20 72 65 6d 2d 74 69 6d 65 (set! rem-time
4390: 20 28 71 75 6f 74 69 65 6e 74 20 28 2d 20 34 30 (quotient (- 40
43a0: 30 30 20 73 79 6e 63 2d 74 69 6d 65 29 20 31 30 00 sync-time) 10
43b0: 30 30 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 00)).. (debug
43c0: 3a 70 72 69 6e 74 20 34 20 22 53 59 4e 43 3a 20 :print 4 "SYNC:
43d0: 74 69 6d 65 3d 20 22 20 73 79 6e 63 2d 74 69 6d time= " sync-tim
43e0: 65 20 22 2c 20 72 65 6d 2d 74 69 6d 65 3d 22 20 e ", rem-time="
43f0: 72 65 6d 2d 74 69 6d 65 29 0a 09 20 20 20 20 0a rem-time).. .
4400: 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 3c . (if (and (<
4410: 3d 20 72 65 6d 2d 74 69 6d 65 20 34 29 0a 09 09 = rem-time 4)...
4420: 20 20 20 20 20 28 3e 20 72 65 6d 2d 74 69 6d 65 (> rem-time
4430: 20 30 29 29 0a 09 09 28 74 68 72 65 61 64 2d 73 0))...(thread-s
4440: 6c 65 65 70 21 20 72 65 6d 2d 74 69 6d 65 29 0a leep! rem-time).
4450: 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 ..(thread-sleep!
4460: 20 34 29 29 29 20 3b 3b 20 66 61 6c 6c 62 61 63 4))) ;; fallbac
4470: 6b 20 66 6f 72 20 69 66 20 74 68 65 20 6d 61 74 k for if the mat
4480: 68 20 69 73 20 63 68 61 6e 67 65 64 20 2e 2e 2e h is changed ...
4490: 0a 0a 09 20 20 3b 3b 0a 09 20 20 3b 3b 20 6e 6f ... ;;.. ;; no
44a0: 20 2a 69 6e 6d 65 6d 64 62 2a 20 79 65 74 2c 20 *inmemdb* yet,
44b0: 73 65 74 20 72 75 6e 6e 69 6e 67 20 61 66 74 65 set running afte
44c0: 72 20 6f 75 72 20 66 69 72 73 74 20 70 61 73 73 r our first pass
44d0: 20 74 68 72 6f 75 67 68 20 61 6e 64 20 73 74 61 through and sta
44e0: 72 74 20 74 68 65 20 64 62 0a 09 20 20 3b 3b 0a rt the db.. ;;.
44f0: 09 20 20 28 69 66 20 28 65 71 3f 20 73 65 72 76 . (if (eq? serv
4500: 65 72 2d 73 74 61 74 65 20 27 61 76 61 69 6c 61 er-state 'availa
4510: 62 6c 65 29 0a 09 20 20 20 20 20 20 28 6c 65 74 ble).. (let
4520: 20 28 28 6e 65 77 2d 73 65 72 76 65 72 2d 69 64 ((new-server-id
4530: 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 61 (tasks:server-a
4540: 6d 2d 69 2d 74 68 65 2d 73 65 72 76 65 72 3f 20 m-i-the-server?
4550: 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 (db:delay-if-bus
4560: 79 20 74 64 62 64 61 74 29 20 72 75 6e 2d 69 64 y tdbdat) run-id
4570: 29 29 29 20 3b 3b 20 74 72 79 20 74 6f 20 65 6e ))) ;; try to en
4580: 73 75 72 65 20 6e 6f 20 64 6f 75 62 6c 65 20 72 sure no double r
4590: 65 67 69 73 74 65 72 69 6e 67 20 6f 66 20 73 65 egistering of se
45a0: 72 76 65 72 73 0a 09 09 28 69 66 20 28 65 71 75 rvers...(if (equ
45b0: 61 6c 3f 20 6e 65 77 2d 73 65 72 76 65 72 2d 69 al? new-server-i
45c0: 64 20 73 65 72 76 65 72 2d 69 64 29 0a 09 09 20 d server-id)...
45d0: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 (begin...
45e0: 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d (tasks:server-
45f0: 73 65 74 2d 73 74 61 74 65 21 20 28 64 62 3a 64 set-state! (db:d
4600: 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 62 elay-if-busy tdb
4610: 64 61 74 29 20 73 65 72 76 65 72 2d 69 64 20 22 dat) server-id "
4620: 64 62 70 72 65 70 22 29 0a 09 09 20 20 20 20 20 dbprep")...
4630: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
4640: 30 2e 35 29 20 3b 3b 20 67 69 76 65 20 73 6f 6d 0.5) ;; give som
4650: 65 20 6d 61 72 67 69 6e 20 66 6f 72 20 71 75 65 e margin for que
4660: 72 69 65 73 20 74 6f 20 63 6f 6d 70 6c 65 74 65 ries to complete
4670: 20 62 65 66 6f 72 65 20 73 77 69 74 63 68 69 6e before switchin
4680: 67 20 66 72 6f 6d 20 66 69 6c 65 20 62 61 73 65 g from file base
4690: 64 20 61 63 63 65 73 73 20 74 6f 20 73 65 72 76 d access to serv
46a0: 65 72 20 62 61 73 65 64 20 61 63 63 65 73 73 0a er based access.
46b0: 09 09 20 20 20 20 20 20 28 73 65 74 21 20 2a 69 .. (set! *i
46c0: 6e 6d 65 6d 64 62 2a 20 20 28 64 62 3a 73 65 74 nmemdb* (db:set
46d0: 75 70 20 72 75 6e 2d 69 64 29 29 0a 09 09 20 20 up run-id))...
46e0: 20 20 20 20 3b 3b 20 66 6f 72 63 65 20 69 6e 69 ;; force ini
46f0: 74 69 61 6c 69 7a 61 74 69 6f 6e 0a 09 09 20 20 tialization...
4700: 20 20 20 20 3b 3b 20 28 64 62 3a 67 65 74 2d 64 ;; (db:get-d
4710: 62 20 2a 69 6e 6d 65 6d 64 62 2a 20 23 74 29 0a b *inmemdb* #t).
4720: 09 09 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d .. (db:get-
4730: 64 62 20 2a 69 6e 6d 65 6d 64 62 2a 20 72 75 6e db *inmemdb* run
4740: 2d 69 64 29 0a 09 09 20 20 20 20 20 20 28 74 61 -id)... (ta
4750: 73 6b 73 3a 73 65 72 76 65 72 2d 73 65 74 2d 73 sks:server-set-s
4760: 74 61 74 65 21 20 28 64 62 3a 64 65 6c 61 79 2d tate! (db:delay-
4770: 69 66 2d 62 75 73 79 20 74 64 62 64 61 74 29 20 if-busy tdbdat)
4780: 73 65 72 76 65 72 2d 69 64 20 22 72 75 6e 6e 69 server-id "runni
4790: 6e 67 22 29 29 0a 09 09 20 20 20 20 28 62 65 67 ng"))... (beg
47a0: 69 6e 20 3b 3b 20 67 6f 74 74 61 20 65 78 69 74 in ;; gotta exit
47b0: 20 6e 69 63 65 6c 79 0a 09 09 20 20 20 20 20 20 nicely...
47c0: 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 73 65 (tasks:server-se
47d0: 74 2d 73 74 61 74 65 21 20 28 64 62 3a 64 65 6c t-state! (db:del
47e0: 61 79 2d 69 66 2d 62 75 73 79 20 74 64 62 64 61 ay-if-busy tdbda
47f0: 74 29 20 73 65 72 76 65 72 2d 69 64 20 22 63 6f t) server-id "co
4800: 6c 6c 69 73 69 6f 6e 22 29 0a 09 09 20 20 20 20 llision")...
4810: 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 (http-transpor
4820: 74 3a 73 65 72 76 65 72 2d 73 68 75 74 64 6f 77 t:server-shutdow
4830: 6e 20 73 65 72 76 65 72 2d 69 64 20 70 6f 72 74 n server-id port
4840: 29 29 29 29 29 29 0a 20 20 20 20 20 20 0a 20 20 )))))). .
4850: 20 20 20 20 28 69 66 20 28 3c 20 63 6f 75 6e 74 (if (< count
4860: 20 31 29 20 3b 3b 20 33 78 33 20 3d 20 39 20 73 1) ;; 3x3 = 9 s
4870: 65 63 73 20 61 70 72 6f 78 0a 09 20 20 28 6c 6f ecs aprox.. (lo
4880: 6f 70 20 28 2b 20 63 6f 75 6e 74 20 31 29 20 27 op (+ count 1) '
4890: 72 75 6e 6e 69 6e 67 20 62 61 64 2d 73 79 6e 63 running bad-sync
48a0: 2d 63 6f 75 6e 74 29 29 0a 20 20 20 20 20 20 0a -count)). .
48b0: 20 20 20 20 20 20 3b 3b 20 43 68 65 63 6b 20 74 ;; Check t
48c0: 68 61 74 20 69 66 61 63 65 20 61 6e 64 20 70 6f hat iface and po
48d0: 72 74 20 68 61 76 65 20 6e 6f 74 20 63 68 61 6e rt have not chan
48e0: 67 65 64 20 28 63 61 6e 20 68 61 70 70 65 6e 20 ged (can happen
48f0: 69 66 20 73 65 72 76 65 72 20 70 6f 72 74 20 63 if server port c
4900: 6f 6c 6c 69 64 65 73 29 0a 20 20 20 20 20 20 28 ollides). (
4910: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 mutex-lock! *hea
4920: 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 rtbeat-mutex*).
4930: 20 20 20 20 20 28 73 65 74 21 20 73 64 61 74 20 (set! sdat
4940: 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 29 0a 20 *server-info*).
4950: 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f (mutex-unlo
4960: 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
4970: 75 74 65 78 2a 29 0a 20 20 20 20 20 20 0a 20 20 utex*). .
4980: 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 (if (or (not
4990: 20 28 65 71 75 61 6c 3f 20 73 64 61 74 20 28 6c (equal? sdat (l
49a0: 69 73 74 20 69 66 61 63 65 20 70 6f 72 74 29 29 ist iface port))
49b0: 29 0a 09 20 20 20 20 20 20 28 6e 6f 74 20 73 65 ).. (not se
49c0: 72 76 65 72 2d 69 64 29 29 0a 09 20 20 28 62 65 rver-id)).. (be
49d0: 67 69 6e 20 0a 09 20 20 20 20 28 64 65 62 75 67 gin .. (debug
49e0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 69 :print-info 0 "i
49f0: 6e 74 65 72 66 61 63 65 20 63 68 61 6e 67 65 64 nterface changed
4a00: 2c 20 72 65 66 72 65 73 68 69 6e 67 20 69 66 61 , refreshing ifa
4a10: 63 65 20 61 6e 64 20 70 6f 72 74 20 69 6e 66 6f ce and port info
4a20: 22 29 0a 09 20 20 20 20 28 73 65 74 21 20 69 66 ").. (set! if
4a30: 61 63 65 20 28 63 61 72 20 73 64 61 74 29 29 0a ace (car sdat)).
4a40: 09 20 20 20 20 28 73 65 74 21 20 70 6f 72 74 20 . (set! port
4a50: 20 28 63 61 64 72 20 73 64 61 74 29 29 29 29 0a (cadr sdat)))).
4a60: 20 20 20 20 20 20 0a 20 20 20 20 20 20 3b 3b 20 . ;;
4a70: 54 72 61 6e 73 66 65 72 20 2a 6c 61 73 74 2d 64 Transfer *last-d
4a80: 62 2d 61 63 63 65 73 73 2a 20 74 6f 20 6c 61 73 b-access* to las
4a90: 74 2d 61 63 63 65 73 73 20 74 6f 20 75 73 65 20 t-access to use
4aa0: 69 6e 20 63 68 65 63 6b 69 6e 67 20 74 68 61 74 in checking that
4ab0: 20 77 65 20 61 72 65 20 73 74 69 6c 6c 20 61 6c we are still al
4ac0: 69 76 65 0a 20 20 20 20 20 20 28 6d 75 74 65 78 ive. (mutex
4ad0: 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 -lock! *heartbea
4ae0: 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 t-mutex*).
4af0: 28 73 65 74 21 20 6c 61 73 74 2d 61 63 63 65 73 (set! last-acces
4b00: 73 20 2a 6c 61 73 74 2d 64 62 2d 61 63 63 65 73 s *last-db-acces
4b10: 73 2a 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 s*). (mutex
4b20: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 -unlock! *heartb
4b30: 65 61 74 2d 6d 75 74 65 78 2a 29 0a 0a 20 20 20 eat-mutex*)..
4b40: 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 ;; (debug:pri
4b50: 6e 74 20 31 31 20 22 6c 61 73 74 2d 61 63 63 65 nt 11 "last-acce
4b60: 73 73 3d 22 20 6c 61 73 74 2d 61 63 63 65 73 73 ss=" last-access
4b70: 20 22 2c 20 73 65 72 76 65 72 2d 74 69 6d 65 6f ", server-timeo
4b80: 75 74 3d 22 20 73 65 72 76 65 72 2d 74 69 6d 65 ut=" server-time
4b90: 6f 75 74 29 0a 20 20 20 20 20 20 3b 3b 0a 20 20 out). ;;.
4ba0: 20 20 20 20 3b 3b 20 6e 6f 5f 74 72 61 66 66 69 ;; no_traffi
4bb0: 63 2c 20 6e 6f 20 72 75 6e 6e 69 6e 67 20 74 65 c, no running te
4bc0: 73 74 73 2c 20 69 66 20 73 65 72 76 65 72 20 30 sts, if server 0
4bd0: 2c 20 6e 6f 20 72 75 6e 6e 69 6e 67 20 73 65 72 , no running ser
4be0: 76 65 72 73 0a 20 20 20 20 20 20 3b 3b 0a 20 20 vers. ;;.
4bf0: 20 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 77 61 ;; (let ((wa
4c00: 69 74 2d 6f 6e 2d 72 75 6e 6e 69 6e 67 20 28 63 it-on-running (c
4c10: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
4c20: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 onfigdat* "serve
4c30: 72 22 20 62 22 77 61 69 74 2d 6f 6e 2d 72 75 6e r" b"wait-on-run
4c40: 6e 69 6e 67 22 29 29 29 20 3b 3b 20 77 61 69 74 ning"))) ;; wait
4c50: 20 6f 6e 20 72 75 6e 6e 69 6e 67 20 74 61 73 6b on running task
4c60: 73 20 28 69 66 20 6e 6f 74 20 74 72 75 65 20 74 s (if not true t
4c70: 68 65 6e 20 65 78 69 74 20 6f 6e 20 74 69 6d 65 hen exit on time
4c80: 20 6f 75 74 29 0a 20 20 20 20 20 20 3b 3b 0a 20 out). ;;.
4c90: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 68 72 73 (let* ((hrs
4ca0: 2d 73 69 6e 63 65 2d 73 74 61 72 74 20 20 28 2f -since-start (/
4cb0: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
4cc0: 6f 6e 64 73 29 20 73 65 72 76 65 72 2d 73 74 61 onds) server-sta
4cd0: 72 74 2d 74 69 6d 65 29 20 33 36 30 30 29 29 0a rt-time) 3600)).
4ce0: 09 20 20 20 20 20 28 61 64 6a 75 73 74 65 64 2d . (adjusted-
4cf0: 74 69 6d 65 6f 75 74 20 28 69 66 20 28 3e 20 68 timeout (if (> h
4d00: 72 73 2d 73 69 6e 63 65 2d 73 74 61 72 74 20 31 rs-since-start 1
4d10: 29 0a 09 09 09 09 20 20 20 28 2d 20 73 65 72 76 )..... (- serv
4d20: 65 72 2d 74 69 6d 65 6f 75 74 20 28 69 6e 65 78 er-timeout (inex
4d30: 61 63 74 2d 3e 65 78 61 63 74 20 28 72 6f 75 6e act->exact (roun
4d40: 64 20 28 2a 20 68 72 73 2d 73 69 6e 63 65 2d 73 d (* hrs-since-s
4d50: 74 61 72 74 20 36 30 29 29 29 29 20 20 3b 3b 20 tart 60)))) ;;
4d60: 73 75 62 74 72 61 63 74 20 36 30 20 73 65 63 6f subtract 60 seco
4d70: 6e 64 73 20 70 65 72 20 68 6f 75 72 0a 09 09 09 nds per hour....
4d80: 09 20 20 20 73 65 72 76 65 72 2d 74 69 6d 65 6f . server-timeo
4d90: 75 74 29 29 29 0a 09 28 69 66 20 28 63 6f 6d 6d ut)))..(if (comm
4da0: 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 on:low-noise-pri
4db0: 6e 74 20 31 32 30 20 22 73 65 72 76 65 72 20 74 nt 120 "server t
4dc0: 69 6d 65 6f 75 74 22 29 0a 09 20 20 20 20 28 64 imeout").. (d
4dd0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
4de0: 30 20 22 41 64 6a 75 73 74 65 64 20 73 65 72 76 0 "Adjusted serv
4df0: 65 72 20 74 69 6d 65 6f 75 74 3a 20 22 20 61 64 er timeout: " ad
4e00: 6a 75 73 74 65 64 2d 74 69 6d 65 6f 75 74 29 29 justed-timeout))
4e10: 0a 09 28 69 66 20 28 61 6e 64 20 2a 73 65 72 76 ..(if (and *serv
4e20: 65 72 2d 72 75 6e 2a 0a 09 09 20 28 3e 20 28 2b er-run*... (> (+
4e30: 20 6c 61 73 74 2d 61 63 63 65 73 73 20 73 65 72 last-access ser
4e40: 76 65 72 2d 74 69 6d 65 6f 75 74 29 0a 09 09 20 ver-timeout)...
4e50: 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (current-seco
4e60: 6e 64 73 29 29 29 0a 09 20 20 20 20 28 62 65 67 nds))).. (beg
4e70: 69 6e 0a 09 20 20 20 20 20 20 28 69 66 20 28 63 in.. (if (c
4e80: 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d ommon:low-noise-
4e90: 70 72 69 6e 74 20 31 32 30 20 22 73 65 72 76 65 print 120 "serve
4ea0: 72 20 63 6f 6e 74 69 6e 75 69 6e 67 22 29 0a 09 r continuing")..
4eb0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
4ec0: 69 6e 66 6f 20 30 20 22 53 65 72 76 65 72 20 63 info 0 "Server c
4ed0: 6f 6e 74 69 6e 75 69 6e 67 2c 20 73 65 63 6f 6e ontinuing, secon
4ee0: 64 73 20 73 69 6e 63 65 20 6c 61 73 74 20 64 62 ds since last db
4ef0: 20 61 63 63 65 73 73 3a 20 22 20 28 2d 20 28 63 access: " (- (c
4f00: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
4f10: 6c 61 73 74 2d 61 63 63 65 73 73 29 29 29 0a 09 last-access)))..
4f20: 20 20 20 20 20 20 3b 3b 0a 09 20 20 20 20 20 20 ;;..
4f30: 3b 3b 20 43 6f 6e 73 69 64 65 72 20 69 6d 70 6c ;; Consider impl
4f40: 65 6d 65 6e 74 69 6e 67 20 73 6f 6d 65 20 73 6d ementing some sm
4f50: 61 72 74 73 20 68 65 72 65 20 74 6f 20 72 65 2d arts here to re-
4f60: 69 6e 73 65 72 74 20 74 68 65 20 72 65 63 6f 72 insert the recor
4f70: 64 20 6f 72 20 6b 69 6c 6c 20 73 65 6c 66 20 69 d or kill self i
4f80: 73 0a 09 20 20 20 20 20 20 3b 3b 20 74 68 65 20 s.. ;; the
4f90: 64 62 20 69 6e 64 69 63 61 74 65 73 20 73 6f 0a db indicates so.
4fa0: 09 20 20 20 20 20 20 3b 3b 0a 09 20 20 20 20 20 . ;;..
4fb0: 20 3b 3b 20 28 69 66 20 28 74 61 73 6b 73 3a 73 ;; (if (tasks:s
4fc0: 65 72 76 65 72 2d 61 6d 2d 69 2d 74 68 65 2d 73 erver-am-i-the-s
4fd0: 65 72 76 65 72 3f 20 74 64 62 20 72 75 6e 2d 69 erver? tdb run-i
4fe0: 64 29 0a 09 20 20 20 20 20 20 3b 3b 20 20 20 20 d).. ;;
4ff0: 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 73 (tasks:server-s
5000: 65 74 2d 73 74 61 74 65 21 20 74 64 62 20 73 65 et-state! tdb se
5010: 72 76 65 72 2d 69 64 20 22 72 75 6e 6e 69 6e 67 rver-id "running
5020: 22 29 29 0a 09 20 20 20 20 20 20 3b 3b 0a 09 20 ")).. ;;..
5030: 20 20 20 20 20 28 6c 6f 6f 70 20 30 20 73 65 72 (loop 0 ser
5040: 76 65 72 2d 73 74 61 74 65 20 62 61 64 2d 73 79 ver-state bad-sy
5050: 6e 63 2d 63 6f 75 6e 74 29 29 0a 09 20 20 20 20 nc-count))..
5060: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
5070: 73 65 72 76 65 72 2d 73 68 75 74 64 6f 77 6e 20 server-shutdown
5080: 73 65 72 76 65 72 2d 69 64 20 70 6f 72 74 29 29 server-id port))
5090: 29 29 29 29 0a 20 20 0a 28 64 65 66 69 6e 65 20 )))). .(define
50a0: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
50b0: 73 65 72 76 65 72 2d 73 68 75 74 64 6f 77 6e 20 server-shutdown
50c0: 73 65 72 76 65 72 2d 69 64 20 70 6f 72 74 29 0a server-id port).
50d0: 20 20 28 6c 65 74 20 28 28 74 64 62 64 61 74 20 (let ((tdbdat
50e0: 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 (tasks:open-db))
50f0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
5100: 6e 74 2d 69 6e 66 6f 20 30 20 22 53 74 61 72 74 nt-info 0 "Start
5110: 69 6e 67 20 74 6f 20 73 68 75 74 64 6f 77 6e 20 ing to shutdown
5120: 74 68 65 20 73 65 72 76 65 72 2e 22 29 0a 20 20 the server.").
5130: 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 64 65 6c ;; need to del
5140: 65 74 65 20 6f 6e 6c 79 20 2a 6d 79 2a 20 73 65 ete only *my* se
5150: 72 76 65 72 20 65 6e 74 72 79 20 28 66 75 74 75 rver entry (futu
5160: 72 65 20 75 73 65 29 0a 20 20 20 20 28 73 65 74 re use). (set
5170: 21 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a ! *time-to-exit*
5180: 20 23 74 29 0a 20 20 20 20 28 69 66 20 2a 69 6e #t). (if *in
5190: 6d 65 6d 64 62 2a 20 28 64 62 3a 73 79 6e 63 2d memdb* (db:sync-
51a0: 74 6f 75 63 68 65 64 20 2a 69 6e 6d 65 6d 64 62 touched *inmemdb
51b0: 2a 20 2a 72 75 6e 2d 69 64 2a 20 66 6f 72 63 65 * *run-id* force
51c0: 2d 73 79 6e 63 3a 20 23 74 29 29 0a 20 20 20 20 -sync: #t)).
51d0: 3b 3b 0a 20 20 20 20 3b 3b 20 73 74 61 72 74 5f ;;. ;; start_
51e0: 73 68 75 74 64 6f 77 6e 0a 20 20 20 20 3b 3b 0a shutdown. ;;.
51f0: 20 20 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 (tasks:serve
5200: 72 2d 73 65 74 2d 73 74 61 74 65 21 20 28 64 62 r-set-state! (db
5210: 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 :delay-if-busy t
5220: 64 62 64 61 74 29 20 73 65 72 76 65 72 2d 69 64 dbdat) server-id
5230: 20 22 73 68 75 74 74 69 6e 67 2d 64 6f 77 6e 22 "shutting-down"
5240: 29 0a 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 65 ). (portlogge
5250: 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 r:open-run-close
5260: 20 70 6f 72 74 6c 6f 67 67 65 72 3a 73 65 74 2d portlogger:set-
5270: 70 6f 72 74 20 70 6f 72 74 20 22 72 65 6c 65 61 port port "relea
5280: 73 65 64 22 29 0a 20 20 20 20 28 74 68 72 65 61 sed"). (threa
5290: 64 2d 73 6c 65 65 70 21 20 35 29 0a 20 20 20 20 d-sleep! 5).
52a0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
52b0: 6f 20 30 20 22 4d 61 78 20 63 61 63 68 65 64 20 o 0 "Max cached
52c0: 71 75 65 72 69 65 73 20 77 61 73 20 20 20 20 22 queries was "
52d0: 20 2a 6d 61 78 2d 63 61 63 68 65 2d 73 69 7a 65 *max-cache-size
52e0: 2a 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 *). (debug:pr
52f0: 69 6e 74 2d 69 6e 66 6f 20 30 20 22 4e 75 6d 62 int-info 0 "Numb
5300: 65 72 20 6f 66 20 63 61 63 68 65 64 20 77 72 69 er of cached wri
5310: 74 65 73 20 20 20 22 20 2a 6e 75 6d 62 65 72 2d tes " *number-
5320: 6f 66 2d 77 72 69 74 65 73 2a 29 0a 20 20 20 20 of-writes*).
5330: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
5340: 6f 20 30 20 22 41 76 65 72 61 67 65 20 63 61 63 o 0 "Average cac
5350: 68 65 64 20 77 72 69 74 65 20 74 69 6d 65 20 22 hed write time "
5360: 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 65 71 ... (if (eq
5370: 3f 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 ? *number-of-wri
5380: 74 65 73 2a 20 30 29 0a 09 09 09 20 20 22 6e 2f tes* 0).... "n/
5390: 61 20 28 6e 6f 20 77 72 69 74 65 73 29 22 0a 09 a (no writes)"..
53a0: 09 09 20 20 28 2f 20 2a 77 72 69 74 65 73 2d 74 .. (/ *writes-t
53b0: 6f 74 61 6c 2d 64 65 6c 61 79 2a 0a 09 09 09 20 otal-delay*....
53c0: 20 20 20 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 *number-of-w
53d0: 72 69 74 65 73 2a 29 29 0a 09 09 20 20 20 20 20 rites*))...
53e0: 20 22 20 6d 73 22 29 0a 20 20 20 20 28 64 65 62 " ms"). (deb
53f0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
5400: 22 4e 75 6d 62 65 72 20 6e 6f 6e 2d 63 61 63 68 "Number non-cach
5410: 65 64 20 71 75 65 72 69 65 73 20 22 20 20 2a 6e ed queries " *n
5420: 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d umber-non-write-
5430: 71 75 65 72 69 65 73 2a 29 0a 20 20 20 20 28 64 queries*). (d
5440: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
5450: 30 20 22 41 76 65 72 61 67 65 20 6e 6f 6e 2d 63 0 "Average non-c
5460: 61 63 68 65 64 20 74 69 6d 65 20 20 20 22 0a 09 ached time "..
5470: 09 20 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 . (if (eq?
5480: 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 *number-non-writ
5490: 65 2d 71 75 65 72 69 65 73 2a 20 30 29 0a 09 09 e-queries* 0)...
54a0: 09 20 20 22 6e 2f 61 20 28 6e 6f 20 71 75 65 72 . "n/a (no quer
54b0: 69 65 73 29 22 0a 09 09 09 20 20 28 2f 20 2a 74 ies)".... (/ *t
54c0: 6f 74 61 6c 2d 6e 6f 6e 2d 77 72 69 74 65 2d 64 otal-non-write-d
54d0: 65 6c 61 79 2a 20 0a 09 09 09 20 20 20 20 20 2a elay* .... *
54e0: 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 number-non-write
54f0: 2d 71 75 65 72 69 65 73 2a 29 29 0a 09 09 20 20 -queries*))...
5500: 20 20 20 20 22 20 6d 73 22 29 0a 20 20 20 20 28 " ms"). (
5510: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
5520: 20 30 20 22 53 65 72 76 65 72 20 73 68 75 74 64 0 "Server shutd
5530: 6f 77 6e 20 63 6f 6d 70 6c 65 74 65 2e 20 45 78 own complete. Ex
5540: 69 74 69 6e 67 22 29 0a 20 20 20 20 28 74 61 73 iting"). (tas
5550: 6b 73 3a 73 65 72 76 65 72 2d 64 65 6c 65 74 65 ks:server-delete
5560: 2d 72 65 63 6f 72 64 20 28 64 62 3a 64 65 6c 61 -record (db:dela
5570: 79 2d 69 66 2d 62 75 73 79 20 74 64 62 64 61 74 y-if-busy tdbdat
5580: 29 20 73 65 72 76 65 72 2d 69 64 20 22 20 68 74 ) server-id " ht
5590: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6b 65 65 tp-transport:kee
55a0: 70 2d 72 75 6e 6e 69 6e 67 20 63 6f 6d 70 6c 65 p-running comple
55b0: 74 65 22 29 0a 20 20 20 20 28 65 78 69 74 29 29 te"). (exit))
55c0: 29 0a 0a 3b 3b 20 61 6c 6c 20 72 6f 75 74 65 73 )..;; all routes
55d0: 20 74 68 6f 75 67 68 20 68 65 72 65 20 65 6e 64 though here end
55e0: 20 69 6e 20 65 78 69 74 20 2e 2e 2e 0a 3b 3b 0a in exit ....;;.
55f0: 3b 3b 20 73 74 61 72 74 5f 73 65 72 76 65 72 3f ;; start_server?
5600: 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 .;;.(define (ht
5610: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6c 61 75 tp-transport:lau
5620: 6e 63 68 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c nch run-id). (l
5630: 65 74 2a 20 28 28 74 64 62 64 61 74 20 28 74 61 et* ((tdbdat (ta
5640: 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 sks:open-db))).
5650: 20 20 20 28 73 65 74 21 20 2a 72 75 6e 2d 69 64 (set! *run-id
5660: 2a 20 20 20 72 75 6e 2d 69 64 29 0a 20 20 20 20 * run-id).
5670: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
5680: 67 20 22 2d 64 61 65 6d 6f 6e 69 7a 65 22 29 0a g "-daemonize").
5690: 09 28 62 65 67 69 6e 0a 09 20 20 28 64 61 65 6d .(begin.. (daem
56a0: 6f 6e 3a 69 7a 65 29 0a 09 20 20 28 69 66 20 2a on:ize).. (if *
56b0: 61 6c 74 2d 6c 6f 67 2d 66 69 6c 65 2a 20 3b 3b alt-log-file* ;;
56c0: 20 77 65 20 73 68 6f 75 6c 64 20 72 65 2d 63 6f we should re-co
56d0: 6e 6e 65 63 74 20 74 6f 20 74 68 69 73 20 70 6f nnect to this po
56e0: 72 74 2c 20 49 20 74 68 69 6e 6b 20 64 61 65 6d rt, I think daem
56f0: 6f 6e 3a 69 7a 65 20 64 69 73 72 75 70 74 73 20 on:ize disrupts
5700: 69 74 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e it.. (begin
5710: 0a 09 09 28 63 75 72 72 65 6e 74 2d 65 72 72 6f ...(current-erro
5720: 72 2d 70 6f 72 74 20 2a 61 6c 74 2d 6c 6f 67 2d r-port *alt-log-
5730: 66 69 6c 65 2a 29 0a 09 09 28 63 75 72 72 65 6e file*)...(curren
5740: 74 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 2a 61 t-output-port *a
5750: 6c 74 2d 6c 6f 67 2d 66 69 6c 65 2a 29 29 29 29 lt-log-file*))))
5760: 29 0a 20 20 20 20 28 69 66 20 28 73 65 72 76 65 ). (if (serve
5770: 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 r:check-if-runni
5780: 6e 67 20 72 75 6e 2d 69 64 29 0a 09 28 62 65 67 ng run-id)..(beg
5790: 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 in.. (debug:pri
57a0: 6e 74 20 30 20 22 49 4e 46 4f 3a 20 53 65 72 76 nt 0 "INFO: Serv
57b0: 65 72 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 20 er for run-id "
57c0: 72 75 6e 2d 69 64 20 22 20 61 6c 72 65 61 64 79 run-id " already
57d0: 20 72 75 6e 6e 69 6e 67 22 29 0a 09 20 20 28 65 running").. (e
57e0: 78 69 74 20 30 29 29 29 0a 20 20 20 20 28 6c 65 xit 0))). (le
57f0: 74 20 6c 6f 6f 70 20 28 28 73 65 72 76 65 72 2d t loop ((server-
5800: 69 64 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 id (tasks:server
5810: 2d 6c 6f 63 6b 2d 73 6c 6f 74 20 28 64 62 3a 64 -lock-slot (db:d
5820: 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 62 elay-if-busy tdb
5830: 64 61 74 29 20 72 75 6e 2d 69 64 29 29 0a 09 20 dat) run-id))..
5840: 20 20 20 20 20 20 28 72 65 6d 74 72 69 65 73 20 (remtries
5850: 20 34 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 4)). (if (
5860: 6e 6f 74 20 73 65 72 76 65 72 2d 69 64 29 0a 09 not server-id)..
5870: 20 20 28 69 66 20 28 3e 20 72 65 6d 74 72 69 65 (if (> remtrie
5880: 73 20 30 29 0a 09 20 20 20 20 20 20 28 62 65 67 s 0).. (beg
5890: 69 6e 0a 09 09 28 74 68 72 65 61 64 2d 73 6c 65 in...(thread-sle
58a0: 65 70 21 20 32 29 0a 09 09 28 6c 6f 6f 70 20 28 ep! 2)...(loop (
58b0: 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 6c 6f 63 tasks:server-loc
58c0: 6b 2d 73 6c 6f 74 20 28 64 62 3a 64 65 6c 61 79 k-slot (db:delay
58d0: 2d 69 66 2d 62 75 73 79 20 74 64 62 64 61 74 29 -if-busy tdbdat)
58e0: 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 20 20 20 run-id)...
58f0: 20 28 2d 20 72 65 6d 74 72 69 65 73 20 31 29 29 (- remtries 1))
5900: 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ).. (begin.
5910: 09 09 3b 3b 20 73 69 6e 63 65 20 77 65 20 64 69 ..;; since we di
5920: 64 6e 27 74 20 67 65 74 20 74 68 65 20 73 65 72 dn't get the ser
5930: 76 65 72 20 6c 6f 63 6b 20 77 65 20 61 72 65 20 ver lock we are
5940: 67 6f 69 6e 67 20 74 6f 20 63 6c 65 61 6e 20 75 going to clean u
5950: 70 20 61 6e 64 20 62 61 69 6c 20 6f 75 74 0a 09 p and bail out..
5960: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e .(debug:print-in
5970: 66 6f 20 32 20 22 49 4e 46 4f 3a 20 73 65 72 76 fo 2 "INFO: serv
5980: 65 72 20 70 69 64 3d 22 20 28 63 75 72 72 65 6e er pid=" (curren
5990: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 22 2c t-process-id) ",
59a0: 20 68 6f 73 74 6e 61 6d 65 3d 22 20 28 67 65 74 hostname=" (get
59b0: 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 20 6e 6f -host-name) " no
59c0: 74 20 73 74 61 72 74 69 6e 67 20 64 75 65 20 74 t starting due t
59d0: 6f 20 6f 74 68 65 72 20 63 61 6e 64 69 64 61 74 o other candidat
59e0: 65 73 20 61 68 65 61 64 20 69 6e 20 73 74 61 72 es ahead in star
59f0: 74 20 71 75 65 75 65 22 29 0a 09 09 28 74 61 73 t queue")...(tas
5a00: 6b 73 3a 73 65 72 76 65 72 2d 64 65 6c 65 74 65 ks:server-delete
5a10: 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d 74 68 69 -records-for-thi
5a20: 73 2d 70 69 64 20 28 64 62 3a 64 65 6c 61 79 2d s-pid (db:delay-
5a30: 69 66 2d 62 75 73 79 20 74 64 62 64 61 74 29 20 if-busy tdbdat)
5a40: 22 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 " http-transport
5a50: 3a 6c 61 75 6e 63 68 22 29 0a 09 09 29 29 0a 09 :launch")...))..
5a60: 20 20 28 6c 65 74 2a 20 28 28 74 68 32 20 28 6d (let* ((th2 (m
5a70: 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 ake-thread (lamb
5a80: 64 61 20 28 29 0a 09 09 09 09 20 20 20 20 20 28 da ()..... (
5a90: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
5aa0: 20 30 20 22 53 65 72 76 65 72 20 72 75 6e 20 74 0 "Server run t
5ab0: 68 72 65 61 64 20 73 74 61 72 74 65 64 22 29 0a hread started").
5ac0: 09 09 09 09 20 20 20 20 20 28 68 74 74 70 2d 74 .... (http-t
5ad0: 72 61 6e 73 70 6f 72 74 3a 72 75 6e 20 0a 09 09 ransport:run ...
5ae0: 09 09 20 20 20 20 20 20 28 69 66 20 28 61 72 67 .. (if (arg
5af0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 s:get-arg "-serv
5b00: 65 72 22 29 0a 09 09 09 09 09 20 20 28 61 72 67 er")...... (arg
5b10: 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 s:get-arg "-serv
5b20: 65 72 22 29 0a 09 09 09 09 09 20 20 22 2d 22 29 er")...... "-")
5b30: 0a 09 09 09 09 20 20 20 20 20 20 72 75 6e 2d 69 ..... run-i
5b40: 64 0a 09 09 09 09 20 20 20 20 20 20 73 65 72 76 d..... serv
5b50: 65 72 2d 69 64 29 29 20 22 53 65 72 76 65 72 20 er-id)) "Server
5b60: 72 75 6e 22 29 29 0a 09 09 20 28 74 68 33 20 28 run"))... (th3 (
5b70: 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d make-thread (lam
5b80: 62 64 61 20 28 29 0a 09 09 09 09 20 20 20 20 20 bda ().....
5b90: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
5ba0: 6f 20 30 20 22 53 65 72 76 65 72 20 6d 6f 6e 69 o 0 "Server moni
5bb0: 74 6f 72 20 74 68 72 65 61 64 20 73 74 61 72 74 tor thread start
5bc0: 65 64 22 29 0a 09 09 09 09 20 20 20 20 20 28 68 ed")..... (h
5bd0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6b 65 ttp-transport:ke
5be0: 65 70 2d 72 75 6e 6e 69 6e 67 20 73 65 72 76 65 ep-running serve
5bf0: 72 2d 69 64 20 72 75 6e 2d 69 64 29 29 0a 09 09 r-id run-id))...
5c00: 09 09 20 20 20 22 4b 65 65 70 20 72 75 6e 6e 69 .. "Keep runni
5c10: 6e 67 22 29 29 29 0a 09 20 20 20 20 28 74 68 72 ng"))).. (thr
5c20: 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a ead-start! th2).
5c30: 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 . (thread-sle
5c40: 65 70 21 20 30 2e 32 35 29 20 3b 3b 20 67 69 76 ep! 0.25) ;; giv
5c50: 65 20 74 68 65 20 73 65 72 76 65 72 20 74 69 6d e the server tim
5c60: 65 20 74 6f 20 73 65 74 74 6c 65 20 62 65 66 6f e to settle befo
5c70: 72 65 20 73 74 61 72 74 69 6e 67 20 74 68 65 20 re starting the
5c80: 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 6d 6f 6e keep-running mon
5c90: 69 74 6f 72 2e 0a 09 20 20 20 20 28 74 68 72 65 itor... (thre
5ca0: 61 64 2d 73 74 61 72 74 21 20 74 68 33 29 0a 09 ad-start! th3)..
5cb0: 20 20 20 20 28 73 65 74 21 20 2a 64 69 64 73 6f (set! *didso
5cc0: 6d 65 74 68 69 6e 67 2a 20 23 74 29 0a 09 20 20 mething* #t)..
5cd0: 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 (thread-join!
5ce0: 74 68 32 29 0a 09 20 20 20 20 28 65 78 69 74 29 th2).. (exit)
5cf0: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
5d00: 68 74 74 70 3a 70 69 6e 67 20 72 75 6e 2d 69 64 http:ping run-id
5d10: 20 68 6f 73 74 2d 70 6f 72 74 29 0a 20 20 28 6c host-port). (l
5d20: 65 74 2a 20 28 28 73 65 72 76 65 72 2d 64 61 74 et* ((server-dat
5d30: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
5d40: 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 :client-connect
5d50: 28 63 61 72 20 68 6f 73 74 2d 70 6f 72 74 29 28 (car host-port)(
5d60: 63 61 64 72 20 68 6f 73 74 2d 70 6f 72 74 29 29 cadr host-port))
5d70: 29 0a 09 20 28 6c 6f 67 69 6e 2d 72 65 73 20 20 ).. (login-res
5d80: 28 72 6d 74 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 (rmt:login-no-au
5d90: 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 to-client-setup
5da0: 73 65 72 76 65 72 2d 64 61 74 20 72 75 6e 2d 69 server-dat run-i
5db0: 64 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e d))). (if (an
5dc0: 64 20 28 6c 69 73 74 3f 20 6c 6f 67 69 6e 2d 72 d (list? login-r
5dd0: 65 73 29 0a 09 20 20 20 20 20 28 63 61 72 20 6c es).. (car l
5de0: 6f 67 69 6e 2d 72 65 73 29 29 0a 09 28 62 65 67 ogin-res))..(beg
5df0: 69 6e 0a 09 20 20 28 70 72 69 6e 74 20 22 4c 4f in.. (print "LO
5e00: 47 49 4e 5f 4f 4b 22 29 0a 09 20 20 28 65 78 69 GIN_OK").. (exi
5e10: 74 20 30 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 t 0))..(begin..
5e20: 20 28 70 72 69 6e 74 20 22 4c 4f 47 49 4e 5f 46 (print "LOGIN_F
5e30: 41 49 4c 45 44 22 29 0a 09 20 20 28 65 78 69 74 AILED").. (exit
5e40: 20 31 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 1)))))..(define
5e50: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
5e60: 3a 73 65 72 76 65 72 2d 73 69 67 6e 61 6c 2d 68 :server-signal-h
5e70: 61 6e 64 6c 65 72 20 73 69 67 6e 75 6d 29 0a 20 andler signum).
5e80: 20 28 73 69 67 6e 61 6c 2d 6d 61 73 6b 21 20 73 (signal-mask! s
5e90: 69 67 6e 75 6d 29 0a 20 20 28 68 61 6e 64 6c 65 ignum). (handle
5ea0: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 -exceptions. e
5eb0: 78 6e 0a 20 20 20 28 64 65 62 75 67 3a 70 72 69 xn. (debug:pri
5ec0: 6e 74 20 22 20 2e 2e 2e 20 65 78 69 74 69 6e 67 nt " ... exiting
5ed0: 20 2e 2e 2e 22 29 0a 20 20 20 28 6c 65 74 20 28 ..."). (let (
5ee0: 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 (th1 (make-threa
5ef0: 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 d (lambda ()....
5f00: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
5f10: 65 70 21 20 31 29 29 0a 09 09 09 20 20 20 22 65 ep! 1)).... "e
5f20: 61 74 20 72 65 73 70 6f 6e 73 65 22 29 29 0a 09 at response"))..
5f30: 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 (th2 (make-thre
5f40: 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 ad (lambda ()...
5f50: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
5f60: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 52 65 63 nt 0 "ERROR: Rec
5f70: 65 69 76 65 64 20 5e 43 2c 20 61 74 74 65 6d 70 eived ^C, attemp
5f80: 74 69 6e 67 20 63 6c 65 61 6e 20 65 78 69 74 2e ting clean exit.
5f90: 20 50 6c 65 61 73 65 20 62 65 20 70 61 74 69 65 Please be patie
5fa0: 6e 74 20 61 6e 64 20 77 61 69 74 20 61 20 66 65 nt and wait a fe
5fb0: 77 20 73 65 63 6f 6e 64 73 20 62 65 66 6f 72 65 w seconds before
5fc0: 20 68 69 74 74 69 6e 67 20 5e 43 20 61 67 61 69 hitting ^C agai
5fd0: 6e 2e 22 29 0a 09 09 09 20 20 20 20 20 28 74 68 n.").... (th
5fe0: 72 65 61 64 2d 73 6c 65 65 70 21 20 33 29 20 3b read-sleep! 3) ;
5ff0: 3b 20 67 69 76 65 20 74 68 65 20 66 6c 75 73 68 ; give the flush
6000: 20 74 68 72 65 65 20 73 65 63 6f 6e 64 73 20 74 three seconds t
6010: 6f 20 64 6f 20 69 74 27 73 20 73 74 75 66 66 0a o do it's stuff.
6020: 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ... (debug:p
6030: 72 69 6e 74 20 30 20 22 20 20 20 20 20 20 20 44 rint 0 " D
6040: 6f 6e 65 2e 22 29 0a 09 09 09 20 20 20 20 20 28 one.").... (
6050: 65 78 69 74 20 34 29 29 0a 09 09 09 20 20 20 22 exit 4)).... "
6060: 65 78 69 74 20 6f 6e 20 5e 43 20 74 69 6d 65 72 exit on ^C timer
6070: 22 29 29 29 0a 20 20 20 20 20 28 74 68 72 65 61 "))). (threa
6080: 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a 20 20 d-start! th2).
6090: 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 (thread-start
60a0: 21 20 74 68 31 29 0a 20 20 20 20 20 28 74 68 72 ! th1). (thr
60b0: 65 61 64 2d 6a 6f 69 6e 21 20 74 68 32 29 29 29 ead-join! th2)))
60c0: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
60d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 77 ===========.;; w
6110: 65 62 20 70 61 67 65 73 0a 3b 3b 3d 3d 3d 3d 3d eb pages.;;=====
6120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6160: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 =..(define (http
6170: 2d 74 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e 2d -transport:main-
6180: 70 61 67 65 29 0a 20 20 28 6c 65 74 20 28 28 6c page). (let ((l
6190: 69 6e 6b 70 61 74 68 20 28 72 6f 6f 74 2d 70 61 inkpath (root-pa
61a0: 74 68 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 th))). (conc
61b0: 22 3c 68 65 61 64 3e 3c 68 31 3e 22 20 28 70 61 "<head><h1>" (pa
61c0: 74 68 6e 61 6d 65 2d 73 74 72 69 70 2d 64 69 72 thname-strip-dir
61d0: 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a ectory *toppath*
61e0: 29 20 22 3c 2f 68 31 3e 3c 2f 68 65 61 64 3e 22 ) "</h1></head>"
61f0: 0a 09 20 20 22 3c 62 6f 64 79 3e 22 0a 09 20 20 .. "<body>"..
6200: 22 52 75 6e 20 61 72 65 61 3a 20 22 20 2a 74 6f "Run area: " *to
6210: 70 70 61 74 68 2a 0a 09 20 20 22 3c 68 32 3e 53 ppath*.. "<h2>S
6220: 65 72 76 65 72 20 53 74 61 74 73 3c 2f 68 32 3e erver Stats</h2>
6230: 22 0a 09 20 20 28 68 74 74 70 2d 74 72 61 6e 73 ".. (http-trans
6240: 70 6f 72 74 3a 73 74 61 74 73 2d 74 61 62 6c 65 port:stats-table
6250: 29 20 0a 09 20 20 22 3c 68 72 3e 22 0a 09 20 20 ) .. "<hr>"..
6260: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
6270: 72 75 6e 73 20 6c 69 6e 6b 70 61 74 68 29 0a 09 runs linkpath)..
6280: 20 20 22 3c 68 72 3e 22 0a 09 20 20 28 68 74 74 "<hr>".. (htt
6290: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 2d p-transport:run-
62a0: 73 74 61 74 73 29 0a 09 20 20 22 3c 2f 62 6f 64 stats).. "</bod
62b0: 79 3e 22 0a 09 20 20 29 29 29 0a 0a 28 64 65 66 y>".. )))..(def
62c0: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
62d0: 6f 72 74 3a 73 74 61 74 73 2d 74 61 62 6c 65 29 ort:stats-table)
62e0: 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 . (mutex-lock!
62f0: 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 *heartbeat-mutex
6300: 2a 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 *). (let ((res
6310: 0a 09 20 28 63 6f 6e 63 20 22 3c 74 61 62 6c 65 .. (conc "<table
6320: 3e 22 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e >".. "<tr>
6330: 3c 74 64 3e 4d 61 78 20 63 61 63 68 65 64 20 71 <td>Max cached q
6340: 75 65 72 69 65 73 3c 2f 74 64 3e 20 20 20 20 20 ueries</td>
6350: 20 20 20 3c 74 64 3e 22 20 2a 6d 61 78 2d 63 61 <td>" *max-ca
6360: 63 68 65 2d 73 69 7a 65 2a 20 22 3c 2f 74 64 3e che-size* "</td>
6370: 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 </tr>".. "
6380: 3c 74 72 3e 3c 74 64 3e 4e 75 6d 62 65 72 20 6f <tr><td>Number o
6390: 66 20 63 61 63 68 65 64 20 77 72 69 74 65 73 3c f cached writes<
63a0: 2f 74 64 3e 20 20 20 3c 74 64 3e 22 20 2a 6e 75 /td> <td>" *nu
63b0: 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a 20 mber-of-writes*
63c0: 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 "</td></tr>"..
63d0: 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 41 76 "<tr><td>Av
63e0: 65 72 61 67 65 20 63 61 63 68 65 64 20 77 72 69 erage cached wri
63f0: 74 65 20 74 69 6d 65 3c 2f 74 64 3e 20 3c 74 64 te time</td> <td
6400: 3e 22 20 28 69 66 20 28 65 71 3f 20 2a 6e 75 6d >" (if (eq? *num
6410: 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a 20 30 ber-of-writes* 0
6420: 29 0a 09 09 09 09 09 09 09 09 20 22 6e 2f 61 20 )......... "n/a
6430: 28 6e 6f 20 77 72 69 74 65 73 29 22 0a 09 09 09 (no writes)"....
6440: 09 09 09 09 09 20 28 2f 20 2a 77 72 69 74 65 73 ..... (/ *writes
6450: 2d 74 6f 74 61 6c 2d 64 65 6c 61 79 2a 0a 09 09 -total-delay*...
6460: 09 09 09 09 09 09 20 20 20 20 2a 6e 75 6d 62 65 ...... *numbe
6470: 72 2d 6f 66 2d 77 72 69 74 65 73 2a 29 29 0a 09 r-of-writes*))..
6480: 20 20 20 20 20 20 20 22 20 6d 73 3c 2f 74 64 3e " ms</td>
6490: 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 </tr>".. "
64a0: 3c 74 72 3e 3c 74 64 3e 4e 75 6d 62 65 72 20 6e <tr><td>Number n
64b0: 6f 6e 2d 63 61 63 68 65 64 20 71 75 65 72 69 65 on-cached querie
64c0: 73 3c 2f 74 64 3e 20 3c 74 64 3e 22 20 20 2a 6e s</td> <td>" *n
64d0: 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d umber-non-write-
64e0: 71 75 65 72 69 65 73 2a 20 22 3c 2f 74 64 3e 3c queries* "</td><
64f0: 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c /tr>".. "<
6500: 74 72 3e 3c 74 64 3e 41 76 65 72 61 67 65 20 6e tr><td>Average n
6510: 6f 6e 2d 63 61 63 68 65 64 20 74 69 6d 65 3c 2f on-cached time</
6520: 74 64 3e 20 20 20 3c 74 64 3e 22 20 28 69 66 20 td> <td>" (if
6530: 28 65 71 3f 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e (eq? *number-non
6540: 2d 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a 20 -write-queries*
6550: 30 29 0a 09 09 09 09 09 09 09 09 20 22 6e 2f 61 0)......... "n/a
6560: 20 28 6e 6f 20 71 75 65 72 69 65 73 29 22 0a 09 (no queries)"..
6570: 09 09 09 09 09 09 09 20 28 2f 20 2a 74 6f 74 61 ....... (/ *tota
6580: 6c 2d 6e 6f 6e 2d 77 72 69 74 65 2d 64 65 6c 61 l-non-write-dela
6590: 79 2a 20 0a 09 09 09 09 09 09 09 09 20 20 20 20 y* .........
65a0: 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 *number-non-writ
65b0: 65 2d 71 75 65 72 69 65 73 2a 29 29 0a 09 20 20 e-queries*))..
65c0: 20 20 20 20 20 22 20 6d 73 3c 2f 74 64 3e 3c 2f " ms</td></
65d0: 74 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c 74 tr>".. "<t
65e0: 72 3e 3c 74 64 3e 4c 61 73 74 20 61 63 63 65 73 r><td>Last acces
65f0: 73 3c 2f 74 64 3e 3c 74 64 3e 22 20 20 20 20 20 s</td><td>"
6600: 20 20 20 20 20 20 20 20 20 28 73 65 63 6f 6e 64 (second
6610: 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 2a s->time-string *
6620: 6c 61 73 74 2d 64 62 2d 61 63 63 65 73 73 2a 29 last-db-access*)
6630: 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 "</td></tr>"..
6640: 20 20 20 20 20 20 22 3c 2f 74 61 62 6c 65 3e 22 "</table>"
6650: 29 29 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 ))). (mutex-u
6660: 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 nlock! *heartbea
6670: 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 72 65 t-mutex*). re
6680: 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 s))..(define (ht
6690: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e tp-transport:run
66a0: 73 20 6c 69 6e 6b 70 61 74 68 29 0a 20 20 28 63 s linkpath). (c
66b0: 6f 6e 63 20 22 3c 68 33 3e 52 75 6e 73 3c 2f 68 onc "<h3>Runs</h
66c0: 33 3e 22 0a 09 28 73 74 72 69 6e 67 2d 69 6e 74 3>"..(string-int
66d0: 65 72 73 70 65 72 73 65 0a 09 20 28 6c 65 74 20 ersperse.. (let
66e0: 28 28 66 69 6c 65 73 20 28 6d 61 70 20 70 61 74 ((files (map pat
66f0: 68 6e 61 6d 65 2d 73 74 72 69 70 2d 64 69 72 65 hname-strip-dire
6700: 63 74 6f 72 79 20 28 67 6c 6f 62 20 28 63 6f 6e ctory (glob (con
6710: 63 20 6c 69 6e 6b 70 61 74 68 20 22 2f 2a 22 29 c linkpath "/*")
6720: 29 29 29 29 0a 09 20 20 20 28 6d 61 70 20 28 6c )))).. (map (l
6730: 61 6d 62 64 61 20 28 70 29 0a 09 09 20 20 28 63 ambda (p)... (c
6740: 6f 6e 63 20 22 3c 61 20 68 72 65 66 3d 5c 22 22 onc "<a href=\""
6750: 20 70 20 22 5c 22 3e 22 20 70 20 22 3c 2f 61 3e p "\">" p "</a>
6760: 3c 62 72 3e 22 29 29 0a 09 09 66 69 6c 65 73 29 <br>"))...files)
6770: 29 0a 09 20 22 20 22 29 29 29 0a 0a 28 64 65 66 ).. " ")))..(def
6780: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
6790: 6f 72 74 3a 72 75 6e 2d 73 74 61 74 73 29 0a 20 ort:run-stats).
67a0: 20 28 6c 65 74 20 28 28 73 74 61 74 73 20 28 6f (let ((stats (o
67b0: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
67c0: 3a 67 65 74 2d 72 75 6e 6e 69 6e 67 2d 73 74 61 :get-running-sta
67d0: 74 73 20 23 66 29 29 29 0a 20 20 20 20 28 63 6f ts #f))). (co
67e0: 6e 63 20 22 3c 74 61 62 6c 65 3e 22 0a 09 20 20 nc "<table>"..
67f0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
6800: 72 73 65 0a 09 20 20 20 28 6d 61 70 20 28 6c 61 rse.. (map (la
6810: 6d 62 64 61 20 28 73 74 61 74 29 0a 09 09 20 20 mbda (stat)...
6820: 28 63 6f 6e 63 20 22 3c 74 72 3e 3c 74 64 3e 22 (conc "<tr><td>"
6830: 20 28 63 61 72 20 73 74 61 74 29 20 22 3c 2f 74 (car stat) "</t
6840: 64 3e 3c 74 64 3e 22 20 28 63 61 64 72 20 73 74 d><td>" (cadr st
6850: 61 74 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 at) "</td></tr>"
6860: 29 29 0a 09 09 73 74 61 74 73 29 0a 09 20 20 20 ))...stats)..
6870: 22 20 22 29 0a 09 20 20 22 3c 2f 74 61 62 6c 65 " ").. "</table
6880: 3e 22 29 29 29 0a >"))).