Artifact
2202b22e9f9b7c2e90dd8142069615c3c3694774:
0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 32 2c 20 4d 61 74 74 68 65 77 06-2012, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 54 68 69 73 20 66 69 6c 65 20 69 73 20 70 61 This file is pa
0040: 72 74 20 6f 66 20 4d 65 67 61 74 65 73 74 2e 0a rt of Megatest..
0050: 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 ;; .;; Megat
0060: 65 73 74 20 69 73 20 66 72 65 65 20 73 6f 66 74 est is free soft
0070: 77 61 72 65 3a 20 79 6f 75 20 63 61 6e 20 72 65 ware: you can re
0080: 64 69 73 74 72 69 62 75 74 65 20 69 74 20 61 6e distribute it an
0090: 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b 3b 20 20 d/or modify.;;
00a0: 20 20 20 69 74 20 75 6e 64 65 72 20 74 68 65 20 it under the
00b0: 74 65 72 6d 73 20 6f 66 20 74 68 65 20 47 4e 55 terms of the GNU
00c0: 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 General Public
00d0: 4c 69 63 65 6e 73 65 20 61 73 20 70 75 62 6c 69 License as publi
00e0: 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 20 20 74 shed by.;; t
00f0: 68 65 20 46 72 65 65 20 53 6f 66 74 77 61 72 65 he Free Software
0100: 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 65 69 74 Foundation, eit
0110: 68 65 72 20 76 65 72 73 69 6f 6e 20 33 20 6f 66 her version 3 of
0120: 20 74 68 65 20 4c 69 63 65 6e 73 65 2c 20 6f 72 the License, or
0130: 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 6f 75 72 .;; (at your
0140: 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 6c 61 74 option) any lat
0150: 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b 3b 20 0a er version..;; .
0160: 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 73 74 20 ;; Megatest
0170: 69 73 20 64 69 73 74 72 69 62 75 74 65 64 20 69 is distributed i
0180: 6e 20 74 68 65 20 68 6f 70 65 20 74 68 61 74 20 n the hope that
0190: 69 74 20 77 69 6c 6c 20 62 65 20 75 73 65 66 75 it will be usefu
01a0: 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 20 57 49 l,.;; but WI
01b0: 54 48 4f 55 54 20 41 4e 59 20 57 41 52 52 41 4e THOUT ANY WARRAN
01c0: 54 59 3b 20 77 69 74 68 6f 75 74 20 65 76 65 6e TY; without even
01d0: 20 74 68 65 20 69 6d 70 6c 69 65 64 20 77 61 72 the implied war
01e0: 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 20 20 20 ranty of.;;
01f0: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0200: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0210: 20 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 PARTICULAR PURP
0220: 4f 53 45 2e 20 20 53 65 65 20 74 68 65 0a 3b 3b OSE. See the.;;
0230: 20 20 20 20 20 47 4e 55 20 47 65 6e 65 72 61 6c GNU General
0240: 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 Public License
0250: 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 69 6c 73 for more details
0260: 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 59 6f 75 ..;; .;; You
0270: 20 73 68 6f 75 6c 64 20 68 61 76 65 20 72 65 63 should have rec
0280: 65 69 76 65 64 20 61 20 63 6f 70 79 20 6f 66 20 eived a copy of
0290: 74 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 the GNU General
02a0: 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 0a 3b Public License.;
02b0: 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 69 74 68 ; along with
02c0: 20 4d 65 67 61 74 65 73 74 2e 20 20 49 66 20 6e Megatest. If n
02d0: 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 3a 2f 2f ot, see <http://
02e0: 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c 69 63 65 www.gnu.org/lice
02f0: 6e 73 65 73 2f 3e 2e 0a 0a 28 72 65 71 75 69 72 nses/>...(requir
0300: 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 73 72 66 e-extension (srf
0310: 69 20 31 38 29 20 65 78 74 72 61 73 20 74 63 70 i 18) extras tcp
0320: 20 73 31 31 6e 29 0a 0a 0a 28 75 73 65 20 20 73 s11n)...(use s
0330: 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 rfi-1 posix rege
0340: 78 20 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 x regex-case srf
0350: 69 2d 36 39 20 68 6f 73 74 69 6e 66 6f 20 6d 64 i-69 hostinfo md
0360: 35 20 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 5 message-digest
0370: 20 70 6f 73 69 78 2d 65 78 74 72 61 73 29 0a 0a posix-extras)..
0380: 28 75 73 65 20 73 70 69 66 66 79 20 75 72 69 2d (use spiffy uri-
0390: 63 6f 6d 6d 6f 6e 20 69 6e 74 61 72 77 65 62 20 common intarweb
03a0: 68 74 74 70 2d 63 6c 69 65 6e 74 20 73 70 69 66 http-client spif
03b0: 66 79 2d 72 65 71 75 65 73 74 2d 76 61 72 73 20 fy-request-vars
03c0: 69 6e 74 61 72 77 65 62 20 73 70 69 66 66 79 2d intarweb spiffy-
03d0: 64 69 72 65 63 74 6f 72 79 2d 6c 69 73 74 69 6e directory-listin
03e0: 67 29 0a 0a 3b 3b 20 43 6f 6e 66 69 67 75 72 61 g)..;; Configura
03f0: 74 69 6f 6e 73 20 66 6f 72 20 73 65 72 76 65 72 tions for server
0400: 0a 28 74 63 70 2d 62 75 66 66 65 72 2d 73 69 7a .(tcp-buffer-siz
0410: 65 20 32 30 34 38 29 0a 28 6d 61 78 2d 63 6f 6e e 2048).(max-con
0420: 6e 65 63 74 69 6f 6e 73 20 32 30 34 38 29 20 0a nections 2048) .
0430: 0a 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 .(declare (unit
0440: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 29 29 http-transport))
0450: 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ..(declare (uses
0460: 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 63 6c 61 common)).(decla
0470: 72 65 20 28 75 73 65 73 20 64 62 29 29 0a 28 64 re (uses db)).(d
0480: 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 65 73 eclare (uses tes
0490: 74 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 ts)).(declare (u
04a0: 73 65 73 20 74 61 73 6b 73 29 29 20 3b 3b 20 74 ses tasks)) ;; t
04b0: 61 73 6b 73 20 61 72 65 20 77 68 65 72 65 20 73 asks are where s
04c0: 74 75 66 66 20 69 73 20 6d 61 69 6e 74 61 69 6e tuff is maintain
04d0: 65 64 20 61 62 6f 75 74 20 77 68 61 74 20 69 73 ed about what is
04e0: 20 72 75 6e 6e 69 6e 67 2e 0a 28 64 65 63 6c 61 running..(decla
04f0: 72 65 20 28 75 73 65 73 20 73 65 72 76 65 72 29 re (uses server)
0500: 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 ).;; (declare (u
0510: 73 65 73 20 64 61 65 6d 6f 6e 29 29 0a 28 64 65 ses daemon)).(de
0520: 63 6c 61 72 65 20 28 75 73 65 73 20 70 6f 72 74 clare (uses port
0530: 6c 6f 67 67 65 72 29 29 0a 28 64 65 63 6c 61 72 logger)).(declar
0540: 65 20 28 75 73 65 73 20 72 6d 74 29 29 0a 0a 28 e (uses rmt))..(
0550: 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f include "common_
0560: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 records.scm").(i
0570: 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 63 6f 72 nclude "db_recor
0580: 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 ds.scm").(includ
0590: 65 20 22 6a 73 2d 70 61 74 68 2e 73 63 6d 22 29 e "js-path.scm")
05a0: 0a 0a 28 72 65 71 75 69 72 65 2d 6c 69 62 72 61 ..(require-libra
05b0: 72 79 20 73 74 6d 6c 29 0a 28 64 65 66 69 6e 65 ry stml).(define
05c0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
05d0: 3a 6d 61 6b 65 2d 73 65 72 76 65 72 2d 75 72 6c :make-server-url
05e0: 20 68 6f 73 74 70 6f 72 74 29 0a 20 20 28 69 66 hostport). (if
05f0: 20 28 6e 6f 74 20 68 6f 73 74 70 6f 72 74 29 0a (not hostport).
0600: 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 #f. (
0610: 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f 22 20 28 conc "http://" (
0620: 63 61 72 20 68 6f 73 74 70 6f 72 74 29 20 22 3a car hostport) ":
0630: 22 20 28 63 61 64 72 20 68 6f 73 74 70 6f 72 74 " (cadr hostport
0640: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 73 ))))..(define *s
0650: 65 72 76 65 72 2d 6c 6f 6f 70 2d 68 65 61 72 74 erver-loop-heart
0660: 2d 62 65 61 74 2a 20 28 63 75 72 72 65 6e 74 2d -beat* (current-
0670: 73 65 63 6f 6e 64 73 29 29 0a 0a 3b 3b 3d 3d 3d seconds))..;;===
0680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06c0: 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 20 56 20 45 ===.;; S E R V E
06d0: 20 52 0a 3b 3b 20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d R.;; ==========
06e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
0720: 20 43 61 6c 6c 20 74 68 69 73 20 74 6f 20 73 74 Call this to st
0730: 61 72 74 20 74 68 65 20 61 63 74 75 61 6c 20 73 art the actual s
0740: 65 72 76 65 72 0a 3b 3b 0a 0a 28 64 65 66 69 6e erver.;;..(defin
0750: 65 20 2a 64 62 3a 70 72 6f 63 65 73 73 2d 71 75 e *db:process-qu
0760: 65 75 65 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 eue-mutex* (make
0770: 2d 6d 75 74 65 78 29 29 0a 0a 28 64 65 66 69 6e -mutex))..(defin
0780: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
0790: 74 3a 72 75 6e 20 68 6f 73 74 6e 29 0a 20 20 3b t:run hostn). ;
07a0: 3b 20 43 6f 6e 66 69 67 75 72 61 74 69 6f 6e 73 ; Configurations
07b0: 20 66 6f 72 20 73 65 72 76 65 72 0a 20 20 28 74 for server. (t
07c0: 63 70 2d 62 75 66 66 65 72 2d 73 69 7a 65 20 32 cp-buffer-size 2
07d0: 30 34 38 29 0a 20 20 28 6d 61 78 2d 63 6f 6e 6e 048). (max-conn
07e0: 65 63 74 69 6f 6e 73 20 32 30 34 38 29 20 0a 20 ections 2048) .
07f0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
0800: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
0810: 74 2a 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 t* "Attempting t
0820: 6f 20 73 74 61 72 74 20 74 68 65 20 73 65 72 76 o start the serv
0830: 65 72 20 2e 2e 2e 22 29 0a 20 20 28 6c 65 74 2a er ..."). (let*
0840: 20 28 28 64 62 20 20 20 20 20 20 20 20 20 20 20 ((db
0850: 20 20 20 23 66 29 20 3b 3b 20 20 20 20 20 20 20 #f) ;;
0860: 20 28 6f 70 65 6e 2d 64 62 29 29 20 3b 3b 20 77 (open-db)) ;; w
0870: 65 20 64 6f 6e 27 74 20 77 61 6e 74 20 74 68 65 e don't want the
0880: 20 73 65 72 76 65 72 20 74 6f 20 62 65 20 6f 70 server to be op
0890: 65 6e 69 6e 67 20 61 6e 64 20 63 6c 6f 73 69 6e ening and closin
08a0: 67 20 74 68 65 20 64 62 20 75 6e 6e 65 63 65 73 g the db unneces
08b0: 61 72 69 6c 79 0a 09 20 28 68 6f 73 74 6e 61 6d arily.. (hostnam
08c0: 65 20 20 20 20 20 20 20 20 28 67 65 74 2d 68 6f e (get-ho
08d0: 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 69 70 61 st-name)).. (ipa
08e0: 64 64 72 73 74 72 20 20 20 20 20 20 20 28 6c 65 ddrstr (le
08f0: 74 20 28 28 69 70 73 74 72 20 28 69 66 20 28 73 t ((ipstr (if (s
0900: 74 72 69 6e 67 3d 3f 20 22 2d 22 20 68 6f 73 74 tring=? "-" host
0910: 6e 29 0a 09 09 09 09 09 20 20 20 3b 3b 20 28 73 n)...... ;; (s
0920: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
0930: 65 20 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e 73 e (map number->s
0940: 74 72 69 6e 67 20 28 75 38 76 65 63 74 6f 72 2d tring (u8vector-
0950: 3e 6c 69 73 74 20 28 68 6f 73 74 6e 61 6d 65 2d >list (hostname-
0960: 3e 69 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 20 >ip hostname)))
0970: 22 2e 22 29 0a 09 09 09 09 09 20 20 20 28 73 65 ".")...... (se
0980: 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 rver:get-best-gu
0990: 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f 73 74 ess-address host
09a0: 6e 61 6d 65 29 0a 09 09 09 09 09 20 20 20 23 66 name)...... #f
09b0: 29 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 69 ))).... (if i
09c0: 70 73 74 72 20 69 70 73 74 72 20 68 6f 73 74 6e pstr ipstr hostn
09d0: 29 29 29 20 3b 3b 20 68 6f 73 74 6e 61 6d 65 29 ))) ;; hostname)
09e0: 29 29 20 0a 09 20 28 73 74 61 72 74 2d 70 6f 72 )) .. (start-por
09f0: 74 20 20 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 t (portlogg
0a00: 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 er:open-run-clos
0a10: 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 66 69 6e e portlogger:fin
0a20: 64 2d 70 6f 72 74 29 29 0a 09 20 28 6c 69 6e 6b d-port)).. (link
0a30: 2d 74 72 65 65 2d 70 61 74 68 20 20 28 63 6f 6d -tree-path (com
0a40: 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 mon:get-linktree
0a50: 29 29 0a 09 20 28 74 6d 70 2d 61 72 65 61 20 20 )).. (tmp-area
0a60: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 (common:ge
0a70: 74 2d 64 62 2d 74 6d 70 2d 61 72 65 61 29 29 0a t-db-tmp-area)).
0a80: 09 20 28 73 74 61 72 74 2d 66 69 6c 65 20 20 20 . (start-file
0a90: 20 20 20 28 63 6f 6e 63 20 74 6d 70 2d 61 72 65 (conc tmp-are
0aa0: 61 20 22 2f 2e 73 65 72 76 65 72 2d 73 74 61 72 a "/.server-star
0ab0: 74 22 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 t"))). (debug
0ac0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
0ad0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
0ae0: 20 22 70 6f 72 74 6c 6f 67 67 65 72 20 72 65 63 "portlogger rec
0af0: 6f 6d 6d 65 6e 64 65 64 20 70 6f 72 74 3a 20 22 ommended port: "
0b00: 20 73 74 61 72 74 2d 70 6f 72 74 29 0a 20 20 20 start-port).
0b10: 20 3b 3b 20 73 65 74 20 73 6f 6d 65 20 70 61 72 ;; set some par
0b20: 61 6d 65 74 65 72 73 20 66 6f 72 20 74 68 65 20 ameters for the
0b30: 73 65 72 76 65 72 0a 20 20 20 20 28 72 6f 6f 74 server. (root
0b40: 2d 70 61 74 68 20 20 20 20 20 28 69 66 20 6c 69 -path (if li
0b50: 6e 6b 2d 74 72 65 65 2d 70 61 74 68 20 0a 09 09 nk-tree-path ...
0b60: 20 20 20 20 20 20 20 6c 69 6e 6b 2d 74 72 65 65 link-tree
0b70: 2d 70 61 74 68 0a 09 09 20 20 20 20 20 20 20 28 -path... (
0b80: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
0b90: 79 29 29 29 20 3b 3b 20 57 41 52 4e 49 4e 47 3a y))) ;; WARNING:
0ba0: 20 53 45 43 55 52 49 54 59 20 48 4f 4c 45 2e 20 SECURITY HOLE.
0bb0: 46 49 58 20 41 53 41 50 21 0a 20 20 20 20 28 68 FIX ASAP!. (h
0bc0: 61 6e 64 6c 65 2d 64 69 72 65 63 74 6f 72 79 20 andle-directory
0bd0: 73 70 69 66 66 79 2d 64 69 72 65 63 74 6f 72 79 spiffy-directory
0be0: 2d 6c 69 73 74 69 6e 67 29 0a 20 20 20 20 28 68 -listing). (h
0bf0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 20 andle-exception
0c00: 28 6c 61 6d 62 64 61 20 28 65 78 6e 20 63 68 61 (lambda (exn cha
0c10: 69 6e 29 0a 09 09 09 28 73 69 67 6e 61 6c 20 28 in)....(signal (
0c20: 6d 61 6b 65 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 make-composite-c
0c30: 6f 6e 64 69 74 69 6f 6e 0a 09 09 09 09 20 28 6d ondition..... (m
0c40: 61 6b 65 2d 70 72 6f 70 65 72 74 79 2d 63 6f 6e ake-property-con
0c50: 64 69 74 69 6f 6e 20 0a 09 09 09 09 20 20 27 73 dition ..... 's
0c60: 65 72 76 65 72 0a 09 09 09 09 20 20 27 6d 65 73 erver..... 'mes
0c70: 73 61 67 65 20 22 73 65 72 76 65 72 20 65 72 72 sage "server err
0c80: 6f 72 22 29 29 29 29 29 0a 0a 20 20 20 20 3b 3b or"))))).. ;;
0c90: 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a http-transport:
0ca0: 68 61 6e 64 6c 65 2d 64 69 72 65 63 74 6f 72 79 handle-directory
0cb0: 29 20 3b 3b 20 73 69 6d 70 6c 65 2d 64 69 72 65 ) ;; simple-dire
0cc0: 63 74 6f 72 79 2d 68 61 6e 64 6c 65 72 29 0a 20 ctory-handler).
0cd0: 20 20 20 3b 3b 20 53 65 74 75 70 20 74 68 65 20 ;; Setup the
0ce0: 77 65 62 20 73 65 72 76 65 72 20 61 6e 64 20 61 web server and a
0cf0: 20 2f 63 74 72 6c 20 69 6e 74 65 72 66 61 63 65 /ctrl interface
0d00: 0a 20 20 20 20 3b 3b 0a 20 20 20 20 28 76 68 6f . ;;. (vho
0d10: 73 74 2d 6d 61 70 20 60 28 28 28 2a 20 61 6e 79 st-map `(((* any
0d20: 29 20 2e 20 2c 28 6c 61 6d 62 64 61 20 28 63 6f ) . ,(lambda (co
0d30: 6e 74 69 6e 75 65 29 0a 09 09 09 20 20 20 20 20 ntinue)....
0d40: 20 20 3b 3b 20 6f 70 65 6e 20 74 68 65 20 64 62 ;; open the db
0d50: 20 6f 6e 20 74 68 65 20 66 69 72 73 74 20 63 61 on the first ca
0d60: 6c 6c 20 0a 09 09 09 09 20 3b 3b 20 54 68 69 73 ll ..... ;; This
0d70: 20 69 73 20 77 65 72 65 20 77 65 20 73 65 74 20 is were we set
0d80: 75 70 20 74 68 65 20 64 61 74 61 62 61 73 65 20 up the database
0d90: 63 6f 6e 6e 65 63 74 69 6f 6e 73 0a 09 09 09 20 connections....
0da0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 24 20 (let* (($
0db0: 20 20 28 72 65 71 75 65 73 74 2d 76 61 72 73 20 (request-vars
0dc0: 73 6f 75 72 63 65 3a 20 27 62 6f 74 68 29 29 0a source: 'both)).
0dd0: 09 09 09 09 20 20 20 20 20 20 28 64 61 74 20 28 .... (dat (
0de0: 24 20 27 64 61 74 29 29 0a 09 09 09 09 20 20 20 $ 'dat)).....
0df0: 20 20 20 28 72 65 73 20 23 66 29 29 0a 09 09 09 (res #f))....
0e00: 09 20 28 63 6f 6e 64 0a 09 09 09 09 20 20 28 28 . (cond..... ((
0e10: 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 equal? (uri-path
0e20: 20 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 (request-uri (c
0e30: 75 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 urrent-request))
0e40: 29 0a 09 09 09 09 09 20 20 20 27 28 2f 20 22 61 )...... '(/ "a
0e50: 70 69 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 pi"))..... (se
0e60: 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 nd-response body
0e70: 3a 20 20 20 20 28 61 70 69 3a 70 72 6f 63 65 73 : (api:proces
0e80: 73 2d 72 65 71 75 65 73 74 20 2a 64 62 73 74 72 s-request *dbstr
0e90: 75 63 74 2d 64 62 2a 20 24 29 20 3b 3b 20 74 68 uct-db* $) ;; th
0ea0: 65 20 24 20 69 73 20 74 68 65 20 72 65 71 75 65 e $ is the reque
0eb0: 73 74 20 76 61 72 73 20 70 72 6f 63 0a 09 09 09 st vars proc....
0ec0: 09 09 09 20 20 68 65 61 64 65 72 73 3a 20 27 28 ... headers: '(
0ed0: 28 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 65 (content-type te
0ee0: 78 74 2f 70 6c 61 69 6e 29 29 29 0a 09 09 09 09 xt/plain))).....
0ef0: 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 (mutex-lock!
0f00: 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 *heartbeat-mutex
0f10: 2a 29 0a 09 09 09 09 20 20 20 28 73 65 74 21 20 *)..... (set!
0f20: 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a *db-last-access*
0f30: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
0f40: 73 29 29 0a 09 09 09 09 20 20 20 28 6d 75 74 65 s))..... (mute
0f50: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 x-unlock! *heart
0f60: 62 65 61 74 2d 6d 75 74 65 78 2a 29 29 0a 09 09 beat-mutex*))...
0f70: 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 75 72 .. ((equal? (ur
0f80: 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 2d i-path (request-
0f90: 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 uri (current-req
0fa0: 75 65 73 74 29 29 29 20 0a 09 09 09 09 09 20 20 uest))) ......
0fb0: 20 27 28 2f 20 22 22 29 29 0a 09 09 09 09 20 20 '(/ "")).....
0fc0: 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 (send-response
0fd0: 62 6f 64 79 3a 20 28 68 74 74 70 2d 74 72 61 6e body: (http-tran
0fe0: 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 61 67 65 29 sport:main-page)
0ff0: 29 29 0a 09 09 09 09 20 20 28 28 65 71 75 61 6c ))..... ((equal
1000: 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 ? (uri-path (req
1010: 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e uest-uri (curren
1020: 74 2d 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 t-request))) ...
1030: 09 09 09 20 20 20 27 28 2f 20 22 6a 73 6f 6e 5f ... '(/ "json_
1040: 61 70 69 22 29 29 0a 09 09 09 09 20 20 20 28 73 api"))..... (s
1050: 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 end-response bod
1060: 79 3a 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f y: (http-transpo
1070: 72 74 3a 6d 61 69 6e 2d 70 61 67 65 29 29 29 0a rt:main-page))).
1080: 09 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 .... ((equal? (
1090: 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 uri-path (reques
10a0: 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 t-uri (current-r
10b0: 65 71 75 65 73 74 29 29 29 20 0a 09 09 09 09 09 equest))) ......
10c0: 20 20 20 27 28 2f 20 22 72 75 6e 73 22 29 29 0a '(/ "runs")).
10d0: 09 09 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 .... (send-res
10e0: 70 6f 6e 73 65 20 62 6f 64 79 3a 20 28 68 74 74 ponse body: (htt
10f0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e p-transport:main
1100: 2d 70 61 67 65 29 29 29 0a 09 09 09 09 20 20 28 -page)))..... (
1110: 28 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 (equal? (uri-pat
1120: 68 20 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 h (request-uri (
1130: 63 75 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 current-request)
1140: 29 29 20 0a 09 09 09 09 09 20 20 20 27 28 2f 20 )) ...... '(/
1150: 61 6e 79 29 29 0a 09 09 09 09 20 20 20 28 73 65 any))..... (se
1160: 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 nd-response body
1170: 3a 20 22 68 65 79 20 74 68 65 72 65 21 5c 6e 22 : "hey there!\n"
1180: 0a 09 09 09 09 09 09 20 20 68 65 61 64 65 72 73 ....... headers
1190: 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 70 : '((content-typ
11a0: 65 20 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 29 e text/plain))))
11b0: 0a 09 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 ..... ((equal?
11c0: 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 (uri-path (reque
11d0: 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d st-uri (current-
11e0: 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 09 09 request))) .....
11f0: 09 20 20 20 27 28 2f 20 22 68 65 79 22 29 29 0a . '(/ "hey")).
1200: 09 09 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 .... (send-res
1210: 70 6f 6e 73 65 20 62 6f 64 79 3a 20 22 68 65 79 ponse body: "hey
1220: 20 74 68 65 72 65 21 5c 6e 22 20 0a 09 09 09 09 there!\n" .....
1230: 09 09 20 20 68 65 61 64 65 72 73 3a 20 27 28 28 .. headers: '((
1240: 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 65 78 content-type tex
1250: 74 2f 70 6c 61 69 6e 29 29 29 29 0a 20 20 20 20 t/plain)))).
1260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
1280: 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 equal? (uri-path
1290: 20 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 (request-uri (c
12a0: 75 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 urrent-request))
12b0: 29 20 0a 09 09 09 09 09 20 20 20 27 28 2f 20 22 ) ...... '(/ "
12c0: 6a 71 75 65 72 79 33 2e 31 2e 30 2e 6a 73 22 29 jquery3.1.0.js")
12d0: 29 0a 09 09 09 09 20 20 20 28 73 65 6e 64 2d 72 )..... (send-r
12e0: 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 28 68 esponse body: (h
12f0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 68 ttp-transport:sh
1300: 6f 77 2d 6a 71 75 65 72 79 29 20 0a 09 09 09 09 ow-jquery) .....
1310: 09 09 20 20 68 65 61 64 65 72 73 3a 20 27 28 28 .. headers: '((
1320: 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 61 70 70 content-type app
1330: 6c 69 63 61 74 69 6f 6e 2f 6a 61 76 61 73 63 72 lication/javascr
1340: 69 70 74 29 29 29 29 0a 20 20 20 20 20 20 20 20 ipt)))).
1350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1360: 20 20 20 20 20 20 20 20 20 20 28 28 65 71 75 61 ((equa
1370: 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 l? (uri-path (re
1380: 71 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 quest-uri (curre
1390: 6e 74 2d 72 65 71 75 65 73 74 29 29 29 20 0a 09 nt-request))) ..
13a0: 09 09 09 09 20 20 20 27 28 2f 20 22 74 65 73 74 .... '(/ "test
13b0: 5f 6c 6f 67 22 29 29 0a 09 09 09 09 20 20 20 28 _log"))..... (
13c0: 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f send-response bo
13d0: 64 79 3a 20 28 68 74 74 70 2d 74 72 61 6e 73 70 dy: (http-transp
13e0: 6f 72 74 3a 68 74 6d 6c 2d 74 65 73 74 2d 6c 6f ort:html-test-lo
13f0: 67 20 24 29 20 0a 09 09 09 09 09 09 20 20 68 65 g $) ....... he
1400: 61 64 65 72 73 3a 20 27 28 28 63 6f 6e 74 65 6e aders: '((conten
1410: 74 2d 74 79 70 65 20 74 65 78 74 2f 48 54 4d 4c t-type text/HTML
1420: 29 29 29 29 20 20 20 20 0a 20 20 20 20 20 20 20 )))) .
1430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1440: 20 20 20 20 20 20 20 20 20 20 20 28 28 65 71 75 ((equ
1450: 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 al? (uri-path (r
1460: 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 equest-uri (curr
1470: 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 20 0a ent-request))) .
1480: 09 09 09 09 09 20 20 20 27 28 2f 20 22 64 61 73 ..... '(/ "das
1490: 68 62 6f 61 72 64 22 29 29 0a 09 09 09 09 20 20 hboard")).....
14a0: 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 (send-response
14b0: 62 6f 64 79 3a 20 28 68 74 74 70 2d 74 72 61 6e body: (http-tran
14c0: 73 70 6f 72 74 3a 68 74 6d 6c 2d 64 62 6f 61 72 sport:html-dboar
14d0: 64 20 24 29 20 0a 09 09 09 09 09 09 20 20 68 65 d $) ....... he
14e0: 61 64 65 72 73 3a 20 27 28 28 63 6f 6e 74 65 6e aders: '((conten
14f0: 74 2d 74 79 70 65 20 74 65 78 74 2f 48 54 4d 4c t-type text/HTML
1500: 29 29 29 29 20 0a 09 09 09 09 20 20 28 65 6c 73 )))) ..... (els
1510: 65 20 28 63 6f 6e 74 69 6e 75 65 29 29 29 29 29 e (continue)))))
1520: 29 29 29 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d ))). (handle-
1530: 65 78 63 65 70 74 69 6f 6e 73 0a 09 65 78 6e 0a exceptions..exn.
1540: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
1550: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
1560: 67 2d 70 6f 72 74 2a 20 22 46 61 69 6c 65 64 20 g-port* "Failed
1570: 74 6f 20 63 72 65 61 74 65 20 66 69 6c 65 20 22 to create file "
1580: 20 73 74 61 72 74 2d 66 69 6c 65 20 22 2c 20 65 start-file ", e
1590: 78 6e 3d 22 20 65 78 6e 29 0a 20 20 20 20 20 20 xn=" exn).
15a0: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
15b0: 66 69 6c 65 20 73 74 61 72 74 2d 66 69 6c 65 20 file start-file
15c0: 28 6c 61 6d 62 64 61 20 28 29 28 70 72 69 6e 74 (lambda ()(print
15d0: 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
15e0: 73 2d 69 64 29 29 29 29 29 0a 20 20 20 20 28 68 s-id))))). (h
15f0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 ttp-transport:tr
1600: 79 2d 73 74 61 72 74 2d 73 65 72 76 65 72 20 69 y-start-server i
1610: 70 61 64 64 72 73 74 72 20 73 74 61 72 74 2d 70 paddrstr start-p
1620: 6f 72 74 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 ort)))..;; This
1630: 69 73 20 72 65 63 75 72 73 69 76 65 6c 79 20 72 is recursively r
1640: 75 6e 20 62 79 20 68 74 74 70 2d 74 72 61 6e 73 un by http-trans
1650: 70 6f 72 74 3a 72 75 6e 20 75 6e 74 69 6c 20 73 port:run until s
1660: 75 63 65 73 73 66 75 6c 0a 3b 3b 0a 28 64 65 66 ucessful.;;.(def
1670: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
1680: 6f 72 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 ort:try-start-se
1690: 72 76 65 72 20 69 70 61 64 64 72 73 74 72 20 70 rver ipaddrstr p
16a0: 6f 72 74 6e 75 6d 29 0a 20 20 28 6c 65 74 20 28 ortnum). (let (
16b0: 28 63 6f 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 (config-hostname
16c0: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
16d0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
16e0: 72 76 65 72 22 20 22 68 6f 73 74 6e 61 6d 65 22 rver" "hostname"
16f0: 29 29 0a 09 28 63 6f 6e 66 69 67 2d 75 73 65 2d ))..(config-use-
1700: 70 72 6f 78 79 20 28 65 71 75 61 6c 3f 20 28 63 proxy (equal? (c
1710: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
1720: 6f 6e 66 69 67 64 61 74 2a 20 22 63 6c 69 65 6e onfigdat* "clien
1730: 74 22 20 22 75 73 65 2d 68 74 74 70 5f 70 72 6f t" "use-http_pro
1740: 78 79 22 29 20 22 79 65 73 22 29 29 29 0a 20 20 xy") "yes"))).
1750: 20 20 28 69 66 20 28 6e 6f 74 20 63 6f 6e 66 69 (if (not confi
1760: 67 2d 75 73 65 2d 70 72 6f 78 79 29 0a 09 28 64 g-use-proxy)..(d
1770: 65 74 65 72 6d 69 6e 65 2d 70 72 6f 78 79 20 28 etermine-proxy (
1780: 63 6f 6e 73 74 61 6e 74 6c 79 20 23 66 29 29 29 constantly #f)))
1790: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
17a0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
17b0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 68 74 74 t-log-port* "htt
17c0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d p-transport:try-
17d0: 73 74 61 72 74 2d 73 65 72 76 65 72 20 74 69 6d start-server tim
17e0: 65 3d 22 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 e=" (seconds->ti
17f0: 6d 65 2d 73 74 72 69 6e 67 20 28 63 75 72 72 65 me-string (curre
1800: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 22 20 69 nt-seconds)) " i
1810: 70 61 64 64 72 73 73 74 72 3d 22 20 69 70 61 64 paddrsstr=" ipad
1820: 64 72 73 74 72 20 22 20 70 6f 72 74 6e 75 6d 3d drstr " portnum=
1830: 22 20 70 6f 72 74 6e 75 6d 20 22 20 63 6f 6e 66 " portnum " conf
1840: 69 67 2d 68 6f 73 74 6e 61 6d 65 3d 22 20 63 6f ig-hostname=" co
1850: 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 29 0a 20 nfig-hostname).
1860: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
1870: 74 69 6f 6e 73 0a 09 65 78 6e 0a 09 28 62 65 67 tions..exn..(beg
1880: 69 6e 0a 09 20 20 28 70 72 69 6e 74 2d 65 72 72 in.. (print-err
1890: 6f 72 2d 6d 65 73 73 61 67 65 20 65 78 6e 29 0a or-message exn).
18a0: 09 20 20 28 69 66 20 28 3c 20 70 6f 72 74 6e 75 . (if (< portnu
18b0: 6d 20 36 34 30 30 30 29 0a 09 20 20 20 20 20 20 m 64000)..
18c0: 28 62 65 67 69 6e 20 0a 09 09 28 64 65 62 75 67 (begin ...(debug
18d0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
18e0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
18f0: 4e 49 4e 47 3a 20 61 74 74 65 6d 70 74 20 74 6f NING: attempt to
1900: 20 73 74 61 72 74 20 73 65 72 76 65 72 20 66 61 start server fa
1910: 69 6c 65 64 2e 20 54 72 79 69 6e 67 20 61 67 61 iled. Trying aga
1920: 69 6e 20 2e 2e 2e 22 29 0a 09 09 28 64 65 62 75 in ...")...(debu
1930: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
1940: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d lt-log-port* " m
1950: 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 essage: " ((cond
1960: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
1970: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
1980: 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 09 28 ssage) exn))...(
1990: 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 2a 64 debug:print 5 *d
19a0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
19b0: 20 22 65 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 "exn=" (conditi
19c0: 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 0a 09 on->list exn))..
19d0: 09 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 .(portlogger:ope
19e0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 n-run-close port
19f0: 6c 6f 67 67 65 72 3a 73 65 74 2d 66 61 69 6c 65 logger:set-faile
1a00: 64 20 70 6f 72 74 6e 75 6d 29 0a 09 09 28 64 65 d portnum)...(de
1a10: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
1a20: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1a30: 57 41 52 4e 49 4e 47 3a 20 66 61 69 6c 65 64 20 WARNING: failed
1a40: 74 6f 20 73 74 61 72 74 20 6f 6e 20 70 6f 72 74 to start on port
1a50: 6e 75 6d 3a 20 22 20 70 6f 72 74 6e 75 6d 20 22 num: " portnum "
1a60: 2c 20 74 72 79 69 6e 67 20 6e 65 78 74 20 70 6f , trying next po
1a70: 72 74 22 29 0a 09 09 28 74 68 72 65 61 64 2d 73 rt")...(thread-s
1a80: 6c 65 65 70 21 20 30 2e 31 29 0a 09 09 0a 09 09 leep! 0.1)......
1a90: 3b 3b 20 67 65 74 5f 6e 65 78 74 5f 70 6f 72 74 ;; get_next_port
1aa0: 20 67 6f 65 73 20 68 65 72 65 0a 09 09 28 68 74 goes here...(ht
1ab0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 tp-transport:try
1ac0: 2d 73 74 61 72 74 2d 73 65 72 76 65 72 20 69 70 -start-server ip
1ad0: 61 64 64 72 73 74 72 0a 09 09 09 09 09 09 20 28 addrstr....... (
1ae0: 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 6e 2d portlogger:open-
1af0: 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 6c 6f run-close portlo
1b00: 67 67 65 72 3a 66 69 6e 64 2d 70 6f 72 74 29 29 gger:find-port))
1b10: 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ).. (begin.
1b20: 09 09 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a ..(print "ERROR:
1b30: 20 54 72 69 65 64 20 61 6e 64 20 74 72 69 65 64 Tried and tried
1b40: 20 62 75 74 20 63 6f 75 6c 64 20 6e 6f 74 20 73 but could not s
1b50: 74 61 72 74 20 74 68 65 20 73 65 72 76 65 72 22 tart the server"
1b60: 29 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 61 6e )))). ;; an
1b70: 79 20 65 72 72 6f 72 20 69 6e 20 66 6f 6c 6c 6f y error in follo
1b80: 77 69 6e 67 20 73 74 65 70 73 20 77 69 6c 6c 20 wing steps will
1b90: 72 65 73 75 6c 74 20 69 6e 20 61 20 72 65 74 72 result in a retr
1ba0: 79 0a 20 20 20 20 20 20 28 73 65 74 21 20 2a 73 y. (set! *s
1bb0: 65 72 76 65 72 2d 69 6e 66 6f 2a 20 28 6c 69 73 erver-info* (lis
1bc0: 74 20 69 70 61 64 64 72 73 74 72 20 70 6f 72 74 t ipaddrstr port
1bd0: 6e 75 6d 29 29 0a 20 20 20 20 20 20 28 64 65 62 num)). (deb
1be0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
1bf0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
1c00: 4e 46 4f 3a 20 54 72 79 69 6e 67 20 74 6f 20 73 NFO: Trying to s
1c10: 74 61 72 74 20 73 65 72 76 65 72 20 6f 6e 20 22 tart server on "
1c20: 20 69 70 61 64 64 72 73 74 72 20 22 3a 22 20 70 ipaddrstr ":" p
1c30: 6f 72 74 6e 75 6d 29 0a 20 20 20 20 20 20 3b 3b ortnum). ;;
1c40: 20 54 68 69 73 20 73 74 61 72 74 73 20 74 68 65 This starts the
1c50: 20 73 70 69 66 66 79 20 73 65 72 76 65 72 0a 20 spiffy server.
1c60: 20 20 20 20 20 3b 3b 20 4e 45 45 44 20 57 41 59 ;; NEED WAY
1c70: 20 54 4f 20 53 45 54 20 49 50 20 54 4f 20 23 66 TO SET IP TO #f
1c80: 20 54 4f 20 42 49 4e 44 20 41 4c 4c 0a 20 20 20 TO BIND ALL.
1c90: 20 20 20 3b 3b 20 28 73 74 61 72 74 2d 73 65 72 ;; (start-ser
1ca0: 76 65 72 20 62 69 6e 64 2d 61 64 64 72 65 73 73 ver bind-address
1cb0: 3a 20 69 70 61 64 64 72 73 74 72 20 70 6f 72 74 : ipaddrstr port
1cc0: 3a 20 70 6f 72 74 6e 75 6d 29 0a 20 20 20 20 20 : portnum).
1cd0: 20 28 69 66 20 63 6f 6e 66 69 67 2d 68 6f 73 74 (if config-host
1ce0: 6e 61 6d 65 20 3b 3b 20 74 68 69 73 20 69 73 20 name ;; this is
1cf0: 61 20 68 69 6e 74 20 74 6f 20 62 69 6e 64 20 64 a hint to bind d
1d00: 69 72 65 63 74 6c 79 0a 09 20 20 28 73 74 61 72 irectly.. (star
1d10: 74 2d 73 65 72 76 65 72 20 70 6f 72 74 3a 20 70 t-server port: p
1d20: 6f 72 74 6e 75 6d 20 62 69 6e 64 2d 61 64 64 72 ortnum bind-addr
1d30: 65 73 73 3a 20 28 69 66 20 28 65 71 75 61 6c 3f ess: (if (equal?
1d40: 20 63 6f 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 config-hostname
1d50: 20 22 2d 22 29 0a 09 09 09 09 09 09 09 69 70 61 "-")........ipa
1d60: 64 64 72 73 74 72 0a 09 09 09 09 09 09 09 63 6f ddrstr........co
1d70: 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 29 29 0a nfig-hostname)).
1d80: 09 20 20 28 73 74 61 72 74 2d 73 65 72 76 65 72 . (start-server
1d90: 20 70 6f 72 74 3a 20 70 6f 72 74 6e 75 6d 29 29 port: portnum))
1da0: 0a 20 20 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 . (portlogg
1db0: 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 er:open-run-clos
1dc0: 65 20 70 6f 72 74 6c 6f 67 67 65 72 3a 73 65 74 e portlogger:set
1dd0: 2d 70 6f 72 74 20 70 6f 72 74 6e 75 6d 20 22 72 -port portnum "r
1de0: 65 6c 65 61 73 65 64 22 29 0a 20 20 20 20 20 20 eleased").
1df0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 2a (debug:print 1 *
1e00: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1e10: 2a 20 22 49 4e 46 4f 3a 20 73 65 72 76 65 72 20 * "INFO: server
1e20: 68 61 73 20 62 65 65 6e 20 73 74 6f 70 70 65 64 has been stopped
1e30: 22 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d "))))..;;=======
1e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
1e80: 3b 3b 20 53 20 45 20 52 20 56 20 45 20 52 20 20 ;; S E R V E R
1e90: 20 55 20 54 20 49 20 4c 20 49 20 54 20 49 20 45 U T I L I T I E
1ea0: 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S .;;==========
1eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
1ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f30: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 20 4c 20 49 20 ======.;; C L I
1f40: 45 20 4e 20 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d E N T S.;;======
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 3d 3d 3d 3d 3d 3d ================
1f70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f90: 0a 0a 28 64 65 66 69 6e 65 20 2a 68 74 74 70 2d ..(define *http-
1fa0: 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 mutex* (make-mut
1fb0: 65 78 29 29 0a 0a 3b 3b 20 4e 4f 54 45 3a 20 4c ex))..;; NOTE: L
1fc0: 61 72 67 65 20 62 6c 6f 63 6b 20 6f 66 20 63 6f arge block of co
1fd0: 64 65 20 66 72 6f 6d 20 33 32 34 33 36 62 34 32 de from 32436b42
1fe0: 36 31 38 38 30 38 30 66 37 32 66 63 65 62 36 38 6188080f72fceb68
1ff0: 39 34 61 66 35 34 31 66 62 61 64 39 39 32 31 65 94af541fbad9921e
2000: 20 72 65 6d 6f 76 65 64 20 68 65 72 65 0a 3b 3b removed here.;;
2010: 20 20 20 20 20 20 20 49 27 6d 20 70 72 65 74 74 I'm prett
2020: 79 20 73 75 72 65 20 69 74 20 69 73 20 64 65 66 y sure it is def
2030: 75 6e 63 74 2e 0a 0a 3b 3b 20 54 68 69 73 20 6e unct...;; This n
2040: 65 78 74 20 62 6c 6f 63 6b 20 61 6c 6c 20 69 6d ext block all im
2050: 70 6f 72 74 65 64 20 65 6e 2d 6d 61 73 73 20 66 ported en-mass f
2060: 72 6f 6d 20 74 68 65 20 61 70 69 20 62 72 61 6e rom the api bran
2070: 63 68 0a 28 64 65 66 69 6e 65 20 2a 68 74 74 70 ch.(define *http
2080: 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 72 6f -requests-in-pro
2090: 67 72 65 73 73 2a 20 30 29 0a 28 64 65 66 69 6e gress* 0).(defin
20a0: 65 20 2a 68 74 74 70 2d 63 6f 6e 6e 65 63 74 69 e *http-connecti
20b0: 6f 6e 73 2d 6e 65 78 74 2d 63 6c 65 61 6e 75 70 ons-next-cleanup
20c0: 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e * (current-secon
20d0: 64 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 ds))..(define (h
20e0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 67 65 ttp-transport:ge
20f0: 74 2d 74 69 6d 65 2d 74 6f 2d 63 6c 65 61 6e 75 t-time-to-cleanu
2100: 70 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 p). (let ((res
2110: 23 66 29 29 0a 20 20 20 20 28 6d 75 74 65 78 2d #f)). (mutex-
2120: 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 65 lock! *http-mute
2130: 78 2a 29 0a 20 20 20 20 28 73 65 74 21 20 72 65 x*). (set! re
2140: 73 20 28 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 s (> (current-se
2150: 63 6f 6e 64 73 29 20 2a 68 74 74 70 2d 63 6f 6e conds) *http-con
2160: 6e 65 63 74 69 6f 6e 73 2d 6e 65 78 74 2d 63 6c nections-next-cl
2170: 65 61 6e 75 70 2a 29 29 0a 20 20 20 20 28 6d 75 eanup*)). (mu
2180: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 tex-unlock! *htt
2190: 70 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 72 65 p-mutex*). re
21a0: 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 s))..(define (ht
21b0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 69 6e 63 tp-transport:inc
21c0: 2d 72 65 71 75 65 73 74 73 2d 63 6f 75 6e 74 29 -requests-count)
21d0: 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 . (mutex-lock!
21e0: 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 *http-mutex*).
21f0: 28 73 65 74 21 20 2a 68 74 74 70 2d 72 65 71 75 (set! *http-requ
2200: 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 ests-in-progress
2210: 2a 20 28 2b 20 31 20 2a 68 74 74 70 2d 72 65 71 * (+ 1 *http-req
2220: 75 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 uests-in-progres
2230: 73 2a 29 29 0a 20 20 3b 3b 20 55 73 65 20 74 68 s*)). ;; Use th
2240: 69 73 20 6f 70 70 6f 72 74 75 6e 69 74 79 20 74 is opportunity t
2250: 6f 20 73 6c 6f 77 20 74 68 69 6e 67 73 20 64 6f o slow things do
2260: 77 6e 20 69 66 66 20 74 68 65 72 65 20 61 72 65 wn iff there are
2270: 20 74 6f 6f 20 6d 61 6e 79 20 72 65 71 75 65 73 too many reques
2280: 74 73 20 69 6e 20 66 6c 69 67 68 74 0a 20 20 28 ts in flight. (
2290: 69 66 20 28 3e 20 2a 68 74 74 70 2d 72 65 71 75 if (> *http-requ
22a0: 65 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 ests-in-progress
22b0: 2a 20 35 29 0a 20 20 20 20 20 20 28 62 65 67 69 * 5). (begi
22c0: 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d n..(debug:print-
22d0: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
22e0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 68 6f 61 20 log-port* "Whoa
22f0: 74 68 65 72 65 20 62 75 64 64 79 2c 20 65 61 73 there buddy, eas
2300: 65 20 75 70 2e 2e 2e 22 29 0a 09 28 74 68 72 65 e up...")..(thre
2310: 61 64 2d 73 6c 65 65 70 21 20 31 29 29 29 0a 20 ad-sleep! 1))).
2320: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
2330: 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 29 0a 0a *http-mutex*))..
2340: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
2350: 61 6e 73 70 6f 72 74 3a 64 65 63 2d 72 65 71 75 ansport:dec-requ
2360: 65 73 74 73 2d 63 6f 75 6e 74 20 70 72 6f 63 29 ests-count proc)
2370: 20 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 . (mutex-lock!
2380: 20 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 *http-mutex*).
2390: 20 28 70 72 6f 63 29 0a 20 20 28 73 65 74 21 20 (proc). (set!
23a0: 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 *http-requests-i
23b0: 6e 2d 70 72 6f 67 72 65 73 73 2a 20 28 2d 20 2a n-progress* (- *
23c0: 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e http-requests-in
23d0: 2d 70 72 6f 67 72 65 73 73 2a 20 31 29 29 0a 20 -progress* 1)).
23e0: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
23f0: 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 29 0a 0a *http-mutex*))..
2400: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
2410: 61 6e 73 70 6f 72 74 3a 64 65 63 2d 72 65 71 75 ansport:dec-requ
2420: 65 73 74 73 2d 63 6f 75 6e 74 2d 61 6e 64 2d 63 ests-count-and-c
2430: 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 lose-all-connect
2440: 69 6f 6e 73 29 0a 20 20 28 73 65 74 21 20 2a 68 ions). (set! *h
2450: 74 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d ttp-requests-in-
2460: 70 72 6f 67 72 65 73 73 2a 20 28 2d 20 2a 68 74 progress* (- *ht
2470: 74 70 2d 72 65 71 75 65 73 74 73 2d 69 6e 2d 70 tp-requests-in-p
2480: 72 6f 67 72 65 73 73 2a 20 31 29 29 0a 20 20 28 rogress* 1)). (
2490: 6c 65 74 20 6c 6f 6f 70 20 28 28 65 74 69 6d 65 let loop ((etime
24a0: 20 28 2b 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (+ (current-sec
24b0: 6f 6e 64 73 29 20 35 29 29 29 20 3b 3b 20 67 69 onds) 5))) ;; gi
24c0: 76 65 20 75 70 20 69 6e 20 66 69 76 65 20 73 65 ve up in five se
24d0: 63 6f 6e 64 73 0a 20 20 20 20 28 69 66 20 28 3e conds. (if (>
24e0: 20 2a 68 74 74 70 2d 72 65 71 75 65 73 74 73 2d *http-requests-
24f0: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 30 29 0a in-progress* 0).
2500: 09 28 69 66 20 28 3e 20 65 74 69 6d 65 20 28 63 .(if (> etime (c
2510: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
2520: 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 .. (begin..
2530: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
2540: 70 21 20 30 2e 30 35 29 0a 09 20 20 20 20 20 20 p! 0.05)..
2550: 28 6c 6f 6f 70 20 65 74 69 6d 65 29 29 0a 09 20 (loop etime))..
2560: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
2570: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
2580: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 71 75 -log-port* "requ
2590: 65 73 74 73 20 73 74 69 6c 6c 20 69 6e 20 70 72 ests still in pr
25a0: 6f 67 72 65 73 73 20 61 66 74 65 72 20 35 20 73 ogress after 5 s
25b0: 65 63 6f 6e 64 73 20 6f 66 20 77 61 69 74 69 6e econds of waitin
25c0: 67 2e 20 49 27 6d 20 67 6f 69 6e 67 20 74 6f 20 g. I'm going to
25d0: 70 61 73 73 20 6f 6e 20 63 6c 65 61 6e 69 6e 67 pass on cleaning
25e0: 20 75 70 20 68 74 74 70 20 63 6f 6e 6e 65 63 74 up http connect
25f0: 69 6f 6e 73 22 29 29 0a 09 28 63 6c 6f 73 65 2d ions"))..(close-
2600: 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 all-connections!
2610: 29 29 29 0a 20 20 28 73 65 74 21 20 2a 68 74 74 ))). (set! *htt
2620: 70 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 2d 6e 65 p-connections-ne
2630: 78 74 2d 63 6c 65 61 6e 75 70 2a 20 28 2b 20 28 xt-cleanup* (+ (
2640: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
2650: 20 31 30 29 29 0a 20 20 28 6d 75 74 65 78 2d 75 10)). (mutex-u
2660: 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 nlock! *http-mut
2670: 65 78 2a 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ex*))..(define (
2680: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 69 http-transport:i
2690: 6e 63 2d 72 65 71 75 65 73 74 73 2d 61 6e 64 2d nc-requests-and-
26a0: 70 72 65 70 2d 74 6f 2d 63 6c 6f 73 65 2d 61 6c prep-to-close-al
26b0: 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 29 0a 20 l-connections).
26c0: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 (mutex-lock! *h
26d0: 74 74 70 2d 6d 75 74 65 78 2a 29 0a 20 20 28 73 ttp-mutex*). (s
26e0: 65 74 21 20 2a 68 74 74 70 2d 72 65 71 75 65 73 et! *http-reques
26f0: 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 ts-in-progress*
2700: 28 2b 20 31 20 2a 68 74 74 70 2d 72 65 71 75 65 (+ 1 *http-reque
2710: 73 74 73 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a sts-in-progress*
2720: 29 29 29 0a 0a 3b 3b 20 53 65 6e 64 20 22 63 6d )))..;; Send "cm
2730: 64 22 20 77 69 74 68 20 6a 73 6f 6e 20 70 61 79 d" with json pay
2740: 6c 6f 61 64 20 22 70 61 72 61 6d 73 22 20 74 6f load "params" to
2750: 20 73 65 72 76 65 72 64 61 74 20 61 6e 64 20 72 serverdat and r
2760: 65 63 65 69 76 65 20 72 65 73 75 6c 74 0a 3b 3b eceive result.;;
2770: 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 .(define (http-t
2780: 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d ransport:client-
2790: 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 api-send-receive
27a0: 20 72 75 6e 2d 69 64 20 73 65 72 76 65 72 64 61 run-id serverda
27b0: 74 20 63 6d 64 20 70 61 72 61 6d 73 20 23 21 6b t cmd params #!k
27c0: 65 79 20 28 6e 75 6d 72 65 74 72 69 65 73 20 33 ey (numretries 3
27d0: 29 28 61 72 65 61 2d 64 61 74 20 23 66 29 29 0a )(area-dat #f)).
27e0: 20 20 28 6c 65 74 2a 20 28 28 66 75 6c 6c 75 72 (let* ((fullur
27f0: 6c 20 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 l (if (vector
2800: 3f 20 73 65 72 76 65 72 64 61 74 29 0a 09 09 09 ? serverdat)....
2810: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
2820: 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d :server-dat-get-
2830: 61 70 69 2d 72 65 71 20 73 65 72 76 65 72 64 61 api-req serverda
2840: 74 29 0a 09 09 09 20 28 62 65 67 69 6e 0a 09 09 t).... (begin...
2850: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
2860: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
2870: 70 6f 72 74 2a 20 22 46 41 54 41 4c 20 45 52 52 port* "FATAL ERR
2880: 4f 52 3a 20 68 74 74 70 2d 74 72 61 6e 73 70 6f OR: http-transpo
2890: 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 rt:client-api-se
28a0: 6e 64 2d 72 65 63 65 69 76 65 20 63 61 6c 6c 65 nd-receive calle
28b0: 64 20 77 69 74 68 20 6e 6f 20 73 65 72 76 65 72 d with no server
28c0: 20 69 6e 66 6f 22 29 0a 09 09 09 20 20 20 28 65 info").... (e
28d0: 78 69 74 20 31 29 29 29 29 0a 09 20 28 72 65 73 xit 1)))).. (res
28e0: 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 20 (vector
28f0: 23 66 20 22 75 6e 69 6e 69 74 69 61 6c 69 7a 65 #f "uninitialize
2900: 64 22 29 29 0a 09 20 28 73 75 63 63 65 73 73 20 d")).. (success
2910: 20 20 20 23 74 29 0a 09 20 28 73 70 61 72 61 6d #t).. (sparam
2920: 73 20 20 20 20 28 64 62 3a 6f 62 6a 2d 3e 73 74 s (db:obj->st
2930: 72 69 6e 67 20 70 61 72 61 6d 73 20 74 72 61 6e ring params tran
2940: 73 70 6f 72 74 3a 20 27 68 74 74 70 29 29 0a 09 sport: 'http))..
2950: 20 28 72 75 6e 72 65 6d 6f 74 65 20 20 28 6f 72 (runremote (or
2960: 20 61 72 65 61 2d 64 61 74 20 2a 72 75 6e 72 65 area-dat *runre
2970: 6d 6f 74 65 2a 29 29 0a 20 20 20 20 20 20 20 20 mote*)).
2980: 20 28 73 65 72 76 65 72 2d 69 64 20 20 20 28 69 (server-id (i
2990: 66 20 28 76 65 63 74 6f 72 3f 20 73 65 72 76 65 f (vector? serve
29a0: 72 64 61 74 29 20 0a 20 20 20 20 20 20 20 20 20 rdat) .
29b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29c0: 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 (http-transpor
29d0: 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 t:server-dat-get
29e0: 2d 73 65 72 76 65 72 2d 69 64 20 73 65 72 76 65 -server-id serve
29f0: 72 64 61 74 29 0a 20 20 20 20 20 20 20 20 20 20 rdat).
2a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a10: 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 (begin....
2a20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
2a30: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2a40: 2a 20 22 46 41 54 41 4c 20 45 52 52 4f 52 3a 20 * "FATAL ERROR:
2a50: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 http-transport:c
2a60: 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 lient-api-send-r
2a70: 65 63 65 69 76 65 20 63 61 6c 6c 65 64 20 77 69 eceive called wi
2a80: 74 68 20 6e 6f 20 73 65 72 76 65 72 20 69 6e 66 th no server inf
2a90: 6f 22 29 0a 09 09 09 20 20 20 20 20 28 65 78 69 o").... (exi
2aa0: 74 20 31 29 29 29 29 29 0a 20 20 20 20 20 20 20 t 1))))).
2ab0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
2ac0: 6f 20 31 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f o 11 *default-lo
2ad0: 67 2d 70 6f 72 74 2a 20 22 63 6d 64 3d 22 20 63 g-port* "cmd=" c
2ae0: 6d 64 20 22 20 66 75 6c 6c 75 72 6c 3d 22 20 66 md " fullurl=" f
2af0: 75 6c 6c 75 72 6c 20 22 20 73 65 72 76 65 72 2d ullurl " server-
2b00: 69 64 3d 22 20 73 65 72 76 65 72 2d 69 64 20 22 id=" server-id "
2b10: 20 63 75 72 72 65 6e 74 20 74 69 6d 65 3a 22 20 current time:"
2b20: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
2b30: 29 29 20 0a 0a 20 20 20 20 20 20 20 3b 3b 20 73 )) .. ;; s
2b40: 65 74 20 75 70 20 74 68 65 20 68 74 74 70 2d 63 et up the http-c
2b50: 6c 69 65 6e 74 20 68 65 72 65 0a 20 20 20 20 20 lient here.
2b60: 20 20 28 6d 61 78 2d 72 65 74 72 79 2d 61 74 74 (max-retry-att
2b70: 65 6d 70 74 73 20 31 29 0a 20 20 20 20 20 20 20 empts 1).
2b80: 3b 3b 20 63 6f 6e 73 69 64 65 72 20 61 6c 6c 20 ;; consider all
2b90: 72 65 71 75 65 73 74 73 20 69 6e 64 65 6d 70 6f requests indempo
2ba0: 74 65 6e 74 0a 20 20 20 20 20 20 20 28 72 65 74 tent. (ret
2bb0: 72 79 2d 72 65 71 75 65 73 74 3f 20 28 6c 61 6d ry-request? (lam
2bc0: 62 64 61 20 28 72 65 71 75 65 73 74 29 0a 09 09 bda (request)...
2bd0: 09 20 23 66 29 29 0a 20 20 20 20 20 20 20 3b 3b . #f)). ;;
2be0: 20 73 65 6e 64 20 74 68 65 20 64 61 74 61 20 61 send the data a
2bf0: 6e 64 20 67 65 74 20 74 68 65 20 72 65 73 70 6f nd get the respo
2c00: 6e 73 65 0a 20 20 20 20 20 20 20 3b 3b 20 65 78 nse. ;; ex
2c10: 74 72 61 63 74 20 74 68 65 20 6e 65 65 64 65 64 tract the needed
2c20: 20 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 20 68 info from the h
2c30: 74 74 70 20 64 61 74 61 20 61 6e 64 20 0a 20 20 ttp data and .
2c40: 20 20 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 20 ;; process
2c50: 61 6e 64 20 72 65 74 75 72 6e 20 69 74 2e 0a 20 and return it..
2c60: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 65 (let* ((se
2c70: 6e 64 2d 72 65 63 69 65 76 65 20 28 6c 61 6d 62 nd-recieve (lamb
2c80: 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 28 da ().... (
2c90: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 74 74 mutex-lock! *htt
2ca0: 70 2d 6d 75 74 65 78 2a 29 0a 09 09 09 20 20 20 p-mutex*)....
2cb0: 20 20 20 3b 3b 20 28 63 6f 6e 64 69 74 69 6f 6e ;; (condition
2cc0: 2d 63 61 73 65 20 28 77 69 74 68 2d 69 6e 70 75 -case (with-inpu
2cd0: 74 2d 66 72 6f 6d 2d 72 65 71 75 65 73 74 20 22 t-from-request "
2ce0: 68 74 74 70 3a 2f 2f 6c 6f 63 61 6c 68 6f 73 74 http://localhost
2cf0: 22 3b 20 23 66 20 72 65 61 64 2d 6c 69 6e 65 73 "; #f read-lines
2d00: 29 0a 09 09 09 20 20 20 20 20 20 3b 3b 09 09 09 ).... ;;...
2d10: 09 09 20 20 20 20 20 20 20 28 28 65 78 6e 20 68 .. ((exn h
2d20: 74 74 70 20 63 6c 69 65 6e 74 2d 65 72 72 6f 72 ttp client-error
2d30: 29 20 65 20 28 70 72 69 6e 74 20 65 29 29 29 0a ) e (print e))).
2d40: 09 09 09 20 20 20 20 20 20 28 73 65 74 21 20 72 ... (set! r
2d50: 65 73 20 28 76 65 63 74 6f 72 20 20 20 20 20 20 es (vector
2d60: 20 20 20 20 20 20 20 20 20 20 3b 3b 3b 20 44 4f ;;; DO
2d70: 4e 27 54 20 46 4f 52 47 45 54 20 2d 20 54 48 49 N'T FORGET - THI
2d80: 53 20 49 53 20 54 48 45 20 43 4c 49 45 4e 54 20 S IS THE CLIENT
2d90: 53 49 44 45 21 20 4e 4f 54 45 3a 20 63 6f 6e 73 SIDE! NOTE: cons
2da0: 69 64 65 72 20 6d 6f 76 69 6e 67 20 74 68 69 73 ider moving this
2db0: 20 74 6f 20 63 6c 69 65 6e 74 2e 73 63 6d 20 73 to client.scm s
2dc0: 69 6e 63 65 20 77 65 20 61 72 65 20 6f 6e 6c 79 ince we are only
2dd0: 20 73 75 70 70 6f 72 74 69 6e 67 20 68 74 74 70 supporting http
2de0: 20 74 72 61 6e 73 70 6f 72 74 20 61 74 20 74 68 transport at th
2df0: 69 73 20 74 69 6d 65 2e 0a 09 09 09 09 09 20 73 is time....... s
2e00: 75 63 63 65 73 73 0a 09 09 09 09 09 20 28 64 62 uccess...... (db
2e10: 3a 73 74 72 69 6e 67 2d 3e 6f 62 6a 20 0a 09 09 :string->obj ...
2e20: 09 09 09 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 ... (handle-exc
2e30: 65 70 74 69 6f 6e 73 0a 09 09 09 09 09 20 20 20 eptions......
2e40: 20 20 20 65 78 6e 0a 09 09 09 09 09 20 20 20 20 exn......
2e50: 20 20 28 6c 65 74 20 28 28 63 61 6c 6c 2d 63 68 (let ((call-ch
2e60: 61 69 6e 20 28 67 65 74 2d 63 61 6c 6c 2d 63 68 ain (get-call-ch
2e70: 61 69 6e 29 29 0a 09 09 09 09 09 09 20 20 20 20 ain)).......
2e80: 28 6d 73 67 20 20 20 20 20 20 20 20 28 28 63 6f (msg ((co
2e90: 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
2ea0: 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 -accessor 'exn '
2eb0: 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 29 0a message) exn))).
2ec0: 09 09 09 09 09 09 28 73 65 74 21 20 73 75 63 63 ......(set! succ
2ed0: 65 73 73 20 23 66 29 0a 20 20 20 20 20 20 20 20 ess #f).
2ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f00: 20 20 20 20 20 20 20 20 28 69 66 20 28 64 65 62 (if (deb
2f10: 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 29 ug:debug-mode 1)
2f20: 0a 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 20 20 20 20 20
2f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f50: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
2f60: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
2f70: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6f 75 t-log-port* "cou
2f80: 6c 64 6e 27 74 20 74 61 6c 6b 20 74 6f 20 73 65 ldn't talk to se
2f90: 72 76 65 72 2c 20 74 72 79 69 6e 67 20 61 67 61 rver, trying aga
2fa0: 69 6e 20 2e 2e 2e 22 29 0a 20 20 20 20 20 20 20 in ...").
2fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 (be
2fe0: 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 gin.
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 20
3010: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
3020: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
3030: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
3040: 4e 49 4e 47 3a 20 66 61 69 6c 75 72 65 20 69 6e NING: failure in
3050: 20 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d with-input-from
3060: 2d 72 65 71 75 65 73 74 20 74 6f 20 22 20 66 75 -request to " fu
3070: 6c 6c 75 72 6c 20 22 2e 22 29 0a 20 20 20 20 20 llurl ".").
3080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
30a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
30b0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
30c0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
30d0: 74 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 t* " message: "
30e0: 6d 73 67 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e msg ", exn=" exn
30f0: 29 0a 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 20
3120: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
3130: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
3140: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 63 6d 64 3a log-port* " cmd:
3150: 20 22 20 63 6d 64 20 22 20 70 61 72 61 6d 73 3a " cmd " params:
3160: 20 22 20 70 61 72 61 6d 73 20 22 20 6b 65 79 3a " params " key:
3170: 22 20 28 6f 72 20 73 65 72 76 65 72 2d 69 64 20 " (or server-id
3180: 22 74 68 65 6b 65 79 22 29 29 0a 20 20 20 20 20 "thekey")).
3190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
31a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
31b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
31c0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
31d0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
31e0: 74 2a 20 22 20 63 61 6c 6c 2d 63 68 61 69 6e 3a t* " call-chain:
31f0: 20 22 20 63 61 6c 6c 2d 63 68 61 69 6e 29 29 29 " call-chain)))
3200: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3230: 20 28 69 66 20 72 75 6e 72 65 6d 6f 74 65 0a 09 (if runremote..
3240: 09 09 09 09 09 20 20 20 20 28 72 65 6d 6f 74 65 ..... (remote
3250: 2d 63 6f 6e 6e 64 61 74 2d 73 65 74 21 20 72 75 -conndat-set! ru
3260: 6e 72 65 6d 6f 74 65 20 23 66 29 29 0a 09 09 09 nremote #f))....
3270: 09 09 09 3b 3b 20 4b 69 6c 6c 69 6e 67 20 61 73 ...;; Killing as
3280: 73 6f 63 69 61 74 65 64 20 73 65 72 76 65 72 20 sociated server
3290: 74 6f 20 61 6c 6c 6f 77 20 63 6c 65 61 6e 20 72 to allow clean r
32a0: 65 74 72 79 2e 22 29 0a 09 09 09 09 09 09 3b 3b etry.").......;;
32b0: 20 28 74 61 73 6b 73 3a 6b 69 6c 6c 2d 73 65 72 (tasks:kill-ser
32c0: 76 65 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 ver-run-id run-i
32d0: 64 29 20 20 3b 3b 20 62 65 74 74 65 72 20 74 6f d) ;; better to
32e0: 20 6b 69 6c 6c 20 74 68 65 20 73 65 72 76 65 72 kill the server
32f0: 20 69 6e 20 74 68 65 20 6c 6f 67 69 63 20 74 68 in the logic th
3300: 61 74 20 63 61 6c 6c 65 64 20 74 68 69 73 20 72 at called this r
3310: 6f 75 74 69 6e 65 3f 0a 09 09 09 09 09 09 28 6d outine?.......(m
3320: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 utex-unlock! *ht
3330: 74 70 2d 6d 75 74 65 78 2a 29 0a 09 09 09 09 09 tp-mutex*)......
3340: 20 20 20 20 20 3b 3b 3b 20 28 73 69 67 6e 61 6c ;;; (signal
3350: 20 28 6d 61 6b 65 2d 63 6f 6d 70 6f 73 69 74 65 (make-composite
3360: 2d 63 6f 6e 64 69 74 69 6f 6e 0a 09 09 09 09 09 -condition......
3370: 20 20 20 20 20 3b 3b 3b 20 20 20 20 20 20 20 20 ;;;
3380: 20 20 28 6d 61 6b 65 2d 70 72 6f 70 65 72 74 79 (make-property
3390: 2d 63 6f 6e 64 69 74 69 6f 6e 20 27 63 6f 6d 6d -condition 'comm
33a0: 66 61 69 6c 20 27 6d 65 73 73 61 67 65 20 22 66 fail 'message "f
33b0: 61 69 6c 65 64 20 74 6f 20 63 6f 6e 6e 65 63 74 ailed to connect
33c0: 20 74 6f 20 73 65 72 76 65 72 22 29 29 29 0a 09 to server")))..
33d0: 09 09 09 09 20 20 20 20 20 3b 3b 3b 20 22 63 6f .... ;;; "co
33e0: 6d 6d 75 6e 69 63 61 74 69 6f 6e 73 20 66 61 69 mmunications fai
33f0: 6c 65 64 22 0a 09 09 09 09 09 09 28 64 62 3a 6f led".......(db:o
3400: 62 6a 2d 3e 73 74 72 69 6e 67 20 23 66 29 29 0a bj->string #f)).
3410: 09 09 09 09 09 20 20 20 20 28 77 69 74 68 2d 69 ..... (with-i
3420: 6e 70 75 74 2d 66 72 6f 6d 2d 72 65 71 75 65 73 nput-from-reques
3430: 74 20 3b 3b 20 77 61 73 20 64 61 74 0a 09 09 09 t ;; was dat....
3440: 09 09 20 20 20 20 20 66 75 6c 6c 75 72 6c 20 0a .. fullurl .
3450: 09 09 09 09 09 20 20 20 20 20 28 6c 69 73 74 20 ..... (list
3460: 28 63 6f 6e 73 20 27 6b 65 79 20 28 6f 72 20 73 (cons 'key (or s
3470: 65 72 76 65 72 2d 69 64 20 20 20 22 74 68 65 6b erver-id "thek
3480: 65 79 22 29 29 0a 09 09 09 09 09 09 20 20 20 28 ey"))....... (
3490: 63 6f 6e 73 20 27 63 6d 64 20 63 6d 64 29 0a 09 cons 'cmd cmd)..
34a0: 09 09 09 09 09 20 20 20 28 63 6f 6e 73 20 27 70 ..... (cons 'p
34b0: 61 72 61 6d 73 20 73 70 61 72 61 6d 73 29 29 0a arams sparams)).
34c0: 09 09 09 09 09 20 20 20 20 20 72 65 61 64 2d 73 ..... read-s
34d0: 74 72 69 6e 67 29 29 0a 09 09 09 09 09 20 20 74 tring))...... t
34e0: 72 61 6e 73 70 6f 72 74 3a 20 27 68 74 74 70 29 ransport: 'http)
34f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3510: 20 20 20 20 20 20 20 20 20 20 30 29 29 20 3b 3b 0)) ;;
3520: 20 61 64 64 65 64 20 74 68 69 73 20 73 70 65 63 added this spec
3530: 75 6c 61 74 69 76 65 6c 79 0a 09 09 09 20 20 20 ulatively....
3540: 20 20 20 3b 3b 20 53 68 6f 75 6c 64 6e 27 74 20 ;; Shouldn't
3550: 74 68 69 73 20 62 65 20 61 20 63 61 6c 6c 20 74 this be a call t
3560: 6f 20 74 68 65 20 6d 61 6e 61 67 65 64 20 63 61 o the managed ca
3570: 6c 6c 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f ll-all-connectio
3580: 6e 73 20 73 74 75 66 66 20 61 62 6f 76 65 3f 0a ns stuff above?.
3590: 09 09 09 20 20 20 20 20 20 28 63 6c 6f 73 65 2d ... (close-
35a0: 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 all-connections!
35b0: 29 0a 09 09 09 20 20 20 20 20 20 28 6d 75 74 65 ).... (mute
35c0: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d x-unlock! *http-
35d0: 6d 75 74 65 78 2a 29 0a 09 09 09 20 20 20 20 20 mutex*)....
35e0: 20 29 29 0a 09 20 20 20 20 20 20 28 74 69 6d 65 )).. (time
35f0: 2d 6f 75 74 20 20 20 20 20 28 6c 61 6d 62 64 61 -out (lambda
3600: 20 28 29 0a 09 09 09 20 20 20 20 20 20 28 74 68 ().... (th
3610: 72 65 61 64 2d 73 6c 65 65 70 21 20 34 35 29 0a read-sleep! 45).
3620: 09 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
3630: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
3640: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e -log-port* "WARN
3650: 49 4e 47 3a 20 73 65 6e 64 2d 72 65 63 65 69 76 ING: send-receiv
3660: 65 20 74 6f 6f 6b 20 6d 6f 72 65 20 74 68 61 6e e took more than
3670: 20 34 35 20 73 65 63 6f 6e 64 73 21 21 22 29 0a 45 seconds!!").
3680: 09 09 09 20 20 20 20 20 20 23 66 29 29 0a 09 20 ... #f))..
3690: 20 20 20 20 20 28 74 68 31 20 28 6d 61 6b 65 2d (th1 (make-
36a0: 74 68 72 65 61 64 20 73 65 6e 64 2d 72 65 63 69 thread send-reci
36b0: 65 76 65 20 22 77 69 74 68 2d 69 6e 70 75 74 2d eve "with-input-
36c0: 66 72 6f 6d 2d 72 65 71 75 65 73 74 22 29 29 0a from-request")).
36d0: 09 20 20 20 20 20 20 28 74 68 32 20 28 6d 61 6b . (th2 (mak
36e0: 65 2d 74 68 72 65 61 64 20 74 69 6d 65 2d 6f 75 e-thread time-ou
36f0: 74 20 20 20 20 20 22 74 69 6d 65 20 6f 75 74 22 t "time out"
3700: 29 29 29 0a 09 20 28 74 68 72 65 61 64 2d 73 74 ))).. (thread-st
3710: 61 72 74 21 20 74 68 31 29 0a 09 20 28 74 68 72 art! th1).. (thr
3720: 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a ead-start! th2).
3730: 09 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 . (thread-join!
3740: 74 68 31 29 0a 20 20 20 20 20 20 20 20 20 20 28 th1). (
3750: 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 73 20 vector-set! res
3760: 30 20 73 75 63 63 65 73 73 29 0a 09 20 28 74 68 0 success).. (th
3770: 72 65 61 64 2d 74 65 72 6d 69 6e 61 74 65 21 20 read-terminate!
3780: 74 68 32 29 0a 09 20 28 69 66 20 28 76 65 63 74 th2).. (if (vect
3790: 6f 72 3f 20 72 65 73 29 0a 09 20 20 20 20 20 28 or? res).. (
37a0: 69 66 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 if (vector-ref r
37b0: 65 73 20 30 29 20 3b 3b 20 74 68 69 73 20 69 73 es 0) ;; this is
37c0: 20 74 68 65 20 66 69 72 73 74 20 66 6c 61 67 20 the first flag
37d0: 6f 72 20 74 68 65 20 73 65 63 6f 6e 64 20 66 6c or the second fl
37e0: 61 67 3f 20 0a 20 20 20 20 20 20 20 20 20 20 20 ag? .
37f0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 65 (let* ((re
3800: 73 2d 64 61 74 20 28 76 65 63 74 6f 72 2d 72 65 s-dat (vector-re
3810: 66 20 72 65 73 20 31 29 29 29 0a 20 20 20 20 20 f res 1))).
3820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3830: 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f if (and (string?
3840: 20 72 65 73 2d 64 61 74 29 20 28 73 74 72 69 6e res-dat) (strin
3850: 67 2d 63 6f 6e 74 61 69 6e 73 20 72 65 73 2d 64 g-contains res-d
3860: 61 74 20 22 73 65 72 76 65 72 2d 69 64 20 6d 69 at "server-id mi
3870: 73 6d 61 74 63 68 22 29 29 0a 20 20 20 20 20 20 smatch")).
3880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3890: 73 69 67 6e 61 6c 20 28 6d 61 6b 65 2d 63 6f 6d signal (make-com
38a0: 70 6f 73 69 74 65 2d 63 6f 6e 64 69 74 69 6f 6e posite-condition
38b0: 0a 09 09 20 20 20 20 20 20 20 20 20 20 28 6d 61 ... (ma
38c0: 6b 65 2d 70 72 6f 70 65 72 74 79 2d 63 6f 6e 64 ke-property-cond
38d0: 69 74 69 6f 6e 20 0a 09 09 20 20 20 20 20 20 20 ition ...
38e0: 27 73 65 72 76 65 72 6d 69 73 6d 61 74 63 68 0a 'servermismatch.
38f0: 09 09 20 20 20 20 20 20 20 27 6d 65 73 73 61 67 .. 'messag
3900: 65 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 e (vector-ref r
3910: 65 73 20 31 29 29 29 29 20 20 20 20 20 20 20 0a es 1)))) .
3920: 09 09 20 20 20 20 20 20 72 65 73 29 29 20 3b 3b .. res)) ;;
3930: 20 74 68 69 73 20 69 73 20 74 68 65 20 2a 69 6e this is the *in
3940: 6e 65 72 2a 20 76 65 63 74 6f 72 3f 20 73 65 72 ner* vector? ser
3950: 69 6f 75 73 6c 79 3f 20 77 68 79 3f 0a 20 20 20 iously? why?.
3960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
3970: 66 20 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d f (debug:debug-m
3980: 6f 64 65 20 31 31 29 0a 20 20 20 20 20 20 20 20 ode 11).
3990: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
39a0: 74 20 28 28 63 61 6c 6c 2d 63 68 61 69 6e 20 28 t ((call-chain (
39b0: 67 65 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 29 get-call-chain))
39c0: 29 20 3b 3b 20 6e 6f 74 65 3a 20 74 68 69 73 20 ) ;; note: this
39d0: 63 6f 64 65 20 61 6c 73 6f 20 63 61 6c 6c 65 64 code also called
39e0: 20 69 6e 20 6e 6d 73 67 2d 74 72 61 6e 73 70 6f in nmsg-transpo
39f0: 72 74 20 2d 20 63 6f 6e 73 69 64 65 72 20 63 6f rt - consider co
3a00: 6e 73 6f 6c 69 64 61 74 69 6e 67 20 69 74 0a 20 nsolidating it.
3a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a20: 20 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c (print-cal
3a30: 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 l-chain (current
3a40: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 -error-port)).
3a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a60: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
3a70: 74 2d 65 72 72 6f 72 20 31 31 20 2a 64 65 66 61 t-error 11 *defa
3a80: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 65 ult-log-port* "e
3a90: 72 72 6f 72 20 61 62 6f 76 65 20 6f 63 63 75 72 rror above occur
3aa0: 65 64 20 61 74 20 73 65 72 76 65 72 2c 20 72 65 ed at server, re
3ab0: 73 3d 22 20 72 65 73 29 20 3b 3b 20 22 20 6d 65 s=" res) ;; " me
3ac0: 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 ssage: " ((condi
3ad0: 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 tion-property-ac
3ae0: 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 cessor 'exn 'mes
3af0: 73 61 67 65 29 20 65 78 6e 29 29 0a 20 20 20 20 sage) exn)).
3b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b10: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
3b20: 31 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 11 *default-log-
3b30: 70 6f 72 74 2a 20 22 20 73 65 72 76 65 72 20 63 port* " server c
3b40: 61 6c 6c 20 63 68 61 69 6e 3a 22 29 0a 20 20 20 all chain:").
3b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b60: 20 20 20 20 28 70 70 20 28 76 65 63 74 6f 72 2d (pp (vector-
3b70: 72 65 66 20 72 65 73 20 31 29 20 28 63 75 72 72 ref res 1) (curr
3b80: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
3b90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3ba0: 20 20 20 20 20 20 20 20 28 73 69 67 6e 61 6c 20 (signal
3bb0: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 73 20 (vector-ref res
3bc0: 30 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 0))).
3bd0: 20 20 20 20 20 20 20 20 20 20 72 65 73 29 29 0a res)).
3be0: 09 20 20 20 20 20 28 73 69 67 6e 61 6c 20 28 6d . (signal (m
3bf0: 61 6b 65 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 6f ake-composite-co
3c00: 6e 64 69 74 69 6f 6e 0a 09 09 20 20 20 20 20 20 ndition...
3c10: 28 6d 61 6b 65 2d 70 72 6f 70 65 72 74 79 2d 63 (make-property-c
3c20: 6f 6e 64 69 74 69 6f 6e 20 0a 09 09 20 20 20 20 ondition ...
3c30: 20 20 20 27 74 69 6d 65 6f 75 74 0a 09 09 20 20 'timeout...
3c40: 20 20 20 20 20 27 6d 65 73 73 61 67 65 20 22 6e 'message "n
3c50: 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c msg-transport:cl
3c60: 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 ient-api-send-re
3c70: 63 65 69 76 65 2d 72 61 77 20 74 69 6d 65 64 20 ceive-raw timed
3c80: 6f 75 74 20 74 61 6c 6b 69 6e 67 20 74 6f 20 73 out talking to s
3c90: 65 72 76 65 72 22 29 29 29 29 29 29 29 0a 0a 3b erver")))))))..;
3ca0: 3b 20 63 61 72 65 66 75 6c 20 63 6c 6f 73 69 6e ; careful closin
3cb0: 67 20 6f 66 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 g of connections
3cc0: 20 73 74 6f 72 65 64 20 69 6e 20 2a 72 75 6e 72 stored in *runr
3cd0: 65 6d 6f 74 65 2a 0a 3b 3b 0a 28 64 65 66 69 6e emote*.;;.(defin
3ce0: 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 e (http-transpor
3cf0: 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 t:close-connecti
3d00: 6f 6e 73 20 23 21 6b 65 79 20 28 61 72 65 61 2d ons #!key (area-
3d10: 64 61 74 20 23 66 29 29 0a 20 20 28 6c 65 74 2a dat #f)). (let*
3d20: 20 28 28 72 75 6e 72 65 6d 6f 74 65 20 20 28 6f ((runremote (o
3d30: 72 20 61 72 65 61 2d 64 61 74 20 2a 72 75 6e 72 r area-dat *runr
3d40: 65 6d 6f 74 65 2a 29 29 0a 09 20 28 73 65 72 76 emote*)).. (serv
3d50: 65 72 2d 64 61 74 20 28 69 66 20 72 75 6e 72 65 er-dat (if runre
3d60: 6d 6f 74 65 0a 20 20 20 20 20 20 20 20 20 20 20 mote.
3d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
3d80: 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 72 75 emote-conndat ru
3d90: 6e 72 65 6d 6f 74 65 29 0a 20 20 20 20 20 20 20 nremote).
3da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3db0: 20 20 23 66 29 29 29 20 3b 3b 20 28 68 61 73 68 #f))) ;; (hash
3dc0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
3dd0: 6c 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 lt *runremote* r
3de0: 75 6e 2d 69 64 20 23 66 29 29 29 0a 20 20 20 20 un-id #f))).
3df0: 28 69 66 20 28 76 65 63 74 6f 72 3f 20 73 65 72 (if (vector? ser
3e00: 76 65 72 2d 64 61 74 29 0a 09 28 6c 65 74 20 28 ver-dat)..(let (
3e10: 28 61 70 69 2d 64 61 74 20 28 68 74 74 70 2d 74 (api-dat (http-t
3e20: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
3e30: 64 61 74 2d 67 65 74 2d 61 70 69 2d 75 72 69 20 dat-get-api-uri
3e40: 73 65 72 76 65 72 2d 64 61 74 29 29 29 0a 09 20 server-dat)))..
3e50: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
3e60: 6f 6e 73 0a 09 20 20 20 20 65 78 6e 0a 09 20 20 ons.. exn..
3e70: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
3e80: 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 (print-call-chai
3e90: 6e 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 n *default-log-p
3ea0: 6f 72 74 2a 29 0a 09 20 20 20 20 20 20 28 64 65 ort*).. (de
3eb0: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
3ec0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
3ed0: 6f 72 74 2a 20 22 20 63 6c 6f 73 69 6e 67 20 63 ort* " closing c
3ee0: 6f 6e 6e 65 63 74 69 6f 6e 20 66 61 69 6c 65 64 onnection failed
3ef0: 20 77 69 74 68 20 65 72 72 6f 72 3a 20 22 20 28 with error: " (
3f00: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
3f10: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
3f20: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
3f30: 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 29 0a ", exn=" exn)).
3f40: 09 20 20 20 20 28 63 6c 6f 73 65 2d 63 6f 6e 6e . (close-conn
3f50: 65 63 74 69 6f 6e 21 20 61 70 69 2d 64 61 74 29 ection! api-dat)
3f60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 28 . ;;(
3f70: 63 6c 6f 73 65 2d 69 64 6c 65 2d 63 6f 6e 6e 65 close-idle-conne
3f80: 63 74 69 6f 6e 73 21 29 0a 09 20 20 20 20 23 74 ctions!).. #t
3f90: 29 29 0a 09 23 66 29 29 29 0a 0a 0a 28 64 65 66 ))..#f)))...(def
3fa0: 69 6e 65 20 28 6d 61 6b 65 2d 68 74 74 70 2d 74 ine (make-http-t
3fb0: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
3fc0: 64 61 74 29 28 6d 61 6b 65 2d 76 65 63 74 6f 72 dat)(make-vector
3fd0: 20 36 29 29 0a 28 64 65 66 69 6e 65 20 28 68 74 6)).(define (ht
3fe0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
3ff0: 76 65 72 2d 64 61 74 2d 67 65 74 2d 69 66 61 63 ver-dat-get-ifac
4000: 65 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 e vec)
4010: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
4020: 65 63 20 30 29 29 0a 28 64 65 66 69 6e 65 20 28 ec 0)).(define (
4030: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
4040: 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 70 6f erver-dat-get-po
4050: 72 74 20 20 20 20 20 20 20 20 20 20 76 65 63 29 rt vec)
4060: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
4070: 20 76 65 63 20 31 29 29 0a 28 64 65 66 69 6e 65 vec 1)).(define
4080: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
4090: 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d :server-dat-get-
40a0: 61 70 69 2d 75 72 69 20 20 20 20 20 20 20 76 65 api-uri ve
40b0: 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 c) (vector-re
40c0: 66 20 20 76 65 63 20 32 29 29 0a 28 64 65 66 69 f vec 2)).(defi
40d0: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
40e0: 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 rt:server-dat-ge
40f0: 74 2d 61 70 69 2d 75 72 6c 20 20 20 20 20 20 20 t-api-url
4100: 76 65 63 29 20 20 20 20 28 76 65 63 74 6f 72 2d vec) (vector-
4110: 72 65 66 20 20 76 65 63 20 33 29 29 0a 28 64 65 ref vec 3)).(de
4120: 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
4130: 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
4140: 67 65 74 2d 61 70 69 2d 72 65 71 20 20 20 20 20 get-api-req
4150: 20 20 76 65 63 29 20 20 20 20 28 76 65 63 74 6f vec) (vecto
4160: 72 2d 72 65 66 20 20 76 65 63 20 34 29 29 0a 28 r-ref vec 4)).(
4170: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
4180: 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 nsport:server-da
4190: 74 2d 67 65 74 2d 6c 61 73 74 2d 61 63 63 65 73 t-get-last-acces
41a0: 73 20 20 20 76 65 63 29 20 20 20 20 28 76 65 63 s vec) (vec
41b0: 74 6f 72 2d 72 65 66 20 20 76 65 63 20 35 29 29 tor-ref vec 5))
41c0: 0a 3b 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d .;(define (http-
41d0: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
41e0: 2d 64 61 74 2d 67 65 74 2d 73 6f 63 6b 65 74 20 -dat-get-socket
41f0: 20 20 20 20 20 20 20 76 65 63 29 20 20 20 20 28 vec) (
4200: 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 63 20 vector-ref vec
4210: 36 29 29 0a 28 64 65 66 69 6e 65 20 28 68 74 74 6)).(define (htt
4220: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 p-transport:serv
4230: 65 72 2d 64 61 74 2d 67 65 74 2d 73 65 72 76 65 er-dat-get-serve
4240: 72 2d 69 64 20 20 20 20 20 76 65 63 29 20 20 20 r-id vec)
4250: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 65 (vector-ref ve
4260: 63 20 36 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 c 6))..(define (
4270: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
4280: 65 72 76 65 72 2d 64 61 74 2d 6d 61 6b 65 2d 75 erver-dat-make-u
4290: 72 6c 20 76 65 63 29 0a 20 20 28 69 66 20 28 61 rl vec). (if (a
42a0: 6e 64 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f nd (http-transpo
42b0: 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 rt:server-dat-ge
42c0: 74 2d 69 66 61 63 65 20 76 65 63 29 0a 09 20 20 t-iface vec)..
42d0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
42e0: 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d :server-dat-get-
42f0: 70 6f 72 74 20 20 76 65 63 29 29 0a 20 20 20 20 port vec)).
4300: 20 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f (conc "http://
4310: 22 20 0a 09 20 20 20 20 28 68 74 74 70 2d 74 72 " .. (http-tr
4320: 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 ansport:server-d
4330: 61 74 2d 67 65 74 2d 69 66 61 63 65 20 76 65 63 at-get-iface vec
4340: 29 0a 09 20 20 20 20 22 3a 22 0a 09 20 20 20 20 ).. ":"..
4350: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
4360: 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 70 server-dat-get-p
4370: 6f 72 74 20 20 76 65 63 29 29 0a 20 20 20 20 20 ort vec)).
4380: 20 23 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 #f))..(define (
4390: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
43a0: 65 72 76 65 72 2d 64 61 74 2d 75 70 64 61 74 65 erver-dat-update
43b0: 2d 6c 61 73 74 2d 61 63 63 65 73 73 20 76 65 63 -last-access vec
43c0: 29 0a 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f ). (if (vector?
43d0: 20 76 65 63 29 0a 20 20 20 20 20 20 28 76 65 63 vec). (vec
43e0: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 35 20 28 tor-set! vec 5 (
43f0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
4400: 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ). (begin..
4410: 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 (print-call-chai
4420: 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 n (current-error
4430: 2d 70 6f 72 74 29 29 0a 09 28 64 65 62 75 67 3a -port))..(debug:
4440: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
4450: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
4460: 20 22 63 61 6c 6c 20 74 6f 20 68 74 74 70 2d 74 "call to http-t
4470: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
4480: 64 61 74 2d 75 70 64 61 74 65 2d 6c 61 73 74 2d dat-update-last-
4490: 61 63 63 65 73 73 20 77 69 74 68 20 6e 6f 6e 2d access with non-
44a0: 76 65 63 74 6f 72 21 21 22 29 29 29 29 0a 0a 3b vector!!"))))..;
44b0: 3b 0a 3b 3b 20 63 6f 6e 6e 65 63 74 0a 3b 3b 0a ;.;; connect.;;.
44c0: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
44d0: 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 63 ansport:client-c
44e0: 6f 6e 6e 65 63 74 20 69 66 61 63 65 20 70 6f 72 onnect iface por
44f0: 74 20 73 65 72 76 65 72 2d 69 64 29 20 0a 20 20 t server-id) .
4500: 28 6c 65 74 2a 20 28 28 61 70 69 2d 75 72 6c 20 (let* ((api-url
4510: 20 20 20 20 20 28 63 6f 6e 63 20 22 68 74 74 70 (conc "http
4520: 3a 2f 2f 22 20 69 66 61 63 65 20 22 3a 22 20 70 ://" iface ":" p
4530: 6f 72 74 20 22 2f 61 70 69 22 29 29 0a 09 20 28 ort "/api")).. (
4540: 61 70 69 2d 75 72 69 20 20 20 20 20 20 28 75 72 api-uri (ur
4550: 69 2d 72 65 66 65 72 65 6e 63 65 20 28 63 6f 6e i-reference (con
4560: 63 20 22 68 74 74 70 3a 2f 2f 22 20 69 66 61 63 c "http://" ifac
4570: 65 20 22 3a 22 20 70 6f 72 74 20 22 2f 61 70 69 e ":" port "/api
4580: 22 29 29 29 0a 09 20 28 61 70 69 2d 72 65 71 20 "))).. (api-req
4590: 20 20 20 20 20 28 6d 61 6b 65 2d 72 65 71 75 65 (make-reque
45a0: 73 74 20 6d 65 74 68 6f 64 3a 20 27 50 4f 53 54 st method: 'POST
45b0: 20 75 72 69 3a 20 61 70 69 2d 75 72 69 29 29 0a uri: api-uri)).
45c0: 09 20 28 73 65 72 76 65 72 2d 64 61 74 20 20 20 . (server-dat
45d0: 28 76 65 63 74 6f 72 20 69 66 61 63 65 20 70 6f (vector iface po
45e0: 72 74 20 61 70 69 2d 75 72 69 20 61 70 69 2d 75 rt api-uri api-u
45f0: 72 6c 20 61 70 69 2d 72 65 71 20 28 63 75 72 72 rl api-req (curr
4600: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 65 72 ent-seconds) ser
4610: 76 65 72 2d 69 64 29 29 29 0a 20 20 20 20 73 65 ver-id))). se
4620: 72 76 65 72 2d 64 61 74 29 29 0a 0a 3b 3b 20 72 rver-dat))..;; r
4630: 75 6e 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 un http-transpor
4640: 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 69 t:keep-running i
4650: 6e 20 61 20 70 61 72 61 6c 6c 65 6c 20 74 68 72 n a parallel thr
4660: 65 61 64 20 74 6f 20 6d 6f 6e 69 74 6f 72 20 74 ead to monitor t
4670: 68 61 74 20 74 68 65 20 64 62 20 69 73 20 62 65 hat the db is be
4680: 69 6e 67 20 0a 3b 3b 20 75 73 65 64 20 61 6e 64 ing .;; used and
4690: 20 74 6f 20 73 68 75 74 64 6f 77 6e 20 61 66 74 to shutdown aft
46a0: 65 72 20 73 6f 6d 65 74 69 6d 65 20 69 66 20 69 er sometime if i
46b0: 74 20 69 73 20 6e 6f 74 2e 0a 3b 3b 0a 28 64 65 t is not..;;.(de
46c0: 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
46d0: 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e port:keep-runnin
46e0: 67 29 20 0a 20 20 3b 3b 20 69 66 20 6e 6f 6e 65 g) . ;; if none
46f0: 20 72 75 6e 6e 69 6e 67 20 6f 72 20 69 66 20 3e running or if >
4700: 20 32 30 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 20 seconds sinc
4710: 65 20 0a 20 20 3b 3b 20 73 65 72 76 65 72 20 6c e . ;; server l
4720: 61 73 74 20 75 73 65 64 20 74 68 65 6e 20 73 74 ast used then st
4730: 61 72 74 20 73 68 75 74 64 6f 77 6e 0a 20 20 3b art shutdown. ;
4740: 3b 20 54 68 69 73 20 74 68 72 65 61 64 20 77 61 ; This thread wa
4750: 69 74 73 20 66 6f 72 20 74 68 65 20 73 65 72 76 its for the serv
4760: 65 72 20 74 6f 20 63 6f 6d 65 20 61 6c 69 76 65 er to come alive
4770: 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
4780: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
4790: 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 74 61 72 74 log-port* "Start
47a0: 69 6e 67 20 74 68 65 20 73 79 6e 63 2d 62 61 63 ing the sync-bac
47b0: 6b 2c 20 6b 65 65 70 20 61 6c 69 76 65 20 74 68 k, keep alive th
47c0: 72 65 61 64 20 69 6e 20 73 65 72 76 65 72 22 29 read in server")
47d0: 0a 20 20 28 6c 65 74 2a 20 28 28 73 64 61 74 20 . (let* ((sdat
47e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 #f)
47f0: 0a 09 20 28 74 6d 70 2d 61 72 65 61 20 20 20 20 .. (tmp-area
4800: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 (common:ge
4810: 74 2d 64 62 2d 74 6d 70 2d 61 72 65 61 29 29 0a t-db-tmp-area)).
4820: 09 20 28 73 74 61 72 74 65 64 2d 66 69 6c 65 20 . (started-file
4830: 20 20 20 20 20 28 63 6f 6e 63 20 74 6d 70 2d 61 (conc tmp-a
4840: 72 65 61 20 22 2f 2e 73 65 72 76 65 72 2d 73 74 rea "/.server-st
4850: 61 72 74 65 64 22 29 29 0a 09 20 28 73 65 72 76 arted")).. (serv
4860: 65 72 2d 73 74 61 72 74 2d 74 69 6d 65 20 28 63 er-start-time (c
4870: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
4880: 0a 09 20 28 73 65 72 76 65 72 2d 69 6e 66 6f 20 .. (server-info
4890: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 73 74 61 72 (let loop ((star
48a0: 74 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d t-time (current-
48b0: 73 65 63 6f 6e 64 73 29 29 0a 09 09 09 09 20 28 seconds))..... (
48c0: 63 68 61 6e 67 65 64 20 20 20 20 23 74 29 0a 09 changed #t)..
48d0: 09 09 09 20 28 6c 61 73 74 2d 73 64 61 74 20 20 ... (last-sdat
48e0: 22 6e 6f 74 20 74 68 69 73 22 29 29 0a 20 20 20 "not this")).
48f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4900: 20 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 6c (begin ;; l
4910: 65 74 20 28 28 73 64 61 74 20 23 66 29 29 0a 09 et ((sdat #f))..
4920: 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .. (thread-slee
4930: 70 21 20 30 2e 30 31 29 0a 09 09 09 20 20 28 64 p! 0.01).... (d
4940: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
4950: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
4960: 6f 72 74 2a 20 22 57 61 69 74 69 6e 67 20 66 6f ort* "Waiting fo
4970: 72 20 73 65 72 76 65 72 20 61 6c 69 76 65 20 73 r server alive s
4980: 69 67 6e 61 74 75 72 65 22 29 0a 20 20 20 20 20 ignature").
4990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
49a0: 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b (mutex-lock
49b0: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
49c0: 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 ex*).
49d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
49e0: 73 65 74 21 20 73 64 61 74 20 2a 73 65 72 76 65 set! sdat *serve
49f0: 72 2d 69 6e 66 6f 2a 29 0a 20 20 20 20 20 20 20 r-info*).
4a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a10: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
4a20: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
4a30: 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 ex*).
4a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4a50: 69 66 20 28 61 6e 64 20 73 64 61 74 0a 09 09 09 if (and sdat....
4a60: 09 20 20 20 28 6e 6f 74 20 63 68 61 6e 67 65 64 . (not changed
4a70: 29 0a 09 09 09 09 20 20 20 28 3e 20 28 2d 20 28 )..... (> (- (
4a80: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
4a90: 20 73 74 61 72 74 2d 74 69 6d 65 29 20 32 29 29 start-time) 2))
4aa0: 0a 09 09 09 20 20 20 20 20 20 28 62 65 67 69 6e .... (begin
4ab0: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
4ac0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
4ad0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 65 63 t-log-port* "Rec
4ae0: 65 69 76 65 64 20 73 65 72 76 65 72 20 61 6c 69 eived server ali
4af0: 76 65 20 73 69 67 6e 61 74 75 72 65 22 29 0a 20 ve signature").
4b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4b20: 63 6f 6d 6d 6f 6e 3a 73 61 76 65 2d 70 6b 74 20 common:save-pkt
4b30: 60 28 28 61 63 74 69 6f 6e 20 2e 20 61 6c 69 76 `((action . aliv
4b40: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
4b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b70: 20 20 20 20 20 20 28 54 20 20 20 20 20 20 2e 20 (T .
4b80: 73 65 72 76 65 72 29 0a 20 20 20 20 20 20 20 20 server).
4b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4bb0: 20 20 20 20 20 20 20 20 20 20 20 28 70 69 64 20 (pid
4bc0: 20 20 20 2e 20 2c 28 63 75 72 72 65 6e 74 2d 70 . ,(current-p
4bd0: 72 6f 63 65 73 73 2d 69 64 29 29 0a 20 20 20 20 rocess-id)).
4be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4c10: 69 70 61 64 64 72 20 2e 20 2c 28 63 61 72 20 73 ipaddr . ,(car s
4c20: 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 dat)).
4c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c50: 20 20 20 20 20 20 20 20 20 28 70 6f 72 74 20 20 (port
4c60: 20 2e 20 2c 28 63 61 64 72 20 73 64 61 74 29 29 . ,(cadr sdat))
4c70: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ca0: 20 20 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 23 *configdat* #
4cb0: 74 29 0a 09 09 09 09 73 64 61 74 29 0a 20 20 20 t).....sdat).
4cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4cd0: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
4ce0: 6e 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 n.....(debug:pri
4cf0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
4d00: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 74 lt-log-port* "St
4d10: 69 6c 6c 20 77 61 69 74 69 6e 67 2c 20 6c 61 73 ill waiting, las
4d20: 74 2d 73 64 61 74 3d 22 20 6c 61 73 74 2d 73 64 t-sdat=" last-sd
4d30: 61 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 at).
4d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4d50: 20 20 20 20 28 73 6c 65 65 70 20 34 29 0a 09 09 (sleep 4)...
4d60: 09 09 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 ..(if (> (- (cur
4d70: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 74 rent-seconds) st
4d80: 61 72 74 2d 74 69 6d 65 29 20 31 32 30 29 20 3b art-time) 120) ;
4d90: 3b 20 62 65 65 6e 20 77 61 69 74 69 6e 67 20 66 ; been waiting f
4da0: 6f 72 20 74 77 6f 20 6d 69 6e 75 74 65 73 0a 09 or two minutes..
4db0: 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 ... (begin...
4dc0: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
4dd0: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
4de0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
4df0: 22 74 72 61 6e 73 70 6f 72 74 20 61 70 70 65 61 "transport appea
4e00: 72 73 20 74 6f 20 68 61 76 65 20 64 69 65 64 2c rs to have died,
4e10: 20 65 78 69 74 69 6e 67 20 73 65 72 76 65 72 22 exiting server"
4e20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4e40: 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a (common:
4e50: 73 61 76 65 2d 70 6b 74 20 60 28 28 61 63 74 69 save-pkt `((acti
4e60: 6f 6e 20 2e 20 64 69 65 64 29 0a 20 20 20 20 20 on . died).
4e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ea0: 20 20 20 20 28 54 20 20 20 20 20 20 2e 20 73 65 (T . se
4eb0: 72 76 65 72 29 0a 20 20 20 20 20 20 20 20 20 20 rver).
4ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4ef0: 70 69 64 20 20 20 20 2e 20 2c 28 63 75 72 72 65 pid . ,(curre
4f00: 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 0a nt-process-id)).
4f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f40: 20 20 20 20 20 20 20 20 20 28 69 70 61 64 64 72 (ipaddr
4f50: 20 2e 20 2c 28 63 61 72 20 73 64 61 74 29 29 0a . ,(car sdat)).
4f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f90: 20 20 20 20 20 20 20 20 20 28 70 6f 72 74 20 20 (port
4fa0: 20 2e 20 2c 28 63 61 64 72 20 73 64 61 74 29 29 . ,(cadr sdat))
4fb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4fe0: 20 20 20 20 20 20 20 20 20 20 28 6d 73 67 20 20 (msg
4ff0: 20 20 2e 20 22 54 72 61 6e 73 70 6f 72 74 20 64 . "Transport d
5000: 69 65 64 3f 22 29 29 0a 09 09 09 09 09 09 20 20 ied?")).......
5010: 20 20 20 20 20 2a 63 6f 6e 66 69 67 64 61 74 2a *configdat*
5020: 20 23 74 29 0a 09 09 09 09 20 20 20 20 20 20 28 #t)..... (
5030: 65 78 69 74 29 29 0a 09 09 09 09 20 20 20 20 28 exit))..... (
5040: 6c 6f 6f 70 20 73 74 61 72 74 2d 74 69 6d 65 0a loop start-time.
5050: 09 09 09 09 09 20 20 28 65 71 75 61 6c 3f 20 73 ..... (equal? s
5060: 64 61 74 20 6c 61 73 74 2d 73 64 61 74 29 0a 09 dat last-sdat)..
5070: 09 09 09 09 20 20 73 64 61 74 29 29 29 29 29 29 .... sdat))))))
5080: 29 0a 09 20 28 69 66 61 63 65 20 20 20 20 20 20 ).. (iface
5090: 20 28 63 61 72 20 73 65 72 76 65 72 2d 69 6e 66 (car server-inf
50a0: 6f 29 29 0a 20 20 20 20 20 20 20 20 20 28 70 6f o)). (po
50b0: 72 74 20 20 20 20 20 20 20 20 28 63 61 64 72 20 rt (cadr
50c0: 73 65 72 76 65 72 2d 69 6e 66 6f 29 29 0a 20 20 server-info)).
50d0: 20 20 20 20 20 20 20 28 6c 61 73 74 2d 61 63 63 (last-acc
50e0: 65 73 73 20 30 29 0a 09 20 28 73 65 72 76 65 72 ess 0).. (server
50f0: 2d 74 69 6d 65 6f 75 74 20 28 73 65 72 76 65 72 -timeout (server
5100: 3a 65 78 70 69 72 61 74 69 6f 6e 2d 74 69 6d 65 :expiration-time
5110: 6f 75 74 29 29 0a 09 20 28 73 65 72 76 65 72 2d out)).. (server-
5120: 67 6f 69 6e 67 20 20 23 66 29 0a 09 20 28 73 65 going #f).. (se
5130: 72 76 65 72 2d 6c 6f 67 2d 66 69 6c 65 20 28 61 rver-log-file (a
5140: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 6c 6f rgs:get-arg "-lo
5150: 67 22 29 29 29 20 3b 3b 20 61 6c 77 61 79 73 20 g"))) ;; always
5160: 73 65 74 20 77 68 65 6e 20 77 65 20 61 72 65 20 set when we are
5170: 61 20 73 65 72 76 65 72 0a 0a 20 20 20 20 28 68 a server.. (h
5180: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
5190: 0a 09 65 78 6e 0a 20 20 20 20 20 20 28 64 65 62 ..exn. (deb
51a0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
51b0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 ult-log-port* "F
51c0: 61 69 6c 65 64 20 74 6f 20 63 72 65 61 74 65 20 ailed to create
51d0: 22 20 73 74 61 72 74 65 64 2d 66 69 6c 65 20 22 " started-file "
51e0: 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a 20 20 20 , exn=" exn).
51f0: 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d (with-output-
5200: 74 6f 2d 66 69 6c 65 20 73 74 61 72 74 65 64 2d to-file started-
5210: 66 69 6c 65 20 28 6c 61 6d 62 64 61 20 28 29 28 file (lambda ()(
5220: 70 72 69 6e 74 20 28 63 75 72 72 65 6e 74 2d 70 print (current-p
5230: 72 6f 63 65 73 73 2d 69 64 29 29 29 29 29 0a 0a rocess-id)))))..
5240: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
5250: 63 6f 75 6e 74 20 20 20 20 20 20 20 20 20 30 29 count 0)
5260: 0a 09 20 20 20 20 20 20 20 28 73 65 72 76 65 72 .. (server
5270: 2d 73 74 61 74 65 20 27 61 76 61 69 6c 61 62 6c -state 'availabl
5280: 65 29 0a 09 20 20 20 20 20 20 20 28 62 61 64 2d e).. (bad-
5290: 73 79 6e 63 2d 63 6f 75 6e 74 20 30 29 0a 09 20 sync-count 0)..
52a0: 20 20 20 20 20 20 28 73 74 61 72 74 2d 74 69 6d (start-tim
52b0: 65 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 6d e (current-m
52c0: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 0a 20 illiseconds))).
52d0: 20 20 20 20 20 3b 3b 20 55 73 65 20 74 68 69 73 ;; Use this
52e0: 20 6f 70 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 opportunity to
52f0: 73 79 6e 63 20 74 68 65 20 74 6d 70 20 64 62 20 sync the tmp db
5300: 74 6f 20 6d 65 67 61 74 65 73 74 2e 64 62 0a 20 to megatest.db.
5310: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 73 65 (if (not se
5320: 72 76 65 72 2d 67 6f 69 6e 67 29 20 3b 3b 20 2a rver-going) ;; *
5330: 64 62 73 74 72 75 63 74 2d 64 62 2a 20 0a 09 20 dbstruct-db* ..
5340: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 64 65 (begin.. (de
5350: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
5360: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5370: 53 45 52 56 45 52 3a 20 64 62 70 72 65 70 22 29 SERVER: dbprep")
5380: 0a 09 20 20 20 20 28 73 65 74 21 20 2a 64 62 73 .. (set! *dbs
5390: 74 72 75 63 74 2d 64 62 2a 20 20 28 64 62 3a 73 truct-db* (db:s
53a0: 65 74 75 70 20 23 74 29 29 20 3b 3b 20 20 72 75 etup #t)) ;; ru
53b0: 6e 2d 69 64 29 29 0a 09 20 20 20 20 28 73 65 74 n-id)).. (set
53c0: 21 20 73 65 72 76 65 72 2d 67 6f 69 6e 67 20 23 ! server-going #
53d0: 74 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 t).. (debug:p
53e0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
53f0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 45 52 56 45 log-port* "SERVE
5400: 52 3a 20 72 75 6e 6e 69 6e 67 2c 20 6d 65 67 61 R: running, mega
5410: 74 65 73 74 20 76 65 72 73 69 6f 6e 3a 20 22 20 test version: "
5420: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 75 6c 6c (common:get-full
5430: 2d 76 65 72 73 69 6f 6e 29 29 20 3b 3b 20 4e 4f -version)) ;; NO
5440: 54 45 3a 20 74 68 65 20 73 65 72 76 65 72 20 69 TE: the server i
5450: 73 20 4e 4f 54 20 79 65 74 20 6d 61 72 6b 65 64 s NOT yet marked
5460: 20 61 73 20 72 75 6e 6e 69 6e 67 20 69 6e 20 74 as running in t
5470: 68 65 20 6c 6f 67 2e 20 57 65 20 64 6f 20 74 68 he log. We do th
5480: 61 74 20 69 6e 20 74 68 65 20 6b 65 65 70 2d 72 at in the keep-r
5490: 75 6e 6e 69 6e 67 20 72 6f 75 74 69 6e 65 2e 0a unning routine..
54a0: 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 . (thread-sta
54b0: 72 74 21 20 2a 77 61 74 63 68 64 6f 67 2a 29 29 rt! *watchdog*))
54c0: 29 0a 20 20 20 20 20 20 0a 20 20 20 20 20 20 3b ). . ;
54d0: 3b 20 77 68 65 6e 20 74 68 69 6e 67 73 20 67 6f ; when things go
54e0: 20 77 72 6f 6e 67 20 77 65 20 64 6f 6e 27 74 20 wrong we don't
54f0: 77 61 6e 74 20 74 6f 20 62 65 20 64 6f 69 6e 67 want to be doing
5500: 20 74 68 65 20 76 61 72 69 6f 75 73 20 71 75 65 the various que
5510: 72 69 65 73 20 74 6f 6f 20 6f 66 74 65 6e 0a 20 ries too often.
5520: 20 20 20 20 20 3b 3b 20 73 6f 20 77 65 20 73 74 ;; so we st
5530: 72 69 76 65 20 74 6f 20 72 75 6e 20 74 68 69 73 rive to run this
5540: 20 73 74 75 66 66 20 6f 6e 6c 79 20 65 76 65 72 stuff only ever
5550: 79 20 66 6f 75 72 20 73 65 63 6f 6e 64 73 20 6f y four seconds o
5560: 72 20 73 6f 2e 0a 20 20 20 20 20 20 28 6c 65 74 r so.. (let
5570: 2a 20 28 28 73 79 6e 63 2d 74 69 6d 65 20 28 2d * ((sync-time (-
5580: 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 (current-millis
5590: 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d 74 69 econds) start-ti
55a0: 6d 65 29 29 0a 09 20 20 20 20 28 72 65 6d 2d 74 me)).. (rem-t
55b0: 69 6d 65 20 20 28 71 75 6f 74 69 65 6e 74 20 28 ime (quotient (
55c0: 2d 20 34 30 30 30 20 73 79 6e 63 2d 74 69 6d 65 - 4000 sync-time
55d0: 29 20 31 30 30 30 29 29 29 0a 09 28 69 66 20 28 ) 1000)))..(if (
55e0: 61 6e 64 20 28 3c 3d 20 72 65 6d 2d 74 69 6d 65 and (<= rem-time
55f0: 20 34 29 0a 09 09 20 28 3e 20 20 72 65 6d 2d 74 4)... (> rem-t
5600: 69 6d 65 20 30 29 29 0a 09 20 20 20 20 28 74 68 ime 0)).. (th
5610: 72 65 61 64 2d 73 6c 65 65 70 21 20 72 65 6d 2d read-sleep! rem-
5620: 74 69 6d 65 29 29 29 0a 20 20 20 20 20 20 0a 20 time))). .
5630: 20 20 20 20 20 28 69 66 20 28 3c 20 63 6f 75 6e (if (< coun
5640: 74 20 31 29 20 3b 3b 20 33 78 33 20 3d 20 39 20 t 1) ;; 3x3 = 9
5650: 73 65 63 73 20 61 70 72 6f 78 0a 09 20 20 28 6c secs aprox.. (l
5660: 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 20 31 29 20 oop (+ count 1)
5670: 27 72 75 6e 6e 69 6e 67 20 62 61 64 2d 73 79 6e 'running bad-syn
5680: 63 2d 63 6f 75 6e 74 20 28 63 75 72 72 65 6e 74 c-count (current
5690: 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 29 -milliseconds)))
56a0: 0a 20 20 20 20 20 20 0a 20 20 20 20 20 20 3b 3b . . ;;
56b0: 20 43 68 65 63 6b 20 74 68 61 74 20 69 66 61 63 Check that ifac
56c0: 65 20 61 6e 64 20 70 6f 72 74 20 68 61 76 65 20 e and port have
56d0: 6e 6f 74 20 63 68 61 6e 67 65 64 20 28 63 61 6e not changed (can
56e0: 20 68 61 70 70 65 6e 20 69 66 20 73 65 72 76 65 happen if serve
56f0: 72 20 70 6f 72 74 20 63 6f 6c 6c 69 64 65 73 29 r port collides)
5700: 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f . (mutex-lo
5710: 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
5720: 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 73 65 utex*). (se
5730: 74 21 20 73 64 61 74 20 2a 73 65 72 76 65 72 2d t! sdat *server-
5740: 69 6e 66 6f 2a 29 0a 20 20 20 20 20 20 28 6d 75 info*). (mu
5750: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 tex-unlock! *hea
5760: 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 rtbeat-mutex*).
5770: 20 20 20 20 20 0a 20 20 20 20 20 20 28 69 66 20 . (if
5780: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 73 64 61 (not (equal? sda
5790: 74 20 28 6c 69 73 74 20 69 66 61 63 65 20 70 6f t (list iface po
57a0: 72 74 29 29 29 0a 09 20 20 28 6c 65 74 20 28 28 rt))).. (let ((
57b0: 6e 65 77 2d 69 66 61 63 65 20 28 63 61 72 20 73 new-iface (car s
57c0: 64 61 74 29 29 0a 09 09 28 6e 65 77 2d 70 6f 72 dat))...(new-por
57d0: 74 20 20 28 63 61 64 72 20 73 64 61 74 29 29 29 t (cadr sdat)))
57e0: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
57f0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
5800: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
5810: 52 4e 49 4e 47 3a 20 69 6e 74 65 72 66 61 63 65 RNING: interface
5820: 20 63 68 61 6e 67 65 64 2c 20 72 65 66 72 65 73 changed, refres
5830: 68 69 6e 67 20 69 66 61 63 65 20 61 6e 64 20 70 hing iface and p
5840: 6f 72 74 20 69 6e 66 6f 22 29 0a 09 20 20 20 20 ort info")..
5850: 28 73 65 74 21 20 69 66 61 63 65 20 6e 65 77 2d (set! iface new-
5860: 69 66 61 63 65 29 0a 09 20 20 20 20 28 73 65 74 iface).. (set
5870: 21 20 70 6f 72 74 20 20 6e 65 77 2d 70 6f 72 74 ! port new-port
5880: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ). (
5890: 69 66 20 28 6e 6f 74 20 2a 73 65 72 76 65 72 2d if (not *server-
58a0: 69 64 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 id*).
58b0: 20 20 20 28 73 65 74 21 20 2a 73 65 72 76 65 72 (set! *server
58c0: 2d 69 64 2a 20 28 73 65 72 76 65 72 3a 6d 6b 2d -id* (server:mk-
58d0: 73 69 67 6e 61 74 75 72 65 29 29 29 0a 20 20 20 signature))).
58e0: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
58f0: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
5900: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 75 72 72 -log-port* (curr
5910: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 63 75 ent-seconds) (cu
5920: 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 rrent-directory)
5930: 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
5940: 73 2d 69 64 29 20 28 61 72 67 76 29 29 0a 09 20 s-id) (argv))..
5950: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
5960: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
5970: 6f 72 74 2a 20 22 53 45 52 56 45 52 20 53 54 41 ort* "SERVER STA
5980: 52 54 45 44 3a 20 22 20 69 66 61 63 65 20 22 3a RTED: " iface ":
5990: 22 20 70 6f 72 74 20 22 20 41 54 20 22 20 28 63 " port " AT " (c
59a0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
59b0: 22 20 73 65 72 76 65 72 2d 69 64 3a 20 22 20 2a " server-id: " *
59c0: 73 65 72 76 65 72 2d 69 64 2a 29 0a 09 20 20 20 server-id*)..
59d0: 20 28 66 6c 75 73 68 2d 6f 75 74 70 75 74 20 2a (flush-output *
59e0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
59f0: 2a 29 29 29 0a 20 20 20 20 20 20 0a 20 20 20 20 *))). .
5a00: 20 20 3b 3b 20 54 72 61 6e 73 66 65 72 20 2a 64 ;; Transfer *d
5a10: 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 74 b-last-access* t
5a20: 6f 20 6c 61 73 74 2d 61 63 63 65 73 73 20 74 6f o last-access to
5a30: 20 75 73 65 20 69 6e 20 63 68 65 63 6b 69 6e 67 use in checking
5a40: 20 74 68 61 74 20 77 65 20 61 72 65 20 73 74 69 that we are sti
5a50: 6c 6c 20 61 6c 69 76 65 0a 20 20 20 20 20 20 28 ll alive. (
5a60: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 mutex-lock! *hea
5a70: 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 rtbeat-mutex*).
5a80: 20 20 20 20 20 28 73 65 74 21 20 6c 61 73 74 2d (set! last-
5a90: 61 63 63 65 73 73 20 2a 64 62 2d 6c 61 73 74 2d access *db-last-
5aa0: 61 63 63 65 73 73 2a 29 0a 20 20 20 20 20 20 28 access*). (
5ab0: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 mutex-unlock! *h
5ac0: 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 eartbeat-mutex*)
5ad0: 0a 20 20 20 20 20 20 0a 20 20 20 20 20 20 28 69 . . (i
5ae0: 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f f (common:low-no
5af0: 69 73 65 2d 70 72 69 6e 74 20 31 32 30 20 28 63 ise-print 120 (c
5b00: 6f 6e 63 20 22 73 65 72 76 65 72 20 72 75 6e 6e onc "server runn
5b10: 69 6e 67 20 6f 6e 20 22 20 69 66 61 63 65 20 22 ing on " iface "
5b20: 3a 22 20 70 6f 72 74 29 29 0a 09 20 20 28 62 65 :" port)).. (be
5b30: 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 gin.
5b40: 20 28 69 66 20 28 6e 6f 74 20 2a 73 65 72 76 65 (if (not *serve
5b50: 72 2d 69 64 2a 29 0a 20 20 20 20 20 20 20 20 20 r-id*).
5b60: 20 20 20 20 20 28 73 65 74 21 20 2a 73 65 72 76 (set! *serv
5b70: 65 72 2d 69 64 2a 20 28 73 65 72 76 65 72 3a 6d er-id* (server:m
5b80: 6b 2d 73 69 67 6e 61 74 75 72 65 29 29 29 0a 20 k-signature))).
5b90: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
5ba0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
5bb0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 75 lt-log-port* (cu
5bc0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 rrent-seconds) (
5bd0: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
5be0: 79 29 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 y) (current-proc
5bf0: 65 73 73 2d 69 64 29 20 28 61 72 67 76 29 29 20 ess-id) (argv))
5c00: 20 20 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
5c10: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
5c20: 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 45 52 56 45 log-port* "SERVE
5c30: 52 20 53 54 41 52 54 45 44 3a 20 22 20 69 66 61 R STARTED: " ifa
5c40: 63 65 20 22 3a 22 20 70 6f 72 74 20 22 20 41 54 ce ":" port " AT
5c50: 20 22 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f " (current-seco
5c60: 6e 64 73 29 20 22 20 73 65 72 76 65 72 2d 69 64 nds) " server-id
5c70: 3a 20 22 20 2a 73 65 72 76 65 72 2d 69 64 2a 29 : " *server-id*)
5c80: 0a 09 20 20 20 20 28 66 6c 75 73 68 2d 6f 75 74 .. (flush-out
5c90: 70 75 74 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 put *default-log
5ca0: 2d 70 6f 72 74 2a 29 29 29 0a 20 20 20 20 20 20 -port*))).
5cb0: 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d (if (common:low-
5cc0: 6e 6f 69 73 65 2d 70 72 69 6e 74 20 36 30 20 22 noise-print 60 "
5cd0: 64 62 73 74 61 74 73 22 29 0a 09 20 20 28 62 65 dbstats").. (be
5ce0: 67 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a gin.. (debug:
5cf0: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
5d00: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 76 -log-port* "Serv
5d10: 65 72 20 73 74 61 74 73 3a 22 29 0a 09 20 20 20 er stats:")..
5d20: 20 28 64 62 3a 70 72 69 6e 74 2d 63 75 72 72 65 (db:print-curre
5d30: 6e 74 2d 71 75 65 72 79 2d 73 74 61 74 73 29 29 nt-query-stats))
5d40: 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ). (let* ((
5d50: 68 72 73 2d 73 69 6e 63 65 2d 73 74 61 72 74 20 hrs-since-start
5d60: 20 28 2f 20 28 2d 20 28 63 75 72 72 65 6e 74 2d (/ (- (current-
5d70: 73 65 63 6f 6e 64 73 29 20 73 65 72 76 65 72 2d seconds) server-
5d80: 73 74 61 72 74 2d 74 69 6d 65 29 20 33 36 30 30 start-time) 3600
5d90: 29 29 29 0a 09 28 63 6f 6e 64 0a 20 20 20 20 20 )))..(cond.
5da0: 20 20 20 20 28 28 61 6e 64 20 2a 73 65 72 76 65 ((and *serve
5db0: 72 2d 72 75 6e 2a 0a 09 20 20 20 20 20 20 20 28 r-run*.. (
5dc0: 3e 20 28 2b 20 6c 61 73 74 2d 61 63 63 65 73 73 > (+ last-access
5dd0: 20 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 29 server-timeout)
5de0: 0a 09 09 20 20 28 63 75 72 72 65 6e 74 2d 73 65 ... (current-se
5df0: 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 20 20 conds))).
5e00: 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c (if (common:l
5e10: 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 31 ow-noise-print 1
5e20: 32 30 20 22 73 65 72 76 65 72 20 63 6f 6e 74 69 20 "server conti
5e30: 6e 75 69 6e 67 22 29 0a 20 20 20 20 20 20 20 20 nuing").
5e40: 20 20 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 65 lt-log-port* "Se
5e70: 72 76 65 72 20 63 6f 6e 74 69 6e 75 69 6e 67 2c rver continuing,
5e80: 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 6c seconds since l
5e90: 61 73 74 20 64 62 20 61 63 63 65 73 73 3a 20 22 ast db access: "
5ea0: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
5eb0: 6f 6e 64 73 29 20 6c 61 73 74 2d 61 63 63 65 73 onds) last-acces
5ec0: 73 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 s)).. (let
5ed0: 28 28 63 75 72 72 2d 74 69 6d 65 20 28 63 75 72 ((curr-time (cur
5ee0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a rent-seconds))).
5ef0: 09 09 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 ..(handle-except
5f00: 69 6f 6e 73 0a 09 09 20 20 20 20 65 78 6e 0a 09 ions... exn..
5f10: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
5f20: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
5f30: 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 46 -port* "ERROR: F
5f40: 61 69 6c 65 64 20 74 6f 20 63 68 61 6e 67 65 20 ailed to change
5f50: 74 69 6d 65 73 74 61 6d 70 20 6f 6e 20 6c 6f 67 timestamp on log
5f60: 20 66 69 6c 65 20 22 20 73 65 72 76 65 72 2d 6c file " server-l
5f70: 6f 67 2d 66 69 6c 65 20 22 2e 20 41 72 65 20 79 og-file ". Are y
5f80: 6f 75 20 6f 75 74 20 6f 66 20 73 70 61 63 65 20 ou out of space
5f90: 6f 6e 20 74 68 61 74 20 64 69 73 6b 3f 20 65 78 on that disk? ex
5fa0: 6e 3d 22 20 65 78 6e 29 0a 09 09 20 20 28 69 66 n=" exn)... (if
5fb0: 20 28 6e 6f 74 20 2a 73 65 72 76 65 72 2d 6f 76 (not *server-ov
5fc0: 65 72 6c 6f 61 64 65 64 2a 29 0a 09 09 20 20 20 erloaded*)...
5fd0: 20 20 20 28 63 68 61 6e 67 65 2d 66 69 6c 65 2d (change-file-
5fe0: 74 69 6d 65 73 20 73 65 72 76 65 72 2d 6c 6f 67 times server-log
5ff0: 2d 66 69 6c 65 20 63 75 72 72 2d 74 69 6d 65 20 -file curr-time
6000: 63 75 72 72 2d 74 69 6d 65 29 29 29 29 29 0a 20 curr-time))))).
6010: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 30 (loop 0
6020: 20 73 65 72 76 65 72 2d 73 74 61 74 65 20 62 61 server-state ba
6030: 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 28 63 75 d-sync-count (cu
6040: 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e rrent-millisecon
6050: 64 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 ds))). (
6060: 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 28 else. (
6070: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6080: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
6090: 70 6f 72 74 2a 20 22 53 65 72 76 65 72 20 74 69 port* "Server ti
60a0: 6d 65 64 20 6f 75 74 2e 20 73 65 63 6f 6e 64 73 med out. seconds
60b0: 20 73 69 6e 63 65 20 6c 61 73 74 20 64 62 20 61 since last db a
60c0: 63 63 65 73 73 3a 20 22 20 28 2d 20 28 63 75 72 ccess: " (- (cur
60d0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c 61 rent-seconds) la
60e0: 73 74 2d 61 63 63 65 73 73 29 29 0a 20 20 20 20 st-access)).
60f0: 20 20 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e (http-tran
6100: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 73 68 75 sport:server-shu
6110: 74 64 6f 77 6e 20 70 6f 72 74 29 29 29 29 29 29 tdown port))))))
6120: 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 )..(define (http
6130: 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 -transport:serve
6140: 72 2d 73 68 75 74 64 6f 77 6e 20 70 6f 72 74 29 r-shutdown port)
6150: 0a 20 20 28 62 65 67 69 6e 0a 20 20 20 20 3b 3b . (begin. ;;
6160: 28 42 42 3e 20 22 68 74 74 70 2d 74 72 61 6e 73 (BB> "http-trans
6170: 70 6f 72 74 3a 73 65 72 76 65 72 2d 73 68 75 74 port:server-shut
6180: 64 6f 77 6e 20 63 61 6c 6c 65 64 22 29 0a 20 20 down called").
6190: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
61a0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
61b0: 6f 67 2d 70 6f 72 74 2a 20 22 53 74 61 72 74 69 og-port* "Starti
61c0: 6e 67 20 74 6f 20 73 68 75 74 64 6f 77 6e 20 74 ng to shutdown t
61d0: 68 65 20 73 65 72 76 65 72 2e 20 70 69 64 3d 22 he server. pid="
61e0: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
61f0: 2d 69 64 29 29 0a 20 20 20 20 3b 3b 0a 20 20 20 -id)). ;;.
6200: 20 3b 3b 20 73 74 61 72 74 5f 73 68 75 74 64 6f ;; start_shutdo
6210: 77 6e 0a 20 20 20 20 3b 3b 0a 20 20 20 20 28 73 wn. ;;. (s
6220: 65 74 21 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 et! *time-to-exi
6230: 74 2a 20 23 74 29 20 3b 3b 20 74 65 6c 6c 20 6f t* #t) ;; tell o
6240: 6e 2d 65 78 69 74 20 74 6f 20 62 65 20 66 61 73 n-exit to be fas
6250: 74 20 61 73 20 77 65 27 76 65 20 61 6c 72 65 61 t as we've alrea
6260: 64 79 20 63 6c 65 61 6e 65 64 20 75 70 0a 20 20 dy cleaned up.
6270: 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 (portlogger:op
6280: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 en-run-close por
6290: 74 6c 6f 67 67 65 72 3a 73 65 74 2d 70 6f 72 74 tlogger:set-port
62a0: 20 70 6f 72 74 20 22 72 65 6c 65 61 73 65 64 22 port "released"
62b0: 29 0a 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c ). (thread-sl
62c0: 65 65 70 21 20 31 29 0a 0a 20 20 20 20 3b 3b 20 eep! 1).. ;;
62d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
62e0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
62f0: 2d 70 6f 72 74 2a 20 22 4d 61 78 20 63 61 63 68 -port* "Max cach
6300: 65 64 20 71 75 65 72 69 65 73 20 77 61 73 20 20 ed queries was
6310: 20 20 22 20 2a 6d 61 78 2d 63 61 63 68 65 2d 73 " *max-cache-s
6320: 69 7a 65 2a 29 0a 20 20 20 20 3b 3b 20 28 64 65 ize*). ;; (de
6330: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
6340: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6350: 72 74 2a 20 22 4e 75 6d 62 65 72 20 6f 66 20 63 rt* "Number of c
6360: 61 63 68 65 64 20 77 72 69 74 65 73 20 20 20 22 ached writes "
6370: 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 *number-of-writ
6380: 65 73 2a 29 0a 20 20 20 20 3b 3b 20 28 64 65 62 es*). ;; (deb
6390: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
63a0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
63b0: 74 2a 20 22 41 76 65 72 61 67 65 20 63 61 63 68 t* "Average cach
63c0: 65 64 20 77 72 69 74 65 20 74 69 6d 65 20 22 0a ed write time ".
63d0: 20 20 20 20 3b 3b 20 09 09 20 20 20 20 20 20 28 ;; .. (
63e0: 69 66 20 28 65 71 3f 20 2a 6e 75 6d 62 65 72 2d if (eq? *number-
63f0: 6f 66 2d 77 72 69 74 65 73 2a 20 30 29 0a 20 20 of-writes* 0).
6400: 20 20 3b 3b 20 09 09 09 20 20 22 6e 2f 61 20 28 ;; ... "n/a (
6410: 6e 6f 20 77 72 69 74 65 73 29 22 0a 20 20 20 20 no writes)".
6420: 3b 3b 20 09 09 09 20 20 28 2f 20 2a 77 72 69 74 ;; ... (/ *writ
6430: 65 73 2d 74 6f 74 61 6c 2d 64 65 6c 61 79 2a 0a es-total-delay*.
6440: 20 20 20 20 3b 3b 20 09 09 09 20 20 20 20 20 2a ;; ... *
6450: 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 number-of-writes
6460: 2a 29 29 0a 20 20 20 20 3b 3b 20 09 09 20 20 20 *)). ;; ..
6470: 20 20 20 22 20 6d 73 22 29 0a 20 20 20 20 3b 3b " ms"). ;;
6480: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
6490: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
64a0: 67 2d 70 6f 72 74 2a 20 22 4e 75 6d 62 65 72 20 g-port* "Number
64b0: 6e 6f 6e 2d 63 61 63 68 65 64 20 71 75 65 72 69 non-cached queri
64c0: 65 73 20 22 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f es " *number-no
64d0: 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a n-write-queries*
64e0: 29 0a 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a ). ;; (debug:
64f0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
6500: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
6510: 22 41 76 65 72 61 67 65 20 6e 6f 6e 2d 63 61 63 "Average non-cac
6520: 68 65 64 20 74 69 6d 65 20 20 20 22 0a 20 20 20 hed time ".
6530: 20 3b 3b 20 09 09 20 20 20 20 20 20 28 69 66 20 ;; .. (if
6540: 28 65 71 3f 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e (eq? *number-non
6550: 2d 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a 20 -write-queries*
6560: 30 29 0a 20 20 20 20 3b 3b 20 09 09 09 20 20 22 0). ;; ... "
6570: 6e 2f 61 20 28 6e 6f 20 71 75 65 72 69 65 73 29 n/a (no queries)
6580: 22 0a 20 20 20 20 3b 3b 20 09 09 09 20 20 28 2f ". ;; ... (/
6590: 20 2a 74 6f 74 61 6c 2d 6e 6f 6e 2d 77 72 69 74 *total-non-writ
65a0: 65 2d 64 65 6c 61 79 2a 20 0a 20 20 20 20 3b 3b e-delay* . ;;
65b0: 20 09 09 09 20 20 20 20 20 2a 6e 75 6d 62 65 72 ... *number
65c0: 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 -non-write-queri
65d0: 65 73 2a 29 29 0a 20 20 20 20 3b 3b 20 09 09 20 es*)). ;; ..
65e0: 20 20 20 20 20 22 20 6d 73 22 29 0a 20 20 20 20 " ms").
65f0: 0a 20 20 20 20 28 64 62 3a 70 72 69 6e 74 2d 63 . (db:print-c
6600: 75 72 72 65 6e 74 2d 71 75 65 72 79 2d 73 74 61 urrent-query-sta
6610: 74 73 29 0a 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a ts). (common:
6620: 73 61 76 65 2d 70 6b 74 20 60 28 28 61 63 74 69 save-pkt `((acti
6630: 6f 6e 20 2e 20 65 78 69 74 29 0a 20 20 20 20 20 on . exit).
6640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6650: 20 20 28 54 20 20 20 20 20 20 2e 20 73 65 72 76 (T . serv
6660: 65 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 er).
6670: 20 20 20 20 20 20 20 20 20 20 20 28 70 69 64 20 (pid
6680: 20 20 20 2e 20 2c 28 63 75 72 72 65 6e 74 2d 70 . ,(current-p
6690: 72 6f 63 65 73 73 2d 69 64 29 29 29 0a 20 20 20 rocess-id))).
66a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
66b0: 20 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 23 74 *configdat* #t
66c0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
66d0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
66e0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 lt-log-port* "Se
66f0: 72 76 65 72 20 73 68 75 74 64 6f 77 6e 20 63 6f rver shutdown co
6700: 6d 70 6c 65 74 65 2e 20 45 78 69 74 69 6e 67 22 mplete. Exiting"
6710: 29 0a 20 20 20 20 28 65 78 69 74 29 29 29 0a 0a ). (exit)))..
6720: 3b 3b 20 61 6c 6c 20 72 6f 75 74 65 73 20 74 68 ;; all routes th
6730: 6f 75 67 68 20 68 65 72 65 20 65 6e 64 20 69 6e ough here end in
6740: 20 65 78 69 74 20 2e 2e 2e 0a 3b 3b 0a 3b 3b 20 exit ....;;.;;
6750: 73 74 61 72 74 5f 73 65 72 76 65 72 3f 20 0a 3b start_server? .;
6760: 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ;.(define (http-
6770: 74 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 transport:launch
6780: 29 0a 20 20 3b 3b 20 63 68 65 63 6b 20 74 68 61 ). ;; check tha
6790: 74 20 61 20 73 65 72 76 65 72 20 73 74 61 72 74 t a server start
67a0: 20 69 73 20 69 6e 20 70 72 6f 67 72 65 73 73 2c is in progress,
67b0: 20 70 61 75 73 65 20 6f 72 20 65 78 69 74 20 69 pause or exit i
67c0: 66 20 73 6f 0a 20 20 28 6c 65 74 2a 20 28 28 74 f so. (let* ((t
67d0: 6d 70 2d 61 72 65 61 20 20 20 20 20 20 20 20 20 mp-area
67e0: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 (common:get-d
67f0: 62 2d 74 6d 70 2d 61 72 65 61 29 29 0a 09 20 28 b-tmp-area)).. (
6800: 73 65 72 76 65 72 2d 73 74 61 72 74 20 20 20 20 server-start
6810: 20 20 20 20 28 63 6f 6e 63 20 74 6d 70 2d 61 72 (conc tmp-ar
6820: 65 61 20 22 2f 2e 73 65 72 76 65 72 2d 73 74 61 ea "/.server-sta
6830: 72 74 22 29 29 0a 09 20 28 73 65 72 76 65 72 2d rt")).. (server-
6840: 73 74 61 72 74 65 64 20 20 20 20 20 20 28 63 6f started (co
6850: 6e 63 20 74 6d 70 2d 61 72 65 61 20 22 2f 2e 73 nc tmp-area "/.s
6860: 65 72 76 65 72 2d 73 74 61 72 74 65 64 22 29 29 erver-started"))
6870: 0a 09 20 28 73 74 61 72 74 2d 74 69 6d 65 20 20 .. (start-time
6880: 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a (common:
6890: 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 61 74 69 6f lazy-modificatio
68a0: 6e 2d 74 69 6d 65 20 73 65 72 76 65 72 2d 73 74 n-time server-st
68b0: 61 72 74 29 29 0a 09 20 28 73 74 61 72 74 65 64 art)).. (started
68c0: 2d 74 69 6d 65 20 20 20 20 20 20 20 20 28 63 6f -time (co
68d0: 6d 6d 6f 6e 3a 6c 61 7a 79 2d 6d 6f 64 69 66 69 mmon:lazy-modifi
68e0: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 73 65 72 76 cation-time serv
68f0: 65 72 2d 73 74 61 72 74 65 64 29 29 0a 09 20 28 er-started)).. (
6900: 73 65 72 76 65 72 2d 73 74 61 72 74 69 6e 67 20 server-starting
6910: 20 20 20 20 28 3c 20 73 74 61 72 74 2d 74 69 6d (< start-tim
6920: 65 20 73 74 61 72 74 65 64 2d 74 69 6d 65 29 29 e started-time))
6930: 20 3b 3b 20 69 66 20 73 74 61 72 74 2d 74 69 6d ;; if start-tim
6940: 65 20 69 73 20 6c 65 73 73 20 74 68 61 6e 20 73 e is less than s
6950: 74 61 72 74 65 64 2d 74 69 6d 65 20 74 68 65 6e tarted-time then
6960: 20 61 20 73 65 72 76 65 72 20 69 73 20 73 74 69 a server is sti
6970: 6c 6c 20 73 74 61 72 74 69 6e 67 0a 09 20 28 73 ll starting.. (s
6980: 74 61 72 74 2d 74 69 6d 65 2d 6f 6c 64 20 20 20 tart-time-old
6990: 20 20 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e (> (- (curren
69a0: 74 2d 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 t-seconds) start
69b0: 2d 74 69 6d 65 29 20 35 29 29 0a 20 20 20 20 20 -time) 5)).
69c0: 20 20 20 20 28 63 6c 65 61 6e 75 70 2d 70 72 6f (cleanup-pro
69d0: 63 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 c (lambda
69e0: 20 28 6d 73 67 29 0a 20 20 20 20 20 20 20 20 20 (msg).
69f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a00: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 (let* ((s
6a10: 65 72 76 2d 66 6e 61 6d 65 20 20 20 20 20 20 28 erv-fname (
6a20: 63 6f 6e 63 20 22 73 65 72 76 65 72 2d 22 20 28 conc "server-" (
6a30: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
6a40: 69 64 29 20 22 2d 22 20 28 67 65 74 2d 68 6f 73 id) "-" (get-hos
6a50: 74 2d 6e 61 6d 65 29 20 22 2e 6c 6f 67 22 29 29 t-name) ".log"))
6a60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a80: 20 20 20 20 20 20 20 20 28 66 75 6c 6c 2d 73 65 (full-se
6a90: 72 76 2d 66 6e 61 6d 65 20 28 63 6f 6e 63 20 2a rv-fname (conc *
6aa0: 74 6f 70 70 61 74 68 2a 20 22 2f 6c 6f 67 73 2f toppath* "/logs/
6ab0: 22 20 73 65 72 76 2d 66 6e 61 6d 65 29 29 0a 20 " serv-fname)).
6ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ae0: 20 20 20 20 20 20 28 6e 65 77 2d 73 65 72 76 2d (new-serv-
6af0: 66 6e 61 6d 65 20 20 28 63 6f 6e 63 20 2a 74 6f fname (conc *to
6b00: 70 70 61 74 68 2a 20 22 2f 6c 6f 67 73 2f 22 20 ppath* "/logs/"
6b10: 22 64 65 66 75 6e 63 74 2d 22 20 73 65 72 76 2d "defunct-" serv-
6b20: 66 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 20 20 fname))).
6b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b40: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
6b50: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
6b60: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 6d 73 67 lt-log-port* msg
6b70: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b90: 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a (if (common:
6ba0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 6c file-exists? ful
6bb0: 6c 2d 73 65 72 76 2d 66 6e 61 6d 65 29 0a 20 20 l-serv-fname).
6bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6be0: 20 20 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e (system (con
6bf0: 63 20 22 73 6c 65 65 70 20 31 3b 6d 76 20 2d 66 c "sleep 1;mv -f
6c00: 20 22 20 66 75 6c 6c 2d 73 65 72 76 2d 66 6e 61 " full-serv-fna
6c10: 6d 65 20 22 20 22 20 6e 65 77 2d 73 65 72 76 2d me " " new-serv-
6c20: 66 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 fname)).
6c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
6c50: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
6c60: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
6c70: 22 49 4e 46 4f 3a 20 63 61 6e 6e 6f 74 20 6d 6f "INFO: cannot mo
6c80: 76 65 20 22 20 66 75 6c 6c 2d 73 65 72 76 2d 66 ve " full-serv-f
6c90: 6e 61 6d 65 20 22 20 74 6f 20 22 20 6e 65 77 2d name " to " new-
6ca0: 73 65 72 76 2d 66 6e 61 6d 65 29 29 0a 20 20 20 serv-fname)).
6cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6cd0: 65 78 69 74 29 29 29 29 29 0a 20 20 20 20 23 3b exit))))). #;
6ce0: 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 73 74 (if (and (not st
6cf0: 61 72 74 2d 74 69 6d 65 2d 6f 6c 64 29 20 3b 3b art-time-old) ;;
6d00: 20 6c 61 73 74 20 73 65 72 76 65 72 20 73 74 61 last server sta
6d10: 72 74 20 74 72 79 20 77 61 73 20 6c 65 73 73 20 rt try was less
6d20: 74 68 61 6e 20 66 69 76 65 20 73 65 63 6f 6e 64 than five second
6d30: 73 20 61 67 6f 0a 09 20 20 20 20 20 28 6e 6f 74 s ago.. (not
6d40: 20 73 65 72 76 65 72 2d 73 74 61 72 74 69 6e 67 server-starting
6d50: 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 63 ))..(begin.. (c
6d60: 6c 65 61 6e 75 70 2d 70 72 6f 63 20 22 4e 4f 54 leanup-proc "NOT
6d70: 20 73 74 61 72 74 69 6e 67 20 73 65 72 76 65 72 starting server
6d80: 2c 20 74 68 65 72 65 20 69 73 20 65 69 74 68 65 , there is eithe
6d90: 72 20 61 20 72 65 63 65 6e 74 6c 79 20 73 74 61 r a recently sta
6da0: 72 74 65 64 20 73 65 72 76 65 72 20 6f 72 20 61 rted server or a
6db0: 20 73 65 72 76 65 72 20 69 6e 20 70 72 6f 63 65 server in proce
6dc0: 73 73 20 6f 66 20 73 74 61 72 74 69 6e 67 22 29 ss of starting")
6dd0: 0a 09 20 20 28 65 78 69 74 29 29 29 0a 20 20 20 .. (exit))).
6de0: 20 3b 3b 20 6c 65 74 73 20 6e 6f 74 20 65 76 65 ;; lets not eve
6df0: 6e 20 62 6f 74 68 65 72 20 74 6f 20 73 74 61 72 n bother to star
6e00: 74 20 69 66 20 74 68 65 72 65 20 61 72 65 20 61 t if there are a
6e10: 6c 72 65 61 64 79 20 74 68 72 65 65 20 6f 72 20 lready three or
6e20: 6d 6f 72 65 20 73 65 72 76 65 72 20 66 69 6c 65 more server file
6e30: 73 20 72 65 61 64 79 20 74 6f 20 67 6f 0a 20 20 s ready to go.
6e40: 20 20 23 3b 28 6c 65 74 2a 20 28 28 6e 75 6d 2d #;(let* ((num-
6e50: 61 6c 69 76 65 20 20 20 28 73 65 72 76 65 72 3a alive (server:
6e60: 67 65 74 2d 6e 75 6d 2d 61 6c 69 76 65 20 28 73 get-num-alive (s
6e70: 65 72 76 65 72 3a 67 65 74 2d 6c 69 73 74 20 2a erver:get-list *
6e80: 74 6f 70 70 61 74 68 2a 29 29 29 29 0a 20 20 20 toppath*)))).
6e90: 20 20 20 28 69 66 20 28 3e 20 6e 75 6d 2d 61 6c (if (> num-al
6ea0: 69 76 65 20 33 29 0a 20 20 20 20 20 20 20 20 20 ive 3).
6eb0: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
6ec0: 20 20 20 20 28 63 6c 65 61 6e 75 70 2d 70 72 6f (cleanup-pro
6ed0: 63 20 28 63 6f 6e 63 20 22 45 52 52 4f 52 3a 20 c (conc "ERROR:
6ee0: 41 62 6f 72 74 69 6e 67 20 73 65 72 76 65 72 20 Aborting server
6ef0: 73 74 61 72 74 20 62 65 63 61 75 73 65 20 74 68 start because th
6f00: 65 72 65 20 61 72 65 20 61 6c 72 65 61 64 79 20 ere are already
6f10: 22 20 6e 75 6d 2d 61 6c 69 76 65 20 22 20 70 6f " num-alive " po
6f20: 73 73 69 62 6c 65 20 73 65 72 76 65 72 73 20 65 ssible servers e
6f30: 69 74 68 65 72 20 72 75 6e 6e 69 6e 67 20 6f 72 ither running or
6f40: 20 73 74 61 72 74 69 6e 67 20 75 70 22 29 29 0a starting up")).
6f50: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 (exi
6f60: 74 29 29 29 29 0a 20 20 28 63 6f 6d 6d 6f 6e 3a t)))). (common:
6f70: 73 61 76 65 2d 70 6b 74 20 60 28 28 61 63 74 69 save-pkt `((acti
6f80: 6f 6e 20 2e 20 73 74 61 72 74 29 0a 09 09 20 20 on . start)...
6f90: 20 20 20 28 54 20 20 20 20 20 20 2e 20 73 65 72 (T . ser
6fa0: 76 65 72 29 0a 09 09 20 20 20 20 20 28 70 69 64 ver)... (pid
6fb0: 20 20 20 20 2e 20 2c 28 63 75 72 72 65 6e 74 2d . ,(current-
6fc0: 70 72 6f 63 65 73 73 2d 69 64 29 29 29 0a 09 09 process-id)))...
6fd0: 20 20 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 23 *configdat* #
6fe0: 74 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 74 t). (let* ((t
6ff0: 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 h2 (make-thread
7000: 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 (lambda ().
7010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7020: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
7030: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
7040: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
7050: 20 22 53 65 72 76 65 72 20 72 75 6e 20 74 68 72 "Server run thr
7060: 65 61 64 20 73 74 61 72 74 65 64 22 29 0a 20 20 ead started").
7070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7080: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 74 (ht
7090: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e tp-transport:run
70a0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
70b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70c0: 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d (if (args:get-
70d0: 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a 20 arg "-server").
70e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7100: 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (args:get-arg
7110: 20 22 2d 73 65 72 76 65 72 22 29 0a 20 20 20 20 "-server").
7120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7140: 22 2d 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 "-").
7150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7160: 20 20 20 20 20 29 29 20 22 53 65 72 76 65 72 20 )) "Server
7170: 72 75 6e 22 29 29 0a 20 20 20 20 20 20 20 20 20 run")).
7180: 20 20 28 74 68 33 20 28 6d 61 6b 65 2d 74 68 72 (th3 (make-thr
7190: 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 ead (lambda ().
71a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
71b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
71c0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
71d0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
71e0: 6f 72 74 2a 20 22 53 65 72 76 65 72 20 6d 6f 6e ort* "Server mon
71f0: 69 74 6f 72 20 74 68 72 65 61 64 20 73 74 61 72 itor thread star
7200: 74 65 64 22 29 0a 20 20 20 20 20 20 20 20 20 20 ted").
7210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7220: 20 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 (http-trans
7230: 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e port:keep-runnin
7240: 67 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 g).
7250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7260: 20 20 22 4b 65 65 70 20 72 75 6e 6e 69 6e 67 22 "Keep running"
7270: 29 29 29 29 0a 20 20 20 20 20 20 28 74 68 72 65 )))). (thre
7280: 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a 20 ad-start! th2).
7290: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
72a0: 65 70 21 20 30 2e 32 35 29 20 3b 3b 20 67 69 76 ep! 0.25) ;; giv
72b0: 65 20 74 68 65 20 73 65 72 76 65 72 20 74 69 6d e the server tim
72c0: 65 20 74 6f 20 73 65 74 74 6c 65 20 62 65 66 6f e to settle befo
72d0: 72 65 20 73 74 61 72 74 69 6e 67 20 74 68 65 20 re starting the
72e0: 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 20 6d 6f 6e keep-running mon
72f0: 69 74 6f 72 2e 0a 20 20 20 20 20 20 28 74 68 72 itor.. (thr
7300: 65 61 64 2d 73 74 61 72 74 21 20 74 68 33 29 0a ead-start! th3).
7310: 20 20 20 20 20 20 28 73 65 74 21 20 2a 64 69 64 (set! *did
7320: 73 6f 6d 65 74 68 69 6e 67 2a 20 23 74 29 0a 20 something* #t).
7330: 20 20 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 (thread-joi
7340: 6e 21 20 74 68 32 29 0a 20 20 20 20 20 20 28 65 n! th2). (e
7350: 78 69 74 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 xit))))..;; (def
7360: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
7370: 6f 72 74 3a 73 65 72 76 65 72 2d 73 69 67 6e 61 ort:server-signa
7380: 6c 2d 68 61 6e 64 6c 65 72 20 73 69 67 6e 75 6d l-handler signum
7390: 29 0a 3b 3b 20 20 20 28 73 69 67 6e 61 6c 2d 6d ).;; (signal-m
73a0: 61 73 6b 21 20 73 69 67 6e 75 6d 29 0a 3b 3b 20 ask! signum).;;
73b0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
73c0: 69 6f 6e 73 0a 3b 3b 20 20 20 20 65 78 6e 0a 3b ions.;; exn.;
73d0: 3b 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e ; (debug:prin
73e0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
73f0: 2d 70 6f 72 74 2a 20 22 20 2e 2e 2e 20 65 78 69 -port* " ... exi
7400: 74 69 6e 67 20 2e 2e 2e 22 29 0a 3b 3b 20 20 20 ting ...").;;
7410: 20 28 6c 65 74 20 28 28 74 68 31 20 28 6d 61 6b (let ((th1 (mak
7420: 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 e-thread (lambda
7430: 20 28 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 28 ().;; ... (
7440: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
7450: 29 0a 3b 3b 20 09 09 09 20 20 20 22 65 61 74 20 ).;; ... "eat
7460: 72 65 73 70 6f 6e 73 65 22 29 29 0a 3b 3b 20 09 response")).;; .
7470: 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 (th2 (make-thre
7480: 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b ad (lambda ().;;
7490: 20 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
74a0: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
74b0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
74c0: 20 22 52 65 63 65 69 76 65 64 20 5e 43 2c 20 61 "Received ^C, a
74d0: 74 74 65 6d 70 74 69 6e 67 20 63 6c 65 61 6e 20 ttempting clean
74e0: 65 78 69 74 2e 20 50 6c 65 61 73 65 20 62 65 20 exit. Please be
74f0: 70 61 74 69 65 6e 74 20 61 6e 64 20 77 61 69 74 patient and wait
7500: 20 61 20 66 65 77 20 73 65 63 6f 6e 64 73 20 62 a few seconds b
7510: 65 66 6f 72 65 20 68 69 74 74 69 6e 67 20 5e 43 efore hitting ^C
7520: 20 61 67 61 69 6e 2e 22 29 0a 3b 3b 20 09 09 09 again.").;; ...
7530: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
7540: 65 70 21 20 33 29 20 3b 3b 20 67 69 76 65 20 74 ep! 3) ;; give t
7550: 68 65 20 66 6c 75 73 68 20 74 68 72 65 65 20 73 he flush three s
7560: 65 63 6f 6e 64 73 20 74 6f 20 64 6f 20 69 74 27 econds to do it'
7570: 73 20 73 74 75 66 66 0a 3b 3b 20 09 09 09 20 20 s stuff.;; ...
7580: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
7590: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
75a0: 6f 72 74 2a 20 22 20 20 20 20 20 20 20 44 6f 6e ort* " Don
75b0: 65 2e 22 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 e.").;; ...
75c0: 28 65 78 69 74 20 34 29 29 0a 3b 3b 20 09 09 09 (exit 4)).;; ...
75d0: 20 20 20 22 65 78 69 74 20 6f 6e 20 5e 43 20 74 "exit on ^C t
75e0: 69 6d 65 72 22 29 29 29 0a 3b 3b 20 20 20 20 20 imer"))).;;
75f0: 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 (thread-start!
7600: 74 68 32 29 0a 3b 3b 20 20 20 20 20 20 28 74 68 th2).;; (th
7610: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 read-start! th1)
7620: 0a 3b 3b 20 20 20 20 20 20 28 74 68 72 65 61 64 .;; (thread
7630: 2d 6a 6f 69 6e 21 20 74 68 32 29 29 29 29 0a 0a -join! th2))))..
7640: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
7650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7670: 3d 0a 3b 3b 20 4a 61 76 61 20 73 63 72 69 70 74 =.;; Java script
7680: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
7690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
76a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
76b0: 3d 3d 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 ==.(define (http
76c0: 2d 74 72 61 6e 73 70 6f 72 74 3a 73 68 6f 77 2d -transport:show-
76d0: 6a 71 75 65 72 79 29 0a 20 20 28 6c 65 74 2a 20 jquery). (let*
76e0: 28 28 64 61 74 61 20 20 28 74 65 73 74 73 3a 72 ((data (tests:r
76f0: 65 61 64 6c 69 6e 65 73 20 2a 6a 61 76 61 2d 73 eadlines *java-s
7700: 63 72 69 70 74 2d 6c 69 62 2a 29 29 29 0a 28 73 cript-lib*))).(s
7710: 74 72 69 6e 67 2d 6a 6f 69 6e 20 64 61 74 61 20 tring-join data
7720: 22 5c 6e 22 29 29 29 0a 0a 0a 0a 3b 3b 3d 3d 3d "\n")))....;;===
7730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7770: 3d 3d 3d 0a 3b 3b 20 77 65 62 20 70 61 67 65 73 ===.;; web pages
7780: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
7790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
77d0: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
77e0: 72 74 3a 68 74 6d 6c 2d 74 65 73 74 2d 6c 6f 67 rt:html-test-log
77f0: 20 24 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 72 $). (let* ((r
7800: 75 6e 2d 69 64 20 28 24 20 27 72 75 6e 69 64 29 un-id ($ 'runid)
7810: 29 0a 20 20 20 20 20 20 20 20 20 28 74 65 73 74 ). (test
7820: 2d 69 74 65 6d 20 28 24 20 27 74 65 73 74 6e 61 -item ($ 'testna
7830: 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 70 me)). (p
7840: 61 72 74 73 20 28 73 74 72 69 6e 67 2d 73 70 6c arts (string-spl
7850: 69 74 20 74 65 73 74 2d 69 74 65 6d 20 22 3a 22 it test-item ":"
7860: 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 65 73 )). (tes
7870: 74 2d 6e 61 6d 65 20 28 63 61 72 20 70 61 72 74 t-name (car part
7880: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)).
7890: 20 0a 20 20 20 20 20 20 20 20 20 28 69 74 65 6d . (item
78a0: 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 75 61 6c -name (if (equal
78b0: 3f 20 28 6c 65 6e 67 74 68 20 70 61 72 74 73 29 ? (length parts)
78c0: 20 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 1).
78d0: 20 22 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 "".
78e0: 20 28 63 61 64 72 20 70 61 72 74 73 29 29 29 29 (cadr parts))))
78f0: 0a 20 20 3b 28 70 72 69 6e 74 20 24 29 20 0a 28 . ;(print $) .(
7900: 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 2d 6c tests:get-test-l
7910: 6f 67 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e og run-id test-n
7920: 61 6d 65 20 69 74 65 6d 2d 6e 61 6d 65 29 29 29 ame item-name)))
7930: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 ...(define (http
7940: 2d 74 72 61 6e 73 70 6f 72 74 3a 68 74 6d 6c 2d -transport:html-
7950: 64 62 6f 61 72 64 20 24 29 0a 20 20 28 6c 65 74 dboard $). (let
7960: 2a 20 28 28 70 61 67 65 20 28 24 20 27 70 61 67 * ((page ($ 'pag
7970: 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 6f 75 e)). (ou
7980: 70 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 p (open-ou
7990: 74 70 75 74 2d 73 74 72 69 6e 67 29 29 20 0a 20 tput-string)) .
79a0: 20 20 20 20 20 20 20 20 28 62 64 79 20 22 2d 2d (bdy "--
79b0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
79c0: 2d 2d 2d 2d 2d 2d 2d 2d 22 29 0a 0a 20 20 20 20 --------")..
79d0: 20 20 20 20 20 28 72 65 74 20 20 28 74 65 73 74 (ret (test
79e0: 73 3a 64 79 6e 61 6d 69 63 2d 64 62 6f 61 72 64 s:dynamic-dboard
79f0: 20 70 61 67 65 29 29 29 0a 20 20 20 20 28 73 3a page))). (s:
7a00: 6f 75 74 70 75 74 2d 6e 65 77 20 20 6f 75 70 20 output-new oup
7a10: 20 72 65 74 29 0a 20 20 20 28 63 6c 6f 73 65 2d ret). (close-
7a20: 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 output-port oup)
7a30: 0a 0a 20 20 28 73 65 74 21 20 62 64 79 20 20 20 .. (set! bdy
7a40: 28 67 65 74 2d 6f 75 74 70 75 74 2d 73 74 72 69 (get-output-stri
7a50: 6e 67 20 6f 75 70 29 29 0a 20 20 20 20 20 28 63 ng oup)). (c
7a60: 6f 6e 63 20 22 3c 68 31 3e 44 61 73 68 62 6f 61 onc "<h1>Dashboa
7a70: 72 64 3c 2f 68 31 3e 22 20 62 64 79 20 22 3c 62 rd</h1>" bdy "<b
7a80: 72 2f 3e 20 3c 62 72 2f 3e 20 22 20 20 29 29 29 r/> <br/> " )))
7a90: 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d ..(define (http-
7aa0: 74 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 transport:main-p
7ab0: 61 67 65 29 0a 20 20 28 6c 65 74 20 28 28 6c 69 age). (let ((li
7ac0: 6e 6b 70 61 74 68 20 28 72 6f 6f 74 2d 70 61 74 nkpath (root-pat
7ad0: 68 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 h))). (conc "
7ae0: 3c 68 65 61 64 3e 3c 68 31 3e 22 20 28 70 61 74 <head><h1>" (pat
7af0: 68 6e 61 6d 65 2d 73 74 72 69 70 2d 64 69 72 65 hname-strip-dire
7b00: 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 ctory *toppath*)
7b10: 20 22 3c 2f 68 31 3e 3c 2f 68 65 61 64 3e 22 0a "</h1></head>".
7b20: 09 20 20 22 3c 62 6f 64 79 3e 22 0a 09 20 20 22 . "<body>".. "
7b30: 52 75 6e 20 61 72 65 61 3a 20 22 20 2a 74 6f 70 Run area: " *top
7b40: 70 61 74 68 2a 0a 09 20 20 22 3c 68 32 3e 53 65 path*.. "<h2>Se
7b50: 72 76 65 72 20 53 74 61 74 73 3c 2f 68 32 3e 22 rver Stats</h2>"
7b60: 0a 09 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 .. (http-transp
7b70: 6f 72 74 3a 73 74 61 74 73 2d 74 61 62 6c 65 29 ort:stats-table)
7b80: 20 0a 09 20 20 22 3c 68 72 3e 22 0a 09 20 20 28 .. "<hr>".. (
7b90: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 http-transport:r
7ba0: 75 6e 73 20 6c 69 6e 6b 70 61 74 68 29 0a 09 20 uns linkpath)..
7bb0: 20 22 3c 68 72 3e 22 0a 09 20 20 3b 3b 20 28 68 "<hr>".. ;; (h
7bc0: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 ttp-transport:ru
7bd0: 6e 2d 73 74 61 74 73 29 0a 09 20 20 22 3c 2f 62 n-stats).. "</b
7be0: 6f 64 79 3e 22 0a 09 20 20 29 29 29 0a 0a 28 64 ody>".. )))..(d
7bf0: 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e efine (http-tran
7c00: 73 70 6f 72 74 3a 73 74 61 74 73 2d 74 61 62 6c sport:stats-tabl
7c10: 65 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b e). (mutex-lock
7c20: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
7c30: 65 78 2a 29 0a 20 20 28 6c 65 74 20 28 28 72 65 ex*). (let ((re
7c40: 73 20 0a 09 20 28 63 6f 6e 63 20 22 3c 74 61 62 s .. (conc "<tab
7c50: 6c 65 3e 22 0a 09 20 20 20 20 20 20 20 3b 3b 20 le>".. ;;
7c60: 22 3c 74 72 3e 3c 74 64 3e 4d 61 78 20 63 61 63 "<tr><td>Max cac
7c70: 68 65 64 20 71 75 65 72 69 65 73 3c 2f 74 64 3e hed queries</td>
7c80: 20 20 20 20 20 20 20 20 3c 74 64 3e 22 20 2a 6d <td>" *m
7c90: 61 78 2d 63 61 63 68 65 2d 73 69 7a 65 2a 20 22 ax-cache-size* "
7ca0: 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 </td></tr>"..
7cb0: 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4e 75 6d "<tr><td>Num
7cc0: 62 65 72 20 6f 66 20 63 61 63 68 65 64 20 77 72 ber of cached wr
7cd0: 69 74 65 73 3c 2f 74 64 3e 20 20 20 3c 74 64 3e ites</td> <td>
7ce0: 22 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 " *number-of-wri
7cf0: 74 65 73 2a 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e tes* "</td></tr>
7d00: 22 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c ".. "<tr><
7d10: 74 64 3e 41 76 65 72 61 67 65 20 63 61 63 68 65 td>Average cache
7d20: 64 20 77 72 69 74 65 20 74 69 6d 65 3c 2f 74 64 d write time</td
7d30: 3e 20 3c 74 64 3e 22 20 28 69 66 20 28 65 71 3f > <td>" (if (eq?
7d40: 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 *number-of-writ
7d50: 65 73 2a 20 30 29 0a 09 09 09 09 09 09 09 09 20 es* 0).........
7d60: 22 6e 2f 61 20 28 6e 6f 20 77 72 69 74 65 73 29 "n/a (no writes)
7d70: 22 0a 09 09 09 09 09 09 09 09 20 28 2f 20 2a 77 "......... (/ *w
7d80: 72 69 74 65 73 2d 74 6f 74 61 6c 2d 64 65 6c 61 rites-total-dela
7d90: 79 2a 0a 09 09 09 09 09 09 09 09 20 20 20 20 2a y*......... *
7da0: 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 number-of-writes
7db0: 2a 29 29 0a 09 20 20 20 20 20 20 20 22 20 6d 73 *)).. " ms
7dc0: 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 </td></tr>"..
7dd0: 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4e 75 6d "<tr><td>Num
7de0: 62 65 72 20 6e 6f 6e 2d 63 61 63 68 65 64 20 71 ber non-cached q
7df0: 75 65 72 69 65 73 3c 2f 74 64 3e 20 3c 74 64 3e ueries</td> <td>
7e00: 22 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 " *number-non-w
7e10: 72 69 74 65 2d 71 75 65 72 69 65 73 2a 20 22 3c rite-queries* "<
7e20: 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 /td></tr>"..
7e30: 20 20 20 3b 3b 20 22 3c 74 72 3e 3c 74 64 3e 41 ;; "<tr><td>A
7e40: 76 65 72 61 67 65 20 6e 6f 6e 2d 63 61 63 68 65 verage non-cache
7e50: 64 20 74 69 6d 65 3c 2f 74 64 3e 20 20 20 3c 74 d time</td> <t
7e60: 64 3e 22 20 28 69 66 20 28 65 71 3f 20 2a 6e 75 d>" (if (eq? *nu
7e70: 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 mber-non-write-q
7e80: 75 65 72 69 65 73 2a 20 30 29 0a 09 20 20 20 20 ueries* 0)..
7e90: 20 20 20 3b 3b 20 09 09 09 09 09 09 09 20 22 6e ;; ....... "n
7ea0: 2f 61 20 28 6e 6f 20 71 75 65 72 69 65 73 29 22 /a (no queries)"
7eb0: 0a 09 20 20 20 20 20 20 20 3b 3b 20 09 09 09 09 .. ;; ....
7ec0: 09 09 09 20 28 2f 20 2a 74 6f 74 61 6c 2d 6e 6f ... (/ *total-no
7ed0: 6e 2d 77 72 69 74 65 2d 64 65 6c 61 79 2a 20 0a n-write-delay* .
7ee0: 09 20 20 20 20 20 20 20 3b 3b 20 09 09 09 09 09 . ;; .....
7ef0: 09 09 20 20 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f .. *number-no
7f00: 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 73 2a n-write-queries*
7f10: 29 29 0a 09 20 20 20 20 20 20 20 22 20 6d 73 3c )).. " ms<
7f20: 2f 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 /td></tr>"..
7f30: 20 20 20 22 3c 74 72 3e 3c 74 64 3e 4c 61 73 74 "<tr><td>Last
7f40: 20 61 63 63 65 73 73 3c 2f 74 64 3e 3c 74 64 3e access</td><td>
7f50: 22 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 " (
7f60: 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 seconds->time-st
7f70: 72 69 6e 67 20 2a 64 62 2d 6c 61 73 74 2d 61 63 ring *db-last-ac
7f80: 63 65 73 73 2a 29 20 22 3c 2f 74 64 3e 3c 2f 74 cess*) "</td></t
7f90: 72 3e 22 0a 09 20 20 20 20 20 20 20 22 3c 2f 74 r>".. "</t
7fa0: 61 62 6c 65 3e 22 29 29 29 0a 20 20 20 20 28 6d able>"))). (m
7fb0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 utex-unlock! *he
7fc0: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
7fd0: 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 res))..(defi
7fe0: 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f ne (http-transpo
7ff0: 72 74 3a 72 75 6e 73 20 6c 69 6e 6b 70 61 74 68 rt:runs linkpath
8000: 29 0a 20 20 28 63 6f 6e 63 20 22 3c 68 33 3e 52 ). (conc "<h3>R
8010: 75 6e 73 3c 2f 68 33 3e 22 0a 09 28 73 74 72 69 uns</h3>"..(stri
8020: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 0a 09 ng-intersperse..
8030: 20 28 6c 65 74 20 28 28 66 69 6c 65 73 20 28 6d (let ((files (m
8040: 61 70 20 70 61 74 68 6e 61 6d 65 2d 73 74 72 69 ap pathname-stri
8050: 70 2d 64 69 72 65 63 74 6f 72 79 20 28 67 6c 6f p-directory (glo
8060: 62 20 28 63 6f 6e 63 20 6c 69 6e 6b 70 61 74 68 b (conc linkpath
8070: 20 22 2f 2a 22 29 29 29 29 29 0a 09 20 20 20 28 "/*"))))).. (
8080: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 70 29 0a map (lambda (p).
8090: 09 09 20 20 28 63 6f 6e 63 20 22 3c 61 20 68 72 .. (conc "<a hr
80a0: 65 66 3d 5c 22 22 20 70 20 22 5c 22 3e 22 20 70 ef=\"" p "\">" p
80b0: 20 22 3c 2f 61 3e 3c 62 72 3e 22 29 29 0a 09 09 "</a><br>"))...
80c0: 66 69 6c 65 73 29 29 0a 09 20 22 20 22 29 29 29 files)).. " ")))
80d0: 0a 0a 23 3b 28 64 65 66 69 6e 65 20 28 68 74 74 ..#;(define (htt
80e0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 2d p-transport:run-
80f0: 73 74 61 74 73 29 0a 20 20 28 6c 65 74 20 28 28 stats). (let ((
8100: 73 74 61 74 73 20 28 6f 70 65 6e 2d 72 75 6e 2d stats (open-run-
8110: 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 72 75 6e close db:get-run
8120: 6e 69 6e 67 2d 73 74 61 74 73 20 23 66 29 29 29 ning-stats #f)))
8130: 0a 20 20 20 20 28 63 6f 6e 63 20 22 3c 74 61 62 . (conc "<tab
8140: 6c 65 3e 22 0a 09 20 20 28 73 74 72 69 6e 67 2d le>".. (string-
8150: 69 6e 74 65 72 73 70 65 72 73 65 0a 09 20 20 20 intersperse..
8160: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 73 74 (map (lambda (st
8170: 61 74 29 0a 09 09 20 20 28 63 6f 6e 63 20 22 3c at)... (conc "<
8180: 74 72 3e 3c 74 64 3e 22 20 28 63 61 72 20 73 74 tr><td>" (car st
8190: 61 74 29 20 22 3c 2f 74 64 3e 3c 74 64 3e 22 20 at) "</td><td>"
81a0: 28 63 61 64 72 20 73 74 61 74 29 20 22 3c 2f 74 (cadr stat) "</t
81b0: 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 73 74 61 d></tr>"))...sta
81c0: 74 73 29 0a 09 20 20 20 22 20 22 29 0a 09 20 20 ts).. " ")..
81d0: 22 3c 2f 74 61 62 6c 65 3e 22 29 29 29 0a "</table>"))).