Artifact
235baaba81b4b1efe0876a4a28369a12911ec92e:
0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 32 2c 20 4d 61 74 74 68 65 77 06-2012, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 54 68 69 73 20 66 69 6c 65 20 69 73 20 70 61 This file is pa
0040: 72 74 20 6f 66 20 4d 65 67 61 74 65 73 74 2e 0a rt of Megatest..
0050: 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 ;; .;; Megat
0060: 65 73 74 20 69 73 20 66 72 65 65 20 73 6f 66 74 est is free soft
0070: 77 61 72 65 3a 20 79 6f 75 20 63 61 6e 20 72 65 ware: you can re
0080: 64 69 73 74 72 69 62 75 74 65 20 69 74 20 61 6e distribute it an
0090: 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b 3b 20 20 d/or modify.;;
00a0: 20 20 20 69 74 20 75 6e 64 65 72 20 74 68 65 20 it under the
00b0: 74 65 72 6d 73 20 6f 66 20 74 68 65 20 47 4e 55 terms of the GNU
00c0: 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 General Public
00d0: 4c 69 63 65 6e 73 65 20 61 73 20 70 75 62 6c 69 License as publi
00e0: 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 20 20 74 shed by.;; t
00f0: 68 65 20 46 72 65 65 20 53 6f 66 74 77 61 72 65 he Free Software
0100: 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 65 69 74 Foundation, eit
0110: 68 65 72 20 76 65 72 73 69 6f 6e 20 33 20 6f 66 her version 3 of
0120: 20 74 68 65 20 4c 69 63 65 6e 73 65 2c 20 6f 72 the License, or
0130: 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 6f 75 72 .;; (at your
0140: 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 6c 61 74 option) any lat
0150: 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b 3b 20 0a er version..;; .
0160: 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 73 74 20 ;; Megatest
0170: 69 73 20 64 69 73 74 72 69 62 75 74 65 64 20 69 is distributed i
0180: 6e 20 74 68 65 20 68 6f 70 65 20 74 68 61 74 20 n the hope that
0190: 69 74 20 77 69 6c 6c 20 62 65 20 75 73 65 66 75 it will be usefu
01a0: 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 20 57 49 l,.;; but WI
01b0: 54 48 4f 55 54 20 41 4e 59 20 57 41 52 52 41 4e THOUT ANY WARRAN
01c0: 54 59 3b 20 77 69 74 68 6f 75 74 20 65 76 65 6e TY; without even
01d0: 20 74 68 65 20 69 6d 70 6c 69 65 64 20 77 61 72 the implied war
01e0: 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 20 20 20 ranty of.;;
01f0: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0200: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0210: 20 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 PARTICULAR PURP
0220: 4f 53 45 2e 20 20 53 65 65 20 74 68 65 0a 3b 3b OSE. See the.;;
0230: 20 20 20 20 20 47 4e 55 20 47 65 6e 65 72 61 6c GNU General
0240: 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 Public License
0250: 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 69 6c 73 for more details
0260: 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 59 6f 75 ..;; .;; You
0270: 20 73 68 6f 75 6c 64 20 68 61 76 65 20 72 65 63 should have rec
0280: 65 69 76 65 64 20 61 20 63 6f 70 79 20 6f 66 20 eived a copy of
0290: 74 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 the GNU General
02a0: 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 0a 3b Public License.;
02b0: 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 69 74 68 ; along with
02c0: 20 4d 65 67 61 74 65 73 74 2e 20 20 49 66 20 6e Megatest. If n
02d0: 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 3a 2f 2f ot, see <http://
02e0: 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c 69 63 65 www.gnu.org/lice
02f0: 6e 73 65 73 2f 3e 2e 0a 0a 28 64 65 63 6c 61 72 nses/>...(declar
0300: 65 20 28 75 6e 69 74 20 68 74 74 70 2d 74 72 61 e (unit http-tra
0310: 6e 73 70 6f 72 74 29 29 0a 0a 28 64 65 63 6c 61 nsport))..(decla
0320: 72 65 20 28 75 73 65 73 20 63 6f 6d 6d 6f 6e 29 re (uses common)
0330: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
0340: 20 64 65 62 75 67 70 72 69 6e 74 29 29 0a 28 64 debugprint)).(d
0350: 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 62 29 eclare (uses db)
0360: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
0370: 20 74 65 73 74 73 29 29 0a 28 64 65 63 6c 61 72 tests)).(declar
0380: 65 20 28 75 73 65 73 20 74 61 73 6b 73 29 29 20 e (uses tasks))
0390: 3b 3b 20 74 61 73 6b 73 20 61 72 65 20 77 68 65 ;; tasks are whe
03a0: 72 65 20 73 74 75 66 66 20 69 73 20 6d 61 69 6e re stuff is main
03b0: 74 61 69 6e 65 64 20 61 62 6f 75 74 20 77 68 61 tained about wha
03c0: 74 20 69 73 20 72 75 6e 6e 69 6e 67 2e 0a 28 64 t is running..(d
03d0: 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 65 72 eclare (uses ser
03e0: 76 65 72 29 29 0a 3b 3b 20 28 64 65 63 6c 61 72 ver)).;; (declar
03f0: 65 20 28 75 73 65 73 20 64 61 65 6d 6f 6e 29 29 e (uses daemon))
0400: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0410: 70 6f 72 74 6c 6f 67 67 65 72 29 29 0a 28 64 65 portlogger)).(de
0420: 63 6c 61 72 65 20 28 75 73 65 73 20 72 6d 74 29 clare (uses rmt)
0430: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
0440: 20 64 62 66 69 6c 65 29 29 0a 28 64 65 63 6c 61 dbfile)).(decla
0450: 72 65 20 28 75 73 65 73 20 63 6f 6d 6d 6f 6e 6d re (uses commonm
0460: 6f 64 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 od)).(declare (u
0470: 73 65 73 20 6d 74 61 72 67 73 29 29 0a 0a 28 6d ses mtargs))..(m
0480: 6f 64 75 6c 65 20 68 74 74 70 2d 74 72 61 6e 73 odule http-trans
0490: 70 6f 72 74 0a 2a 0a 0a 0a 28 69 6d 70 6f 72 74 port.*...(import
04a0: 20 73 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 srfi-1 posix re
04b0: 67 65 78 20 72 65 67 65 78 2d 63 61 73 65 20 73 gex regex-case s
04c0: 72 66 69 2d 36 39 20 68 6f 73 74 69 6e 66 6f 20 rfi-69 hostinfo
04d0: 6d 64 35 0a 09 6d 65 73 73 61 67 65 2d 64 69 67 md5..message-dig
04e0: 65 73 74 20 70 6f 73 69 78 2d 65 78 74 72 61 73 est posix-extras
04f0: 20 73 70 69 66 66 79 20 75 72 69 2d 63 6f 6d 6d spiffy uri-comm
0500: 6f 6e 20 69 6e 74 61 72 77 65 62 20 68 74 74 70 on intarweb http
0510: 2d 63 6c 69 65 6e 74 0a 09 73 70 69 66 66 79 2d -client..spiffy-
0520: 72 65 71 75 65 73 74 2d 76 61 72 73 20 69 6e 74 request-vars int
0530: 61 72 77 65 62 20 73 70 69 66 66 79 2d 64 69 72 arweb spiffy-dir
0540: 65 63 74 6f 72 79 2d 6c 69 73 74 69 6e 67 0a 09 ectory-listing..
0550: 28 73 72 66 69 20 31 38 29 20 65 78 74 72 61 73 (srfi 18) extras
0560: 20 74 63 70 20 73 31 31 6e 29 0a 0a 28 69 6d 70 tcp s11n)..(imp
0570: 6f 72 74 20 73 63 68 65 6d 65 0a 09 63 68 69 63 ort scheme..chic
0580: 6b 65 6e 0a 09 0a 09 28 70 72 65 66 69 78 20 6d ken....(prefix m
0590: 74 61 72 67 73 20 61 72 67 73 3a 29 0a 09 64 65 targs args:)..de
05a0: 62 75 67 70 72 69 6e 74 29 0a 0a 3b 3b 20 43 6f bugprint)..;; Co
05b0: 6e 66 69 67 75 72 61 74 69 6f 6e 73 20 66 6f 72 nfigurations for
05c0: 20 73 65 72 76 65 72 0a 28 74 63 70 2d 62 75 66 server.(tcp-buf
05d0: 66 65 72 2d 73 69 7a 65 20 32 30 34 38 29 0a 28 fer-size 2048).(
05e0: 6d 61 78 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 max-connections
05f0: 32 30 34 38 29 20 0a 0a 28 69 6e 63 6c 75 64 65 2048) ..(include
0600: 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 "common_records
0610: 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 .scm").(include
0620: 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 "db_records.scm"
0630: 29 0a 28 69 6e 63 6c 75 64 65 20 22 6a 73 2d 70 ).(include "js-p
0640: 61 74 68 2e 73 63 6d 22 29 0a 0a 28 69 6d 70 6f ath.scm")..(impo
0650: 72 74 20 64 62 66 69 6c 65 20 63 6f 6d 6d 6f 6e rt dbfile common
0660: 6d 6f 64 29 0a 0a 28 72 65 71 75 69 72 65 2d 6c mod)..(require-l
0670: 69 62 72 61 72 79 20 73 74 6d 6c 29 0a 28 64 65 ibrary stml).(de
0680: 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
0690: 70 6f 72 74 3a 6d 61 6b 65 2d 73 65 72 76 65 72 port:make-server
06a0: 2d 75 72 6c 20 68 6f 73 74 70 6f 72 74 29 0a 20 -url hostport).
06b0: 20 28 69 66 20 28 6e 6f 74 20 68 6f 73 74 70 6f (if (not hostpo
06c0: 72 74 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 rt). #f.
06d0: 20 20 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f (conc "http:/
06e0: 2f 22 20 28 63 61 72 20 68 6f 73 74 70 6f 72 74 /" (car hostport
06f0: 29 20 22 3a 22 20 28 63 61 64 72 20 68 6f 73 74 ) ":" (cadr host
0700: 70 6f 72 74 29 29 29 29 0a 0a 28 64 65 66 69 6e port))))..(defin
0710: 65 20 2a 73 65 72 76 65 72 2d 6c 6f 6f 70 2d 68 e *server-loop-h
0720: 65 61 72 74 2d 62 65 61 74 2a 20 28 63 75 72 72 eart-beat* (curr
0730: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 0a 3b ent-seconds))..;
0740: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
0750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0780: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 =======.;; S E R
0790: 20 56 20 45 20 52 0a 3b 3b 20 3d 3d 3d 3d 3d 3d V E R.;; ======
07a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07e0: 0a 0a 3b 3b 20 43 61 6c 6c 20 74 68 69 73 20 74 ..;; Call this t
07f0: 6f 20 73 74 61 72 74 20 74 68 65 20 61 63 74 75 o start the actu
0800: 61 6c 20 73 65 72 76 65 72 0a 3b 3b 0a 0a 28 64 al server.;;..(d
0810: 65 66 69 6e 65 20 2a 64 62 3a 70 72 6f 63 65 73 efine *db:proces
0820: 73 2d 71 75 65 75 65 2d 6d 75 74 65 78 2a 20 28 s-queue-mutex* (
0830: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 28 64 make-mutex))..(d
0840: 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e efine (http-tran
0850: 73 70 6f 72 74 3a 72 75 6e 20 68 6f 73 74 6e 29 sport:run hostn)
0860: 0a 20 20 3b 3b 20 43 6f 6e 66 69 67 75 72 61 74 . ;; Configurat
0870: 69 6f 6e 73 20 66 6f 72 20 73 65 72 76 65 72 0a ions for server.
0880: 20 20 28 74 63 70 2d 62 75 66 66 65 72 2d 73 69 (tcp-buffer-si
0890: 7a 65 20 32 30 34 38 29 0a 20 20 28 6d 61 78 2d ze 2048). (max-
08a0: 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 32 30 34 38 connections 2048
08b0: 29 20 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e ) . (debug:prin
08c0: 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 2 *default-log
08d0: 2d 70 6f 72 74 2a 20 22 41 74 74 65 6d 70 74 69 -port* "Attempti
08e0: 6e 67 20 74 6f 20 73 74 61 72 74 20 74 68 65 20 ng to start the
08f0: 73 65 72 76 65 72 20 2e 2e 2e 22 29 0a 20 20 28 server ..."). (
0900: 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 let* ((db
0910: 20 20 20 20 20 20 20 23 66 29 20 3b 3b 20 20 20 #f) ;;
0920: 20 20 20 20 20 28 6f 70 65 6e 2d 64 62 29 29 20 (open-db))
0930: 3b 3b 20 77 65 20 64 6f 6e 27 74 20 77 61 6e 74 ;; we don't want
0940: 20 74 68 65 20 73 65 72 76 65 72 20 74 6f 20 62 the server to b
0950: 65 20 6f 70 65 6e 69 6e 67 20 61 6e 64 20 63 6c e opening and cl
0960: 6f 73 69 6e 67 20 74 68 65 20 64 62 20 75 6e 6e osing the db unn
0970: 65 63 65 73 61 72 69 6c 79 0a 09 20 28 68 6f 73 ecesarily.. (hos
0980: 74 6e 61 6d 65 20 20 20 20 20 20 20 20 28 67 65 tname (ge
0990: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 t-host-name))..
09a0: 28 69 70 61 64 64 72 73 74 72 20 20 20 20 20 20 (ipaddrstr
09b0: 20 28 6c 65 74 20 28 28 69 70 73 74 72 20 28 69 (let ((ipstr (i
09c0: 66 20 28 73 74 72 69 6e 67 3d 3f 20 22 2d 22 20 f (string=? "-"
09d0: 68 6f 73 74 6e 29 0a 09 09 09 09 09 20 20 20 3b hostn)...... ;
09e0: 3b 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 ; (string-inters
09f0: 70 65 72 73 65 20 28 6d 61 70 20 6e 75 6d 62 65 perse (map numbe
0a00: 72 2d 3e 73 74 72 69 6e 67 20 28 75 38 76 65 63 r->string (u8vec
0a10: 74 6f 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 6e tor->list (hostn
0a20: 61 6d 65 2d 3e 69 70 20 68 6f 73 74 6e 61 6d 65 ame->ip hostname
0a30: 29 29 29 20 22 2e 22 29 0a 09 09 09 09 09 20 20 ))) ".")......
0a40: 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 (server:get-bes
0a50: 74 2d 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 t-guess-address
0a60: 68 6f 73 74 6e 61 6d 65 29 0a 09 09 09 09 09 20 hostname)......
0a70: 20 20 23 66 29 29 29 0a 09 09 09 20 20 20 20 28 #f))).... (
0a80: 69 66 20 69 70 73 74 72 20 69 70 73 74 72 20 68 if ipstr ipstr h
0a90: 6f 73 74 6e 29 29 29 20 3b 3b 20 68 6f 73 74 6e ostn))) ;; hostn
0aa0: 61 6d 65 29 29 29 20 0a 09 20 28 73 74 61 72 74 ame))) .. (start
0ab0: 2d 70 6f 72 74 20 20 20 20 20 20 28 70 6f 72 74 -port (port
0ac0: 6c 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d logger:open-run-
0ad0: 63 6c 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 close portlogger
0ae0: 3a 66 69 6e 64 2d 70 6f 72 74 29 29 0a 09 20 28 :find-port)).. (
0af0: 6c 69 6e 6b 2d 74 72 65 65 2d 70 61 74 68 20 20 link-tree-path
0b00: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b (common:get-link
0b10: 74 72 65 65 29 29 0a 09 20 28 74 6d 70 2d 61 72 tree)).. (tmp-ar
0b20: 65 61 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f ea (commo
0b30: 6e 3a 67 65 74 2d 64 62 2d 74 6d 70 2d 61 72 65 n:get-db-tmp-are
0b40: 61 29 29 0a 09 20 28 73 74 61 72 74 2d 66 69 6c a)).. (start-fil
0b50: 65 20 20 20 20 20 20 28 63 6f 6e 63 20 74 6d 70 e (conc tmp
0b60: 2d 61 72 65 61 20 22 2f 2e 73 65 72 76 65 72 2d -area "/.server-
0b70: 73 74 61 72 74 22 29 29 29 0a 20 20 20 20 28 64 start"))). (d
0b80: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
0b90: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
0ba0: 6f 72 74 2a 20 22 70 6f 72 74 6c 6f 67 67 65 72 ort* "portlogger
0bb0: 20 72 65 63 6f 6d 6d 65 6e 64 65 64 20 70 6f 72 recommended por
0bc0: 74 3a 20 22 20 73 74 61 72 74 2d 70 6f 72 74 29 t: " start-port)
0bd0: 0a 20 20 20 20 3b 3b 20 73 65 74 20 73 6f 6d 65 . ;; set some
0be0: 20 70 61 72 61 6d 65 74 65 72 73 20 66 6f 72 20 parameters for
0bf0: 74 68 65 20 73 65 72 76 65 72 0a 20 20 20 20 28 the server. (
0c00: 72 6f 6f 74 2d 70 61 74 68 20 20 20 20 20 28 69 root-path (i
0c10: 66 20 6c 69 6e 6b 2d 74 72 65 65 2d 70 61 74 68 f link-tree-path
0c20: 20 0a 09 09 20 20 20 20 20 20 20 6c 69 6e 6b 2d ... link-
0c30: 74 72 65 65 2d 70 61 74 68 0a 09 09 20 20 20 20 tree-path...
0c40: 20 20 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 (current-dire
0c50: 63 74 6f 72 79 29 29 29 20 3b 3b 20 57 41 52 4e ctory))) ;; WARN
0c60: 49 4e 47 3a 20 53 45 43 55 52 49 54 59 20 48 4f ING: SECURITY HO
0c70: 4c 45 2e 20 46 49 58 20 41 53 41 50 21 0a 20 20 LE. FIX ASAP!.
0c80: 20 20 28 68 61 6e 64 6c 65 2d 64 69 72 65 63 74 (handle-direct
0c90: 6f 72 79 20 73 70 69 66 66 79 2d 64 69 72 65 63 ory spiffy-direc
0ca0: 74 6f 72 79 2d 6c 69 73 74 69 6e 67 29 0a 20 20 tory-listing).
0cb0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
0cc0: 69 6f 6e 20 28 6c 61 6d 62 64 61 20 28 65 78 6e ion (lambda (exn
0cd0: 20 63 68 61 69 6e 29 0a 09 09 09 28 73 69 67 6e chain)....(sign
0ce0: 61 6c 20 28 6d 61 6b 65 2d 63 6f 6d 70 6f 73 69 al (make-composi
0cf0: 74 65 2d 63 6f 6e 64 69 74 69 6f 6e 0a 09 09 09 te-condition....
0d00: 09 20 28 6d 61 6b 65 2d 70 72 6f 70 65 72 74 79 . (make-property
0d10: 2d 63 6f 6e 64 69 74 69 6f 6e 20 0a 09 09 09 09 -condition .....
0d20: 20 20 27 73 65 72 76 65 72 0a 09 09 09 09 20 20 'server.....
0d30: 27 6d 65 73 73 61 67 65 20 22 73 65 72 76 65 72 'message "server
0d40: 20 65 72 72 6f 72 22 29 29 29 29 29 0a 0a 20 20 error")))))..
0d50: 20 20 3b 3b 20 68 74 74 70 2d 74 72 61 6e 73 70 ;; http-transp
0d60: 6f 72 74 3a 68 61 6e 64 6c 65 2d 64 69 72 65 63 ort:handle-direc
0d70: 74 6f 72 79 29 20 3b 3b 20 73 69 6d 70 6c 65 2d tory) ;; simple-
0d80: 64 69 72 65 63 74 6f 72 79 2d 68 61 6e 64 6c 65 directory-handle
0d90: 72 29 0a 20 20 20 20 3b 3b 20 53 65 74 75 70 20 r). ;; Setup
0da0: 74 68 65 20 77 65 62 20 73 65 72 76 65 72 20 61 the web server a
0db0: 6e 64 20 61 20 2f 63 74 72 6c 20 69 6e 74 65 72 nd a /ctrl inter
0dc0: 66 61 63 65 0a 20 20 20 20 3b 3b 0a 20 20 20 20 face. ;;.
0dd0: 28 76 68 6f 73 74 2d 6d 61 70 20 60 28 28 28 2a (vhost-map `(((*
0de0: 20 61 6e 79 29 20 2e 20 2c 28 6c 61 6d 62 64 61 any) . ,(lambda
0df0: 20 28 63 6f 6e 74 69 6e 75 65 29 0a 09 09 09 20 (continue)....
0e00: 20 20 20 20 20 20 3b 3b 20 6f 70 65 6e 20 74 68 ;; open th
0e10: 65 20 64 62 20 6f 6e 20 74 68 65 20 66 69 72 73 e db on the firs
0e20: 74 20 63 61 6c 6c 20 0a 09 09 09 09 20 3b 3b 20 t call ..... ;;
0e30: 54 68 69 73 20 69 73 20 77 65 72 65 20 77 65 20 This is were we
0e40: 73 65 74 20 75 70 20 74 68 65 20 64 61 74 61 62 set up the datab
0e50: 61 73 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 0a ase connections.
0e60: 09 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ... (let*
0e70: 28 28 24 20 20 20 28 72 65 71 75 65 73 74 2d 76 (($ (request-v
0e80: 61 72 73 20 73 6f 75 72 63 65 3a 20 27 62 6f 74 ars source: 'bot
0e90: 68 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 64 h))..... (d
0ea0: 61 74 20 28 24 20 27 64 61 74 29 29 0a 09 09 09 at ($ 'dat))....
0eb0: 09 20 20 20 20 20 20 28 72 65 73 20 23 66 29 29 . (res #f))
0ec0: 0a 09 09 09 09 20 28 63 6f 6e 64 0a 09 09 09 09 ..... (cond.....
0ed0: 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 69 2d ((equal? (uri-
0ee0: 70 61 74 68 20 28 72 65 71 75 65 73 74 2d 75 72 path (request-ur
0ef0: 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 75 65 i (current-reque
0f00: 73 74 29 29 29 0a 09 09 09 09 09 20 20 20 27 28 st)))...... '(
0f10: 2f 20 22 61 70 69 22 29 29 0a 09 09 09 09 20 20 / "api")).....
0f20: 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 (send-response
0f30: 62 6f 64 79 3a 20 20 20 20 28 61 70 69 3a 70 72 body: (api:pr
0f40: 6f 63 65 73 73 2d 72 65 71 75 65 73 74 20 2a 64 ocess-request *d
0f50: 62 73 74 72 75 63 74 2d 64 62 73 2a 20 24 29 20 bstruct-dbs* $)
0f60: 3b 3b 20 74 68 65 20 24 20 69 73 20 74 68 65 20 ;; the $ is the
0f70: 72 65 71 75 65 73 74 20 76 61 72 73 20 70 72 6f request vars pro
0f80: 63 0a 09 09 09 09 09 09 20 20 68 65 61 64 65 72 c....... header
0f90: 73 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 s: '((content-ty
0fa0: 70 65 20 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 pe text/plain)))
0fb0: 0a 09 09 09 09 20 20 20 28 6d 75 74 65 78 2d 6c ..... (mutex-l
0fc0: 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d ock! *heartbeat-
0fd0: 6d 75 74 65 78 2a 29 0a 09 09 09 09 20 20 20 28 mutex*)..... (
0fe0: 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 2d 61 63 set! *db-last-ac
0ff0: 63 65 73 73 2a 20 28 63 75 72 72 65 6e 74 2d 73 cess* (current-s
1000: 65 63 6f 6e 64 73 29 29 0a 09 09 09 09 20 20 20 econds)).....
1010: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
1020: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
1030: 29 29 0a 09 09 09 09 20 20 28 28 65 71 75 61 6c ))..... ((equal
1040: 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 ? (uri-path (req
1050: 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e uest-uri (curren
1060: 74 2d 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 t-request))) ...
1070: 09 09 09 20 20 20 27 28 2f 20 22 22 29 29 0a 09 ... '(/ ""))..
1080: 09 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 ... (send-resp
1090: 6f 6e 73 65 20 62 6f 64 79 3a 20 28 68 74 74 70 onse body: (http
10a0: 2d 74 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e 2d -transport:main-
10b0: 70 61 67 65 29 29 29 0a 09 09 09 09 20 20 28 28 page)))..... ((
10c0: 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 equal? (uri-path
10d0: 20 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 (request-uri (c
10e0: 75 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 urrent-request))
10f0: 29 20 0a 09 09 09 09 09 20 20 20 27 28 2f 20 22 ) ...... '(/ "
1100: 6a 73 6f 6e 5f 61 70 69 22 29 29 0a 09 09 09 09 json_api")).....
1110: 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 (send-respons
1120: 65 20 62 6f 64 79 3a 20 28 68 74 74 70 2d 74 72 e body: (http-tr
1130: 61 6e 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 61 67 ansport:main-pag
1140: 65 29 29 29 0a 09 09 09 09 20 20 28 28 65 71 75 e)))..... ((equ
1150: 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 al? (uri-path (r
1160: 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 equest-uri (curr
1170: 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 20 0a ent-request))) .
1180: 09 09 09 09 09 20 20 20 27 28 2f 20 22 72 75 6e ..... '(/ "run
1190: 73 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e s"))..... (sen
11a0: 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a d-response body:
11b0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
11c0: 3a 6d 61 69 6e 2d 70 61 67 65 29 29 29 0a 09 09 :main-page)))...
11d0: 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 .. ((equal? (ur
11e0: 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 2d i-path (request-
11f0: 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 uri (current-req
1200: 75 65 73 74 29 29 29 20 0a 09 09 09 09 09 20 20 uest))) ......
1210: 20 27 28 2f 20 61 6e 79 29 29 0a 09 09 09 09 20 '(/ any)).....
1220: 20 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 (send-response
1230: 20 62 6f 64 79 3a 20 22 68 65 79 20 74 68 65 72 body: "hey ther
1240: 65 21 5c 6e 22 0a 09 09 09 09 09 09 20 20 68 65 e!\n"....... he
1250: 61 64 65 72 73 3a 20 27 28 28 63 6f 6e 74 65 6e aders: '((conten
1260: 74 2d 74 79 70 65 20 74 65 78 74 2f 70 6c 61 69 t-type text/plai
1270: 6e 29 29 29 29 0a 09 09 09 09 20 20 28 28 65 71 n))))..... ((eq
1280: 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 28 ual? (uri-path (
1290: 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 72 request-uri (cur
12a0: 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 20 rent-request)))
12b0: 0a 09 09 09 09 09 20 20 20 27 28 2f 20 22 68 65 ...... '(/ "he
12c0: 79 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e y"))..... (sen
12d0: 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a d-response body:
12e0: 20 22 68 65 79 20 74 68 65 72 65 21 5c 6e 22 20 "hey there!\n"
12f0: 0a 09 09 09 09 09 09 20 20 68 65 61 64 65 72 73 ....... headers
1300: 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 : '((content-typ
1310: 65 20 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 29 e text/plain))))
1320: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1340: 20 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 69 ((equal? (uri
1350: 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 2d 75 -path (request-u
1360: 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 75 ri (current-requ
1370: 65 73 74 29 29 29 20 0a 09 09 09 09 09 20 20 20 est))) ......
1380: 27 28 2f 20 22 6a 71 75 65 72 79 33 2e 31 2e 30 '(/ "jquery3.1.0
1390: 2e 6a 73 22 29 29 0a 09 09 09 09 20 20 20 28 73 .js"))..... (s
13a0: 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 end-response bod
13b0: 79 3a 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f y: (http-transpo
13c0: 72 74 3a 73 68 6f 77 2d 6a 71 75 65 72 79 29 20 rt:show-jquery)
13d0: 0a 09 09 09 09 09 09 20 20 68 65 61 64 65 72 73 ....... headers
13e0: 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 : '((content-typ
13f0: 65 20 61 70 70 6c 69 63 61 74 69 6f 6e 2f 6a 61 e application/ja
1400: 76 61 73 63 72 69 70 74 29 29 29 29 0a 20 20 20 vascript)))).
1410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1430: 28 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 (equal? (uri-pat
1440: 68 20 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 h (request-uri (
1450: 63 75 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 current-request)
1460: 29 29 20 0a 09 09 09 09 09 20 20 20 27 28 2f 20 )) ...... '(/
1470: 22 74 65 73 74 5f 6c 6f 67 22 29 29 0a 09 09 09 "test_log"))....
1480: 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e . (send-respon
1490: 73 65 20 62 6f 64 79 3a 20 28 68 74 74 70 2d 74 se body: (http-t
14a0: 72 61 6e 73 70 6f 72 74 3a 68 74 6d 6c 2d 74 65 ransport:html-te
14b0: 73 74 2d 6c 6f 67 20 24 29 20 0a 09 09 09 09 09 st-log $) ......
14c0: 09 20 20 68 65 61 64 65 72 73 3a 20 27 28 28 63 . headers: '((c
14d0: 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 65 78 74 ontent-type text
14e0: 2f 48 54 4d 4c 29 29 29 29 20 20 20 20 0a 20 20 /HTML)))) .
14f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1510: 28 28 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 ((equal? (uri-pa
1520: 74 68 20 28 72 65 71 75 65 73 74 2d 75 72 69 20 th (request-uri
1530: 28 63 75 72 72 65 6e 74 2d 72 65 71 75 65 73 74 (current-request
1540: 29 29 29 20 0a 09 09 09 09 09 20 20 20 27 28 2f ))) ...... '(/
1550: 20 22 64 61 73 68 62 6f 61 72 64 22 29 29 0a 09 "dashboard"))..
1560: 09 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 ... (send-resp
1570: 6f 6e 73 65 20 62 6f 64 79 3a 20 28 68 74 74 70 onse body: (http
1580: 2d 74 72 61 6e 73 70 6f 72 74 3a 68 74 6d 6c 2d -transport:html-
1590: 64 62 6f 61 72 64 20 24 29 20 0a 09 09 09 09 09 dboard $) ......
15a0: 09 20 20 68 65 61 64 65 72 73 3a 20 27 28 28 63 . headers: '((c
15b0: 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 65 78 74 ontent-type text
15c0: 2f 48 54 4d 4c 29 29 29 29 20 0a 09 09 09 09 20 /HTML)))) .....
15d0: 20 28 65 6c 73 65 20 28 63 6f 6e 74 69 6e 75 65 (else (continue
15e0: 29 29 29 29 29 29 29 29 0a 20 20 20 20 28 68 61 )))))))). (ha
15f0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
1600: 09 65 78 6e 0a 20 20 20 20 20 20 28 64 65 62 75 .exn. (debu
1610: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
1620: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 61 lt-log-port* "Fa
1630: 69 6c 65 64 20 74 6f 20 63 72 65 61 74 65 20 66 iled to create f
1640: 69 6c 65 20 22 20 73 74 61 72 74 2d 66 69 6c 65 ile " start-file
1650: 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a 20 ", exn=" exn).
1660: 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 (with-outpu
1670: 74 2d 74 6f 2d 66 69 6c 65 20 73 74 61 72 74 2d t-to-file start-
1680: 66 69 6c 65 20 28 6c 61 6d 62 64 61 20 28 29 28 file (lambda ()(
1690: 70 72 69 6e 74 20 28 63 75 72 72 65 6e 74 2d 70 print (current-p
16a0: 72 6f 63 65 73 73 2d 69 64 29 29 29 29 29 0a 20 rocess-id))))).
16b0: 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f (http-transpo
16c0: 72 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 rt:try-start-ser
16d0: 76 65 72 20 69 70 61 64 64 72 73 74 72 20 73 74 ver ipaddrstr st
16e0: 61 72 74 2d 70 6f 72 74 29 29 29 0a 0a 3b 3b 20 art-port)))..;;
16f0: 54 68 69 73 20 69 73 20 72 65 63 75 72 73 69 76 This is recursiv
1700: 65 6c 79 20 72 75 6e 20 62 79 20 68 74 74 70 2d ely run by http-
1710: 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 20 75 6e transport:run un
1720: 74 69 6c 20 73 75 63 65 73 73 66 75 6c 0a 3b 3b til sucessful.;;
1730: 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 .(define (http-t
1740: 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 74 61 ransport:try-sta
1750: 72 74 2d 73 65 72 76 65 72 20 69 70 61 64 64 72 rt-server ipaddr
1760: 73 74 72 20 70 6f 72 74 6e 75 6d 29 0a 20 20 28 str portnum). (
1770: 6c 65 74 20 28 28 63 6f 6e 66 69 67 2d 68 6f 73 let ((config-hos
1780: 74 6e 61 6d 65 20 28 63 6f 6e 66 69 67 66 3a 6c tname (configf:l
1790: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
17a0: 2a 20 22 73 65 72 76 65 72 22 20 22 68 6f 73 74 * "server" "host
17b0: 6e 61 6d 65 22 29 29 0a 09 28 63 6f 6e 66 69 67 name"))..(config
17c0: 2d 75 73 65 2d 70 72 6f 78 79 20 28 65 71 75 61 -use-proxy (equa
17d0: 6c 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b l? (configf:look
17e0: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
17f0: 63 6c 69 65 6e 74 22 20 22 75 73 65 2d 68 74 74 client" "use-htt
1800: 70 5f 70 72 6f 78 79 22 29 20 22 79 65 73 22 29 p_proxy") "yes")
1810: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
1820: 63 6f 6e 66 69 67 2d 75 73 65 2d 70 72 6f 78 79 config-use-proxy
1830: 29 0a 09 28 64 65 74 65 72 6d 69 6e 65 2d 70 72 )..(determine-pr
1840: 6f 78 79 20 28 63 6f 6e 73 74 61 6e 74 6c 79 20 oxy (constantly
1850: 23 66 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 #f))). (debug
1860: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
1870: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1880: 20 22 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 "http-transport
1890: 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 76 65 :try-start-serve
18a0: 72 20 74 69 6d 65 3d 22 20 28 73 65 63 6f 6e 64 r time=" (second
18b0: 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 28 s->time-string (
18c0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
18d0: 29 20 22 20 69 70 61 64 64 72 73 73 74 72 3d 22 ) " ipaddrsstr="
18e0: 20 69 70 61 64 64 72 73 74 72 20 22 20 70 6f 72 ipaddrstr " por
18f0: 74 6e 75 6d 3d 22 20 70 6f 72 74 6e 75 6d 20 22 tnum=" portnum "
1900: 20 63 6f 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 config-hostname
1910: 3d 22 20 63 6f 6e 66 69 67 2d 68 6f 73 74 6e 61 =" config-hostna
1920: 6d 65 29 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d me). (handle-
1930: 65 78 63 65 70 74 69 6f 6e 73 0a 09 65 78 6e 0a exceptions..exn.
1940: 09 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 28 70 .(begin.. ;; (p
1950: 72 69 6e 74 2d 65 72 72 6f 72 2d 6d 65 73 73 61 rint-error-messa
1960: 67 65 20 65 78 6e 29 0a 09 20 20 28 69 66 20 28 ge exn).. (if (
1970: 3c 20 70 6f 72 74 6e 75 6d 20 36 34 30 30 30 29 < portnum 64000)
1980: 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a .. (begin .
1990: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
19a0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
19b0: 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 61 74 rt* "WARNING: at
19c0: 74 65 6d 70 74 20 74 6f 20 73 74 61 72 74 20 73 tempt to start s
19d0: 65 72 76 65 72 20 66 61 69 6c 65 64 2e 20 54 72 erver failed. Tr
19e0: 79 69 6e 67 20 61 67 61 69 6e 20 2e 2e 2e 22 29 ying again ...")
19f0: 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
1a00: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
1a10: 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 ort* " message:
1a20: 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 " ((condition-pr
1a30: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
1a40: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
1a50: 78 6e 29 29 0a 09 09 28 64 65 62 75 67 3a 70 72 xn))...(debug:pr
1a60: 69 6e 74 20 35 20 2a 64 65 66 61 75 6c 74 2d 6c int 5 *default-l
1a70: 6f 67 2d 70 6f 72 74 2a 20 22 65 78 6e 3d 22 20 og-port* "exn="
1a80: 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 (condition->list
1a90: 20 65 78 6e 29 29 0a 09 09 28 70 6f 72 74 6c 6f exn))...(portlo
1aa0: 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c gger:open-run-cl
1ab0: 6f 73 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 73 ose portlogger:s
1ac0: 65 74 2d 66 61 69 6c 65 64 20 70 6f 72 74 6e 75 et-failed portnu
1ad0: 6d 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e m)...(debug:prin
1ae0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
1af0: 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a -port* "WARNING:
1b00: 20 66 61 69 6c 65 64 20 74 6f 20 73 74 61 72 74 failed to start
1b10: 20 6f 6e 20 70 6f 72 74 6e 75 6d 3a 20 22 20 70 on portnum: " p
1b20: 6f 72 74 6e 75 6d 20 22 2c 20 74 72 79 69 6e 67 ortnum ", trying
1b30: 20 6e 65 78 74 20 70 6f 72 74 22 29 0a 09 09 28 next port")...(
1b40: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
1b50: 31 29 0a 09 09 0a 09 09 3b 3b 20 67 65 74 5f 6e 1)......;; get_n
1b60: 65 78 74 5f 70 6f 72 74 20 67 6f 65 73 20 68 65 ext_port goes he
1b70: 72 65 0a 09 09 28 68 74 74 70 2d 74 72 61 6e 73 re...(http-trans
1b80: 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 port:try-start-s
1b90: 65 72 76 65 72 20 69 70 61 64 64 72 73 74 72 0a erver ipaddrstr.
1ba0: 09 09 09 09 09 09 20 28 70 6f 72 74 6c 6f 67 67 ...... (portlogg
1bb0: 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 er:open-run-clos
1bc0: 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 66 69 6e e portlogger:fin
1bd0: 64 2d 70 6f 72 74 29 29 29 0a 09 20 20 20 20 20 d-port)))..
1be0: 20 28 62 65 67 69 6e 0a 09 09 28 64 65 62 75 67 (begin...(debug
1bf0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
1c00: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 t-log-port* "ERR
1c10: 4f 52 3a 20 54 72 69 65 64 20 61 6e 64 20 74 72 OR: Tried and tr
1c20: 69 65 64 20 62 75 74 20 63 6f 75 6c 64 20 6e 6f ied but could no
1c30: 74 20 73 74 61 72 74 20 74 68 65 20 73 65 72 76 t start the serv
1c40: 65 72 22 29 29 29 29 0a 20 20 20 20 20 20 3b 3b er")))). ;;
1c50: 20 61 6e 79 20 65 72 72 6f 72 20 69 6e 20 66 6f any error in fo
1c60: 6c 6c 6f 77 69 6e 67 20 73 74 65 70 73 20 77 69 llowing steps wi
1c70: 6c 6c 20 72 65 73 75 6c 74 20 69 6e 20 61 20 72 ll result in a r
1c80: 65 74 72 79 0a 20 20 20 20 20 20 28 73 65 74 21 etry. (set!
1c90: 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 28 *server-info* (
1ca0: 6c 69 73 74 20 69 70 61 64 64 72 73 74 72 20 70 list ipaddrstr p
1cb0: 6f 72 74 6e 75 6d 29 29 0a 20 20 20 20 20 20 28 ortnum)). (
1cc0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
1cd0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1ce0: 20 22 49 4e 46 4f 3a 20 54 72 79 69 6e 67 20 74 "INFO: Trying t
1cf0: 6f 20 73 74 61 72 74 20 73 65 72 76 65 72 20 6f o start server o
1d00: 6e 20 22 20 69 70 61 64 64 72 73 74 72 20 22 3a n " ipaddrstr ":
1d10: 22 20 70 6f 72 74 6e 75 6d 29 0a 20 20 20 20 20 " portnum).
1d20: 20 3b 3b 20 54 68 69 73 20 73 74 61 72 74 73 20 ;; This starts
1d30: 74 68 65 20 73 70 69 66 66 79 20 73 65 72 76 65 the spiffy serve
1d40: 72 0a 20 20 20 20 20 20 3b 3b 20 4e 45 45 44 20 r. ;; NEED
1d50: 57 41 59 20 54 4f 20 53 45 54 20 49 50 20 54 4f WAY TO SET IP TO
1d60: 20 23 66 20 54 4f 20 42 49 4e 44 20 41 4c 4c 0a #f TO BIND ALL.
1d70: 20 20 20 20 20 20 3b 3b 20 28 73 74 61 72 74 2d ;; (start-
1d80: 73 65 72 76 65 72 20 62 69 6e 64 2d 61 64 64 72 server bind-addr
1d90: 65 73 73 3a 20 69 70 61 64 64 72 73 74 72 20 70 ess: ipaddrstr p
1da0: 6f 72 74 3a 20 70 6f 72 74 6e 75 6d 29 0a 20 20 ort: portnum).
1db0: 20 20 20 20 28 69 66 20 63 6f 6e 66 69 67 2d 68 (if config-h
1dc0: 6f 73 74 6e 61 6d 65 20 3b 3b 20 74 68 69 73 20 ostname ;; this
1dd0: 69 73 20 61 20 68 69 6e 74 20 74 6f 20 62 69 6e is a hint to bin
1de0: 64 20 64 69 72 65 63 74 6c 79 0a 09 20 20 28 73 d directly.. (s
1df0: 74 61 72 74 2d 73 65 72 76 65 72 20 70 6f 72 74 tart-server port
1e00: 3a 20 70 6f 72 74 6e 75 6d 29 20 3b 3b 20 62 69 : portnum) ;; bi
1e10: 6e 64 2d 61 64 64 72 65 73 73 3a 20 28 69 66 20 nd-address: (if
1e20: 28 65 71 75 61 6c 3f 20 63 6f 6e 66 69 67 2d 68 (equal? config-h
1e30: 6f 73 74 6e 61 6d 65 20 22 2d 22 29 0a 09 09 09 ostname "-")....
1e40: 09 09 3b 3b 09 09 69 70 61 64 64 72 73 74 72 0a ..;;..ipaddrstr.
1e50: 09 09 09 09 09 3b 3b 09 09 63 6f 6e 66 69 67 2d .....;;..config-
1e60: 68 6f 73 74 6e 61 6d 65 29 29 0a 09 20 20 28 73 hostname)).. (s
1e70: 74 61 72 74 2d 73 65 72 76 65 72 20 70 6f 72 74 tart-server port
1e80: 3a 20 70 6f 72 74 6e 75 6d 29 29 0a 20 20 20 20 : portnum)).
1e90: 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 (portlogger:op
1ea0: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 en-run-close por
1eb0: 74 6c 6f 67 67 65 72 3a 73 65 74 2d 70 6f 72 74 tlogger:set-port
1ec0: 20 70 6f 72 74 6e 75 6d 20 22 72 65 6c 65 61 73 portnum "releas
1ed0: 65 64 22 29 0a 20 20 20 20 20 20 28 64 65 62 75 ed"). (debu
1ee0: 67 3a 70 72 69 6e 74 20 31 20 2a 64 65 66 61 75 g:print 1 *defau
1ef0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e lt-log-port* "IN
1f00: 46 4f 3a 20 73 65 72 76 65 72 20 68 61 73 20 62 FO: server has b
1f10: 65 65 6e 20 73 74 6f 70 70 65 64 22 29 29 29 29 een stopped"))))
1f20: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
1f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 ==========.;; S
1f70: 45 20 52 20 56 20 45 20 52 20 20 20 55 20 54 20 E R V E R U T
1f80: 49 20 4c 20 49 20 54 20 49 20 45 20 53 20 0a 3b I L I T I E S .;
1f90: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
1fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fd0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d 3d 3d 3d =======..;;=====
1fe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2020: 3d 0a 3b 3b 20 43 20 4c 20 49 20 45 20 4e 20 54 =.;; C L I E N T
2030: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
2040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
2080: 66 69 6e 65 20 2a 68 74 74 70 2d 6d 75 74 65 78 fine *http-mutex
2090: 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a * (make-mutex)).
20a0: 0a 3b 3b 20 4e 4f 54 45 3a 20 4c 61 72 67 65 20 .;; NOTE: Large
20b0: 62 6c 6f 63 6b 20 6f 66 20 63 6f 64 65 20 66 72 block of code fr
20c0: 6f 6d 20 33 32 34 33 36 62 34 32 36 31 38 38 30 om 32436b4261880
20d0: 38 30 66 37 32 66 63 65 62 36 38 39 34 61 66 35 80f72fceb6894af5
20e0: 34 31 66 62 61 64 39 39 32 31 65 20 72 65 6d 6f 41fbad9921e remo
20f0: 76 65 64 20 68 65 72 65 0a 3b 3b 20 20 20 20 20 ved here.;;
2100: 20 20 49 27 6d 20 70 72 65 74 74 79 20 73 75 72 I'm pretty sur
2110: 65 20 69 74 20 69 73 20 64 65 66 75 6e 63 74 2e e it is defunct.
2120: 0a 0a 3b 3b 20 54 68 69 73 20 6e 65 78 74 20 62 ..;; This next b
2130: 6c 6f 63 6b 20 61 6c 6c 20 69 6d 70 6f 72 74 65 lock all importe
2140: 64 20 65 6e 2d 6d 61 73 73 20 66 72 6f 6d 20 74 d en-mass from t
2150: 68 65 20 61 70 69 20 62 72 61 6e 63 68 0a 28 64 he api branch.(d
2160: 65 66 69 6e 65 20 2a 68 74 74 70 2d 72 65 71 75 efine *http-requ
2170: 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 ests-in-progress
2180: 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 2a 68 74 * 0).(define *ht
2190: 74 70 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 2d 6e tp-connections-n
21a0: 65 78 74 2d 63 6c 65 61 6e 75 70 2a 20 28 63 75 ext-cleanup* (cu
21b0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
21c0: 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 .(define (http-t
21d0: 72 61 6e 73 70 6f 72 74 3a 67 65 74 2d 74 69 6d ransport:get-tim
21e0: 65 2d 74 6f 2d 63 6c 65 61 6e 75 70 29 0a 20 20 e-to-cleanup).
21f0: 28 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 0a (let ((res #f)).
2200: 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 (mutex-lock!
2210: 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 *http-mutex*).
2220: 20 20 20 28 73 65 74 21 20 72 65 73 20 28 3e 20 (set! res (>
2230: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
2240: 29 20 2a 68 74 74 70 2d 63 6f 6e 6e 65 63 74 69 ) *http-connecti
2250: 6f 6e 73 2d 6e 65 78 74 2d 63 6c 65 61 6e 75 70 ons-next-cleanup
2260: 2a 29 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 *)). (mutex-u
2270: 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 nlock! *http-mut
2280: 65 78 2a 29 0a 20 20 20 20 72 65 73 29 29 0a 0a ex*). res))..
2290: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
22a0: 61 6e 73 70 6f 72 74 3a 69 6e 63 2d 72 65 71 75 ansport:inc-requ
22b0: 65 73 74 73 2d 63 6f 75 6e 74 29 0a 20 20 28 6d ests-count). (m
22c0: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 utex-lock! *http
22d0: 2d 6d 75 74 65 78 2a 29 0a 20 20 28 73 65 74 21 -mutex*). (set!
22e0: 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d *http-requests-
22f0: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 28 2b 20 in-progress* (+
2300: 31 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 1 *http-requests
2310: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 29 29 0a -in-progress*)).
2320: 20 20 3b 3b 20 55 73 65 20 74 68 69 73 20 6f 70 ;; Use this op
2330: 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 73 6c 6f portunity to slo
2340: 77 20 74 68 69 6e 67 73 20 64 6f 77 6e 20 69 66 w things down if
2350: 66 20 74 68 65 72 65 20 61 72 65 20 74 6f 6f 20 f there are too
2360: 6d 61 6e 79 20 72 65 71 75 65 73 74 73 20 69 6e many requests in
2370: 20 66 6c 69 67 68 74 0a 20 20 28 69 66 20 28 3e flight. (if (>
2380: 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d *http-requests-
2390: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 35 29 0a in-progress* 5).
23a0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 64 (begin..(d
23b0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
23c0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
23d0: 6f 72 74 2a 20 22 57 68 6f 61 20 74 68 65 72 65 ort* "Whoa there
23e0: 20 62 75 64 64 79 2c 20 65 61 73 65 20 75 70 2e buddy, ease up.
23f0: 2e 2e 22 29 0a 09 28 74 68 72 65 61 64 2d 73 6c ..")..(thread-sl
2400: 65 65 70 21 20 31 29 29 29 0a 20 20 28 6d 75 74 eep! 1))). (mut
2410: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 ex-unlock! *http
2420: 2d 6d 75 74 65 78 2a 29 29 0a 0a 28 64 65 66 69 -mutex*))..(defi
2430: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
2440: 72 74 3a 64 65 63 2d 72 65 71 75 65 73 74 73 2d rt:dec-requests-
2450: 63 6f 75 6e 74 20 70 72 6f 63 29 20 0a 20 20 28 count proc) . (
2460: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 mutex-lock! *htt
2470: 70 2d 6d 75 74 65 78 2a 29 0a 20 20 28 70 72 6f p-mutex*). (pro
2480: 63 29 0a 20 20 28 73 65 74 21 20 2a 68 74 74 70 c). (set! *http
2490: 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f -requests-in-pro
24a0: 67 72 65 73 73 2a 20 28 2d 20 2a 68 74 74 70 2d gress* (- *http-
24b0: 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 requests-in-prog
24c0: 72 65 73 73 2a 20 31 29 29 0a 20 20 28 6d 75 74 ress* 1)). (mut
24d0: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 ex-unlock! *http
24e0: 2d 6d 75 74 65 78 2a 29 29 0a 0a 28 64 65 66 69 -mutex*))..(defi
24f0: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
2500: 72 74 3a 64 65 63 2d 72 65 71 75 65 73 74 73 2d rt:dec-requests-
2510: 63 6f 75 6e 74 2d 61 6e 64 2d 63 6c 6f 73 65 2d count-and-close-
2520: 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 29 all-connections)
2530: 0a 20 20 28 73 65 74 21 20 2a 68 74 74 70 2d 72 . (set! *http-r
2540: 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 equests-in-progr
2550: 65 73 73 2a 20 28 2d 20 2a 68 74 74 70 2d 72 65 ess* (- *http-re
2560: 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 quests-in-progre
2570: 73 73 2a 20 31 29 29 0a 20 20 28 6c 65 74 20 6c ss* 1)). (let l
2580: 6f 6f 70 20 28 28 65 74 69 6d 65 20 28 2b 20 28 oop ((etime (+ (
2590: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
25a0: 20 35 29 29 29 20 3b 3b 20 67 69 76 65 20 75 70 5))) ;; give up
25b0: 20 69 6e 20 66 69 76 65 20 73 65 63 6f 6e 64 73 in five seconds
25c0: 0a 20 20 20 20 28 69 66 20 28 3e 20 2a 68 74 74 . (if (> *htt
25d0: 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 p-requests-in-pr
25e0: 6f 67 72 65 73 73 2a 20 30 29 0a 09 28 69 66 20 ogress* 0)..(if
25f0: 28 3e 20 65 74 69 6d 65 20 28 63 75 72 72 65 6e (> etime (curren
2600: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 20 t-seconds))..
2610: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
2620: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
2630: 30 35 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 05).. (loop
2640: 20 65 74 69 6d 65 29 29 0a 09 20 20 20 20 28 64 etime)).. (d
2650: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
2660: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
2670: 70 6f 72 74 2a 20 22 72 65 71 75 65 73 74 73 20 port* "requests
2680: 73 74 69 6c 6c 20 69 6e 20 70 72 6f 67 72 65 73 still in progres
2690: 73 20 61 66 74 65 72 20 35 20 73 65 63 6f 6e 64 s after 5 second
26a0: 73 20 6f 66 20 77 61 69 74 69 6e 67 2e 20 49 27 s of waiting. I'
26b0: 6d 20 67 6f 69 6e 67 20 74 6f 20 70 61 73 73 20 m going to pass
26c0: 6f 6e 20 63 6c 65 61 6e 69 6e 67 20 75 70 20 68 on cleaning up h
26d0: 74 74 70 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 22 ttp connections"
26e0: 29 29 0a 09 28 63 6c 6f 73 65 2d 61 6c 6c 2d 63 ))..(close-all-c
26f0: 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 29 29 0a 20 onnections!))).
2700: 20 28 73 65 74 21 20 2a 68 74 74 70 2d 63 6f 6e (set! *http-con
2710: 6e 65 63 74 69 6f 6e 73 2d 6e 65 78 74 2d 63 6c nections-next-cl
2720: 65 61 6e 75 70 2a 20 28 2b 20 28 63 75 72 72 65 eanup* (+ (curre
2730: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 31 30 29 29 nt-seconds) 10))
2740: 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b . (mutex-unlock
2750: 21 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 29 ! *http-mutex*))
2760: 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ..(define (http-
2770: 74 72 61 6e 73 70 6f 72 74 3a 69 6e 63 2d 72 65 transport:inc-re
2780: 71 75 65 73 74 73 2d 61 6e 64 2d 70 72 65 70 2d quests-and-prep-
2790: 74 6f 2d 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e to-close-all-con
27a0: 6e 65 63 74 69 6f 6e 73 29 0a 20 20 28 6d 75 74 nections). (mut
27b0: 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d ex-lock! *http-m
27c0: 75 74 65 78 2a 29 0a 20 20 28 73 65 74 21 20 2a utex*). (set! *
27d0: 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e http-requests-in
27e0: 2d 70 72 6f 67 72 65 73 73 2a 20 28 2b 20 31 20 -progress* (+ 1
27f0: 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 *http-requests-i
2800: 6e 2d 70 72 6f 67 72 65 73 73 2a 29 29 29 0a 0a n-progress*)))..
2810: 3b 3b 20 53 65 6e 64 20 22 63 6d 64 22 20 77 69 ;; Send "cmd" wi
2820: 74 68 20 6a 73 6f 6e 20 70 61 79 6c 6f 61 64 20 th json payload
2830: 22 70 61 72 61 6d 73 22 20 74 6f 20 73 65 72 76 "params" to serv
2840: 65 72 64 61 74 20 61 6e 64 20 72 65 63 65 69 76 erdat and receiv
2850: 65 20 72 65 73 75 6c 74 0a 3b 3b 0a 28 64 65 66 e result.;;.(def
2860: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
2870: 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 ort:client-api-s
2880: 65 6e 64 2d 72 65 63 65 69 76 65 20 72 75 6e 2d end-receive run-
2890: 69 64 20 72 75 6e 72 65 6d 6f 74 65 20 63 6d 64 id runremote cmd
28a0: 20 70 61 72 61 6d 73 20 23 21 6b 65 79 20 28 6e params #!key (n
28b0: 75 6d 72 65 74 72 69 65 73 20 33 29 29 0a 20 20 umretries 3)).
28c0: 28 61 73 73 65 72 74 20 28 72 65 6d 6f 74 65 3f (assert (remote?
28d0: 20 72 75 6e 72 65 6d 6f 74 65 29 20 22 46 41 54 runremote) "FAT
28e0: 41 4c 3a 20 68 74 74 70 2d 74 72 61 6e 73 70 6f AL: http-transpo
28f0: 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 rt:client-api-se
2900: 6e 64 2d 72 65 63 65 69 76 65 20 63 61 6c 6c 65 nd-receive calle
2910: 64 20 77 69 74 68 20 73 65 72 76 65 72 64 61 74 d with serverdat
2920: 3d 22 73 65 72 76 65 72 64 61 74 29 0a 20 20 28 ="serverdat). (
2930: 6c 65 74 2a 20 28 28 66 75 6c 6c 75 72 6c 20 20 let* ((fullurl
2940: 20 20 28 72 65 6d 6f 74 65 2d 61 70 69 2d 72 65 (remote-api-re
2950: 71 20 72 75 6e 72 65 6d 6f 74 65 29 29 0a 09 20 q runremote))..
2960: 28 72 65 73 20 20 20 20 20 20 20 20 28 76 65 63 (res (vec
2970: 74 6f 72 20 23 66 20 22 75 6e 69 6e 69 74 69 61 tor #f "uninitia
2980: 6c 69 7a 65 64 22 29 29 0a 09 20 28 73 75 63 63 lized")).. (succ
2990: 65 73 73 20 20 20 20 23 74 29 0a 09 20 28 73 70 ess #t).. (sp
29a0: 61 72 61 6d 73 20 20 20 20 28 64 62 3a 6f 62 6a arams (db:obj
29b0: 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d 73 20 ->string params
29c0: 74 72 61 6e 73 70 6f 72 74 3a 20 27 68 74 74 70 transport: 'http
29d0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 73 65 72 )). (ser
29e0: 76 65 72 2d 69 64 20 20 28 72 65 6d 6f 74 65 2d ver-id (remote-
29f0: 73 65 72 76 65 72 2d 69 64 20 72 75 6e 72 65 6d server-id runrem
2a00: 6f 74 65 29 29 29 0a 20 20 20 20 20 20 20 28 64 ote))). (d
2a10: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
2a20: 31 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 11 *default-log-
2a30: 70 6f 72 74 2a 20 22 63 6d 64 3d 22 20 63 6d 64 port* "cmd=" cmd
2a40: 20 22 20 66 75 6c 6c 75 72 6c 3d 22 20 66 75 6c " fullurl=" ful
2a50: 6c 75 72 6c 20 22 20 73 65 72 76 65 72 2d 69 64 lurl " server-id
2a60: 3d 22 20 73 65 72 76 65 72 2d 69 64 20 22 20 63 =" server-id " c
2a70: 75 72 72 65 6e 74 20 74 69 6d 65 3a 22 20 28 63 urrent time:" (c
2a80: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
2a90: 20 0a 0a 20 20 20 20 20 20 20 3b 3b 20 73 65 74 .. ;; set
2aa0: 20 75 70 20 74 68 65 20 68 74 74 70 2d 63 6c 69 up the http-cli
2ab0: 65 6e 74 20 68 65 72 65 0a 20 20 20 20 20 20 20 ent here.
2ac0: 28 6d 61 78 2d 72 65 74 72 79 2d 61 74 74 65 6d (max-retry-attem
2ad0: 70 74 73 20 31 29 0a 20 20 20 20 20 20 20 3b 3b pts 1). ;;
2ae0: 20 63 6f 6e 73 69 64 65 72 20 61 6c 6c 20 72 65 consider all re
2af0: 71 75 65 73 74 73 20 69 6e 64 65 6d 70 6f 74 65 quests indempote
2b00: 6e 74 0a 20 20 20 20 20 20 20 28 72 65 74 72 79 nt. (retry
2b10: 2d 72 65 71 75 65 73 74 3f 20 28 6c 61 6d 62 64 -request? (lambd
2b20: 61 20 28 72 65 71 75 65 73 74 29 0a 09 09 09 20 a (request)....
2b30: 23 66 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 73 #f)). ;; s
2b40: 65 6e 64 20 74 68 65 20 64 61 74 61 20 61 6e 64 end the data and
2b50: 20 67 65 74 20 74 68 65 20 72 65 73 70 6f 6e 73 get the respons
2b60: 65 0a 20 20 20 20 20 20 20 3b 3b 20 65 78 74 72 e. ;; extr
2b70: 61 63 74 20 74 68 65 20 6e 65 65 64 65 64 20 69 act the needed i
2b80: 6e 66 6f 20 66 72 6f 6d 20 74 68 65 20 68 74 74 nfo from the htt
2b90: 70 20 64 61 74 61 20 61 6e 64 20 0a 20 20 20 20 p data and .
2ba0: 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 20 61 6e ;; process an
2bb0: 64 20 72 65 74 75 72 6e 20 69 74 2e 0a 20 20 20 d return it..
2bc0: 20 20 20 20 28 6c 65 74 2a 20 28 28 73 65 6e 64 (let* ((send
2bd0: 2d 72 65 63 69 65 76 65 20 28 6c 61 6d 62 64 61 -recieve (lambda
2be0: 20 28 29 0a 09 09 09 20 20 20 20 20 20 28 6d 75 ().... (mu
2bf0: 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 70 2d tex-lock! *http-
2c00: 6d 75 74 65 78 2a 29 0a 09 09 09 20 20 20 20 20 mutex*)....
2c10: 20 3b 3b 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 ;; (condition-c
2c20: 61 73 65 20 28 77 69 74 68 2d 69 6e 70 75 74 2d ase (with-input-
2c30: 66 72 6f 6d 2d 72 65 71 75 65 73 74 20 22 68 74 from-request "ht
2c40: 74 70 3a 2f 2f 6c 6f 63 61 6c 68 6f 73 74 22 3b tp://localhost";
2c50: 20 23 66 20 72 65 61 64 2d 6c 69 6e 65 73 29 0a #f read-lines).
2c60: 09 09 09 20 20 20 20 20 20 3b 3b 09 09 09 09 09 ... ;;.....
2c70: 20 20 20 20 20 20 20 28 28 65 78 6e 20 68 74 74 ((exn htt
2c80: 70 20 63 6c 69 65 6e 74 2d 65 72 72 6f 72 29 20 p client-error)
2c90: 65 20 28 70 72 69 6e 74 20 65 29 29 29 0a 09 09 e (print e)))...
2ca0: 09 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 . (set! res
2cb0: 20 28 76 65 63 74 6f 72 20 20 20 20 20 20 20 20 (vector
2cc0: 20 20 20 20 20 20 20 20 3b 3b 3b 20 44 4f 4e 27 ;;; DON'
2cd0: 54 20 46 4f 52 47 45 54 20 2d 20 54 48 49 53 20 T FORGET - THIS
2ce0: 49 53 20 54 48 45 20 43 4c 49 45 4e 54 20 53 49 IS THE CLIENT SI
2cf0: 44 45 21 20 4e 4f 54 45 3a 20 63 6f 6e 73 69 64 DE! NOTE: consid
2d00: 65 72 20 6d 6f 76 69 6e 67 20 74 68 69 73 20 74 er moving this t
2d10: 6f 20 63 6c 69 65 6e 74 2e 73 63 6d 20 73 69 6e o client.scm sin
2d20: 63 65 20 77 65 20 61 72 65 20 6f 6e 6c 79 20 73 ce we are only s
2d30: 75 70 70 6f 72 74 69 6e 67 20 68 74 74 70 20 74 upporting http t
2d40: 72 61 6e 73 70 6f 72 74 20 61 74 20 74 68 69 73 ransport at this
2d50: 20 74 69 6d 65 2e 0a 09 09 09 09 09 20 73 75 63 time....... suc
2d60: 63 65 73 73 0a 09 09 09 09 09 20 28 64 62 3a 73 cess...... (db:s
2d70: 74 72 69 6e 67 2d 3e 6f 62 6a 20 0a 09 09 09 09 tring->obj .....
2d80: 09 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 . (handle-excep
2d90: 74 69 6f 6e 73 0a 09 09 09 09 09 20 20 20 20 20 tions......
2da0: 20 65 78 6e 0a 09 09 09 09 09 20 20 20 20 20 20 exn......
2db0: 28 6c 65 74 20 28 28 63 61 6c 6c 2d 63 68 61 69 (let ((call-chai
2dc0: 6e 20 28 67 65 74 2d 63 61 6c 6c 2d 63 68 61 69 n (get-call-chai
2dd0: 6e 29 29 0a 09 09 09 09 09 09 20 20 20 20 28 6d n))....... (m
2de0: 73 67 20 20 20 20 20 20 20 20 28 28 63 6f 6e 64 sg ((cond
2df0: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
2e00: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
2e10: 73 73 61 67 65 29 20 65 78 6e 29 29 29 0a 09 09 ssage) exn)))...
2e20: 09 09 09 09 28 73 65 74 21 20 73 75 63 63 65 73 ....(set! succes
2e30: 73 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 s #f).
2e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e60: 20 20 20 20 20 20 28 69 66 20 28 64 65 62 75 67 (if (debug
2e70: 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 29 0a 20 :debug-mode 1).
2e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2eb0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
2ec0: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
2ed0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6f 75 6c 64 log-port* "could
2ee0: 6e 27 74 20 74 61 6c 6b 20 74 6f 20 73 65 72 76 n't talk to serv
2ef0: 65 72 2c 20 74 72 79 69 6e 67 20 61 67 61 69 6e er, trying again
2f00: 20 2e 2e 2e 22 29 0a 20 20 20 20 20 20 20 20 20 ...").
2f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f30: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
2f40: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
2f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f70: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
2f80: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
2f90: 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 log-port* "WARNI
2fa0: 4e 47 3a 20 66 61 69 6c 75 72 65 20 69 6e 20 77 NG: failure in w
2fb0: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 ith-input-from-r
2fc0: 65 71 75 65 73 74 20 74 6f 20 22 20 66 75 6c 6c equest to " full
2fd0: 75 72 6c 20 22 2e 22 29 0a 20 20 20 20 20 20 20 url ".").
2fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3010: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
3020: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3030: 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 6d 73 " message: " ms
3040: 67 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a g ", exn=" exn).
3050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3080: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
3090: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
30a0: 67 2d 70 6f 72 74 2a 20 22 20 63 6d 64 3a 20 22 g-port* " cmd: "
30b0: 20 63 6d 64 20 22 20 70 61 72 61 6d 73 3a 20 22 cmd " params: "
30c0: 20 70 61 72 61 6d 73 20 22 20 6b 65 79 3a 22 20 params " key:"
30d0: 28 6f 72 20 73 65 72 76 65 72 2d 69 64 20 22 74 (or server-id "t
30e0: 68 65 6b 65 79 22 29 29 0a 20 20 20 20 20 20 20 hekey")).
30f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3120: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
3130: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3140: 20 22 20 63 61 6c 6c 2d 63 68 61 69 6e 3a 20 22 " call-chain: "
3150: 20 63 61 6c 6c 2d 63 68 61 69 6e 29 29 29 0a 09 call-chain)))..
3160: 09 09 09 09 09 3b 3b 20 77 68 61 74 20 69 66 20 .....;; what if
3170: 61 6e 6f 74 68 65 72 20 74 68 72 65 61 64 20 69 another thread i
3180: 73 20 63 6f 6d 6d 75 6e 69 63 61 74 69 6e 67 20 s communicating
3190: 6f 6b 3f 20 43 61 6e 27 74 20 68 61 70 70 65 6e ok? Can't happen
31a0: 20 64 75 65 20 74 6f 20 6d 75 74 65 78 0a 09 09 due to mutex...
31b0: 09 09 09 09 28 68 74 74 70 2d 74 72 61 6e 73 70 ....(http-transp
31c0: 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 ort:close-connec
31d0: 74 69 6f 6e 73 20 72 75 6e 72 65 6d 6f 74 65 29 tions runremote)
31e0: 0a 09 09 09 09 09 09 28 6d 75 74 65 78 2d 75 6e .......(mutex-un
31f0: 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 lock! *http-mute
3200: 78 2a 29 0a 09 09 09 09 09 09 3b 3b 20 28 63 6c x*).......;; (cl
3210: 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 6f 6e 21 20 ose-connection!
3220: 66 75 6c 6c 75 72 6c 29 0a 09 09 09 09 09 09 28 fullurl).......(
3230: 64 62 3a 6f 62 6a 2d 3e 73 74 72 69 6e 67 20 23 db:obj->string #
3240: 66 29 29 0a 09 09 09 09 09 20 20 20 20 20 20 28 f))...... (
3250: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
3260: 72 65 71 75 65 73 74 20 3b 3b 20 77 61 73 20 64 request ;; was d
3270: 61 74 0a 09 09 09 09 09 20 20 20 20 20 20 20 66 at...... f
3280: 75 6c 6c 75 72 6c 20 0a 09 09 09 09 09 20 20 20 ullurl ......
3290: 20 20 20 20 28 6c 69 73 74 20 28 63 6f 6e 73 20 (list (cons
32a0: 27 6b 65 79 20 28 6f 72 20 73 65 72 76 65 72 2d 'key (or server-
32b0: 69 64 20 20 20 22 74 68 65 6b 65 79 22 29 29 0a id "thekey")).
32c0: 09 09 09 09 09 09 20 20 20 20 20 28 63 6f 6e 73 ...... (cons
32d0: 20 27 63 6d 64 20 63 6d 64 29 0a 09 09 09 09 09 'cmd cmd)......
32e0: 09 20 20 20 20 20 28 63 6f 6e 73 20 27 70 61 72 . (cons 'par
32f0: 61 6d 73 20 73 70 61 72 61 6d 73 29 29 0a 09 09 ams sparams))...
3300: 09 09 09 20 20 20 20 20 20 20 72 65 61 64 2d 73 ... read-s
3310: 74 72 69 6e 67 29 29 0a 09 09 09 09 09 20 20 74 tring))...... t
3320: 72 61 6e 73 70 6f 72 74 3a 20 27 68 74 74 70 29 ransport: 'http)
3330: 0a 09 09 09 09 09 20 30 29 29 20 3b 3b 20 61 64 ...... 0)) ;; ad
3340: 64 65 64 20 74 68 69 73 20 73 70 65 63 75 6c 61 ded this specula
3350: 74 69 76 65 6c 79 0a 09 09 09 20 20 20 20 20 20 tively....
3360: 3b 3b 20 53 68 6f 75 6c 64 6e 27 74 20 74 68 69 ;; Shouldn't thi
3370: 73 20 62 65 20 61 20 63 61 6c 6c 20 74 6f 20 74 s be a call to t
3380: 68 65 20 6d 61 6e 61 67 65 64 20 63 61 6c 6c 2d he managed call-
3390: 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 all-connections
33a0: 73 74 75 66 66 20 61 62 6f 76 65 3f 0a 09 09 09 stuff above?....
33b0: 20 20 20 20 20 20 3b 3b 20 28 63 6c 6f 73 65 2d ;; (close-
33c0: 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 all-connections!
33d0: 29 20 3b 3b 20 42 55 47 3f 20 57 48 59 20 49 53 ) ;; BUG? WHY IS
33e0: 20 54 48 49 53 20 48 45 52 45 3f 20 41 72 65 20 THIS HERE? Are
33f0: 77 65 20 66 61 69 6c 69 6e 67 20 74 6f 20 72 65 we failing to re
3400: 75 73 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 3f use connections?
3410: 0a 09 09 09 20 20 20 20 20 20 28 6d 75 74 65 78 .... (mutex
3420: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d -unlock! *http-m
3430: 75 74 65 78 2a 29 0a 09 09 09 20 20 20 20 20 20 utex*)....
3440: 29 29 0a 09 20 20 20 20 20 20 28 74 69 6d 65 2d )).. (time-
3450: 6f 75 74 20 20 20 20 20 28 6c 61 6d 62 64 61 20 out (lambda
3460: 28 29 0a 09 09 09 20 20 20 20 20 20 28 74 68 72 ().... (thr
3470: 65 61 64 2d 73 6c 65 65 70 21 20 34 35 29 0a 09 ead-sleep! 45)..
3480: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
3490: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
34a0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 log-port* "WARNI
34b0: 4e 47 3a 20 73 65 6e 64 2d 72 65 63 65 69 76 65 NG: send-receive
34c0: 20 74 6f 6f 6b 20 6d 6f 72 65 20 74 68 61 6e 20 took more than
34d0: 34 35 20 73 65 63 6f 6e 64 73 21 21 22 29 0a 09 45 seconds!!")..
34e0: 09 09 20 20 20 20 20 20 23 66 29 29 0a 09 20 20 .. #f))..
34f0: 20 20 20 20 28 74 68 31 20 28 6d 61 6b 65 2d 74 (th1 (make-t
3500: 68 72 65 61 64 20 73 65 6e 64 2d 72 65 63 69 65 hread send-recie
3510: 76 65 20 22 77 69 74 68 2d 69 6e 70 75 74 2d 66 ve "with-input-f
3520: 72 6f 6d 2d 72 65 71 75 65 73 74 22 29 29 0a 09 rom-request"))..
3530: 20 20 20 20 20 20 28 74 68 32 20 28 6d 61 6b 65 (th2 (make
3540: 2d 74 68 72 65 61 64 20 74 69 6d 65 2d 6f 75 74 -thread time-out
3550: 20 20 20 20 20 22 74 69 6d 65 20 6f 75 74 22 29 "time out")
3560: 29 29 0a 09 20 28 74 68 72 65 61 64 2d 73 74 61 )).. (thread-sta
3570: 72 74 21 20 74 68 31 29 0a 09 20 28 74 68 72 65 rt! th1).. (thre
3580: 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a 09 ad-start! th2)..
3590: 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 (thread-join! t
35a0: 68 31 29 0a 20 20 20 20 20 20 20 20 20 20 28 76 h1). (v
35b0: 65 63 74 6f 72 2d 73 65 74 21 20 72 65 73 20 30 ector-set! res 0
35c0: 20 73 75 63 63 65 73 73 29 0a 09 20 28 74 68 72 success).. (thr
35d0: 65 61 64 2d 74 65 72 6d 69 6e 61 74 65 21 20 74 ead-terminate! t
35e0: 68 32 29 0a 09 20 28 69 66 20 28 76 65 63 74 6f h2).. (if (vecto
35f0: 72 3f 20 72 65 73 29 0a 09 20 20 20 20 20 28 69 r? res).. (i
3600: 66 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 f (vector-ref re
3610: 73 20 30 29 20 3b 3b 20 74 68 69 73 20 69 73 20 s 0) ;; this is
3620: 74 68 65 20 66 69 72 73 74 20 66 6c 61 67 20 6f the first flag o
3630: 72 20 74 68 65 20 73 65 63 6f 6e 64 20 66 6c 61 r the second fla
3640: 67 3f 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 g? .
3650: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 65 73 (let* ((res
3660: 2d 64 61 74 20 28 76 65 63 74 6f 72 2d 72 65 66 -dat (vector-ref
3670: 20 72 65 73 20 31 29 29 29 0a 20 20 20 20 20 20 res 1))).
3680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
3690: 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 f (and (string?
36a0: 72 65 73 2d 64 61 74 29 20 28 73 74 72 69 6e 67 res-dat) (string
36b0: 2d 63 6f 6e 74 61 69 6e 73 20 72 65 73 2d 64 61 -contains res-da
36c0: 74 20 22 73 65 72 76 65 72 2d 69 64 20 6d 69 73 t "server-id mis
36d0: 6d 61 74 63 68 22 29 29 0a 20 20 20 20 20 20 20 match")).
36e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
36f0: 69 67 6e 61 6c 20 28 6d 61 6b 65 2d 63 6f 6d 70 ignal (make-comp
3700: 6f 73 69 74 65 2d 63 6f 6e 64 69 74 69 6f 6e 0a osite-condition.
3710: 09 09 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b .. (mak
3720: 65 2d 70 72 6f 70 65 72 74 79 2d 63 6f 6e 64 69 e-property-condi
3730: 74 69 6f 6e 20 0a 09 09 20 20 20 20 20 20 20 27 tion ... '
3740: 73 65 72 76 65 72 6d 69 73 6d 61 74 63 68 0a 09 servermismatch..
3750: 09 20 20 20 20 20 20 20 27 6d 65 73 73 61 67 65 . 'message
3760: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 (vector-ref re
3770: 73 20 31 29 29 29 29 20 20 20 20 20 20 20 0a 09 s 1)))) ..
3780: 09 20 20 20 20 20 20 72 65 73 29 29 20 3b 3b 20 . res)) ;;
3790: 74 68 69 73 20 69 73 20 74 68 65 20 2a 69 6e 6e this is the *inn
37a0: 65 72 2a 20 76 65 63 74 6f 72 3f 20 73 65 72 69 er* vector? seri
37b0: 6f 75 73 6c 79 3f 20 77 68 79 3f 0a 20 20 20 20 ously? why?.
37c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
37d0: 20 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f (debug:debug-mo
37e0: 64 65 20 31 31 29 0a 20 20 20 20 20 20 20 20 20 de 11).
37f0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
3800: 20 28 28 63 61 6c 6c 2d 63 68 61 69 6e 20 28 67 ((call-chain (g
3810: 65 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 29 29 et-call-chain)))
3820: 20 3b 3b 20 6e 6f 74 65 3a 20 74 68 69 73 20 63 ;; note: this c
3830: 6f 64 65 20 61 6c 73 6f 20 63 61 6c 6c 65 64 20 ode also called
3840: 69 6e 20 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 in nmsg-transpor
3850: 74 20 2d 20 63 6f 6e 73 69 64 65 72 20 63 6f 6e t - consider con
3860: 73 6f 6c 69 64 61 74 69 6e 67 20 69 74 0a 20 20 solidating it.
3870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3880: 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c (print-call
3890: 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d -chain (current-
38a0: 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 20 error-port)).
38b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
38c0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
38d0: 2d 65 72 72 6f 72 20 31 31 20 2a 64 65 66 61 75 -error 11 *defau
38e0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 65 72 lt-log-port* "er
38f0: 72 6f 72 20 61 62 6f 76 65 20 6f 63 63 75 72 65 ror above occure
3900: 64 20 61 74 20 73 65 72 76 65 72 2c 20 72 65 73 d at server, res
3910: 3d 22 20 72 65 73 29 20 3b 3b 20 22 20 6d 65 73 =" res) ;; " mes
3920: 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 sage: " ((condit
3930: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
3940: 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
3950: 61 67 65 29 20 65 78 6e 29 29 0a 20 20 20 20 20 age) exn)).
3960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3970: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
3980: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
3990: 6f 72 74 2a 20 22 20 73 65 72 76 65 72 20 63 61 ort* " server ca
39a0: 6c 6c 20 63 68 61 69 6e 3a 22 29 0a 20 20 20 20 ll chain:").
39b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
39c0: 20 20 20 28 70 70 20 28 76 65 63 74 6f 72 2d 72 (pp (vector-r
39d0: 65 66 20 72 65 73 20 31 29 20 28 63 75 72 72 65 ef res 1) (curre
39e0: 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a nt-error-port)).
39f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a00: 20 20 20 20 20 20 20 28 73 69 67 6e 61 6c 20 28 (signal (
3a10: 76 65 63 74 6f 72 2d 72 65 66 20 72 65 73 20 30 vector-ref res 0
3a20: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
3a30: 20 20 20 20 20 20 20 20 20 72 65 73 29 29 0a 09 res))..
3a40: 20 20 20 20 20 28 73 69 67 6e 61 6c 20 28 6d 61 (signal (ma
3a50: 6b 65 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 6f 6e ke-composite-con
3a60: 64 69 74 69 6f 6e 0a 09 09 20 20 20 20 20 20 28 dition... (
3a70: 6d 61 6b 65 2d 70 72 6f 70 65 72 74 79 2d 63 6f make-property-co
3a80: 6e 64 69 74 69 6f 6e 20 0a 09 09 20 20 20 20 20 ndition ...
3a90: 20 20 27 74 69 6d 65 6f 75 74 0a 09 09 20 20 20 'timeout...
3aa0: 20 20 20 20 27 6d 65 73 73 61 67 65 20 22 6e 6d 'message "nm
3ab0: 73 67 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 sg-transport:cli
3ac0: 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 ent-api-send-rec
3ad0: 65 69 76 65 2d 72 61 77 20 74 69 6d 65 64 20 6f eive-raw timed o
3ae0: 75 74 20 74 61 6c 6b 69 6e 67 20 74 6f 20 73 65 ut talking to se
3af0: 72 76 65 72 22 29 29 29 29 29 29 29 0a 0a 3b 3b rver")))))))..;;
3b00: 20 63 61 72 65 66 75 6c 20 63 6c 6f 73 69 6e 67 careful closing
3b10: 20 6f 66 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 of connections
3b20: 73 74 6f 72 65 64 20 69 6e 20 2a 72 75 6e 72 65 stored in *runre
3b30: 6d 6f 74 65 2a 0a 3b 3b 0a 28 64 65 66 69 6e 65 mote*.;;.(define
3b40: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
3b50: 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 6f :close-connectio
3b60: 6e 73 20 72 75 6e 72 65 6d 6f 74 65 29 0a 20 20 ns runremote).
3b70: 28 69 66 20 28 72 65 6d 6f 74 65 3f 20 72 75 6e (if (remote? run
3b80: 72 65 6d 6f 74 65 29 0a 20 20 20 20 20 20 28 6c remote). (l
3b90: 65 74 20 28 28 61 70 69 2d 64 61 74 20 28 72 65 et ((api-dat (re
3ba0: 6d 6f 74 65 2d 61 70 69 2d 75 72 69 20 72 75 6e mote-api-uri run
3bb0: 72 65 6d 6f 74 65 29 29 29 0a 09 28 68 61 6e 64 remote)))..(hand
3bc0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 le-exceptions..
3bd0: 20 20 20 65 78 6e 0a 09 20 20 28 62 65 67 69 6e exn.. (begin
3be0: 0a 09 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c .. (print-cal
3bf0: 6c 2d 63 68 61 69 6e 20 2a 64 65 66 61 75 6c 74 l-chain *default
3c00: 2d 6c 6f 67 2d 70 6f 72 74 2a 29 0a 09 20 20 20 -log-port*)..
3c10: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
3c20: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
3c30: 6f 67 2d 70 6f 72 74 2a 20 22 20 63 6c 6f 73 69 og-port* " closi
3c40: 6e 67 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 66 61 ng connection fa
3c50: 69 6c 65 64 20 77 69 74 68 20 65 72 72 6f 72 3a iled with error:
3c60: 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
3c70: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
3c80: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
3c90: 65 78 6e 29 20 22 2c 20 65 78 6e 3d 22 20 65 78 exn) ", exn=" ex
3ca0: 6e 29 29 0a 09 20 20 28 69 66 20 28 61 72 67 73 n)).. (if (args
3cb0: 3a 61 6e 79 2d 64 65 66 69 6e 65 64 3f 20 22 2d :any-defined? "-
3cc0: 73 65 72 76 65 72 22 20 22 2d 65 78 65 63 75 74 server" "-execut
3cd0: 65 22 20 22 2d 72 75 6e 22 29 0a 09 20 20 20 20 e" "-run")..
3ce0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
3cf0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
3d00: 6f 67 2d 70 6f 72 74 2a 20 22 43 6c 6f 73 69 6e og-port* "Closin
3d10: 67 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 74 6f g connections to
3d20: 20 22 61 70 69 2d 64 61 74 29 29 0a 09 20 20 28 "api-dat)).. (
3d30: 69 66 20 61 70 69 2d 64 61 74 20 28 63 6c 6f 73 if api-dat (clos
3d40: 65 2d 63 6f 6e 6e 65 63 74 69 6f 6e 21 20 61 70 e-connection! ap
3d50: 69 2d 64 61 74 29 29 0a 0a 09 20 20 3b 3b 20 57 i-dat))... ;; W
3d60: 6f 75 6c 64 20 69 74 20 62 65 20 62 65 74 74 65 ould it be bette
3d70: 72 20 74 6f 20 73 65 74 20 2a 72 75 6e 72 65 6d r to set *runrem
3d80: 6f 74 65 2a 20 74 6f 20 23 66 3f 20 49 20 64 6f ote* to #f? I do
3d90: 6e 27 74 20 74 68 69 6e 6b 20 73 6f 2e 20 42 75 n't think so. Bu
3da0: 74 20 77 65 20 6d 61 79 0a 09 20 20 3b 3b 20 6e t we may.. ;; n
3db0: 65 65 64 20 74 6f 20 63 6c 65 61 72 20 6d 6f 72 eed to clear mor
3dc0: 65 20 6f 66 20 74 68 65 20 72 75 6e 72 65 6d 6f e of the runremo
3dd0: 74 65 20 66 69 65 6c 64 73 0a 09 20 20 28 72 65 te fields.. (re
3de0: 6d 6f 74 65 2d 61 70 69 2d 75 72 6c 2d 73 65 74 mote-api-url-set
3df0: 21 20 72 75 6e 72 65 6d 6f 74 65 20 23 66 29 20 ! runremote #f)
3e00: 3b 3b 20 75 73 65 64 20 61 73 20 61 20 66 6c 61 ;; used as a fla
3e10: 67 20 66 6f 72 20 63 6f 6e 6e 65 63 74 69 6f 6e g for connection
3e20: 20 75 70 20 61 6e 64 20 72 75 6e 6e 69 6e 67 0a up and running.
3e30: 09 20 20 0a 09 20 20 23 74 29 29 0a 20 20 20 20 . .. #t)).
3e40: 20 20 23 66 29 29 0a 0a 3b 3b 20 72 75 6e 20 68 #f))..;; run h
3e50: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6b 65 ttp-transport:ke
3e60: 65 70 2d 72 75 6e 6e 69 6e 67 20 69 6e 20 61 20 ep-running in a
3e70: 70 61 72 61 6c 6c 65 6c 20 74 68 72 65 61 64 20 parallel thread
3e80: 74 6f 20 6d 6f 6e 69 74 6f 72 20 74 68 61 74 20 to monitor that
3e90: 74 68 65 20 64 62 20 69 73 20 62 65 69 6e 67 20 the db is being
3ea0: 0a 3b 3b 20 75 73 65 64 20 61 6e 64 20 74 6f 20 .;; used and to
3eb0: 73 68 75 74 64 6f 77 6e 20 61 66 74 65 72 20 73 shutdown after s
3ec0: 6f 6d 65 74 69 6d 65 20 69 66 20 69 74 20 69 73 ometime if it is
3ed0: 20 6e 6f 74 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 not..;;.(define
3ee0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
3ef0: 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 29 20 0a :keep-running) .
3f00: 20 20 3b 3b 20 69 66 20 6e 6f 6e 65 20 72 75 6e ;; if none run
3f10: 6e 69 6e 67 20 6f 72 20 69 66 20 3e 20 32 30 20 ning or if > 20
3f20: 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 0a 20 seconds since .
3f30: 20 3b 3b 20 73 65 72 76 65 72 20 6c 61 73 74 20 ;; server last
3f40: 75 73 65 64 20 74 68 65 6e 20 73 74 61 72 74 20 used then start
3f50: 73 68 75 74 64 6f 77 6e 0a 20 20 3b 3b 20 54 68 shutdown. ;; Th
3f60: 69 73 20 74 68 72 65 61 64 20 77 61 69 74 73 20 is thread waits
3f70: 66 6f 72 20 74 68 65 20 73 65 72 76 65 72 20 74 for the server t
3f80: 6f 20 63 6f 6d 65 20 61 6c 69 76 65 0a 20 20 28 o come alive. (
3f90: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
3fa0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
3fb0: 70 6f 72 74 2a 20 22 53 74 61 72 74 69 6e 67 20 port* "Starting
3fc0: 74 68 65 20 73 79 6e 63 2d 62 61 63 6b 2c 20 6b the sync-back, k
3fd0: 65 65 70 20 61 6c 69 76 65 20 74 68 72 65 61 64 eep alive thread
3fe0: 20 69 6e 20 73 65 72 76 65 72 22 29 0a 20 20 28 in server"). (
3ff0: 6c 65 74 2a 20 28 28 73 65 72 76 69 6e 66 6f 66 let* ((servinfof
4000: 69 6c 65 20 20 20 20 20 20 23 66 29 0a 09 20 28 ile #f).. (
4010: 73 64 61 74 20 20 20 20 20 20 20 20 20 20 20 20 sdat
4020: 20 20 23 66 29 0a 09 20 28 6e 6f 2d 73 79 6e 63 #f).. (no-sync
4030: 2d 64 62 20 20 20 20 20 20 20 20 28 64 62 3a 6f -db (db:o
4040: 70 65 6e 2d 6e 6f 2d 73 79 6e 63 2d 64 62 29 29 pen-no-sync-db))
4050: 0a 09 20 28 74 6d 70 2d 61 72 65 61 20 20 20 20 .. (tmp-area
4060: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 (common:ge
4070: 74 2d 64 62 2d 74 6d 70 2d 61 72 65 61 29 29 0a t-db-tmp-area)).
4080: 09 20 28 73 74 61 72 74 65 64 2d 66 69 6c 65 20 . (started-file
4090: 20 20 20 20 20 28 63 6f 6e 63 20 74 6d 70 2d 61 (conc tmp-a
40a0: 72 65 61 20 22 2f 2e 73 65 72 76 65 72 2d 73 74 rea "/.server-st
40b0: 61 72 74 65 64 22 29 29 0a 09 20 28 73 65 72 76 arted")).. (serv
40c0: 65 72 2d 73 74 61 72 74 2d 74 69 6d 65 20 28 63 er-start-time (c
40d0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
40e0: 0a 09 20 28 73 65 72 76 65 72 2d 69 6e 66 6f 20 .. (server-info
40f0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 73 74 61 72 (let loop ((star
4100: 74 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d t-time (current-
4110: 73 65 63 6f 6e 64 73 29 29 0a 09 09 09 09 20 28 seconds))..... (
4120: 63 68 61 6e 67 65 64 20 20 20 20 23 74 29 0a 09 changed #t)..
4130: 09 09 09 20 28 6c 61 73 74 2d 73 64 61 74 20 20 ... (last-sdat
4140: 22 6e 6f 74 20 74 68 69 73 22 29 29 0a 20 20 20 "not this")).
4150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4160: 20 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 6c (begin ;; l
4170: 65 74 20 28 28 73 64 61 74 20 23 66 29 29 0a 09 et ((sdat #f))..
4180: 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .. (thread-slee
4190: 70 21 20 30 2e 30 31 29 0a 09 09 09 20 20 28 64 p! 0.01).... (d
41a0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
41b0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
41c0: 6f 72 74 2a 20 22 57 61 69 74 69 6e 67 20 66 6f ort* "Waiting fo
41d0: 72 20 73 65 72 76 65 72 20 61 6c 69 76 65 20 73 r server alive s
41e0: 69 67 6e 61 74 75 72 65 22 29 0a 20 20 20 20 20 ignature").
41f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4200: 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b (mutex-lock
4210: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
4220: 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 ex*).
4230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4240: 73 65 74 21 20 73 64 61 74 20 2a 73 65 72 76 65 set! sdat *serve
4250: 72 2d 69 6e 66 6f 2a 29 0a 20 20 20 20 20 20 20 r-info*).
4260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4270: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
4280: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
4290: 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 ex*).
42a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
42b0: 69 66 20 28 61 6e 64 20 73 64 61 74 0a 09 09 09 if (and sdat....
42c0: 09 20 20 20 28 6e 6f 74 20 63 68 61 6e 67 65 64 . (not changed
42d0: 29 0a 09 09 09 09 20 20 20 28 3e 20 28 2d 20 28 )..... (> (- (
42e0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
42f0: 20 73 74 61 72 74 2d 74 69 6d 65 29 20 32 29 29 start-time) 2))
4300: 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 2a 20 .... (let*
4310: 28 28 73 65 72 76 69 6e 66 6f 64 69 72 20 28 73 ((servinfodir (s
4320: 65 72 76 65 72 3a 67 65 74 2d 73 65 72 76 69 6e erver:get-servin
4330: 66 6f 2d 64 69 72 20 2a 74 6f 70 70 61 74 68 2a fo-dir *toppath*
4340: 29 29 20 3b 3b 20 28 63 6f 6e 63 20 2a 74 6f 70 )) ;; (conc *top
4350: 70 61 74 68 2a 22 2f 2e 73 65 72 76 69 6e 66 6f path*"/.servinfo
4360: 22 29 29 0a 09 09 09 09 20 20 20 20 20 28 69 70 "))..... (ip
4370: 61 64 64 72 20 20 20 20 20 20 28 63 61 72 20 73 addr (car s
4380: 64 61 74 29 29 0a 09 09 09 09 20 20 20 20 20 28 dat))..... (
4390: 70 6f 72 74 20 20 20 20 20 20 20 20 28 63 61 64 port (cad
43a0: 72 20 73 64 61 74 29 29 0a 09 09 09 09 20 20 20 r sdat)).....
43b0: 20 20 28 73 65 72 76 69 6e 66 20 20 20 20 20 28 (servinf (
43c0: 63 6f 6e 63 20 73 65 72 76 69 6e 66 6f 64 69 72 conc servinfodir
43d0: 22 2f 22 69 70 61 64 64 72 22 3a 22 70 6f 72 74 "/"ipaddr":"port
43e0: 29 29 29 0a 09 09 09 09 28 73 65 74 21 20 73 65 ))).....(set! se
43f0: 72 76 69 6e 66 6f 66 69 6c 65 20 73 65 72 76 69 rvinfofile servi
4400: 6e 66 29 0a 09 09 09 09 28 69 66 20 28 6e 6f 74 nf).....(if (not
4410: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 (file-exists? s
4420: 65 72 76 69 6e 66 6f 64 69 72 29 29 0a 09 09 09 ervinfodir))....
4430: 09 20 20 20 20 28 63 72 65 61 74 65 2d 64 69 72 . (create-dir
4440: 65 63 74 6f 72 79 20 73 65 72 76 69 6e 66 6f 64 ectory servinfod
4450: 69 72 20 23 74 29 29 0a 09 09 09 09 28 77 69 74 ir #t)).....(wit
4460: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 h-output-to-file
4470: 20 73 65 72 76 69 6e 66 0a 09 09 09 09 20 20 28 servinf..... (
4480: 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 20 20 lambda ().....
4490: 20 20 28 6c 65 74 2a 20 28 28 73 65 72 76 2d 69 (let* ((serv-i
44a0: 64 20 28 73 65 72 76 65 72 3a 6d 6b 2d 73 69 67 d (server:mk-sig
44b0: 6e 61 74 75 72 65 29 29 29 0a 09 09 09 09 20 20 nature))).....
44c0: 20 20 20 20 28 73 65 74 21 20 2a 73 65 72 76 65 (set! *serve
44d0: 72 2d 69 64 2a 20 73 65 72 76 2d 69 64 29 0a 09 r-id* serv-id)..
44e0: 09 09 09 20 20 20 20 20 20 28 70 72 69 6e 74 20 ... (print
44f0: 22 53 45 52 56 45 52 20 53 54 41 52 54 45 44 3a "SERVER STARTED:
4500: 20 22 69 70 61 64 64 72 22 3a 22 70 6f 72 74 22 "ipaddr":"port"
4510: 20 41 54 20 22 28 63 75 72 72 65 6e 74 2d 73 65 AT "(current-se
4520: 63 6f 6e 64 73 29 22 20 73 65 72 76 65 72 2d 69 conds)" server-i
4530: 64 3a 20 22 73 65 72 76 2d 69 64 22 20 70 69 64 d: "serv-id" pid
4540: 3a 20 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 : "(current-proc
4550: 65 73 73 2d 69 64 29 29 0a 09 09 09 09 20 20 20 ess-id)).....
4560: 20 20 20 28 70 72 69 6e 74 20 22 73 74 61 72 74 (print "start
4570: 65 64 3a 20 22 28 73 65 63 6f 6e 64 73 2d 3e 79 ed: "(seconds->y
4580: 65 61 72 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d ear-week/day-tim
4590: 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e e (current-secon
45a0: 64 73 29 29 29 29 29 29 0a 09 09 09 09 28 73 65 ds)))))).....(se
45b0: 74 21 20 2a 6f 6e 2d 65 78 69 74 2d 70 72 6f 63 t! *on-exit-proc
45c0: 73 2a 20 28 63 6f 6e 73 0a 09 09 09 09 09 09 20 s* (cons.......
45d0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
45e0: 0a 09 09 09 09 09 09 09 20 28 64 65 6c 65 74 65 ........ (delete
45f0: 2d 66 69 6c 65 2a 20 73 65 72 76 69 6e 66 29 29 -file* servinf))
4600: 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 2a 6f ....... *o
4610: 6e 2d 65 78 69 74 2d 70 72 6f 63 73 2a 29 29 0a n-exit-procs*)).
4620: 09 09 09 09 3b 3b 20 70 75 74 20 64 61 74 61 20 ....;; put data
4630: 61 62 6f 75 74 20 74 68 69 73 20 73 65 72 76 65 about this serve
4640: 72 20 69 6e 74 6f 20 61 20 73 69 6d 70 6c 65 20 r into a simple
4650: 66 6c 61 74 20 66 69 6c 65 20 68 6f 73 74 2e 70 flat file host.p
4660: 6f 72 74 0a 09 09 09 09 28 64 65 62 75 67 3a 70 ort.....(debug:p
4670: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
4680: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4690: 52 65 63 65 69 76 65 64 20 73 65 72 76 65 72 20 Received server
46a0: 61 6c 69 76 65 20 73 69 67 6e 61 74 75 72 65 22 alive signature"
46b0: 29 0a 09 09 09 09 73 64 61 74 29 0a 20 20 20 20 ).....sdat).
46c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
46d0: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
46e0: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
46f0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
4700: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 74 69 t-log-port* "Sti
4710: 6c 6c 20 77 61 69 74 69 6e 67 2c 20 6c 61 73 74 ll waiting, last
4720: 2d 73 64 61 74 3d 22 20 6c 61 73 74 2d 73 64 61 -sdat=" last-sda
4730: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
4740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4750: 20 20 20 28 73 6c 65 65 70 20 34 29 0a 09 09 09 (sleep 4)....
4760: 09 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 .(if (> (- (curr
4770: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 74 61 ent-seconds) sta
4780: 72 74 2d 74 69 6d 65 29 20 31 32 30 29 20 3b 3b rt-time) 120) ;;
4790: 20 62 65 65 6e 20 77 61 69 74 69 6e 67 20 66 6f been waiting fo
47a0: 72 20 74 77 6f 20 6d 69 6e 75 74 65 73 0a 20 20 r two minutes.
47b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
47c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
47d0: 20 20 28 69 66 20 73 64 61 74 20 0a 09 09 09 09 (if sdat .....
47e0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 69 70 (let* ((ip
47f0: 61 64 64 72 20 20 28 63 61 72 20 73 64 61 74 29 addr (car sdat)
4800: 29 0a 09 09 09 09 09 20 20 20 28 70 6f 72 74 20 )...... (port
4810: 20 20 20 28 63 61 64 72 20 73 64 61 74 29 29 0a (cadr sdat)).
4820: 09 09 09 09 09 20 20 20 28 73 65 72 76 69 6e 66 ..... (servinf
4830: 20 28 63 6f 6e 63 20 28 73 65 72 76 65 72 3a 67 (conc (server:g
4840: 65 74 2d 73 65 72 76 69 6e 66 6f 2d 64 69 72 20 et-servinfo-dir
4850: 2a 74 6f 70 70 61 74 68 2a 29 22 2f 22 69 70 61 *toppath*)"/"ipa
4860: 64 64 72 22 3a 22 70 6f 72 74 29 29 29 0a 09 09 ddr":"port)))...
4870: 09 09 20 20 20 20 20 20 20 20 28 64 65 62 75 67 .. (debug
4880: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
4890: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
48a0: 2a 20 22 74 72 61 6e 73 70 6f 72 74 20 61 70 70 * "transport app
48b0: 65 61 72 73 20 74 6f 20 68 61 76 65 20 64 69 65 ears to have die
48c0: 64 2c 20 65 78 69 74 69 6e 67 20 73 65 72 76 65 d, exiting serve
48d0: 72 22 29 0a 09 09 09 09 20 20 20 20 20 20 28 65 r")..... (e
48e0: 78 69 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 xit)).
48f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4900: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 (exi
4910: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
4920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4930: 20 20 20 20 20 20 20 29 0a 09 09 09 09 20 20 20 ).....
4940: 20 28 6c 6f 6f 70 20 73 74 61 72 74 2d 74 69 6d (loop start-tim
4950: 65 0a 09 09 09 09 09 20 20 28 65 71 75 61 6c 3f e...... (equal?
4960: 20 73 64 61 74 20 6c 61 73 74 2d 73 64 61 74 29 sdat last-sdat)
4970: 0a 09 09 09 09 09 20 20 73 64 61 74 29 29 29 29 ...... sdat))))
4980: 29 29 29 0a 09 20 28 69 66 61 63 65 20 20 20 20 ))).. (iface
4990: 20 20 20 28 63 61 72 20 73 65 72 76 65 72 2d 69 (car server-i
49a0: 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 28 nfo)). (
49b0: 70 6f 72 74 20 20 20 20 20 20 20 20 28 63 61 64 port (cad
49c0: 72 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 29 0a r server-info)).
49d0: 20 20 20 20 20 20 20 20 20 28 6c 61 73 74 2d 61 (last-a
49e0: 63 63 65 73 73 20 30 29 0a 09 20 28 73 65 72 76 ccess 0).. (serv
49f0: 65 72 2d 74 69 6d 65 6f 75 74 20 28 73 65 72 76 er-timeout (serv
4a00: 65 72 3a 65 78 70 69 72 61 74 69 6f 6e 2d 74 69 er:expiration-ti
4a10: 6d 65 6f 75 74 29 29 0a 09 20 28 73 65 72 76 65 meout)).. (serve
4a20: 72 2d 67 6f 69 6e 67 20 20 23 66 29 0a 09 20 28 r-going #f).. (
4a30: 73 65 72 76 65 72 2d 6c 6f 67 2d 66 69 6c 65 20 server-log-file
4a40: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
4a50: 6c 6f 67 22 29 29 29 20 3b 3b 20 61 6c 77 61 79 log"))) ;; alway
4a60: 73 20 73 65 74 20 77 68 65 6e 20 77 65 20 61 72 s set when we ar
4a70: 65 20 61 20 73 65 72 76 65 72 0a 0a 20 20 20 20 e a server..
4a80: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
4a90: 6e 73 0a 09 65 78 6e 0a 20 20 20 20 20 20 28 64 ns..exn. (d
4aa0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
4ab0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
4ac0: 22 46 61 69 6c 65 64 20 74 6f 20 63 72 65 61 74 "Failed to creat
4ad0: 65 20 22 20 73 74 61 72 74 65 64 2d 66 69 6c 65 e " started-file
4ae0: 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a 20 ", exn=" exn).
4af0: 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 (with-outpu
4b00: 74 2d 74 6f 2d 66 69 6c 65 20 73 74 61 72 74 65 t-to-file starte
4b10: 64 2d 66 69 6c 65 20 28 6c 61 6d 62 64 61 20 28 d-file (lambda (
4b20: 29 28 70 72 69 6e 74 20 28 63 75 72 72 65 6e 74 )(print (current
4b30: 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 29 29 -process-id)))))
4b40: 0a 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 .. (let loop
4b50: 28 28 63 6f 75 6e 74 20 20 20 20 20 20 20 20 20 ((count
4b60: 30 29 0a 09 20 20 20 20 20 20 20 28 73 65 72 76 0).. (serv
4b70: 65 72 2d 73 74 61 74 65 20 27 61 76 61 69 6c 61 er-state 'availa
4b80: 62 6c 65 29 0a 09 20 20 20 20 20 20 20 28 62 61 ble).. (ba
4b90: 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 30 29 0a d-sync-count 0).
4ba0: 09 20 20 20 20 20 20 20 28 73 74 61 72 74 2d 74 . (start-t
4bb0: 69 6d 65 20 20 20 20 20 28 63 75 72 72 65 6e 74 ime (current
4bc0: 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 -milliseconds)))
4bd0: 0a 0a 20 20 20 20 20 20 3b 3b 20 55 73 65 20 74 .. ;; Use t
4be0: 68 69 73 20 6f 70 70 6f 72 74 75 6e 69 74 79 20 his opportunity
4bf0: 74 6f 20 73 79 6e 63 20 74 68 65 20 74 6d 70 20 to sync the tmp
4c00: 64 62 20 74 6f 20 6d 65 67 61 74 65 73 74 2e 64 db to megatest.d
4c10: 62 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 b. (if (not
4c20: 20 73 65 72 76 65 72 2d 67 6f 69 6e 67 29 20 3b server-going) ;
4c30: 3b 20 2a 64 62 73 74 72 75 63 74 2d 64 62 73 2a ; *dbstruct-dbs*
4c40: 20 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 .. (begin..
4c50: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
4c60: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
4c70: 74 2a 20 22 53 45 52 56 45 52 3a 20 64 62 70 72 t* "SERVER: dbpr
4c80: 65 70 22 29 0a 09 20 20 20 20 28 73 65 74 21 20 ep").. (set!
4c90: 2a 64 62 73 74 72 75 63 74 2d 64 62 73 2a 20 20 *dbstruct-dbs*
4ca0: 28 64 62 3a 73 65 74 75 70 20 23 74 29 29 20 3b (db:setup #t)) ;
4cb0: 3b 20 20 72 75 6e 2d 69 64 29 29 20 46 49 58 4d ; run-id)) FIXM
4cc0: 45 21 21 21 0a 09 20 20 20 20 28 73 65 74 21 20 E!!!.. (set!
4cd0: 73 65 72 76 65 72 2d 67 6f 69 6e 67 20 23 74 29 server-going #t)
4ce0: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
4cf0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
4d00: 67 2d 70 6f 72 74 2a 20 22 53 45 52 56 45 52 3a g-port* "SERVER:
4d10: 20 72 75 6e 6e 69 6e 67 2c 20 6d 65 67 61 74 65 running, megate
4d20: 73 74 20 76 65 72 73 69 6f 6e 3a 20 22 20 28 63 st version: " (c
4d30: 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 75 6c 6c 2d 76 ommon:get-full-v
4d40: 65 72 73 69 6f 6e 29 29 29 20 3b 3b 20 4e 4f 54 ersion))) ;; NOT
4d50: 45 3a 20 74 68 65 20 73 65 72 76 65 72 20 69 73 E: the server is
4d60: 20 4e 4f 54 20 79 65 74 20 6d 61 72 6b 65 64 20 NOT yet marked
4d70: 61 73 20 72 75 6e 6e 69 6e 67 20 69 6e 20 74 68 as running in th
4d80: 65 20 6c 6f 67 2e 20 57 65 20 64 6f 20 74 68 61 e log. We do tha
4d90: 74 20 69 6e 20 74 68 65 20 6b 65 65 70 2d 72 75 t in the keep-ru
4da0: 6e 6e 69 6e 67 20 72 6f 75 74 69 6e 65 2e 0a 09 nning routine...
4db0: 20 20 28 69 66 20 28 61 6e 64 20 6e 6f 2d 73 79 (if (and no-sy
4dc0: 6e 63 2d 64 62 0a 09 09 20 20 20 28 63 6f 6d 6d nc-db... (comm
4dd0: 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 on:low-noise-pri
4de0: 6e 74 20 31 30 20 22 73 79 6e 63 2d 61 6c 6c 22 nt 10 "sync-all"
4df0: 29 29 20 3b 3b 20 63 68 65 65 73 79 20 77 61 79 )) ;; cheesy way
4e00: 20 74 6f 20 72 65 64 75 63 65 20 66 72 65 71 75 to reduce frequ
4e10: 65 6e 63 79 20 6f 66 20 72 75 6e 6e 69 6e 67 20 ency of running
4e20: 73 79 6e 63 20 3a 29 0a 20 20 20 20 20 20 20 20 sync :).
4e30: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 (begin...(
4e40: 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e if (common:low-n
4e50: 6f 69 73 65 2d 70 72 69 6e 74 20 31 32 30 20 22 oise-print 120 "
4e60: 73 79 6e 63 2d 61 6c 6c 2d 70 72 69 6e 74 22 29 sync-all-print")
4e70: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4e80: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
4e90: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
4ea0: 2d 70 6f 72 74 2a 20 22 6b 65 65 70 2d 72 75 6e -port* "keep-run
4eb0: 6e 69 6e 67 20 63 61 6c 6c 69 6e 67 20 64 62 3a ning calling db:
4ec0: 61 6c 6c 2d 64 62 2d 73 79 6e 63 20 61 74 20 22 all-db-sync at "
4ed0: 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 28 (time->string (
4ee0: 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 seconds->local-t
4ef0: 69 6d 65 29 20 22 25 48 3a 25 4d 3a 25 53 22 29 ime) "%H:%M:%S")
4f00: 29 29 0a 09 09 28 64 62 3a 61 6c 6c 2d 64 62 2d ))...(db:all-db-
4f10: 73 79 6e 63 20 2a 64 62 73 74 72 75 63 74 2d 64 sync *dbstruct-d
4f20: 62 73 2a 29 0a 09 09 29 29 29 0a 20 20 20 20 20 bs*)...))).
4f30: 20 0a 20 20 20 20 20 20 3b 3b 20 77 68 65 6e 20 . ;; when
4f40: 74 68 69 6e 67 73 20 67 6f 20 77 72 6f 6e 67 20 things go wrong
4f50: 77 65 20 64 6f 6e 27 74 20 77 61 6e 74 20 74 6f we don't want to
4f60: 20 62 65 20 64 6f 69 6e 67 20 74 68 65 20 76 61 be doing the va
4f70: 72 69 6f 75 73 20 71 75 65 72 69 65 73 20 74 6f rious queries to
4f80: 6f 20 6f 66 74 65 6e 0a 20 20 20 20 20 20 3b 3b o often. ;;
4f90: 20 73 6f 20 77 65 20 73 74 72 69 76 65 20 74 6f so we strive to
4fa0: 20 72 75 6e 20 74 68 69 73 20 73 74 75 66 66 20 run this stuff
4fb0: 6f 6e 6c 79 20 65 76 65 72 79 20 66 6f 75 72 20 only every four
4fc0: 73 65 63 6f 6e 64 73 20 6f 72 20 73 6f 2e 0a 20 seconds or so..
4fd0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 79 6e (let* ((syn
4fe0: 63 2d 74 69 6d 65 20 28 2d 20 28 63 75 72 72 65 c-time (- (curre
4ff0: 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
5000: 20 73 74 61 72 74 2d 74 69 6d 65 29 29 0a 09 20 start-time))..
5010: 20 20 20 28 72 65 6d 2d 74 69 6d 65 20 20 28 71 (rem-time (q
5020: 75 6f 74 69 65 6e 74 20 28 2d 20 34 30 30 30 20 uotient (- 4000
5030: 73 79 6e 63 2d 74 69 6d 65 29 20 31 30 30 30 29 sync-time) 1000)
5040: 29 29 0a 09 28 69 66 20 28 61 6e 64 20 28 3c 3d ))..(if (and (<=
5050: 20 72 65 6d 2d 74 69 6d 65 20 34 29 0a 09 09 20 rem-time 4)...
5060: 28 3e 20 20 72 65 6d 2d 74 69 6d 65 20 30 29 29 (> rem-time 0))
5070: 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c .. (thread-sl
5080: 65 65 70 21 20 72 65 6d 2d 74 69 6d 65 29 29 29 eep! rem-time)))
5090: 0a 20 20 20 20 20 20 0a 20 20 20 20 20 20 28 69 . . (i
50a0: 66 20 28 3c 20 63 6f 75 6e 74 20 31 29 20 3b 3b f (< count 1) ;;
50b0: 20 33 78 33 20 3d 20 39 20 73 65 63 73 20 61 70 3x3 = 9 secs ap
50c0: 72 6f 78 0a 09 20 20 28 6c 6f 6f 70 20 28 2b 20 rox.. (loop (+
50d0: 63 6f 75 6e 74 20 31 29 20 27 72 75 6e 6e 69 6e count 1) 'runnin
50e0: 67 20 62 61 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 g bad-sync-count
50f0: 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 (current-millis
5100: 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 20 econds))).
5110: 0a 20 20 20 20 20 20 3b 3b 20 43 68 65 63 6b 20 . ;; Check
5120: 74 68 61 74 20 69 66 61 63 65 20 61 6e 64 20 70 that iface and p
5130: 6f 72 74 20 68 61 76 65 20 6e 6f 74 20 63 68 61 ort have not cha
5140: 6e 67 65 64 20 28 63 61 6e 20 68 61 70 70 65 6e nged (can happen
5150: 20 69 66 20 73 65 72 76 65 72 20 70 6f 72 74 20 if server port
5160: 63 6f 6c 6c 69 64 65 73 29 0a 20 20 20 20 20 20 collides).
5170: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 (mutex-lock! *he
5180: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
5190: 20 20 20 20 20 20 28 73 65 74 21 20 73 64 61 74 (set! sdat
51a0: 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 29 0a *server-info*).
51b0: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
51c0: 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d ock! *heartbeat-
51d0: 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 0a 20 mutex*). .
51e0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 (if (not (e
51f0: 71 75 61 6c 3f 20 73 64 61 74 20 28 6c 69 73 74 qual? sdat (list
5200: 20 69 66 61 63 65 20 70 6f 72 74 29 29 29 0a 09 iface port)))..
5210: 20 20 28 6c 65 74 20 28 28 6e 65 77 2d 69 66 61 (let ((new-ifa
5220: 63 65 20 28 63 61 72 20 73 64 61 74 29 29 0a 09 ce (car sdat))..
5230: 09 28 6e 65 77 2d 70 6f 72 74 20 20 28 63 61 64 .(new-port (cad
5240: 72 20 73 64 61 74 29 29 29 0a 09 20 20 20 20 28 r sdat))).. (
5250: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
5260: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
5270: 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
5280: 69 6e 74 65 72 66 61 63 65 20 63 68 61 6e 67 65 interface change
5290: 64 2c 20 72 65 66 72 65 73 68 69 6e 67 20 69 66 d, refreshing if
52a0: 61 63 65 20 61 6e 64 20 70 6f 72 74 20 69 6e 66 ace and port inf
52b0: 6f 22 29 0a 09 20 20 20 20 28 73 65 74 21 20 69 o").. (set! i
52c0: 66 61 63 65 20 6e 65 77 2d 69 66 61 63 65 29 0a face new-iface).
52d0: 09 20 20 20 20 28 73 65 74 21 20 70 6f 72 74 20 . (set! port
52e0: 20 6e 65 77 2d 70 6f 72 74 29 0a 20 20 20 20 20 new-port).
52f0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 (if (not
5300: 20 2a 73 65 72 76 65 72 2d 69 64 2a 29 0a 09 09 *server-id*)...
5310: 20 28 73 65 74 21 20 2a 73 65 72 76 65 72 2d 69 (set! *server-i
5320: 64 2a 20 28 73 65 72 76 65 72 3a 6d 6b 2d 73 69 d* (server:mk-si
5330: 67 6e 61 74 75 72 65 29 29 29 0a 09 20 20 20 20 gnature)))..
5340: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
5350: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
5360: 2a 20 22 53 45 52 56 45 52 20 53 54 41 52 54 45 * "SERVER STARTE
5370: 44 3a 20 22 20 69 66 61 63 65 20 22 3a 22 20 70 D: " iface ":" p
5380: 6f 72 74 20 22 20 41 54 20 22 20 28 63 75 72 72 ort " AT " (curr
5390: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 22 20 73 ent-seconds) " s
53a0: 65 72 76 65 72 2d 69 64 3a 20 22 20 2a 73 65 72 erver-id: " *ser
53b0: 76 65 72 2d 69 64 2a 29 0a 09 20 20 20 20 28 66 ver-id*).. (f
53c0: 6c 75 73 68 2d 6f 75 74 70 75 74 20 2a 64 65 66 lush-output *def
53d0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 29 29 ault-log-port*))
53e0: 29 0a 20 20 20 20 20 20 0a 20 20 20 20 20 20 3b ). . ;
53f0: 3b 20 54 72 61 6e 73 66 65 72 20 2a 64 62 2d 6c ; Transfer *db-l
5400: 61 73 74 2d 61 63 63 65 73 73 2a 20 74 6f 20 6c ast-access* to l
5410: 61 73 74 2d 61 63 63 65 73 73 20 74 6f 20 75 73 ast-access to us
5420: 65 20 69 6e 20 63 68 65 63 6b 69 6e 67 20 74 68 e in checking th
5430: 61 74 20 77 65 20 61 72 65 20 73 74 69 6c 6c 20 at we are still
5440: 61 6c 69 76 65 0a 20 20 20 20 20 20 28 6d 75 74 alive. (mut
5450: 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 ex-lock! *heartb
5460: 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 eat-mutex*).
5470: 20 20 28 73 65 74 21 20 6c 61 73 74 2d 61 63 63 (set! last-acc
5480: 65 73 73 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 ess *db-last-acc
5490: 65 73 73 2a 29 0a 20 20 20 20 20 20 28 6d 75 74 ess*). (mut
54a0: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 ex-unlock! *hear
54b0: 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 tbeat-mutex*).
54c0: 20 20 20 20 0a 20 20 20 20 20 20 28 69 66 20 28 . (if (
54d0: 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 common:low-noise
54e0: 2d 70 72 69 6e 74 20 31 32 30 20 28 63 6f 6e 63 -print 120 (conc
54f0: 20 22 73 65 72 76 65 72 20 72 75 6e 6e 69 6e 67 "server running
5500: 20 6f 6e 20 22 20 69 66 61 63 65 20 22 3a 22 20 on " iface ":"
5510: 70 6f 72 74 29 29 0a 09 20 20 28 62 65 67 69 6e port)).. (begin
5520: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 . (i
5530: 66 20 28 6e 6f 74 20 2a 73 65 72 76 65 72 2d 69 f (not *server-i
5540: 64 2a 29 0a 09 09 20 28 73 65 74 21 20 2a 73 65 d*)... (set! *se
5550: 72 76 65 72 2d 69 64 2a 20 28 73 65 72 76 65 72 rver-id* (server
5560: 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 29 29 :mk-signature)))
5570: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 . (d
5580: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
5590: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
55a0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
55b0: 29 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 ) (current-direc
55c0: 74 6f 72 79 29 20 28 63 75 72 72 65 6e 74 2d 70 tory) (current-p
55d0: 72 6f 63 65 73 73 2d 69 64 29 20 28 61 72 67 76 rocess-id) (argv
55e0: 29 29 20 20 20 0a 09 20 20 20 20 20 28 64 65 62 )) .. (deb
55f0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
5600: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 ult-log-port* "S
5610: 45 52 56 45 52 20 53 54 41 52 54 45 44 3a 20 22 ERVER STARTED: "
5620: 20 69 66 61 63 65 20 22 3a 22 20 70 6f 72 74 20 iface ":" port
5630: 22 20 41 54 20 22 20 28 63 75 72 72 65 6e 74 2d " AT " (current-
5640: 73 65 63 6f 6e 64 73 29 20 22 20 73 65 72 76 65 seconds) " serve
5650: 72 2d 69 64 3a 20 22 20 2a 73 65 72 76 65 72 2d r-id: " *server-
5660: 69 64 2a 29 0a 09 20 20 20 20 20 28 66 6c 75 73 id*).. (flus
5670: 68 2d 6f 75 74 70 75 74 20 2a 64 65 66 61 75 6c h-output *defaul
5680: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 29 29 29 0a 20 t-log-port*))).
5690: 20 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e (if (common
56a0: 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 :low-noise-print
56b0: 20 36 30 20 22 64 62 73 74 61 74 73 22 29 0a 09 60 "dbstats")..
56c0: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 64 (begin.. (d
56d0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
56e0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
56f0: 22 53 65 72 76 65 72 20 73 74 61 74 73 3a 22 29 "Server stats:")
5700: 0a 09 20 20 20 20 28 64 62 3a 70 72 69 6e 74 2d .. (db:print-
5710: 63 75 72 72 65 6e 74 2d 71 75 65 72 79 2d 73 74 current-query-st
5720: 61 74 73 29 29 29 0a 20 20 20 20 20 20 28 6c 65 ats))). (le
5730: 74 2a 20 28 28 68 72 73 2d 73 69 6e 63 65 2d 73 t* ((hrs-since-s
5740: 74 61 72 74 20 20 28 2f 20 28 2d 20 28 63 75 72 tart (/ (- (cur
5750: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 65 rent-seconds) se
5760: 72 76 65 72 2d 73 74 61 72 74 2d 74 69 6d 65 29 rver-start-time)
5770: 20 33 36 30 30 29 29 29 0a 09 28 63 6f 6e 64 0a 3600)))..(cond.
5780: 20 20 20 20 20 20 20 20 20 28 28 61 6e 64 20 2a ((and *
5790: 73 65 72 76 65 72 2d 72 75 6e 2a 0a 09 20 20 20 server-run*..
57a0: 20 20 20 20 28 3e 20 28 2b 20 6c 61 73 74 2d 61 (> (+ last-a
57b0: 63 63 65 73 73 20 73 65 72 76 65 72 2d 74 69 6d ccess server-tim
57c0: 65 6f 75 74 29 0a 09 09 20 20 28 63 75 72 72 65 eout)... (curre
57d0: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 nt-seconds))).
57e0: 20 20 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d (if (com
57f0: 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 mon:low-noise-pr
5800: 69 6e 74 20 31 32 30 20 22 73 65 72 76 65 72 20 int 120 "server
5810: 63 6f 6e 74 69 6e 75 69 6e 67 22 29 0a 20 20 20 continuing").
5820: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
5830: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
5840: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
5850: 2a 20 22 53 65 72 76 65 72 20 63 6f 6e 74 69 6e * "Server contin
5860: 75 69 6e 67 2c 20 73 65 63 6f 6e 64 73 20 73 69 uing, seconds si
5870: 6e 63 65 20 6c 61 73 74 20 64 62 20 61 63 63 65 nce last db acce
5880: 73 73 3a 20 22 20 28 2d 20 28 63 75 72 72 65 6e ss: " (- (curren
5890: 74 2d 73 65 63 6f 6e 64 73 29 20 6c 61 73 74 2d t-seconds) last-
58a0: 61 63 63 65 73 73 29 29 0a 09 20 20 20 20 20 20 access))..
58b0: 28 6c 65 74 20 28 28 63 75 72 72 2d 74 69 6d 65 (let ((curr-time
58c0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
58d0: 73 29 29 29 0a 09 09 28 68 61 6e 64 6c 65 2d 65 s)))...(handle-e
58e0: 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 20 20 20 xceptions...
58f0: 65 78 6e 0a 09 09 20 20 20 20 28 64 65 62 75 67 exn... (debug
5900: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
5910: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 t-log-port* "ERR
5920: 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 63 68 OR: Failed to ch
5930: 61 6e 67 65 20 74 69 6d 65 73 74 61 6d 70 20 6f ange timestamp o
5940: 6e 20 69 6e 66 6f 20 66 69 6c 65 20 22 20 73 65 n info file " se
5950: 72 76 69 6e 66 6f 66 69 6c 65 20 22 2e 20 41 72 rvinfofile ". Ar
5960: 65 20 79 6f 75 20 6f 75 74 20 6f 66 20 73 70 61 e you out of spa
5970: 63 65 20 6f 6e 20 74 68 61 74 20 64 69 73 6b 3f ce on that disk?
5980: 20 65 78 6e 3d 22 20 65 78 6e 29 0a 09 09 20 20 exn=" exn)...
5990: 20 20 28 69 66 20 28 61 6e 64 20 3b 3b 20 28 3c (if (and ;; (<
59a0: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
59b0: 6f 6e 64 73 29 20 73 65 72 76 65 72 2d 73 74 61 onds) server-sta
59c0: 72 74 2d 74 69 6d 65 29 20 36 30 30 29 20 3b 3b rt-time) 600) ;;
59d0: 20 72 75 6e 20 66 6f 72 20 74 65 6e 20 6d 69 6e run for ten min
59e0: 75 74 65 73 20 66 6f 72 20 65 78 70 65 72 69 6d utes for experim
59f0: 65 6e 74 2c 20 33 36 30 30 20 74 68 65 72 65 61 ent, 3600 therea
5a00: 66 74 65 72 0a 09 09 09 20 20 20 20 20 28 6e 6f fter.... (no
5a10: 74 20 2a 73 65 72 76 65 72 2d 6f 76 65 72 6c 6f t *server-overlo
5a20: 61 64 65 64 2a 29 0a 09 09 09 20 20 20 20 20 28 aded*).... (
5a30: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 73 65 72 file-exists? ser
5a40: 76 69 6e 66 6f 66 69 6c 65 29 29 0a 09 09 09 28 vinfofile))....(
5a50: 63 68 61 6e 67 65 2d 66 69 6c 65 2d 74 69 6d 65 change-file-time
5a60: 73 20 73 65 72 76 69 6e 66 6f 66 69 6c 65 20 63 s servinfofile c
5a70: 75 72 72 2d 74 69 6d 65 20 63 75 72 72 2d 74 69 urr-time curr-ti
5a80: 6d 65 29 29 29 0a 09 09 28 69 66 20 28 61 6e 64 me)))...(if (and
5a90: 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 (common:low-noi
5aa0: 73 65 2d 70 72 69 6e 74 20 31 32 30 20 22 73 74 se-print 120 "st
5ab0: 61 72 74 20 6e 65 77 20 73 65 72 76 65 72 22 29 art new server")
5ac0: 0a 09 09 09 28 3e 20 2a 61 70 69 2d 70 72 6f 63 ....(> *api-proc
5ad0: 65 73 73 2d 72 65 71 75 65 73 74 2d 63 6f 75 6e ess-request-coun
5ae0: 74 2a 20 35 30 29 29 20 3b 3b 20 69 66 20 74 68 t* 50)) ;; if th
5af0: 69 73 20 73 65 72 76 65 72 20 69 73 20 6b 69 6e is server is kin
5b00: 64 20 6f 66 20 62 75 73 79 20 73 74 61 72 74 20 d of busy start
5b10: 75 70 20 61 6e 6f 74 68 65 72 0a 09 09 20 20 20 up another...
5b20: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 (begin...
5b30: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
5b40: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
5b50: 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 72 20 69 -port* "Server i
5b60: 73 20 62 75 73 79 2c 20 61 70 69 2d 63 6f 75 6e s busy, api-coun
5b70: 74 20 22 2a 61 70 69 2d 70 72 6f 63 65 73 73 2d t "*api-process-
5b80: 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a 22 2c request-count*",
5b90: 20 73 74 61 72 74 20 61 6e 6f 74 68 65 72 20 69 start another i
5ba0: 66 20 70 6f 73 73 69 62 6c 65 2e 2e 2e 22 29 0a f possible...").
5bb0: 09 09 20 20 20 20 20 20 28 73 65 72 76 65 72 3a .. (server:
5bc0: 6b 69 6e 64 2d 72 75 6e 20 2a 74 6f 70 70 61 74 kind-run *toppat
5bd0: 68 2a 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 h*)... (if
5be0: 28 3e 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 2d (> *api-process-
5bf0: 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a 20 31 request-count* 1
5c00: 30 30 29 0a 09 09 09 20 20 28 62 65 67 69 6e 0a 00).... (begin.
5c10: 09 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
5c20: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
5c30: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 ult-log-port* "S
5c40: 65 72 76 65 72 20 69 73 20 6f 76 65 72 6c 6f 61 erver is overloa
5c50: 64 65 64 20 61 74 20 61 70 69 2d 63 6f 75 6e 74 ded at api-count
5c60: 3d 22 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 2d =" *api-process-
5c70: 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a 22 2c request-count*",
5c80: 20 72 65 6d 6f 76 69 6e 67 20 22 73 65 72 76 69 removing "servi
5c90: 6e 66 6f 66 69 6c 65 29 20 0a 09 09 09 20 20 20 nfofile) ....
5ca0: 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 73 (delete-file* s
5cb0: 65 72 76 69 6e 66 6f 66 69 6c 65 29 29 29 29 29 ervinfofile)))))
5cc0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 6f )). (lo
5cd0: 6f 70 20 30 20 73 65 72 76 65 72 2d 73 74 61 74 op 0 server-stat
5ce0: 65 20 62 61 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 e bad-sync-count
5cf0: 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 (current-millis
5d00: 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 20 econds))).
5d10: 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 (else.
5d20: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
5d30: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
5d40: 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 log-port* "Serve
5d50: 72 20 74 69 6d 65 64 20 6f 75 74 2e 20 73 65 63 r timed out. sec
5d60: 6f 6e 64 73 20 73 69 6e 63 65 20 6c 61 73 74 20 onds since last
5d70: 64 62 20 61 63 63 65 73 73 3a 20 22 20 28 2d 20 db access: " (-
5d80: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
5d90: 29 20 6c 61 73 74 2d 61 63 63 65 73 73 29 29 0a ) last-access)).
5da0: 20 20 20 20 20 20 20 20 20 20 28 68 74 74 70 2d (http-
5db0: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
5dc0: 2d 73 68 75 74 64 6f 77 6e 20 70 6f 72 74 29 29 -shutdown port))
5dd0: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
5de0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
5df0: 65 72 76 65 72 2d 73 68 75 74 64 6f 77 6e 20 70 erver-shutdown p
5e00: 6f 72 74 29 0a 20 20 28 62 65 67 69 6e 0a 20 20 ort). (begin.
5e10: 20 20 3b 3b 28 42 42 3e 20 22 68 74 74 70 2d 74 ;;(BB> "http-t
5e20: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
5e30: 73 68 75 74 64 6f 77 6e 20 63 61 6c 6c 65 64 22 shutdown called"
5e40: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
5e50: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
5e60: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 74 lt-log-port* "St
5e70: 61 72 74 69 6e 67 20 74 6f 20 73 68 75 74 64 6f arting to shutdo
5e80: 77 6e 20 74 68 65 20 73 65 72 76 65 72 2e 20 70 wn the server. p
5e90: 69 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 6f id="(current-pro
5ea0: 63 65 73 73 2d 69 64 29 29 0a 20 20 20 20 3b 3b cess-id)). ;;
5eb0: 0a 20 20 20 20 3b 3b 20 73 74 61 72 74 5f 73 68 . ;; start_sh
5ec0: 75 74 64 6f 77 6e 0a 20 20 20 20 3b 3b 0a 20 20 utdown. ;;.
5ed0: 20 20 28 73 65 74 21 20 2a 74 69 6d 65 2d 74 6f (set! *time-to
5ee0: 2d 65 78 69 74 2a 20 23 74 29 20 3b 3b 20 74 65 -exit* #t) ;; te
5ef0: 6c 6c 20 6f 6e 2d 65 78 69 74 20 74 6f 20 62 65 ll on-exit to be
5f00: 20 66 61 73 74 20 61 73 20 77 65 27 76 65 20 61 fast as we've a
5f10: 6c 72 65 61 64 79 20 63 6c 65 61 6e 65 64 20 75 lready cleaned u
5f20: 70 0a 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 65 p. (portlogge
5f30: 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 r:open-run-close
5f40: 20 70 6f 72 74 6c 6f 67 67 65 72 3a 73 65 74 2d portlogger:set-
5f50: 70 6f 72 74 20 70 6f 72 74 20 22 72 65 6c 65 61 port port "relea
5f60: 73 65 64 22 29 0a 20 20 20 20 28 74 68 72 65 61 sed"). (threa
5f70: 64 2d 73 6c 65 65 70 21 20 31 29 0a 0a 20 20 20 d-sleep! 1)..
5f80: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
5f90: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
5fa0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4d 61 78 20 -log-port* "Max
5fb0: 63 61 63 68 65 64 20 71 75 65 72 69 65 73 20 77 cached queries w
5fc0: 61 73 20 20 20 20 22 20 2a 6d 61 78 2d 63 61 63 as " *max-cac
5fd0: 68 65 2d 73 69 7a 65 2a 29 0a 20 20 20 20 3b 3b he-size*). ;;
5fe0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
5ff0: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
6000: 67 2d 70 6f 72 74 2a 20 22 4e 75 6d 62 65 72 20 g-port* "Number
6010: 6f 66 20 63 61 63 68 65 64 20 77 72 69 74 65 73 of cached writes
6020: 20 20 20 22 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d " *number-of-
6030: 77 72 69 74 65 73 2a 29 0a 20 20 20 20 3b 3b 20 writes*). ;;
6040: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
6050: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
6060: 2d 70 6f 72 74 2a 20 22 41 76 65 72 61 67 65 20 -port* "Average
6070: 63 61 63 68 65 64 20 77 72 69 74 65 20 74 69 6d cached write tim
6080: 65 20 22 0a 20 20 20 20 3b 3b 20 09 09 20 20 20 e ". ;; ..
6090: 20 20 20 28 69 66 20 28 65 71 3f 20 2a 6e 75 6d (if (eq? *num
60a0: 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a 20 30 ber-of-writes* 0
60b0: 29 0a 20 20 20 20 3b 3b 20 09 09 09 20 20 22 6e ). ;; ... "n
60c0: 2f 61 20 28 6e 6f 20 77 72 69 74 65 73 29 22 0a /a (no writes)".
60d0: 20 20 20 20 3b 3b 20 09 09 09 20 20 28 2f 20 2a ;; ... (/ *
60e0: 77 72 69 74 65 73 2d 74 6f 74 61 6c 2d 64 65 6c writes-total-del
60f0: 61 79 2a 0a 20 20 20 20 3b 3b 20 09 09 09 20 20 ay*. ;; ...
6100: 20 20 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 *number-of-wr
6110: 69 74 65 73 2a 29 29 0a 20 20 20 20 3b 3b 20 09 ites*)). ;; .
6120: 09 20 20 20 20 20 20 22 20 6d 73 22 29 0a 20 20 . " ms").
6130: 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
6140: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
6150: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4e 75 6d t-log-port* "Num
6160: 62 65 72 20 6e 6f 6e 2d 63 61 63 68 65 64 20 71 ber non-cached q
6170: 75 65 72 69 65 73 20 22 20 20 2a 6e 75 6d 62 65 ueries " *numbe
6180: 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 r-non-write-quer
6190: 69 65 73 2a 29 0a 20 20 20 20 3b 3b 20 28 64 65 ies*). ;; (de
61a0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
61b0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
61c0: 72 74 2a 20 22 41 76 65 72 61 67 65 20 6e 6f 6e rt* "Average non
61d0: 2d 63 61 63 68 65 64 20 74 69 6d 65 20 20 20 22 -cached time "
61e0: 0a 20 20 20 20 3b 3b 20 09 09 20 20 20 20 20 20 . ;; ..
61f0: 28 69 66 20 28 65 71 3f 20 2a 6e 75 6d 62 65 72 (if (eq? *number
6200: 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 -non-write-queri
6210: 65 73 2a 20 30 29 0a 20 20 20 20 3b 3b 20 09 09 es* 0). ;; ..
6220: 09 20 20 22 6e 2f 61 20 28 6e 6f 20 71 75 65 72 . "n/a (no quer
6230: 69 65 73 29 22 0a 20 20 20 20 3b 3b 20 09 09 09 ies)". ;; ...
6240: 20 20 28 2f 20 2a 74 6f 74 61 6c 2d 6e 6f 6e 2d (/ *total-non-
6250: 77 72 69 74 65 2d 64 65 6c 61 79 2a 20 0a 20 20 write-delay* .
6260: 20 20 3b 3b 20 09 09 09 20 20 20 20 20 2a 6e 75 ;; ... *nu
6270: 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 mber-non-write-q
6280: 75 65 72 69 65 73 2a 29 29 0a 20 20 20 20 3b 3b ueries*)). ;;
6290: 20 09 09 20 20 20 20 20 20 22 20 6d 73 22 29 0a .. " ms").
62a0: 20 20 20 20 0a 20 20 20 20 28 64 62 3a 70 72 69 . (db:pri
62b0: 6e 74 2d 63 75 72 72 65 6e 74 2d 71 75 65 72 79 nt-current-query
62c0: 2d 73 74 61 74 73 29 0a 20 20 20 20 23 3b 28 63 -stats). #;(c
62d0: 6f 6d 6d 6f 6e 3a 73 61 76 65 2d 70 6b 74 20 60 ommon:save-pkt `
62e0: 28 28 61 63 74 69 6f 6e 20 2e 20 65 78 69 74 29 ((action . exit)
62f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6300: 20 20 20 20 20 20 20 20 28 54 20 20 20 20 20 20 (T
6310: 2e 20 73 65 72 76 65 72 29 0a 20 20 20 20 20 20 . server).
6320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6330: 20 28 70 69 64 20 20 20 20 2e 20 2c 28 63 75 72 (pid . ,(cur
6340: 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 rent-process-id)
6350: 29 29 0a 20 20 20 20 2a 63 6f 6e 66 69 67 64 61 )). *configda
6360: 74 2a 20 23 74 29 0a 0a 20 20 20 20 3b 3b 20 72 t* #t).. ;; r
6370: 65 6d 6f 76 65 20 2e 73 65 72 76 69 6e 66 6f 20 emove .servinfo
6380: 66 69 6c 65 28 73 29 20 68 65 72 65 0a 20 20 20 file(s) here.
6390: 20 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
63a0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
63b0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 lt-log-port* "Se
63c0: 72 76 65 72 20 73 68 75 74 64 6f 77 6e 20 63 6f rver shutdown co
63d0: 6d 70 6c 65 74 65 2e 20 45 78 69 74 69 6e 67 22 mplete. Exiting"
63e0: 29 0a 20 20 20 20 28 65 78 69 74 29 29 29 0a 0a ). (exit)))..
63f0: 3b 3b 20 61 6c 6c 20 72 6f 75 74 65 73 20 74 68 ;; all routes th
6400: 6f 75 67 68 20 68 65 72 65 20 65 6e 64 20 69 6e ough here end in
6410: 20 65 78 69 74 20 2e 2e 2e 0a 3b 3b 0a 3b 3b 20 exit ....;;.;;
6420: 73 74 61 72 74 5f 73 65 72 76 65 72 3f 20 0a 3b start_server? .;
6430: 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ;.(define (http-
6440: 74 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 transport:launch
6450: 29 0a 20 20 3b 3b 20 63 68 65 63 6b 20 74 68 65 ). ;; check the
6460: 20 2e 73 65 72 76 69 6e 66 6f 20 64 69 72 65 63 .servinfo direc
6470: 74 6f 72 79 2c 20 61 72 65 20 74 68 65 72 65 20 tory, are there
6480: 6f 74 68 65 72 20 73 65 72 76 65 72 73 20 72 75 other servers ru
6490: 6e 6e 69 6e 67 20 6f 6e 20 74 68 69 73 0a 20 20 nning on this.
64a0: 3b 3b 20 6f 72 20 61 6e 6f 74 68 65 72 20 68 6f ;; or another ho
64b0: 73 74 3f 0a 20 20 28 6c 65 74 2a 20 28 28 73 65 st?. (let* ((se
64c0: 72 76 65 72 2d 73 74 61 72 74 2d 69 73 2d 6f 6b rver-start-is-ok
64d0: 20 20 28 73 65 72 76 65 72 3a 6d 69 6e 69 6d 61 (server:minima
64e0: 6c 2d 63 68 65 63 6b 20 2a 74 6f 70 70 61 74 68 l-check *toppath
64f0: 2a 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f *))). (if (no
6500: 74 20 73 65 72 76 65 72 2d 73 74 61 72 74 2d 69 t server-start-i
6510: 73 2d 6f 6b 29 0a 09 28 62 65 67 69 6e 0a 09 20 s-ok)..(begin..
6520: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
6530: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6540: 74 2a 20 22 45 52 52 4f 52 3a 20 73 65 72 76 65 t* "ERROR: serve
6550: 72 20 73 74 61 72 74 20 6e 6f 74 20 6f 6b 2c 20 r start not ok,
6560: 65 78 69 74 69 6e 67 20 6e 6f 77 2e 22 29 0a 09 exiting now.")..
6570: 20 20 28 65 78 69 74 20 31 29 29 29 29 0a 20 20 (exit 1)))).
6580: 20 20 0a 20 20 3b 3b 20 63 68 65 63 6b 20 74 68 . ;; check th
6590: 61 74 20 61 20 73 65 72 76 65 72 20 73 74 61 72 at a server star
65a0: 74 20 69 73 20 69 6e 20 70 72 6f 67 72 65 73 73 t is in progress
65b0: 2c 20 70 61 75 73 65 20 6f 72 20 65 78 69 74 20 , pause or exit
65c0: 69 66 20 73 6f 0a 20 20 28 6c 65 74 2a 20 28 28 if so. (let* ((
65d0: 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 th2 (make-thread
65e0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 (lambda ().
65f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6600: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
6610: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
6620: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
6630: 22 53 65 72 76 65 72 20 72 75 6e 20 74 68 72 65 "Server run thre
6640: 61 64 20 73 74 61 72 74 65 64 22 29 0a 20 20 20 ad started").
6650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6660: 20 20 20 20 20 20 20 20 20 20 28 68 74 74 70 2d (http-
6670: 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 20 0a 20 transport:run .
6680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6690: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
66a0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
66b0: 2d 73 65 72 76 65 72 22 29 0a 20 20 20 20 20 20 -server").
66c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
66d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 72 67 (arg
66e0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 s:get-arg "-serv
66f0: 65 72 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 er").
6700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6710: 20 20 20 20 20 20 20 22 2d 22 29 0a 20 20 20 20 "-").
6720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6730: 20 20 20 20 20 20 20 20 20 20 29 29 20 22 53 65 )) "Se
6740: 72 76 65 72 20 72 75 6e 22 29 29 0a 20 20 20 20 rver run")).
6750: 20 20 20 20 20 28 74 68 33 20 28 6d 61 6b 65 2d (th3 (make-
6760: 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 thread (lambda (
6770: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6790: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
67a0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
67b0: 70 6f 72 74 2a 20 22 53 65 72 76 65 72 20 6d 6f port* "Server mo
67c0: 6e 69 74 6f 72 20 74 68 72 65 61 64 20 73 74 61 nitor thread sta
67d0: 72 74 65 64 22 29 0a 20 20 20 20 20 20 20 20 20 rted").
67e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
67f0: 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 (http-transp
6800: 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 ort:keep-running
6810: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
6830: 4b 65 65 70 20 72 75 6e 6e 69 6e 67 22 29 29 29 Keep running")))
6840: 29 0a 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 ). (thread-st
6850: 61 72 74 21 20 74 68 32 29 0a 20 20 20 20 28 74 art! th2). (t
6860: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 hread-sleep! 0.2
6870: 35 29 20 3b 3b 20 67 69 76 65 20 74 68 65 20 73 5) ;; give the s
6880: 65 72 76 65 72 20 74 69 6d 65 20 74 6f 20 73 65 erver time to se
6890: 74 74 6c 65 20 62 65 66 6f 72 65 20 73 74 61 72 ttle before star
68a0: 74 69 6e 67 20 74 68 65 20 6b 65 65 70 2d 72 75 ting the keep-ru
68b0: 6e 6e 69 6e 67 20 6d 6f 6e 69 74 6f 72 2e 0a 20 nning monitor..
68c0: 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 (thread-start
68d0: 21 20 74 68 33 29 0a 20 20 20 20 28 73 65 74 21 ! th3). (set!
68e0: 20 2a 64 69 64 73 6f 6d 65 74 68 69 6e 67 2a 20 *didsomething*
68f0: 23 74 29 0a 20 20 20 20 28 74 68 72 65 61 64 2d #t). (thread-
6900: 6a 6f 69 6e 21 20 74 68 32 29 0a 20 20 20 20 28 join! th2). (
6910: 65 78 69 74 29 29 29 0a 0a 3b 3b 20 28 64 65 66 exit)))..;; (def
6920: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
6930: 6f 72 74 3a 73 65 72 76 65 72 2d 73 69 67 6e 61 ort:server-signa
6940: 6c 2d 68 61 6e 64 6c 65 72 20 73 69 67 6e 75 6d l-handler signum
6950: 29 0a 3b 3b 20 20 20 28 73 69 67 6e 61 6c 2d 6d ).;; (signal-m
6960: 61 73 6b 21 20 73 69 67 6e 75 6d 29 0a 3b 3b 20 ask! signum).;;
6970: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
6980: 69 6f 6e 73 0a 3b 3b 20 20 20 20 65 78 6e 0a 3b ions.;; exn.;
6990: 3b 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e ; (debug:prin
69a0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
69b0: 2d 70 6f 72 74 2a 20 22 20 2e 2e 2e 20 65 78 69 -port* " ... exi
69c0: 74 69 6e 67 20 2e 2e 2e 22 29 0a 3b 3b 20 20 20 ting ...").;;
69d0: 20 28 6c 65 74 20 28 28 74 68 31 20 28 6d 61 6b (let ((th1 (mak
69e0: 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 e-thread (lambda
69f0: 20 28 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 28 ().;; ... (
6a00: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
6a10: 29 0a 3b 3b 20 09 09 09 20 20 20 22 65 61 74 20 ).;; ... "eat
6a20: 72 65 73 70 6f 6e 73 65 22 29 29 0a 3b 3b 20 09 response")).;; .
6a30: 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 (th2 (make-thre
6a40: 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b ad (lambda ().;;
6a50: 20 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
6a60: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
6a70: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
6a80: 20 22 52 65 63 65 69 76 65 64 20 5e 43 2c 20 61 "Received ^C, a
6a90: 74 74 65 6d 70 74 69 6e 67 20 63 6c 65 61 6e 20 ttempting clean
6aa0: 65 78 69 74 2e 20 50 6c 65 61 73 65 20 62 65 20 exit. Please be
6ab0: 70 61 74 69 65 6e 74 20 61 6e 64 20 77 61 69 74 patient and wait
6ac0: 20 61 20 66 65 77 20 73 65 63 6f 6e 64 73 20 62 a few seconds b
6ad0: 65 66 6f 72 65 20 68 69 74 74 69 6e 67 20 5e 43 efore hitting ^C
6ae0: 20 61 67 61 69 6e 2e 22 29 0a 3b 3b 20 09 09 09 again.").;; ...
6af0: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
6b00: 65 70 21 20 33 29 20 3b 3b 20 67 69 76 65 20 74 ep! 3) ;; give t
6b10: 68 65 20 66 6c 75 73 68 20 74 68 72 65 65 20 73 he flush three s
6b20: 65 63 6f 6e 64 73 20 74 6f 20 64 6f 20 69 74 27 econds to do it'
6b30: 73 20 73 74 75 66 66 0a 3b 3b 20 09 09 09 20 20 s stuff.;; ...
6b40: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
6b50: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
6b60: 6f 72 74 2a 20 22 20 20 20 20 20 20 20 44 6f 6e ort* " Don
6b70: 65 2e 22 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 e.").;; ...
6b80: 28 65 78 69 74 20 34 29 29 0a 3b 3b 20 09 09 09 (exit 4)).;; ...
6b90: 20 20 20 22 65 78 69 74 20 6f 6e 20 5e 43 20 74 "exit on ^C t
6ba0: 69 6d 65 72 22 29 29 29 0a 3b 3b 20 20 20 20 20 imer"))).;;
6bb0: 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 (thread-start!
6bc0: 74 68 32 29 0a 3b 3b 20 20 20 20 20 20 28 74 68 th2).;; (th
6bd0: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 read-start! th1)
6be0: 0a 3b 3b 20 20 20 20 20 20 28 74 68 72 65 61 64 .;; (thread
6bf0: 2d 6a 6f 69 6e 21 20 74 68 32 29 29 29 29 0a 0a -join! th2))))..
6c00: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
6c10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c30: 3d 0a 3b 3b 20 4a 61 76 61 20 73 63 72 69 70 74 =.;; Java script
6c40: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
6c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c70: 3d 3d 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 ==.(define (http
6c80: 2d 74 72 61 6e 73 70 6f 72 74 3a 73 68 6f 77 2d -transport:show-
6c90: 6a 71 75 65 72 79 29 0a 20 20 28 6c 65 74 2a 20 jquery). (let*
6ca0: 28 28 64 61 74 61 20 20 28 74 65 73 74 73 3a 72 ((data (tests:r
6cb0: 65 61 64 6c 69 6e 65 73 20 2a 6a 61 76 61 2d 73 eadlines *java-s
6cc0: 63 72 69 70 74 2d 6c 69 62 2a 29 29 29 0a 28 73 cript-lib*))).(s
6cd0: 74 72 69 6e 67 2d 6a 6f 69 6e 20 64 61 74 61 20 tring-join data
6ce0: 22 5c 6e 22 29 29 29 0a 0a 0a 0a 3b 3b 3d 3d 3d "\n")))....;;===
6cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6d00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6d30: 3d 3d 3d 0a 3b 3b 20 77 65 62 20 70 61 67 65 73 ===.;; web pages
6d40: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
6d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6d70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6d80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
6d90: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
6da0: 72 74 3a 68 74 6d 6c 2d 74 65 73 74 2d 6c 6f 67 rt:html-test-log
6db0: 20 24 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 72 $). (let* ((r
6dc0: 75 6e 2d 69 64 20 28 24 20 27 72 75 6e 69 64 29 un-id ($ 'runid)
6dd0: 29 0a 20 20 20 20 20 20 20 20 20 28 74 65 73 74 ). (test
6de0: 2d 69 74 65 6d 20 28 24 20 27 74 65 73 74 6e 61 -item ($ 'testna
6df0: 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 70 me)). (p
6e00: 61 72 74 73 20 28 73 74 72 69 6e 67 2d 73 70 6c arts (string-spl
6e10: 69 74 20 74 65 73 74 2d 69 74 65 6d 20 22 3a 22 it test-item ":"
6e20: 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 65 73 )). (tes
6e30: 74 2d 6e 61 6d 65 20 28 63 61 72 20 70 61 72 74 t-name (car part
6e40: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)).
6e50: 20 0a 20 20 20 20 20 20 20 20 20 28 69 74 65 6d . (item
6e60: 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 75 61 6c -name (if (equal
6e70: 3f 20 28 6c 65 6e 67 74 68 20 70 61 72 74 73 29 ? (length parts)
6e80: 20 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 1).
6e90: 20 22 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 "".
6ea0: 20 28 63 61 64 72 20 70 61 72 74 73 29 29 29 29 (cadr parts))))
6eb0: 0a 20 20 3b 28 70 72 69 6e 74 20 24 29 20 0a 28 . ;(print $) .(
6ec0: 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 2d 6c tests:get-test-l
6ed0: 6f 67 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e og run-id test-n
6ee0: 61 6d 65 20 69 74 65 6d 2d 6e 61 6d 65 29 29 29 ame item-name)))
6ef0: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 ...(define (http
6f00: 2d 74 72 61 6e 73 70 6f 72 74 3a 68 74 6d 6c 2d -transport:html-
6f10: 64 62 6f 61 72 64 20 24 29 0a 20 20 28 6c 65 74 dboard $). (let
6f20: 2a 20 28 28 70 61 67 65 20 28 24 20 27 70 61 67 * ((page ($ 'pag
6f30: 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 6f 75 e)). (ou
6f40: 70 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 p (open-ou
6f50: 74 70 75 74 2d 73 74 72 69 6e 67 29 29 20 0a 20 tput-string)) .
6f60: 20 20 20 20 20 20 20 20 28 62 64 79 20 22 2d 2d (bdy "--
6f70: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
6f80: 2d 2d 2d 2d 2d 2d 2d 2d 22 29 0a 0a 20 20 20 20 --------")..
6f90: 20 20 20 20 20 28 72 65 74 20 20 28 74 65 73 74 (ret (test
6fa0: 73 3a 64 79 6e 61 6d 69 63 2d 64 62 6f 61 72 64 s:dynamic-dboard
6fb0: 20 70 61 67 65 29 29 29 0a 20 20 20 20 28 73 3a page))). (s:
6fc0: 6f 75 74 70 75 74 2d 6e 65 77 20 20 6f 75 70 20 output-new oup
6fd0: 20 72 65 74 29 0a 20 20 20 28 63 6c 6f 73 65 2d ret). (close-
6fe0: 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 output-port oup)
6ff0: 0a 0a 20 20 28 73 65 74 21 20 62 64 79 20 20 20 .. (set! bdy
7000: 28 67 65 74 2d 6f 75 74 70 75 74 2d 73 74 72 69 (get-output-stri
7010: 6e 67 20 6f 75 70 29 29 0a 20 20 20 20 20 28 63 ng oup)). (c
7020: 6f 6e 63 20 22 3c 68 31 3e 44 61 73 68 62 6f 61 onc "<h1>Dashboa
7030: 72 64 3c 2f 68 31 3e 22 20 62 64 79 20 22 3c 62 rd</h1>" bdy "<b
7040: 72 2f 3e 20 3c 62 72 2f 3e 20 22 20 20 29 29 29 r/> <br/> " )))
7050: 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ..(define (http-
7060: 74 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 transport:main-p
7070: 61 67 65 29 0a 20 20 28 6c 65 74 20 28 28 6c 69 age). (let ((li
7080: 6e 6b 70 61 74 68 20 28 72 6f 6f 74 2d 70 61 74 nkpath (root-pat
7090: 68 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 h))). (conc "
70a0: 3c 68 65 61 64 3e 3c 68 31 3e 22 20 28 70 61 74 <head><h1>" (pat
70b0: 68 6e 61 6d 65 2d 73 74 72 69 70 2d 64 69 72 65 hname-strip-dire
70c0: 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 ctory *toppath*)
70d0: 20 22 3c 2f 68 31 3e 3c 2f 68 65 61 64 3e 22 0a "</h1></head>".
70e0: 09 20 20 22 3c 62 6f 64 79 3e 22 0a 09 20 20 22 . "<body>".. "
70f0: 52 75 6e 20 61 72 65 61 3a 20 22 20 2a 74 6f 70 Run area: " *top
7100: 70 61 74 68 2a 0a 09 20 20 22 3c 68 32 3e 53 65 path*.. "<h2>Se
7110: 72 76 65 72 20 53 74 61 74 73 3c 2f 68 32 3e 22 rver Stats</h2>"
7120: 0a 09 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 .. (http-transp
7130: 6f 72 74 3a 73 74 61 74 73 2d 74 61 62 6c 65 29 ort:stats-table)
7140: 20 0a 09 20 20 22 3c 68 72 3e 22 0a 09 20 20 28 .. "<hr>".. (
7150: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 http-transport:r
7160: 75 6e 73 20 6c 69 6e 6b 70 61 74 68 29 0a 09 20 uns linkpath)..
7170: 20 22 3c 68 72 3e 22 0a 09 20 20 3b 3b 20 28 68 "<hr>".. ;; (h
7180: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 ttp-transport:ru
7190: 6e 2d 73 74 61 74 73 29 0a 09 20 20 22 3c 2f 62 n-stats).. "</b
71a0: 6f 64 79 3e 22 0a 09 20 20 29 29 29 0a 0a 28 64 ody>".. )))..(d
71b0: 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e efine (http-tran
71c0: 73 70 6f 72 74 3a 73 74 61 74 73 2d 74 61 62 6c sport:stats-tabl
71d0: 65 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b e). (mutex-lock
71e0: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
71f0: 65 78 2a 29 0a 20 20 28 6c 65 74 20 28 28 72 65 ex*). (let ((re
7200: 73 20 0a 09 20 28 63 6f 6e 63 20 22 3c 74 61 62 s .. (conc "<tab
7210: 6c 65 3e 22 0a 09 20 20 20 20 20 20 20 3b 3b 20 le>".. ;;
7220: 22 3c 74 72 3e 3c 74 64 3e 4d 61 78 20 63 61 63 "<tr><td>Max cac
7230: 68 65 64 20 71 75 65 72 69 65 73 3c 2f 74 64 3e hed queries</td>
7240: 20 20 20 20 20 20 20 20 3c 74 64 3e 22 20 2a 6d <td>" *m
7250: 61 78 2d 63 61 63 68 65 2d 73 69 7a 65 2a 20 22 ax-cache-size* "
7260: 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 </td></tr>"..
7270: 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4e 75 6d "<tr><td>Num
7280: 62 65 72 20 6f 66 20 63 61 63 68 65 64 20 77 72 ber of cached wr
7290: 69 74 65 73 3c 2f 74 64 3e 20 20 20 3c 74 64 3e ites</td> <td>
72a0: 22 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 " *number-of-wri
72b0: 74 65 73 2a 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e tes* "</td></tr>
72c0: 22 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c ".. "<tr><
72d0: 74 64 3e 41 76 65 72 61 67 65 20 63 61 63 68 65 td>Average cache
72e0: 64 20 77 72 69 74 65 20 74 69 6d 65 3c 2f 74 64 d write time</td
72f0: 3e 20 3c 74 64 3e 22 20 28 69 66 20 28 65 71 3f > <td>" (if (eq?
7300: 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 *number-of-writ
7310: 65 73 2a 20 30 29 0a 09 09 09 09 09 09 09 09 20 es* 0).........
7320: 22 6e 2f 61 20 28 6e 6f 20 77 72 69 74 65 73 29 "n/a (no writes)
7330: 22 0a 09 09 09 09 09 09 09 09 20 28 2f 20 2a 77 "......... (/ *w
7340: 72 69 74 65 73 2d 74 6f 74 61 6c 2d 64 65 6c 61 rites-total-dela
7350: 79 2a 0a 09 09 09 09 09 09 09 09 20 20 20 20 2a y*......... *
7360: 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 number-of-writes
7370: 2a 29 29 0a 09 20 20 20 20 20 20 20 22 20 6d 73 *)).. " ms
7380: 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 </td></tr>"..
7390: 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4e 75 6d "<tr><td>Num
73a0: 62 65 72 20 6e 6f 6e 2d 63 61 63 68 65 64 20 71 ber non-cached q
73b0: 75 65 72 69 65 73 3c 2f 74 64 3e 20 3c 74 64 3e ueries</td> <td>
73c0: 22 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 " *number-non-w
73d0: 72 69 74 65 2d 71 75 65 72 69 65 73 2a 20 22 3c rite-queries* "<
73e0: 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 /td></tr>"..
73f0: 20 20 20 3b 3b 20 22 3c 74 72 3e 3c 74 64 3e 41 ;; "<tr><td>A
7400: 76 65 72 61 67 65 20 6e 6f 6e 2d 63 61 63 68 65 verage non-cache
7410: 64 20 74 69 6d 65 3c 2f 74 64 3e 20 20 20 3c 74 d time</td> <t
7420: 64 3e 22 20 28 69 66 20 28 65 71 3f 20 2a 6e 75 d>" (if (eq? *nu
7430: 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 mber-non-write-q
7440: 75 65 72 69 65 73 2a 20 30 29 0a 09 20 20 20 20 ueries* 0)..
7450: 20 20 20 3b 3b 20 09 09 09 09 09 09 09 20 22 6e ;; ....... "n
7460: 2f 61 20 28 6e 6f 20 71 75 65 72 69 65 73 29 22 /a (no queries)"
7470: 0a 09 20 20 20 20 20 20 20 3b 3b 20 09 09 09 09 .. ;; ....
7480: 09 09 09 20 28 2f 20 2a 74 6f 74 61 6c 2d 6e 6f ... (/ *total-no
7490: 6e 2d 77 72 69 74 65 2d 64 65 6c 61 79 2a 20 0a n-write-delay* .
74a0: 09 20 20 20 20 20 20 20 3b 3b 20 09 09 09 09 09 . ;; .....
74b0: 09 09 20 20 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f .. *number-no
74c0: 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a n-write-queries*
74d0: 29 29 0a 09 20 20 20 20 20 20 20 22 20 6d 73 3c )).. " ms<
74e0: 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 /td></tr>"..
74f0: 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4c 61 73 74 "<tr><td>Last
7500: 20 61 63 63 65 73 73 3c 2f 74 64 3e 3c 74 64 3e access</td><td>
7510: 22 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 " (
7520: 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 seconds->time-st
7530: 72 69 6e 67 20 2a 64 62 2d 6c 61 73 74 2d 61 63 ring *db-last-ac
7540: 63 65 73 73 2a 29 20 22 3c 2f 74 64 3e 3c 2f 74 cess*) "</td></t
7550: 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c 2f 74 r>".. "</t
7560: 61 62 6c 65 3e 22 29 29 29 0a 20 20 20 20 28 6d able>"))). (m
7570: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 utex-unlock! *he
7580: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
7590: 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 res))..(defi
75a0: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
75b0: 72 74 3a 72 75 6e 73 20 6c 69 6e 6b 70 61 74 68 rt:runs linkpath
75c0: 29 0a 20 20 28 63 6f 6e 63 20 22 3c 68 33 3e 52 ). (conc "<h3>R
75d0: 75 6e 73 3c 2f 68 33 3e 22 0a 09 28 73 74 72 69 uns</h3>"..(stri
75e0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 0a 09 ng-intersperse..
75f0: 20 28 6c 65 74 20 28 28 66 69 6c 65 73 20 28 6d (let ((files (m
7600: 61 70 20 70 61 74 68 6e 61 6d 65 2d 73 74 72 69 ap pathname-stri
7610: 70 2d 64 69 72 65 63 74 6f 72 79 20 28 67 6c 6f p-directory (glo
7620: 62 20 28 63 6f 6e 63 20 6c 69 6e 6b 70 61 74 68 b (conc linkpath
7630: 20 22 2f 2a 22 29 29 29 29 29 0a 09 20 20 20 28 "/*"))))).. (
7640: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 70 29 0a map (lambda (p).
7650: 09 09 20 20 28 63 6f 6e 63 20 22 3c 61 20 68 72 .. (conc "<a hr
7660: 65 66 3d 5c 22 22 20 70 20 22 5c 22 3e 22 20 70 ef=\"" p "\">" p
7670: 20 22 3c 2f 61 3e 3c 62 72 3e 22 29 29 0a 09 09 "</a><br>"))...
7680: 66 69 6c 65 73 29 29 0a 09 20 22 20 22 29 29 29 files)).. " ")))
7690: 0a 0a 23 3b 28 64 65 66 69 6e 65 20 28 68 74 74 ..#;(define (htt
76a0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 2d p-transport:run-
76b0: 73 74 61 74 73 29 0a 20 20 28 6c 65 74 20 28 28 stats). (let ((
76c0: 73 74 61 74 73 20 28 6f 70 65 6e 2d 72 75 6e 2d stats (open-run-
76d0: 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 72 75 6e close db:get-run
76e0: 6e 69 6e 67 2d 73 74 61 74 73 20 23 66 29 29 29 ning-stats #f)))
76f0: 0a 20 20 20 20 28 63 6f 6e 63 20 22 3c 74 61 62 . (conc "<tab
7700: 6c 65 3e 22 0a 09 20 20 28 73 74 72 69 6e 67 2d le>".. (string-
7710: 69 6e 74 65 72 73 70 65 72 73 65 0a 09 20 20 20 intersperse..
7720: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 73 74 (map (lambda (st
7730: 61 74 29 0a 09 09 20 20 28 63 6f 6e 63 20 22 3c at)... (conc "<
7740: 74 72 3e 3c 74 64 3e 22 20 28 63 61 72 20 73 74 tr><td>" (car st
7750: 61 74 29 20 22 3c 2f 74 64 3e 3c 74 64 3e 22 20 at) "</td><td>"
7760: 28 63 61 64 72 20 73 74 61 74 29 20 22 3c 2f 74 (cadr stat) "</t
7770: 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 73 74 61 d></tr>"))...sta
7780: 74 73 29 0a 09 20 20 20 22 20 22 29 0a 09 20 20 ts).. " ")..
7790: 22 3c 2f 74 61 62 6c 65 3e 22 29 29 29 0a 29 0a "</table>"))).).