Artifact
8a03c7ec77b5d9d16f7b72aac2c47da83f288534:
0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 31 37 2c 20 4d 61 74 74 right 2017, Matt
0060: 68 65 77 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 hew Welland..;;
0070: 0a 3b 3b 20 54 68 69 73 20 66 69 6c 65 20 69 73 .;; This file is
0080: 20 70 61 72 74 20 6f 66 20 4d 65 67 61 74 65 73 part of Megates
0090: 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 t..;; .;; Me
00a0: 67 61 74 65 73 74 20 69 73 20 66 72 65 65 20 73 gatest is free s
00b0: 6f 66 74 77 61 72 65 3a 20 79 6f 75 20 63 61 6e oftware: you can
00c0: 20 72 65 64 69 73 74 72 69 62 75 74 65 20 69 74 redistribute it
00d0: 20 61 6e 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b and/or modify.;
00e0: 3b 20 20 20 20 20 69 74 20 75 6e 64 65 72 20 74 ; it under t
00f0: 68 65 20 74 65 72 6d 73 20 6f 66 20 74 68 65 20 he terms of the
0100: 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 75 62 6c GNU General Publ
0110: 69 63 20 4c 69 63 65 6e 73 65 20 61 73 20 70 75 ic License as pu
0120: 62 6c 69 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 blished by.;;
0130: 20 20 74 68 65 20 46 72 65 65 20 53 6f 66 74 77 the Free Softw
0140: 61 72 65 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 are Foundation,
0150: 65 69 74 68 65 72 20 76 65 72 73 69 6f 6e 20 33 either version 3
0160: 20 6f 66 20 74 68 65 20 4c 69 63 65 6e 73 65 2c of the License,
0170: 20 6f 72 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 or.;; (at y
0180: 6f 75 72 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 our option) any
0190: 6c 61 74 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b later version..;
01a0: 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 ; .;; Megate
01b0: 73 74 20 69 73 20 64 69 73 74 72 69 62 75 74 65 st is distribute
01c0: 64 20 69 6e 20 74 68 65 20 68 6f 70 65 20 74 68 d in the hope th
01d0: 61 74 20 69 74 20 77 69 6c 6c 20 62 65 20 75 73 at it will be us
01e0: 65 66 75 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 eful,.;; but
01f0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
0200: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
0210: 76 65 6e 20 74 68 65 20 69 6d 70 6c 69 65 64 20 ven the implied
0220: 77 61 72 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 warranty of.;;
0230: 20 20 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 MERCHANTABILI
0240: 54 59 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f TY or FITNESS FO
0250: 52 20 41 20 50 41 52 54 49 43 55 4c 41 52 20 50 R A PARTICULAR P
0260: 55 52 50 4f 53 45 2e 20 20 53 65 65 20 74 68 65 URPOSE. See the
0270: 0a 3b 3b 20 20 20 20 20 47 4e 55 20 47 65 6e 65 .;; GNU Gene
0280: 72 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e ral Public Licen
0290: 73 65 20 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 se for more deta
02a0: 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 ils..;; .;;
02b0: 59 6f 75 20 73 68 6f 75 6c 64 20 68 61 76 65 20 You should have
02c0: 72 65 63 65 69 76 65 64 20 61 20 63 6f 70 79 20 received a copy
02d0: 6f 66 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 of the GNU Gener
02e0: 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 al Public Licens
02f0: 65 0a 3b 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 e.;; along w
0300: 69 74 68 20 4d 65 67 61 74 65 73 74 2e 20 20 49 ith Megatest. I
0310: 66 20 6e 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 f not, see <http
0320: 3a 2f 2f 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c ://www.gnu.org/l
0330: 69 63 65 6e 73 65 73 2f 3e 2e 0a 0a 3b 3b 3d 3d icenses/>...;;==
0340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 0a 0a 28 64 65 63 6c 61 72 65 20 28 ====..(declare (
0390: 75 6e 69 74 20 74 72 61 6e 73 70 6f 72 74 29 29 unit transport))
03a0: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
03b0: 63 6f 6d 6d 6f 6e 6d 6f 64 29 29 0a 28 64 65 63 commonmod)).(dec
03c0: 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6e 66 69 lare (uses confi
03d0: 67 66 6d 6f 64 29 29 0a 28 64 65 63 6c 61 72 65 gfmod)).(declare
03e0: 20 28 75 73 65 73 20 70 6f 72 74 6c 6f 67 67 65 (uses portlogge
03f0: 72 29 29 0a 0a 28 6d 6f 64 75 6c 65 20 74 72 61 r))..(module tra
0400: 6e 73 70 6f 72 74 0a 09 2a 0a 09 0a 28 69 6d 70 nsport..*...(imp
0410: 6f 72 74 20 73 63 68 65 6d 65 20 63 68 69 63 6b ort scheme chick
0420: 65 6e 20 64 61 74 61 2d 73 74 72 75 63 74 75 72 en data-structur
0430: 65 73 20 65 78 74 72 61 73 20 70 6f 72 74 73 29 es extras ports)
0440: 0a 0a 28 69 6d 70 6f 72 74 20 63 6f 6d 6d 6f 6e ..(import common
0450: 6d 6f 64 29 0a 28 69 6d 70 6f 72 74 20 63 6f 6e mod).(import con
0460: 66 69 67 66 6d 6f 64 29 0a 0a 28 69 6d 70 6f 72 figfmod)..(impor
0470: 74 20 70 6f 72 74 6c 6f 67 67 65 72 29 0a 0a 28 t portlogger)..(
0480: 69 6d 70 6f 72 74 0a 20 20 28 70 72 65 66 69 78 import. (prefix
0490: 20 62 61 73 65 36 34 20 62 61 73 65 36 34 3a 29 base64 base64:)
04a0: 0a 20 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 . (prefix sqlit
04b0: 65 33 20 73 71 6c 69 74 65 33 3a 29 0a 20 20 63 e3 sqlite3:). c
04c0: 61 6c 6c 2d 77 69 74 68 2d 65 6e 76 69 72 6f 6e all-with-environ
04d0: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 73 0a 20 ment-variables.
04e0: 20 63 73 76 0a 20 20 63 73 76 2d 78 6d 6c 0a 20 csv. csv-xml.
04f0: 20 64 69 72 65 63 74 6f 72 79 2d 75 74 69 6c 73 directory-utils
0500: 0a 20 20 66 69 6c 65 73 0a 20 20 68 6f 73 74 69 . files. hosti
0510: 6e 66 6f 0a 20 20 68 74 74 70 2d 63 6c 69 65 6e nfo. http-clien
0520: 74 0a 20 20 69 6e 74 61 72 77 65 62 0a 20 20 6d t. intarweb. m
0530: 61 74 63 68 61 62 6c 65 0a 20 20 6d 64 35 0a 20 atchable. md5.
0540: 20 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 0a message-digest.
0550: 20 20 70 6f 73 69 78 0a 20 20 70 6f 73 69 78 2d posix. posix-
0560: 65 78 74 72 61 73 0a 20 20 72 65 67 65 78 0a 20 extras. regex.
0570: 20 72 65 67 65 78 2d 63 61 73 65 0a 20 20 73 31 regex-case. s1
0580: 31 6e 0a 20 20 73 70 69 66 66 79 0a 20 20 73 70 1n. spiffy. sp
0590: 69 66 66 79 2d 64 69 72 65 63 74 6f 72 79 2d 6c iffy-directory-l
05a0: 69 73 74 69 6e 67 0a 20 20 73 70 69 66 66 79 2d isting. spiffy-
05b0: 72 65 71 75 65 73 74 2d 76 61 72 73 0a 20 20 73 request-vars. s
05c0: 72 66 69 2d 31 0a 20 20 73 72 66 69 2d 31 33 0a rfi-1. srfi-13.
05d0: 20 20 73 72 66 69 2d 31 38 0a 20 20 73 72 66 69 srfi-18. srfi
05e0: 2d 36 39 0a 20 20 73 74 61 63 6b 0a 20 20 74 63 -69. stack. tc
05f0: 70 0a 20 20 74 79 70 65 64 2d 72 65 63 6f 72 64 p. typed-record
0600: 73 0a 20 20 75 72 69 2d 63 6f 6d 6d 6f 6e 0a 20 s. uri-common.
0610: 20 7a 33 0a 20 20 29 0a 0a 28 64 65 66 69 6e 65 z3. )..(define
0620: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
0630: 3a 6d 61 6b 65 2d 73 65 72 76 65 72 2d 75 72 6c :make-server-url
0640: 20 68 6f 73 74 70 6f 72 74 29 0a 20 20 28 69 66 hostport). (if
0650: 20 28 6e 6f 74 20 68 6f 73 74 70 6f 72 74 29 0a (not hostport).
0660: 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 #f. (
0670: 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f 22 20 28 conc "http://" (
0680: 63 61 72 20 68 6f 73 74 70 6f 72 74 29 20 22 3a car hostport) ":
0690: 22 20 28 63 61 64 72 20 68 6f 73 74 70 6f 72 74 " (cadr hostport
06a0: 29 29 29 29 0a 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
06f0: 3b 20 53 20 45 20 52 20 56 20 45 20 52 0a 3b 3b ; S E R V E R.;;
0700: 20 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 3d 3d 3d 3d ================
0720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0740: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 43 61 6c 6c =======..;; Call
0750: 20 74 68 69 73 20 74 6f 20 73 74 61 72 74 20 74 this to start t
0760: 68 65 20 61 63 74 75 61 6c 20 73 65 72 76 65 72 he actual server
0770: 0a 3b 3b 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 .;;..;; (define
0780: 2a 64 62 3a 70 72 6f 63 65 73 73 2d 71 75 65 75 *db:process-queu
0790: 65 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d e-mutex* (make-m
07a0: 75 74 65 78 29 29 0a 0a 28 64 65 66 69 6e 65 20 utex))..(define
07b0: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
07c0: 72 75 6e 20 68 6f 73 74 6e 29 0a 20 20 3b 3b 20 run hostn). ;;
07d0: 43 6f 6e 66 69 67 75 72 61 74 69 6f 6e 73 20 66 Configurations f
07e0: 6f 72 20 73 65 72 76 65 72 0a 20 20 28 74 63 70 or server. (tcp
07f0: 2d 62 75 66 66 65 72 2d 73 69 7a 65 20 32 30 34 -buffer-size 204
0800: 38 29 0a 20 20 28 6d 61 78 2d 63 6f 6e 6e 65 63 8). (max-connec
0810: 74 69 6f 6e 73 20 32 30 34 38 29 20 0a 20 20 28 tions 2048) . (
0820: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 debug:print 2 *d
0830: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
0840: 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 "Attempting to
0850: 73 74 61 72 74 20 74 68 65 20 73 65 72 76 65 72 start the server
0860: 20 2e 2e 2e 22 29 0a 20 20 28 6c 65 74 2a 20 28 ..."). (let* (
0870: 28 64 62 20 20 20 20 20 20 20 20 20 20 20 20 20 (db
0880: 20 23 66 29 20 3b 3b 20 20 20 20 20 20 20 20 28 #f) ;; (
0890: 6f 70 65 6e 2d 64 62 29 29 20 3b 3b 20 77 65 20 open-db)) ;; we
08a0: 64 6f 6e 27 74 20 77 61 6e 74 20 74 68 65 20 73 don't want the s
08b0: 65 72 76 65 72 20 74 6f 20 62 65 20 6f 70 65 6e erver to be open
08c0: 69 6e 67 20 61 6e 64 20 63 6c 6f 73 69 6e 67 20 ing and closing
08d0: 74 68 65 20 64 62 20 75 6e 6e 65 63 65 73 61 72 the db unnecesar
08e0: 69 6c 79 0a 09 20 28 68 6f 73 74 6e 61 6d 65 20 ily.. (hostname
08f0: 20 20 20 20 20 20 20 28 67 65 74 2d 68 6f 73 74 (get-host
0900: 2d 6e 61 6d 65 29 29 0a 09 20 28 69 70 61 64 64 -name)).. (ipadd
0910: 72 73 74 72 20 20 20 20 20 20 20 28 6c 65 74 20 rstr (let
0920: 28 28 69 70 73 74 72 20 28 69 66 20 28 73 74 72 ((ipstr (if (str
0930: 69 6e 67 3d 3f 20 22 2d 22 20 68 6f 73 74 6e 29 ing=? "-" hostn)
0940: 0a 09 09 09 09 09 20 20 20 3b 3b 20 28 73 74 72 ...... ;; (str
0950: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
0960: 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e 73 74 72 (map number->str
0970: 69 6e 67 20 28 75 38 76 65 63 74 6f 72 2d 3e 6c ing (u8vector->l
0980: 69 73 74 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 69 ist (hostname->i
0990: 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 20 22 2e p hostname))) ".
09a0: 22 29 0a 09 09 09 09 09 20 20 20 28 73 65 72 76 ")...... (serv
09b0: 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 er:get-best-gues
09c0: 73 2d 61 64 64 72 65 73 73 20 68 6f 73 74 6e 61 s-address hostna
09d0: 6d 65 29 0a 09 09 09 09 09 20 20 20 23 66 29 29 me)...... #f))
09e0: 29 0a 09 09 09 20 20 20 20 28 69 66 20 69 70 73 ).... (if ips
09f0: 74 72 20 69 70 73 74 72 20 68 6f 73 74 6e 29 29 tr ipstr hostn))
0a00: 29 20 3b 3b 20 68 6f 73 74 6e 61 6d 65 29 29 29 ) ;; hostname)))
0a10: 20 0a 09 20 28 73 74 61 72 74 2d 70 6f 72 74 20 .. (start-port
0a20: 20 20 20 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 (portlogger
0a30: 3a 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 0a :open-run-close.
0a40: 09 09 09 20 20 20 28 6c 61 6d 62 64 61 20 28 64 ... (lambda (d
0a50: 62 29 0a 09 09 09 20 20 20 20 20 28 70 6f 72 74 b).... (port
0a60: 6c 6f 67 67 65 72 3a 66 69 6e 64 2d 70 6f 72 74 logger:find-port
0a70: 20 64 62 29 29 29 29 0a 09 20 28 6c 69 6e 6b 2d db)))).. (link-
0a80: 74 72 65 65 2d 70 61 74 68 20 20 28 63 6f 6d 6d tree-path (comm
0a90: 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 on:get-linktree)
0aa0: 29 0a 09 20 28 74 6d 70 2d 61 72 65 61 20 20 20 ).. (tmp-area
0ab0: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 (common:get
0ac0: 2d 64 62 2d 74 6d 70 2d 61 72 65 61 29 29 0a 09 -db-tmp-area))..
0ad0: 20 28 73 74 61 72 74 2d 66 69 6c 65 20 20 20 20 (start-file
0ae0: 20 20 28 63 6f 6e 63 20 74 6d 70 2d 61 72 65 61 (conc tmp-area
0af0: 20 22 2f 2e 73 65 72 76 65 72 2d 73 74 61 72 74 "/.server-start
0b00: 22 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a "))). (debug:
0b10: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
0b20: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
0b30: 22 70 6f 72 74 6c 6f 67 67 65 72 20 72 65 63 6f "portlogger reco
0b40: 6d 6d 65 6e 64 65 64 20 70 6f 72 74 3a 20 22 20 mmended port: "
0b50: 73 74 61 72 74 2d 70 6f 72 74 29 0a 20 20 20 20 start-port).
0b60: 3b 3b 20 73 65 74 20 73 6f 6d 65 20 70 61 72 61 ;; set some para
0b70: 6d 65 74 65 72 73 20 66 6f 72 20 74 68 65 20 73 meters for the s
0b80: 65 72 76 65 72 0a 20 20 20 20 28 72 6f 6f 74 2d erver. (root-
0b90: 70 61 74 68 20 20 20 20 20 28 69 66 20 6c 69 6e path (if lin
0ba0: 6b 2d 74 72 65 65 2d 70 61 74 68 20 0a 09 09 20 k-tree-path ...
0bb0: 20 20 20 20 20 20 6c 69 6e 6b 2d 74 72 65 65 2d link-tree-
0bc0: 70 61 74 68 0a 09 09 20 20 20 20 20 20 20 28 63 path... (c
0bd0: 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 urrent-directory
0be0: 29 29 29 20 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 ))) ;; WARNING:
0bf0: 53 45 43 55 52 49 54 59 20 48 4f 4c 45 2e 20 46 SECURITY HOLE. F
0c00: 49 58 20 41 53 41 50 21 0a 20 20 20 20 28 68 61 IX ASAP!. (ha
0c10: 6e 64 6c 65 2d 64 69 72 65 63 74 6f 72 79 20 73 ndle-directory s
0c20: 70 69 66 66 79 2d 64 69 72 65 63 74 6f 72 79 2d piffy-directory-
0c30: 6c 69 73 74 69 6e 67 29 0a 20 20 20 20 28 68 61 listing). (ha
0c40: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 20 28 ndle-exception (
0c50: 6c 61 6d 62 64 61 20 28 65 78 6e 20 63 68 61 69 lambda (exn chai
0c60: 6e 29 0a 09 09 09 28 73 69 67 6e 61 6c 20 28 6d n)....(signal (m
0c70: 61 6b 65 2d 63 6f 6d 70 6f 73 69 74 65 2d 63 6f ake-composite-co
0c80: 6e 64 69 74 69 6f 6e 0a 09 09 09 09 20 28 6d 61 ndition..... (ma
0c90: 6b 65 2d 70 72 6f 70 65 72 74 79 2d 63 6f 6e 64 ke-property-cond
0ca0: 69 74 69 6f 6e 20 0a 09 09 09 09 20 20 27 73 65 ition ..... 'se
0cb0: 72 76 65 72 0a 09 09 09 09 20 20 27 6d 65 73 73 rver..... 'mess
0cc0: 61 67 65 20 22 73 65 72 76 65 72 20 65 72 72 6f age "server erro
0cd0: 72 22 29 29 29 29 29 0a 0a 20 20 20 20 3b 3b 20 r"))))).. ;;
0ce0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 68 http-transport:h
0cf0: 61 6e 64 6c 65 2d 64 69 72 65 63 74 6f 72 79 29 andle-directory)
0d00: 20 3b 3b 20 73 69 6d 70 6c 65 2d 64 69 72 65 63 ;; simple-direc
0d10: 74 6f 72 79 2d 68 61 6e 64 6c 65 72 29 0a 20 20 tory-handler).
0d20: 20 20 3b 3b 20 53 65 74 75 70 20 74 68 65 20 77 ;; Setup the w
0d30: 65 62 20 73 65 72 76 65 72 20 61 6e 64 20 61 20 eb server and a
0d40: 2f 63 74 72 6c 20 69 6e 74 65 72 66 61 63 65 0a /ctrl interface.
0d50: 20 20 20 20 3b 3b 0a 20 20 20 20 28 76 68 6f 73 ;;. (vhos
0d60: 74 2d 6d 61 70 20 60 28 28 28 2a 20 61 6e 79 29 t-map `(((* any)
0d70: 20 2e 20 2c 28 6c 61 6d 62 64 61 20 28 63 6f 6e . ,(lambda (con
0d80: 74 69 6e 75 65 29 0a 09 09 09 20 20 20 20 20 20 tinue)....
0d90: 20 3b 3b 20 6f 70 65 6e 20 74 68 65 20 64 62 20 ;; open the db
0da0: 6f 6e 20 74 68 65 20 66 69 72 73 74 20 63 61 6c on the first cal
0db0: 6c 20 0a 09 09 09 09 20 3b 3b 20 54 68 69 73 20 l ..... ;; This
0dc0: 69 73 20 77 65 72 65 20 77 65 20 73 65 74 20 75 is were we set u
0dd0: 70 20 74 68 65 20 64 61 74 61 62 61 73 65 20 63 p the database c
0de0: 6f 6e 6e 65 63 74 69 6f 6e 73 0a 09 09 09 20 20 onnections....
0df0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 24 20 20 (let* (($
0e00: 20 28 72 65 71 75 65 73 74 2d 76 61 72 73 20 73 (request-vars s
0e10: 6f 75 72 63 65 3a 20 27 62 6f 74 68 29 29 0a 09 ource: 'both))..
0e20: 09 09 09 20 20 20 20 20 20 28 64 61 74 20 28 24 ... (dat ($
0e30: 20 27 64 61 74 29 29 0a 09 09 09 09 20 20 20 20 'dat)).....
0e40: 20 20 28 72 65 73 20 23 66 29 29 0a 09 09 09 09 (res #f)).....
0e50: 20 28 63 6f 6e 64 0a 09 09 09 09 20 20 28 28 65 (cond..... ((e
0e60: 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 qual? (uri-path
0e70: 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 (request-uri (cu
0e80: 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 rrent-request)))
0e90: 0a 09 09 09 09 09 20 20 20 27 28 2f 20 22 61 70 ...... '(/ "ap
0ea0: 69 22 29 29 0a 09 09 09 09 20 20 20 28 73 65 6e i"))..... (sen
0eb0: 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a d-response body:
0ec0: 20 20 20 20 28 61 70 69 3a 70 72 6f 63 65 73 73 (api:process
0ed0: 2d 72 65 71 75 65 73 74 20 2a 64 62 73 74 72 75 -request *dbstru
0ee0: 63 74 2d 64 62 2a 20 24 29 20 3b 3b 20 74 68 65 ct-db* $) ;; the
0ef0: 20 24 20 69 73 20 74 68 65 20 72 65 71 75 65 73 $ is the reques
0f00: 74 20 76 61 72 73 20 70 72 6f 63 0a 09 09 09 09 t vars proc.....
0f10: 09 09 20 20 68 65 61 64 65 72 73 3a 20 27 28 28 .. headers: '((
0f20: 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 74 65 78 content-type tex
0f30: 74 2f 70 6c 61 69 6e 29 29 29 0a 09 09 09 09 20 t/plain))).....
0f40: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
0f50: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
0f60: 29 0a 09 09 09 09 20 20 20 28 73 65 74 21 20 2a )..... (set! *
0f70: 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 db-last-access*
0f80: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
0f90: 29 29 0a 09 09 09 09 20 20 20 28 6d 75 74 65 78 ))..... (mutex
0fa0: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 -unlock! *heartb
0fb0: 65 61 74 2d 6d 75 74 65 78 2a 29 29 0a 09 09 09 eat-mutex*))....
0fc0: 09 20 20 3b 3b 20 28 28 65 71 75 61 6c 3f 20 28 . ;; ((equal? (
0fd0: 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 uri-path (reques
0fe0: 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 t-uri (current-r
0ff0: 65 71 75 65 73 74 29 29 29 20 0a 09 09 09 09 20 equest))) .....
1000: 20 3b 3b 20 09 20 20 20 27 28 2f 20 22 22 29 29 ;; . '(/ ""))
1010: 0a 09 09 09 09 20 20 3b 3b 20 20 28 73 65 6e 64 ..... ;; (send
1020: 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 -response body:
1030: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
1040: 6d 61 69 6e 2d 70 61 67 65 29 29 29 0a 09 09 09 main-page)))....
1050: 09 3b 3b 28 28 65 71 75 61 6c 3f 20 28 75 72 69 .;;((equal? (uri
1060: 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 2d 75 -path (request-u
1070: 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 75 ri (current-requ
1080: 65 73 74 29 29 29 20 0a 09 09 09 09 3b 3b 09 20 est))) .....;;.
1090: 20 20 27 28 2f 20 22 6a 73 6f 6e 5f 61 70 69 22 '(/ "json_api"
10a0: 29 29 0a 09 09 09 09 3b 3b 20 28 73 65 6e 64 2d )).....;; (send-
10b0: 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 28 response body: (
10c0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6d http-transport:m
10d0: 61 69 6e 2d 70 61 67 65 29 29 29 0a 09 09 09 09 ain-page))).....
10e0: 3b 3b 28 28 65 71 75 61 6c 3f 20 28 75 72 69 2d ;;((equal? (uri-
10f0: 70 61 74 68 20 28 72 65 71 75 65 73 74 2d 75 72 path (request-ur
1100: 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 75 65 i (current-reque
1110: 73 74 29 29 29 20 0a 09 09 09 09 3b 3b 09 20 20 st))) .....;;.
1120: 20 27 28 2f 20 22 72 75 6e 73 22 29 29 0a 09 09 '(/ "runs"))...
1130: 09 09 3b 3b 20 28 73 65 6e 64 2d 72 65 73 70 6f ..;; (send-respo
1140: 6e 73 65 20 62 6f 64 79 3a 20 28 68 74 74 70 2d nse body: (http-
1150: 74 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e 2d 70 transport:main-p
1160: 61 67 65 29 29 29 0a 09 09 09 09 3b 3b 28 28 65 age))).....;;((e
1170: 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 20 qual? (uri-path
1180: 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 75 (request-uri (cu
1190: 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 29 rrent-request)))
11a0: 20 0a 09 09 09 09 3b 3b 09 20 20 20 27 28 2f 20 .....;;. '(/
11b0: 61 6e 79 29 29 0a 09 09 09 09 3b 3b 20 28 73 65 any)).....;; (se
11c0: 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 nd-response body
11d0: 3a 20 22 68 65 79 20 74 68 65 72 65 21 5c 6e 22 : "hey there!\n"
11e0: 0a 09 09 09 09 3b 3b 09 09 20 20 68 65 61 64 65 .....;;.. heade
11f0: 72 73 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d 74 rs: '((content-t
1200: 79 70 65 20 74 65 78 74 2f 70 6c 61 69 6e 29 29 ype text/plain))
1210: 29 29 0a 09 09 09 09 3b 3b 28 28 65 71 75 61 6c )).....;;((equal
1220: 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 ? (uri-path (req
1230: 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e uest-uri (curren
1240: 74 2d 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 t-request))) ...
1250: 09 09 3b 3b 09 20 20 20 27 28 2f 20 22 68 65 79 ..;;. '(/ "hey
1260: 22 29 29 0a 09 09 09 09 3b 3b 20 28 73 65 6e 64 ")).....;; (send
1270: 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 -response body:
1280: 22 68 65 79 20 74 68 65 72 65 21 5c 6e 22 20 0a "hey there!\n" .
1290: 09 09 09 09 3b 3b 09 09 20 20 68 65 61 64 65 72 ....;;.. header
12a0: 73 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 s: '((content-ty
12b0: 70 65 20 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 pe text/plain)))
12c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
12d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12e0: 20 20 3b 3b 28 28 65 71 75 61 6c 3f 20 28 75 72 ;;((equal? (ur
12f0: 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 2d i-path (request-
1300: 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 uri (current-req
1310: 75 65 73 74 29 29 29 20 0a 09 09 09 09 3b 3b 09 uest))) .....;;.
1320: 20 20 20 27 28 2f 20 22 6a 71 75 65 72 79 33 2e '(/ "jquery3.
1330: 31 2e 30 2e 6a 73 22 29 29 0a 09 09 09 09 3b 3b 1.0.js")).....;;
1340: 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 (send-response
1350: 62 6f 64 79 3a 20 28 68 74 74 70 2d 74 72 61 6e body: (http-tran
1360: 73 70 6f 72 74 3a 73 68 6f 77 2d 6a 71 75 65 72 sport:show-jquer
1370: 79 29 20 0a 09 09 09 09 3b 3b 09 09 20 20 68 65 y) .....;;.. he
1380: 61 64 65 72 73 3a 20 27 28 28 63 6f 6e 74 65 6e aders: '((conten
1390: 74 2d 74 79 70 65 20 61 70 70 6c 69 63 61 74 69 t-type applicati
13a0: 6f 6e 2f 6a 61 76 61 73 63 72 69 70 74 29 29 29 on/javascript)))
13b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
13c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13d0: 20 20 3b 3b 28 28 65 71 75 61 6c 3f 20 28 75 72 ;;((equal? (ur
13e0: 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 74 2d i-path (request-
13f0: 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 65 71 uri (current-req
1400: 75 65 73 74 29 29 29 20 0a 09 09 09 09 3b 3b 09 uest))) .....;;.
1410: 20 20 20 27 28 2f 20 22 74 65 73 74 5f 6c 6f 67 '(/ "test_log
1420: 22 29 29 0a 09 09 09 09 3b 3b 20 28 73 65 6e 64 ")).....;; (send
1430: 2d 72 65 73 70 6f 6e 73 65 20 62 6f 64 79 3a 20 -response body:
1440: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
1450: 68 74 6d 6c 2d 74 65 73 74 2d 6c 6f 67 20 24 29 html-test-log $)
1460: 20 0a 09 09 09 09 3b 3b 09 09 20 20 68 65 61 64 .....;;.. head
1470: 65 72 73 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d ers: '((content-
1480: 74 79 70 65 20 74 65 78 74 2f 48 54 4d 4c 29 29 type text/HTML))
1490: 29 29 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 )) .
14a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14b0: 20 20 20 20 20 20 20 3b 3b 28 28 65 71 75 61 6c ;;((equal
14c0: 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 ? (uri-path (req
14d0: 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e uest-uri (curren
14e0: 74 2d 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 t-request))) ...
14f0: 09 09 3b 3b 09 20 20 20 27 28 2f 20 22 64 61 73 ..;;. '(/ "das
1500: 68 62 6f 61 72 64 22 29 29 0a 09 09 09 09 3b 3b hboard")).....;;
1510: 20 28 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 (send-response
1520: 62 6f 64 79 3a 20 28 68 74 74 70 2d 74 72 61 6e body: (http-tran
1530: 73 70 6f 72 74 3a 68 74 6d 6c 2d 64 62 6f 61 72 sport:html-dboar
1540: 64 20 24 29 20 0a 09 09 09 09 3b 3b 09 09 20 20 d $) .....;;..
1550: 68 65 61 64 65 72 73 3a 20 27 28 28 63 6f 6e 74 headers: '((cont
1560: 65 6e 74 2d 74 79 70 65 20 74 65 78 74 2f 48 54 ent-type text/HT
1570: 4d 4c 29 29 29 29 20 0a 09 09 09 09 20 20 28 65 ML)))) ..... (e
1580: 6c 73 65 20 28 63 6f 6e 74 69 6e 75 65 29 29 29 lse (continue)))
1590: 29 29 29 29 29 0a 20 20 20 20 28 68 61 6e 64 6c ))))). (handl
15a0: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 65 78 e-exceptions..ex
15b0: 6e 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 n. (debug:p
15c0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
15d0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 61 69 6c 65 log-port* "Faile
15e0: 64 20 74 6f 20 63 72 65 61 74 65 20 66 69 6c 65 d to create file
15f0: 20 22 20 73 74 61 72 74 2d 66 69 6c 65 20 22 2c " start-file ",
1600: 20 65 78 6e 3d 22 20 65 78 6e 29 0a 20 20 20 20 exn=" exn).
1610: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
1620: 6f 2d 66 69 6c 65 20 73 74 61 72 74 2d 66 69 6c o-file start-fil
1630: 65 20 28 6c 61 6d 62 64 61 20 28 29 28 70 72 69 e (lambda ()(pri
1640: 6e 74 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 nt (current-proc
1650: 65 73 73 2d 69 64 29 29 29 29 29 0a 20 20 20 20 ess-id))))).
1660: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
1670: 74 72 79 2d 73 74 61 72 74 2d 73 65 72 76 65 72 try-start-server
1680: 20 69 70 61 64 64 72 73 74 72 20 73 74 61 72 74 ipaddrstr start
1690: 2d 70 6f 72 74 29 29 29 0a 0a 0a 3b 3b 20 54 68 -port)))...;; Th
16a0: 69 73 20 69 73 20 72 65 63 75 72 73 69 76 65 6c is is recursivel
16b0: 79 20 72 75 6e 20 62 79 20 68 74 74 70 2d 74 72 y run by http-tr
16c0: 61 6e 73 70 6f 72 74 3a 72 75 6e 20 75 6e 74 69 ansport:run unti
16d0: 6c 20 73 75 63 65 73 73 66 75 6c 0a 3b 3b 0a 28 l sucessful.;;.(
16e0: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
16f0: 6e 73 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 74 nsport:try-start
1700: 2d 73 65 72 76 65 72 20 69 70 61 64 64 72 73 74 -server ipaddrst
1710: 72 20 70 6f 72 74 6e 75 6d 29 0a 20 20 28 6c 65 r portnum). (le
1720: 74 20 28 28 63 6f 6e 66 69 67 2d 68 6f 73 74 6e t ((config-hostn
1730: 61 6d 65 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f ame (configf:loo
1740: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
1750: 22 73 65 72 76 65 72 22 20 22 68 6f 73 74 6e 61 "server" "hostna
1760: 6d 65 22 29 29 0a 09 28 63 6f 6e 66 69 67 2d 75 me"))..(config-u
1770: 73 65 2d 70 72 6f 78 79 20 28 65 71 75 61 6c 3f se-proxy (equal?
1780: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
1790: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 63 6c *configdat* "cl
17a0: 69 65 6e 74 22 20 22 75 73 65 2d 68 74 74 70 5f ient" "use-http_
17b0: 70 72 6f 78 79 22 29 20 22 79 65 73 22 29 29 29 proxy") "yes")))
17c0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 63 6f . (if (not co
17d0: 6e 66 69 67 2d 75 73 65 2d 70 72 6f 78 79 29 0a nfig-use-proxy).
17e0: 09 28 64 65 74 65 72 6d 69 6e 65 2d 70 72 6f 78 .(determine-prox
17f0: 79 20 28 63 6f 6e 73 74 61 6e 74 6c 79 20 23 66 y (constantly #f
1800: 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 ))). (debug:p
1810: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
1820: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1830: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 74 http-transport:t
1840: 72 79 2d 73 74 61 72 74 2d 73 65 72 76 65 72 20 ry-start-server
1850: 74 69 6d 65 3d 22 20 28 73 65 63 6f 6e 64 73 2d time=" (seconds-
1860: 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 28 63 75 >time-string (cu
1870: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 rrent-seconds))
1880: 22 20 69 70 61 64 64 72 73 73 74 72 3d 22 20 69 " ipaddrsstr=" i
1890: 70 61 64 64 72 73 74 72 20 22 20 70 6f 72 74 6e paddrstr " portn
18a0: 75 6d 3d 22 20 70 6f 72 74 6e 75 6d 20 22 20 63 um=" portnum " c
18b0: 6f 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 3d 22 onfig-hostname="
18c0: 20 63 6f 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 config-hostname
18d0: 29 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 ). (handle-ex
18e0: 63 65 70 74 69 6f 6e 73 0a 09 65 78 6e 0a 09 28 ceptions..exn..(
18f0: 62 65 67 69 6e 0a 09 20 20 28 70 72 69 6e 74 2d begin.. (print-
1900: 65 72 72 6f 72 2d 6d 65 73 73 61 67 65 20 65 78 error-message ex
1910: 6e 29 0a 09 20 20 28 69 66 20 28 3c 20 70 6f 72 n).. (if (< por
1920: 74 6e 75 6d 20 36 34 30 30 30 29 0a 09 20 20 20 tnum 64000)..
1930: 20 20 20 28 62 65 67 69 6e 20 0a 09 09 28 64 65 (begin ...(de
1940: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
1950: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1960: 57 41 52 4e 49 4e 47 3a 20 61 74 74 65 6d 70 74 WARNING: attempt
1970: 20 74 6f 20 73 74 61 72 74 20 73 65 72 76 65 72 to start server
1980: 20 66 61 69 6c 65 64 2e 20 54 72 79 69 6e 67 20 failed. Trying
1990: 61 67 61 69 6e 20 2e 2e 2e 22 29 0a 09 09 28 64 again ...")...(d
19a0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
19b0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
19c0: 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 " message: " ((c
19d0: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
19e0: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
19f0: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 'message) exn)).
1a00: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 ..(debug:print 5
1a10: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1a20: 72 74 2a 20 22 65 78 6e 3d 22 20 28 63 6f 6e 64 rt* "exn=" (cond
1a30: 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 ition->list exn)
1a40: 29 0a 09 09 28 70 6f 72 74 6c 6f 67 67 65 72 3a )...(portlogger:
1a50: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 open-run-close p
1a60: 6f 72 74 6c 6f 67 67 65 72 3a 73 65 74 2d 66 61 ortlogger:set-fa
1a70: 69 6c 65 64 20 70 6f 72 74 6e 75 6d 29 0a 09 09 iled portnum)...
1a80: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
1a90: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1aa0: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 66 61 69 6c * "WARNING: fail
1ab0: 65 64 20 74 6f 20 73 74 61 72 74 20 6f 6e 20 70 ed to start on p
1ac0: 6f 72 74 6e 75 6d 3a 20 22 20 70 6f 72 74 6e 75 ortnum: " portnu
1ad0: 6d 20 22 2c 20 74 72 79 69 6e 67 20 6e 65 78 74 m ", trying next
1ae0: 20 70 6f 72 74 22 29 0a 09 09 28 74 68 72 65 61 port")...(threa
1af0: 64 2d 73 6c 65 65 70 21 20 30 2e 31 29 0a 09 09 d-sleep! 0.1)...
1b00: 0a 09 09 3b 3b 20 67 65 74 5f 6e 65 78 74 5f 70 ...;; get_next_p
1b10: 6f 72 74 20 67 6f 65 73 20 68 65 72 65 0a 09 09 ort goes here...
1b20: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
1b30: 74 72 79 2d 73 74 61 72 74 2d 73 65 72 76 65 72 try-start-server
1b40: 20 69 70 61 64 64 72 73 74 72 0a 09 09 09 09 09 ipaddrstr......
1b50: 09 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 . (portlogger:op
1b60: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 en-run-close por
1b70: 74 6c 6f 67 67 65 72 3a 66 69 6e 64 2d 70 6f 72 tlogger:find-por
1b80: 74 29 29 29 0a 09 20 20 20 20 20 20 28 62 65 67 t))).. (beg
1b90: 69 6e 0a 09 09 28 70 72 69 6e 74 20 22 45 52 52 in...(print "ERR
1ba0: 4f 52 3a 20 54 72 69 65 64 20 61 6e 64 20 74 72 OR: Tried and tr
1bb0: 69 65 64 20 62 75 74 20 63 6f 75 6c 64 20 6e 6f ied but could no
1bc0: 74 20 73 74 61 72 74 20 74 68 65 20 73 65 72 76 t start the serv
1bd0: 65 72 22 29 29 29 29 0a 20 20 20 20 20 20 3b 3b er")))). ;;
1be0: 20 61 6e 79 20 65 72 72 6f 72 20 69 6e 20 66 6f any error in fo
1bf0: 6c 6c 6f 77 69 6e 67 20 73 74 65 70 73 20 77 69 llowing steps wi
1c00: 6c 6c 20 72 65 73 75 6c 74 20 69 6e 20 61 20 72 ll result in a r
1c10: 65 74 72 79 0a 20 20 20 20 20 20 28 73 65 74 21 etry. (set!
1c20: 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 28 *server-info* (
1c30: 6c 69 73 74 20 69 70 61 64 64 72 73 74 72 20 70 list ipaddrstr p
1c40: 6f 72 74 6e 75 6d 29 29 0a 20 20 20 20 20 20 28 ortnum)). (
1c50: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
1c60: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1c70: 20 22 49 4e 46 4f 3a 20 54 72 79 69 6e 67 20 74 "INFO: Trying t
1c80: 6f 20 73 74 61 72 74 20 73 65 72 76 65 72 20 6f o start server o
1c90: 6e 20 22 20 69 70 61 64 64 72 73 74 72 20 22 3a n " ipaddrstr ":
1ca0: 22 20 70 6f 72 74 6e 75 6d 29 0a 20 20 20 20 20 " portnum).
1cb0: 20 3b 3b 20 54 68 69 73 20 73 74 61 72 74 73 20 ;; This starts
1cc0: 74 68 65 20 73 70 69 66 66 79 20 73 65 72 76 65 the spiffy serve
1cd0: 72 0a 20 20 20 20 20 20 3b 3b 20 4e 45 45 44 20 r. ;; NEED
1ce0: 57 41 59 20 54 4f 20 53 45 54 20 49 50 20 54 4f WAY TO SET IP TO
1cf0: 20 23 66 20 54 4f 20 42 49 4e 44 20 41 4c 4c 0a #f TO BIND ALL.
1d00: 20 20 20 20 20 20 3b 3b 20 28 73 74 61 72 74 2d ;; (start-
1d10: 73 65 72 76 65 72 20 62 69 6e 64 2d 61 64 64 72 server bind-addr
1d20: 65 73 73 3a 20 69 70 61 64 64 72 73 74 72 20 70 ess: ipaddrstr p
1d30: 6f 72 74 3a 20 70 6f 72 74 6e 75 6d 29 0a 20 20 ort: portnum).
1d40: 20 20 20 20 28 69 66 20 63 6f 6e 66 69 67 2d 68 (if config-h
1d50: 6f 73 74 6e 61 6d 65 20 3b 3b 20 74 68 69 73 20 ostname ;; this
1d60: 69 73 20 61 20 68 69 6e 74 20 74 6f 20 62 69 6e is a hint to bin
1d70: 64 20 64 69 72 65 63 74 6c 79 0a 09 20 20 28 73 d directly.. (s
1d80: 74 61 72 74 2d 73 65 72 76 65 72 20 70 6f 72 74 tart-server port
1d90: 3a 20 70 6f 72 74 6e 75 6d 20 62 69 6e 64 2d 61 : portnum bind-a
1da0: 64 64 72 65 73 73 3a 20 28 69 66 20 28 65 71 75 ddress: (if (equ
1db0: 61 6c 3f 20 63 6f 6e 66 69 67 2d 68 6f 73 74 6e al? config-hostn
1dc0: 61 6d 65 20 22 2d 22 29 0a 09 09 09 09 09 09 09 ame "-")........
1dd0: 69 70 61 64 64 72 73 74 72 0a 09 09 09 09 09 09 ipaddrstr.......
1de0: 09 63 6f 6e 66 69 67 2d 68 6f 73 74 6e 61 6d 65 .config-hostname
1df0: 29 29 0a 09 20 20 28 73 74 61 72 74 2d 73 65 72 )).. (start-ser
1e00: 76 65 72 20 70 6f 72 74 3a 20 70 6f 72 74 6e 75 ver port: portnu
1e10: 6d 29 29 0a 20 20 20 20 20 20 28 70 6f 72 74 6c m)). (portl
1e20: 6f 67 67 65 72 3a 6f 70 65 6e 2d 72 75 6e 2d 63 ogger:open-run-c
1e30: 6c 6f 73 65 0a 20 20 20 20 20 20 20 28 6c 61 6d lose. (lam
1e40: 62 64 61 20 28 64 62 29 0a 09 20 28 70 6f 72 74 bda (db).. (port
1e50: 6c 6f 67 67 65 72 3a 73 65 74 2d 70 6f 72 74 20 logger:set-port
1e60: 64 62 20 70 6f 72 74 6e 75 6d 20 22 72 65 6c 65 db portnum "rele
1e70: 61 73 65 64 22 29 29 29 0a 20 20 20 20 20 20 28 ased"))). (
1e80: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 2a 64 debug:print 1 *d
1e90: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1ea0: 20 22 49 4e 46 4f 3a 20 73 65 72 76 65 72 20 68 "INFO: server h
1eb0: 61 73 20 62 65 65 6e 20 73 74 6f 70 70 65 64 22 as been stopped"
1ec0: 29 29 29 29 0a 0a 0a 29 0a ))))...).