Artifact
26ebbfd6a6769f1427a1044c8d6b9488bbf253e2:
0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 32 2c 20 4d 61 74 74 68 65 77 06-2012, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 28 72 65 71 75 PURPOSE...(requ
0150: 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 73 ire-extension (s
0160: 72 66 69 20 31 38 29 20 65 78 74 72 61 73 20 74 rfi 18) extras t
0170: 63 70 20 73 31 31 6e 29 0a 0a 28 75 73 65 20 73 cp s11n)..(use s
0180: 71 6c 69 74 65 33 20 73 72 66 69 2d 31 20 70 6f qlite3 srfi-1 po
0190: 73 69 78 20 72 65 67 65 78 20 72 65 67 65 78 2d six regex regex-
01a0: 63 61 73 65 20 73 72 66 69 2d 36 39 20 68 6f 73 case srfi-69 hos
01b0: 74 69 6e 66 6f 20 6d 64 35 20 6d 65 73 73 61 67 tinfo md5 messag
01c0: 65 2d 64 69 67 65 73 74 29 0a 28 69 6d 70 6f 72 e-digest).(impor
01d0: 74 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 t (prefix sqlite
01e0: 33 20 73 71 6c 69 74 65 33 3a 29 29 0a 0a 28 75 3 sqlite3:))..(u
01f0: 73 65 20 73 70 69 66 66 79 20 75 72 69 2d 63 6f se spiffy uri-co
0200: 6d 6d 6f 6e 20 69 6e 74 61 72 77 65 62 20 68 74 mmon intarweb ht
0210: 74 70 2d 63 6c 69 65 6e 74 20 73 70 69 66 66 79 tp-client spiffy
0220: 2d 72 65 71 75 65 73 74 2d 76 61 72 73 20 20 75 -request-vars u
0230: 72 69 2d 63 6f 6d 6d 6f 6e 20 69 6e 74 61 72 77 ri-common intarw
0240: 65 62 20 73 70 69 66 66 79 2d 64 69 72 65 63 74 eb spiffy-direct
0250: 6f 72 79 2d 6c 69 73 74 69 6e 67 29 0a 0a 3b 3b ory-listing)..;;
0260: 20 43 6f 6e 66 69 67 75 72 61 74 69 6f 6e 73 20 Configurations
0270: 66 6f 72 20 73 65 72 76 65 72 0a 28 74 63 70 2d for server.(tcp-
0280: 62 75 66 66 65 72 2d 73 69 7a 65 20 32 30 34 38 buffer-size 2048
0290: 29 0a 28 6d 61 78 2d 63 6f 6e 6e 65 63 74 69 6f ).(max-connectio
02a0: 6e 73 20 32 30 34 38 29 20 0a 0a 28 64 65 63 6c ns 2048) ..(decl
02b0: 61 72 65 20 28 75 6e 69 74 20 68 74 74 70 2d 74 are (unit http-t
02c0: 72 61 6e 73 70 6f 72 74 29 29 0a 0a 28 64 65 63 ransport))..(dec
02d0: 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6d 6d 6f lare (uses commo
02e0: 6e 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 n)).(declare (us
02f0: 65 73 20 64 62 29 29 0a 28 64 65 63 6c 61 72 65 es db)).(declare
0300: 20 28 75 73 65 73 20 74 65 73 74 73 29 29 0a 28 (uses tests)).(
0310: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 61 declare (uses ta
0320: 73 6b 73 29 29 20 3b 3b 20 74 61 73 6b 73 20 61 sks)) ;; tasks a
0330: 72 65 20 77 68 65 72 65 20 73 74 75 66 66 20 69 re where stuff i
0340: 73 20 6d 61 69 6e 74 61 69 6e 65 64 20 61 62 6f s maintained abo
0350: 75 74 20 77 68 61 74 20 69 73 20 72 75 6e 6e 69 ut what is runni
0360: 6e 67 2e 0a 28 64 65 63 6c 61 72 65 20 28 75 73 ng..(declare (us
0370: 65 73 20 73 65 72 76 65 72 29 29 0a 28 64 65 63 es server)).(dec
0380: 6c 61 72 65 20 28 75 73 65 73 20 64 61 65 6d 6f lare (uses daemo
0390: 6e 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 63 n))..(include "c
03a0: 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 ommon_records.sc
03b0: 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 m").(include "db
03c0: 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a _records.scm")..
03d0: 28 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 (define (http-tr
03e0: 61 6e 73 70 6f 72 74 3a 6d 61 6b 65 2d 73 65 72 ansport:make-ser
03f0: 76 65 72 2d 75 72 6c 20 68 6f 73 74 70 6f 72 74 ver-url hostport
0400: 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 68 6f 73 ). (if (not hos
0410: 74 70 6f 72 74 29 0a 20 20 20 20 20 20 23 66 0a tport). #f.
0420: 20 20 20 20 20 20 28 63 6f 6e 63 20 22 68 74 74 (conc "htt
0430: 70 3a 2f 2f 22 20 28 63 61 72 20 68 6f 73 74 70 p://" (car hostp
0440: 6f 72 74 29 20 22 3a 22 20 28 63 61 64 72 20 68 ort) ":" (cadr h
0450: 6f 73 74 70 6f 72 74 29 29 29 29 0a 0a 28 64 65 ostport))))..(de
0460: 66 69 6e 65 20 20 2a 73 65 72 76 65 72 2d 6c 6f fine *server-lo
0470: 6f 70 2d 68 65 61 72 74 2d 62 65 61 74 2a 20 28 op-heart-beat* (
0480: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
0490: 29 0a 28 64 65 66 69 6e 65 20 2a 68 65 61 72 74 ).(define *heart
04a0: 62 65 61 74 2d 6d 75 74 65 78 2a 20 28 6d 61 6b beat-mutex* (mak
04b0: 65 2d 6d 75 74 65 78 29 29 0a 0a 3b 3b 3d 3d 3d e-mutex))..;;===
04c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0500: 3d 3d 3d 0a 3b 3b 20 53 20 45 20 52 20 56 20 45 ===.;; S E R V E
0510: 20 52 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d R.;;===========
0520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
0560: 43 61 6c 6c 20 74 68 69 73 20 74 6f 20 73 74 61 Call this to sta
0570: 72 74 20 74 68 65 20 61 63 74 75 61 6c 20 73 65 rt the actual se
0580: 72 76 65 72 0a 3b 3b 0a 0a 28 64 65 66 69 6e 65 rver.;;..(define
0590: 20 2a 64 62 3a 70 72 6f 63 65 73 73 2d 71 75 65 *db:process-que
05a0: 75 65 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d ue-mutex* (make-
05b0: 6d 75 74 65 78 29 29 0a 0a 28 64 65 66 69 6e 65 mutex))..(define
05c0: 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 (server:get-bes
05d0: 74 2d 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 t-guess-address
05e0: 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 hostname). (let
05f0: 20 28 28 72 65 73 20 23 66 29 29 0a 20 20 20 20 ((res #f)).
0600: 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 (for-each .
0610: 28 6c 61 6d 62 64 61 20 28 61 64 72 29 0a 20 20 (lambda (adr).
0620: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 (if (not (e
0630: 71 3f 20 28 75 38 76 65 63 74 6f 72 2d 72 65 66 q? (u8vector-ref
0640: 20 61 64 72 20 30 29 20 31 32 37 29 29 0a 09 20 adr 0) 127))..
0650: 20 20 28 73 65 74 21 20 72 65 73 20 61 64 72 29 (set! res adr)
0660: 29 29 0a 20 20 20 20 20 28 76 65 63 74 6f 72 2d )). (vector-
0670: 3e 6c 69 73 74 20 28 68 6f 73 74 69 6e 66 6f 2d >list (hostinfo-
0680: 61 64 64 72 65 73 73 65 73 20 28 68 6f 73 74 6e addresses (hostn
0690: 61 6d 65 2d 3e 68 6f 73 74 69 6e 66 6f 20 68 6f ame->hostinfo ho
06a0: 73 74 6e 61 6d 65 29 29 29 29 0a 20 20 20 20 28 stname)))). (
06b0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
06c0: 73 65 20 0a 20 20 20 20 20 28 6d 61 70 20 6e 75 se . (map nu
06d0: 6d 62 65 72 2d 3e 73 74 72 69 6e 67 0a 09 20 20 mber->string..
06e0: 28 75 38 76 65 63 74 6f 72 2d 3e 6c 69 73 74 0a (u8vector->list.
06f0: 09 20 20 20 28 69 66 20 72 65 73 20 72 65 73 20 . (if res res
0700: 28 68 6f 73 74 6e 61 6d 65 2d 3e 69 70 20 68 6f (hostname->ip ho
0710: 73 74 6e 61 6d 65 29 29 29 29 20 22 2e 22 29 29 stname)))) "."))
0720: 29 0a 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 )..(define (http
0730: 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 20 68 -transport:run h
0740: 6f 73 74 6e 29 0a 20 20 28 64 65 62 75 67 3a 70 ostn). (debug:p
0750: 72 69 6e 74 20 32 20 22 41 74 74 65 6d 70 74 69 rint 2 "Attempti
0760: 6e 67 20 74 6f 20 73 74 61 72 74 20 74 68 65 20 ng to start the
0770: 73 65 72 76 65 72 20 2e 2e 2e 22 29 0a 20 20 28 server ..."). (
0780: 69 66 20 28 6e 6f 74 20 2a 74 6f 70 70 61 74 68 if (not *toppath
0790: 2a 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f *). (if (no
07a0: 74 20 28 73 65 74 75 70 2d 66 6f 72 2d 72 75 6e t (setup-for-run
07b0: 29 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 )).. (begin..
07c0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
07d0: 20 22 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 "ERROR: cannot
07e0: 66 69 6e 64 20 6d 65 67 61 74 65 73 74 2e 63 6f find megatest.co
07f0: 6e 66 69 67 2c 20 63 61 6e 6e 6f 74 20 73 74 61 nfig, cannot sta
0800: 72 74 20 73 65 72 76 65 72 2c 20 65 78 69 74 69 rt server, exiti
0810: 6e 67 22 29 0a 09 20 20 20 20 28 65 78 69 74 29 ng").. (exit)
0820: 29 29 29 0a 20 20 28 6c 65 74 2a 20 28 3b 3b 20 ))). (let* (;;
0830: 28 69 66 61 63 65 20 20 20 20 20 20 20 20 20 20 (iface
0840: 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 22 (if (string=? "
0850: 2d 22 20 68 6f 73 74 6e 29 0a 09 20 3b 3b 20 20 -" hostn).. ;;
0860: 20 20 20 20 20 20 09 20 20 20 20 20 20 23 66 20 . #f
0870: 3b 3b 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d ;; (get-host-nam
0880: 65 29 20 0a 09 20 3b 3b 20 20 20 20 20 20 20 20 e) .. ;;
0890: 09 20 20 20 20 20 20 68 6f 73 74 6e 29 29 0a 09 . hostn))..
08a0: 20 28 64 62 20 20 20 20 20 20 20 20 20 20 20 20 (db
08b0: 20 20 23 66 29 20 3b 3b 20 20 20 20 20 20 20 20 #f) ;;
08c0: 28 6f 70 65 6e 2d 64 62 29 29 20 3b 3b 20 77 65 (open-db)) ;; we
08d0: 20 64 6f 6e 27 74 20 77 61 6e 74 20 74 68 65 20 don't want the
08e0: 73 65 72 76 65 72 20 74 6f 20 62 65 20 6f 70 65 server to be ope
08f0: 6e 69 6e 67 20 61 6e 64 20 63 6c 6f 73 69 6e 67 ning and closing
0900: 20 74 68 65 20 64 62 20 75 6e 6e 65 63 65 73 61 the db unnecesa
0910: 72 69 6c 79 0a 09 20 28 68 6f 73 74 6e 61 6d 65 rily.. (hostname
0920: 20 20 20 20 20 20 20 20 28 67 65 74 2d 68 6f 73 (get-hos
0930: 74 2d 6e 61 6d 65 29 29 0a 09 20 28 69 70 61 64 t-name)).. (ipad
0940: 64 72 73 74 72 20 20 20 20 20 20 20 28 6c 65 74 drstr (let
0950: 20 28 28 69 70 73 74 72 20 28 69 66 20 28 73 74 ((ipstr (if (st
0960: 72 69 6e 67 3d 3f 20 22 2d 22 20 68 6f 73 74 6e ring=? "-" hostn
0970: 29 0a 09 09 09 09 09 20 20 20 3b 3b 20 28 73 74 )...... ;; (st
0980: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
0990: 20 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e 73 74 (map number->st
09a0: 72 69 6e 67 20 28 75 38 76 65 63 74 6f 72 2d 3e ring (u8vector->
09b0: 6c 69 73 74 20 28 68 6f 73 74 6e 61 6d 65 2d 3e list (hostname->
09c0: 69 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 20 22 ip hostname))) "
09d0: 2e 22 29 0a 09 09 09 09 09 20 20 20 28 73 65 72 .")...... (ser
09e0: 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 ver:get-best-gue
09f0: 73 73 2d 61 64 64 72 65 73 73 20 68 6f 73 74 6e ss-address hostn
0a00: 61 6d 65 29 0a 09 09 09 09 09 20 20 20 23 66 29 ame)...... #f)
0a10: 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 69 70 )).... (if ip
0a20: 73 74 72 20 69 70 73 74 72 20 68 6f 73 74 6e 29 str ipstr hostn)
0a30: 29 29 20 3b 3b 20 68 6f 73 74 6e 61 6d 65 29 29 )) ;; hostname))
0a40: 29 0a 09 20 28 73 74 61 72 74 2d 70 6f 72 74 20 ).. (start-port
0a50: 20 20 20 28 69 66 20 28 61 6e 64 20 28 61 72 67 (if (and (arg
0a60: 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 6f 72 74 s:get-arg "-port
0a70: 22 29 0a 09 09 09 09 20 28 73 74 72 69 6e 67 2d ")..... (string-
0a80: 3e 6e 75 6d 62 65 72 20 28 61 72 67 73 3a 67 65 >number (args:ge
0a90: 74 2d 61 72 67 20 22 2d 70 6f 72 74 22 29 29 29 t-arg "-port")))
0aa0: 0a 09 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d .... (string-
0ab0: 3e 6e 75 6d 62 65 72 20 28 61 72 67 73 3a 67 65 >number (args:ge
0ac0: 74 2d 61 72 67 20 22 2d 70 6f 72 74 22 29 29 0a t-arg "-port")).
0ad0: 09 09 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 ... (if (and
0ae0: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 20 (config-lookup
0af0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 *configdat* "ser
0b00: 76 65 72 22 20 22 70 6f 72 74 22 29 0a 09 09 09 ver" "port")....
0b10: 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e . (string->n
0b20: 75 6d 62 65 72 20 28 63 6f 6e 66 69 67 2d 6c 6f umber (config-lo
0b30: 6f 6b 75 70 20 20 2a 63 6f 6e 66 69 67 64 61 74 okup *configdat
0b40: 2a 20 22 73 65 72 76 65 72 22 20 22 70 6f 72 74 * "server" "port
0b50: 22 29 29 29 0a 09 09 09 09 28 73 74 72 69 6e 67 "))).....(string
0b60: 2d 3e 6e 75 6d 62 65 72 20 28 63 6f 6e 66 69 67 ->number (config
0b70: 2d 6c 6f 6f 6b 75 70 20 20 2a 63 6f 6e 66 69 67 -lookup *config
0b80: 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 70 dat* "server" "p
0b90: 6f 72 74 22 29 29 0a 09 09 09 09 28 2b 20 35 30 ort")).....(+ 50
0ba0: 30 30 20 28 72 61 6e 64 6f 6d 20 31 30 30 31 29 00 (random 1001)
0bb0: 29 29 29 29 0a 09 20 28 6c 69 6e 6b 2d 74 72 65 )))).. (link-tre
0bc0: 65 2d 70 61 74 68 20 28 63 6f 6e 66 69 67 2d 6c e-path (config-l
0bd0: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
0be0: 2a 20 22 73 65 74 75 70 22 20 22 6c 69 6e 6b 74 * "setup" "linkt
0bf0: 72 65 65 22 29 29 29 0a 20 20 20 20 28 73 65 74 ree"))). (set
0c00: 21 20 2a 63 61 63 68 65 2d 6f 6e 2a 20 23 74 29 ! *cache-on* #t)
0c10: 0a 20 20 20 20 28 72 6f 6f 74 2d 70 61 74 68 20 . (root-path
0c20: 20 20 20 20 28 69 66 20 6c 69 6e 6b 2d 74 72 65 (if link-tre
0c30: 65 2d 70 61 74 68 20 0a 09 09 20 20 20 20 20 20 e-path ...
0c40: 20 6c 69 6e 6b 2d 74 72 65 65 2d 70 61 74 68 0a link-tree-path.
0c50: 09 09 20 20 20 20 20 20 20 28 63 75 72 72 65 6e .. (curren
0c60: 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 20 3b t-directory))) ;
0c70: 3b 20 57 41 52 4e 49 4e 47 3a 20 53 45 43 55 52 ; WARNING: SECUR
0c80: 49 54 59 20 48 4f 4c 45 2e 20 46 49 58 20 41 53 ITY HOLE. FIX AS
0c90: 41 50 21 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d AP!. (handle-
0ca0: 64 69 72 65 63 74 6f 72 79 20 73 70 69 66 66 79 directory spiffy
0cb0: 2d 64 69 72 65 63 74 6f 72 79 2d 6c 69 73 74 69 -directory-listi
0cc0: 6e 67 29 0a 20 20 20 20 3b 3b 20 68 74 74 70 2d ng). ;; http-
0cd0: 74 72 61 6e 73 70 6f 72 74 3a 68 61 6e 64 6c 65 transport:handle
0ce0: 2d 64 69 72 65 63 74 6f 72 79 29 20 3b 3b 20 73 -directory) ;; s
0cf0: 69 6d 70 6c 65 2d 64 69 72 65 63 74 6f 72 79 2d imple-directory-
0d00: 68 61 6e 64 6c 65 72 29 0a 20 20 20 20 3b 3b 20 handler). ;;
0d10: 53 65 74 75 70 20 74 68 65 20 77 65 62 20 73 65 Setup the web se
0d20: 72 76 65 72 20 61 6e 64 20 61 20 2f 63 74 72 6c rver and a /ctrl
0d30: 20 69 6e 74 65 72 66 61 63 65 0a 20 20 20 20 3b interface. ;
0d40: 3b 0a 20 20 20 20 28 76 68 6f 73 74 2d 6d 61 70 ;. (vhost-map
0d50: 20 60 28 28 28 2a 20 61 6e 79 29 20 2e 20 2c 28 `(((* any) . ,(
0d60: 6c 61 6d 62 64 61 20 28 63 6f 6e 74 69 6e 75 65 lambda (continue
0d70: 29 0a 09 09 09 20 20 20 20 20 20 20 3b 3b 20 6f ).... ;; o
0d80: 70 65 6e 20 74 68 65 20 64 62 20 6f 6e 20 74 68 pen the db on th
0d90: 65 20 66 69 72 73 74 20 63 61 6c 6c 20 0a 09 09 e first call ...
0da0: 09 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 . (if (not
0db0: 20 64 62 29 28 73 65 74 21 20 64 62 20 28 6f 70 db)(set! db (op
0dc0: 65 6e 2d 64 62 29 29 29 0a 09 09 09 20 20 20 20 en-db)))....
0dd0: 20 20 20 28 6c 65 74 2a 20 28 28 24 20 20 20 28 (let* (($ (
0de0: 72 65 71 75 65 73 74 2d 76 61 72 73 20 73 6f 75 request-vars sou
0df0: 72 63 65 3a 20 27 62 6f 74 68 29 29 0a 09 09 09 rce: 'both))....
0e00: 09 20 20 20 20 20 20 28 64 61 74 20 28 24 20 27 . (dat ($ '
0e10: 64 61 74 29 29 0a 09 09 09 09 20 20 20 20 20 20 dat)).....
0e20: 28 72 65 73 20 23 66 29 29 0a 09 09 09 09 20 28 (res #f))..... (
0e30: 63 6f 6e 64 0a 09 09 09 09 20 20 3b 3b 20 54 68 cond..... ;; Th
0e40: 69 73 20 69 73 20 74 68 65 20 2f 63 74 72 6c 20 is is the /ctrl
0e50: 70 61 74 68 20 77 68 65 72 65 20 64 61 74 61 20 path where data
0e60: 69 73 20 68 61 6e 64 65 64 20 74 6f 20 74 68 65 is handed to the
0e70: 20 73 65 72 76 65 72 20 61 6e 64 0a 09 09 09 09 server and.....
0e80: 20 20 3b 3b 20 72 65 73 70 6f 6e 73 65 73 20 0a ;; responses .
0e90: 09 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 .... ((equal? (
0ea0: 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 73 uri-path (reques
0eb0: 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d 72 t-uri (current-r
0ec0: 65 71 75 65 73 74 29 29 29 0a 09 09 09 09 09 20 equest)))......
0ed0: 20 20 27 28 2f 20 22 63 74 72 6c 22 29 29 0a 09 '(/ "ctrl"))..
0ee0: 09 09 09 20 20 20 28 6c 65 74 2a 20 28 28 70 61 ... (let* ((pa
0ef0: 63 6b 65 74 20 28 64 62 3a 73 74 72 69 6e 67 2d cket (db:string-
0f00: 3e 6f 62 6a 20 64 61 74 29 29 0a 09 09 09 09 09 >obj dat))......
0f10: 20 20 28 71 74 79 70 65 20 20 28 63 64 62 3a 70 (qtype (cdb:p
0f20: 61 63 6b 65 74 2d 67 65 74 2d 71 74 79 70 65 20 acket-get-qtype
0f30: 70 61 63 6b 65 74 29 29 29 0a 09 09 09 09 20 20 packet))).....
0f40: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
0f50: 69 6e 66 6f 20 31 32 20 22 73 65 72 76 65 72 3d info 12 "server=
0f60: 3e 20 72 65 63 65 69 76 65 64 20 70 61 63 6b 65 > received packe
0f70: 74 3d 22 20 70 61 63 6b 65 74 29 0a 09 09 09 09 t=" packet).....
0f80: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6d (if (not (m
0f90: 65 6d 62 65 72 20 71 74 79 70 65 20 27 28 73 79 ember qtype '(sy
0fa0: 6e 63 20 70 69 6e 67 29 29 29 0a 09 09 09 09 09 nc ping)))......
0fb0: 20 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 20 (begin......
0fc0: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 (mutex-lock! *he
0fd0: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
0fe0: 09 09 09 09 09 20 20 20 28 73 65 74 21 20 2a 6c ..... (set! *l
0ff0: 61 73 74 2d 64 62 2d 61 63 63 65 73 73 2a 20 28 ast-db-access* (
1000: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
1010: 29 0a 09 09 09 09 09 20 20 20 28 6d 75 74 65 78 )...... (mutex
1020: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 -unlock! *heartb
1030: 65 61 74 2d 6d 75 74 65 78 2a 29 29 29 0a 09 09 eat-mutex*)))...
1040: 09 09 20 20 20 20 20 3b 3b 20 28 6d 75 74 65 78 .. ;; (mutex
1050: 2d 6c 6f 63 6b 21 20 2a 64 62 3a 70 72 6f 63 65 -lock! *db:proce
1060: 73 73 2d 71 75 65 75 65 2d 6d 75 74 65 78 2a 29 ss-queue-mutex*)
1070: 20 3b 3b 20 74 72 79 69 6e 67 20 61 20 6d 75 74 ;; trying a mut
1080: 65 78 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 28 ex..... ;; (
1090: 73 65 74 21 20 72 65 73 20 28 6f 70 65 6e 2d 72 set! res (open-r
10a0: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 70 72 6f 63 un-close db:proc
10b0: 65 73 73 2d 71 75 65 75 65 2d 69 74 65 6d 20 6f ess-queue-item o
10c0: 70 65 6e 2d 64 62 20 70 61 63 6b 65 74 29 29 0a pen-db packet)).
10d0: 09 09 09 09 20 20 20 20 20 28 73 65 74 21 20 72 .... (set! r
10e0: 65 73 20 28 64 62 3a 70 72 6f 63 65 73 73 2d 71 es (db:process-q
10f0: 75 65 75 65 2d 69 74 65 6d 20 64 62 20 70 61 63 ueue-item db pac
1100: 6b 65 74 29 29 0a 09 09 09 09 20 20 20 20 20 3b ket))..... ;
1110: 3b 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 ; (mutex-unlock!
1120: 20 2a 64 62 3a 70 72 6f 63 65 73 73 2d 71 75 65 *db:process-que
1130: 75 65 2d 6d 75 74 65 78 2a 29 0a 09 09 09 09 20 ue-mutex*).....
1140: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
1150: 2d 69 6e 66 6f 20 31 31 20 22 52 65 74 75 72 6e -info 11 "Return
1160: 20 76 61 6c 75 65 20 66 72 6f 6d 20 64 62 3a 70 value from db:p
1170: 72 6f 63 65 73 73 2d 71 75 65 75 65 2d 69 74 65 rocess-queue-ite
1180: 6d 20 69 73 20 22 20 72 65 73 29 0a 09 09 09 09 m is " res).....
1190: 20 20 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f (send-respo
11a0: 6e 73 65 20 62 6f 64 79 3a 20 28 63 6f 6e 63 20 nse body: (conc
11b0: 22 3c 68 65 61 64 3e 63 74 72 6c 20 64 61 74 61 "<head>ctrl data
11c0: 3c 2f 68 65 61 64 3e 5c 6e 3c 62 6f 64 79 3e 22 </head>\n<body>"
11d0: 0a 09 09 09 09 09 09 09 09 72 65 73 0a 09 09 09 .........res....
11e0: 09 09 09 09 09 22 3c 2f 62 6f 64 79 3e 22 29 0a ....."</body>").
11f0: 09 09 09 09 09 09 20 20 20 20 68 65 61 64 65 72 ...... header
1200: 73 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d 74 79 s: '((content-ty
1210: 70 65 20 74 65 78 74 2f 70 6c 61 69 6e 29 29 29 pe text/plain)))
1220: 29 29 0a 09 09 09 09 20 20 28 28 65 71 75 61 6c ))..... ((equal
1230: 3f 20 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 ? (uri-path (req
1240: 75 65 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e uest-uri (curren
1250: 74 2d 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 t-request))) ...
1260: 09 09 09 20 20 20 27 28 2f 20 22 22 29 29 0a 09 ... '(/ ""))..
1270: 09 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 ... (send-resp
1280: 6f 6e 73 65 20 62 6f 64 79 3a 20 28 68 74 74 70 onse body: (http
1290: 2d 74 72 61 6e 73 70 6f 72 74 3a 6d 61 69 6e 2d -transport:main-
12a0: 70 61 67 65 29 29 29 0a 09 09 09 09 20 20 28 28 page)))..... ((
12b0: 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 68 equal? (uri-path
12c0: 20 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 63 (request-uri (c
12d0: 75 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 29 urrent-request))
12e0: 29 20 0a 09 09 09 09 09 20 20 20 27 28 2f 20 22 ) ...... '(/ "
12f0: 72 75 6e 73 22 29 29 0a 09 09 09 09 20 20 20 28 runs"))..... (
1300: 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f send-response bo
1310: 64 79 3a 20 28 68 74 74 70 2d 74 72 61 6e 73 70 dy: (http-transp
1320: 6f 72 74 3a 6d 61 69 6e 2d 70 61 67 65 29 29 29 ort:main-page)))
1330: 0a 09 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 ..... ((equal?
1340: 28 75 72 69 2d 70 61 74 68 20 28 72 65 71 75 65 (uri-path (reque
1350: 73 74 2d 75 72 69 20 28 63 75 72 72 65 6e 74 2d st-uri (current-
1360: 72 65 71 75 65 73 74 29 29 29 20 0a 09 09 09 09 request))) .....
1370: 09 20 20 20 27 28 2f 20 61 6e 79 29 29 0a 09 09 . '(/ any))...
1380: 09 09 20 20 20 28 73 65 6e 64 2d 72 65 73 70 6f .. (send-respo
1390: 6e 73 65 20 62 6f 64 79 3a 20 22 68 65 79 20 74 nse body: "hey t
13a0: 68 65 72 65 21 5c 6e 22 0a 09 09 09 09 09 09 20 here!\n".......
13b0: 20 68 65 61 64 65 72 73 3a 20 27 28 28 63 6f 6e headers: '((con
13c0: 74 65 6e 74 2d 74 79 70 65 20 74 65 78 74 2f 70 tent-type text/p
13d0: 6c 61 69 6e 29 29 29 29 0a 09 09 09 09 20 20 28 lain))))..... (
13e0: 28 65 71 75 61 6c 3f 20 28 75 72 69 2d 70 61 74 (equal? (uri-pat
13f0: 68 20 28 72 65 71 75 65 73 74 2d 75 72 69 20 28 h (request-uri (
1400: 63 75 72 72 65 6e 74 2d 72 65 71 75 65 73 74 29 current-request)
1410: 29 29 20 0a 09 09 09 09 09 20 20 20 27 28 2f 20 )) ...... '(/
1420: 22 68 65 79 22 29 29 0a 09 09 09 09 20 20 20 28 "hey"))..... (
1430: 73 65 6e 64 2d 72 65 73 70 6f 6e 73 65 20 62 6f send-response bo
1440: 64 79 3a 20 22 68 65 79 20 74 68 65 72 65 21 5c dy: "hey there!\
1450: 6e 22 0a 09 09 09 09 09 09 20 20 68 65 61 64 65 n"....... heade
1460: 72 73 3a 20 27 28 28 63 6f 6e 74 65 6e 74 2d 74 rs: '((content-t
1470: 79 70 65 20 74 65 78 74 2f 70 6c 61 69 6e 29 29 ype text/plain))
1480: 29 29 0a 09 09 09 09 20 20 28 65 6c 73 65 20 28 ))..... (else (
1490: 63 6f 6e 74 69 6e 75 65 29 29 29 29 29 29 29 29 continue))))))))
14a0: 0a 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 . (http-trans
14b0: 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 port:try-start-s
14c0: 65 72 76 65 72 20 69 70 61 64 64 72 73 74 72 20 erver ipaddrstr
14d0: 73 74 61 72 74 2d 70 6f 72 74 29 29 29 0a 0a 3b start-port)))..;
14e0: 3b 20 54 68 69 73 20 69 73 20 72 65 63 75 72 73 ; This is recurs
14f0: 69 76 65 6c 79 20 72 75 6e 20 62 79 20 68 74 74 ively run by htt
1500: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 20 p-transport:run
1510: 75 6e 74 69 6c 20 73 75 63 65 73 73 66 75 6c 0a until sucessful.
1520: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 74 74 70 ;;.(define (http
1530: 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 -transport:try-s
1540: 74 61 72 74 2d 73 65 72 76 65 72 20 69 70 61 64 tart-server ipad
1550: 64 72 73 74 72 20 70 6f 72 74 6e 75 6d 29 0a 20 drstr portnum).
1560: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
1570: 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 62 ons. exn. (b
1580: 65 67 69 6e 0a 20 20 20 20 20 28 70 72 69 6e 74 egin. (print
1590: 2d 65 72 72 6f 72 2d 6d 65 73 73 61 67 65 20 65 -error-message e
15a0: 78 6e 29 0a 20 20 20 20 20 28 69 66 20 28 3c 20 xn). (if (<
15b0: 70 6f 72 74 6e 75 6d 20 39 30 30 30 29 0a 09 20 portnum 9000)..
15c0: 28 62 65 67 69 6e 20 0a 09 20 20 20 28 64 65 62 (begin .. (deb
15d0: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
15e0: 49 4e 47 3a 20 66 61 69 6c 65 64 20 74 6f 20 73 ING: failed to s
15f0: 74 61 72 74 20 6f 6e 20 70 6f 72 74 6e 75 6d 3a tart on portnum:
1600: 20 22 20 70 6f 72 74 6e 75 6d 20 22 2c 20 74 72 " portnum ", tr
1610: 79 69 6e 67 20 6e 65 78 74 20 70 6f 72 74 22 29 ying next port")
1620: 0a 09 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 .. (thread-sle
1630: 65 70 21 20 30 2e 31 29 0a 09 20 20 20 3b 3b 20 ep! 0.1).. ;;
1640: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
1650: 74 61 73 6b 73 3a 72 65 6d 6f 76 65 2d 73 65 72 tasks:remove-ser
1660: 76 65 72 2d 72 65 63 6f 72 64 73 20 74 61 73 6b ver-records task
1670: 73 3a 6f 70 65 6e 2d 64 62 29 0a 09 20 20 20 28 s:open-db).. (
1680: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 open-run-close t
1690: 61 73 6b 73 3a 73 65 72 76 65 72 2d 64 65 6c 65 asks:server-dele
16a0: 74 65 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 te tasks:open-db
16b0: 20 69 70 61 64 64 72 73 74 72 20 70 6f 72 74 6e ipaddrstr portn
16c0: 75 6d 29 0a 09 20 20 20 28 68 74 74 70 2d 74 72 um).. (http-tr
16d0: 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 74 61 72 ansport:try-star
16e0: 74 2d 73 65 72 76 65 72 20 69 70 61 64 64 72 73 t-server ipaddrs
16f0: 74 72 20 28 2b 20 70 6f 72 74 6e 75 6d 20 31 29 tr (+ portnum 1)
1700: 29 29 0a 09 20 28 70 72 69 6e 74 20 22 45 52 52 )).. (print "ERR
1710: 4f 52 3a 20 54 72 69 65 64 20 61 6e 64 20 74 72 OR: Tried and tr
1720: 69 65 64 20 62 75 74 20 63 6f 75 6c 64 20 6e 6f ied but could no
1730: 74 20 73 74 61 72 74 20 74 68 65 20 73 65 72 76 t start the serv
1740: 65 72 22 29 29 29 0a 20 20 20 3b 3b 20 61 6e 79 er"))). ;; any
1750: 20 65 72 72 6f 72 20 69 6e 20 66 6f 6c 6c 6f 77 error in follow
1760: 69 6e 67 20 73 74 65 70 73 20 77 69 6c 6c 20 72 ing steps will r
1770: 65 73 75 6c 74 20 69 6e 20 61 20 72 65 74 72 79 esult in a retry
1780: 0a 20 20 20 28 73 65 74 21 20 2a 72 75 6e 72 65 . (set! *runre
1790: 6d 6f 74 65 2a 20 28 6c 69 73 74 20 69 70 61 64 mote* (list ipad
17a0: 64 72 73 74 72 20 70 6f 72 74 6e 75 6d 29 29 0a drstr portnum)).
17b0: 20 20 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d ;; (open-run-
17c0: 63 6c 6f 73 65 20 74 61 73 6b 73 3a 72 65 6d 6f close tasks:remo
17d0: 76 65 2d 73 65 72 76 65 72 2d 72 65 63 6f 72 64 ve-server-record
17e0: 73 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 s tasks:open-db)
17f0: 0a 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c . (open-run-cl
1800: 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 76 65 72 ose tasks:server
1810: 2d 72 65 67 69 73 74 65 72 20 0a 09 09 20 20 20 -register ...
1820: 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 0a 09 tasks:open-db ..
1830: 09 20 20 20 28 63 75 72 72 65 6e 74 2d 70 72 6f . (current-pro
1840: 63 65 73 73 2d 69 64 29 0a 09 09 20 20 20 69 70 cess-id)... ip
1850: 61 64 64 72 73 74 72 20 70 6f 72 74 6e 75 6d 20 addrstr portnum
1860: 30 20 27 73 74 61 72 74 75 70 20 27 68 74 74 70 0 'startup 'http
1870: 29 0a 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e ). (debug:prin
1880: 74 20 31 20 22 49 4e 46 4f 3a 20 54 72 79 69 6e t 1 "INFO: Tryin
1890: 67 20 74 6f 20 73 74 61 72 74 20 73 65 72 76 65 g to start serve
18a0: 72 20 6f 6e 20 22 20 69 70 61 64 64 72 73 74 72 r on " ipaddrstr
18b0: 20 22 3a 22 20 70 6f 72 74 6e 75 6d 29 0a 20 20 ":" portnum).
18c0: 20 3b 3b 20 54 68 69 73 20 73 74 61 72 74 73 20 ;; This starts
18d0: 74 68 65 20 73 70 69 66 66 79 20 73 65 72 76 65 the spiffy serve
18e0: 72 0a 20 20 20 3b 3b 20 4e 45 45 44 20 57 41 59 r. ;; NEED WAY
18f0: 20 54 4f 20 53 45 54 20 49 50 20 54 4f 20 23 66 TO SET IP TO #f
1900: 20 54 4f 20 42 49 4e 44 20 41 4c 4c 0a 20 20 20 TO BIND ALL.
1910: 28 73 74 61 72 74 2d 73 65 72 76 65 72 20 62 69 (start-server bi
1920: 6e 64 2d 61 64 64 72 65 73 73 3a 20 69 70 61 64 nd-address: ipad
1930: 64 72 73 74 72 20 70 6f 72 74 3a 20 70 6f 72 74 drstr port: port
1940: 6e 75 6d 29 0a 20 20 20 28 6f 70 65 6e 2d 72 75 num). (open-ru
1950: 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 n-close tasks:se
1960: 72 76 65 72 2d 64 65 6c 65 74 65 20 74 61 73 6b rver-delete task
1970: 73 3a 6f 70 65 6e 2d 64 62 20 69 70 61 64 64 72 s:open-db ipaddr
1980: 73 74 72 20 70 6f 72 74 6e 75 6d 29 0a 20 20 20 str portnum).
1990: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
19a0: 49 4e 46 4f 3a 20 73 65 72 76 65 72 20 68 61 73 INFO: server has
19b0: 20 62 65 65 6e 20 73 74 6f 70 70 65 64 22 29 29 been stopped"))
19c0: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
19d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 ===========.;; S
1a10: 20 45 20 52 20 56 20 45 20 52 20 20 20 55 20 54 E R V E R U T
1a20: 20 49 20 4c 20 49 20 54 20 49 20 45 20 53 20 0a I L I T I E S .
1a30: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
1a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a70: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d 3d 3d ========..;;====
1a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ac0: 3d 3d 0a 3b 3b 20 43 20 4c 20 49 20 45 20 4e 20 ==.;; C L I E N
1ad0: 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d T S.;;==========
1ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
1b20: 65 66 69 6e 65 20 2a 68 74 74 70 2d 6d 75 74 65 efine *http-mute
1b30: 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 x* (make-mutex))
1b40: 0a 0a 3b 3b 20 28 73 79 73 74 65 6d 20 22 6d 65 ..;; (system "me
1b50: 67 61 74 65 73 74 20 2d 6c 69 73 74 2d 73 65 72 gatest -list-ser
1b60: 76 65 72 73 20 7c 20 67 72 65 70 20 61 6c 69 76 vers | grep aliv
1b70: 65 20 7c 7c 20 6d 65 67 61 74 65 73 74 20 2d 73 e || megatest -s
1b80: 65 72 76 65 72 20 2d 20 2d 64 61 65 6d 6f 6e 69 erver - -daemoni
1b90: 7a 65 20 26 26 20 73 6c 65 65 70 20 34 22 29 0a ze && sleep 4").
1ba0: 0a 3b 3b 20 3c 68 74 6d 6c 3e 0a 3b 3b 20 3c 68 .;; <html>.;; <h
1bb0: 65 61 64 3e 3c 2f 68 65 61 64 3e 0a 3b 3b 20 3c ead></head>.;; <
1bc0: 62 6f 64 79 3e 31 20 48 65 6c 6c 6f 2c 20 77 6f body>1 Hello, wo
1bd0: 72 6c 64 21 20 47 6f 6f 64 62 79 65 20 44 6f 6c rld! Goodbye Dol
1be0: 6c 79 3c 2f 62 6f 64 79 3e 3c 2f 68 74 6d 6c 3e ly</body></html>
1bf0: 0a 3b 3b 20 53 65 6e 64 20 6d 73 67 20 74 6f 20 .;; Send msg to
1c00: 73 65 72 76 65 72 64 61 74 20 61 6e 64 20 72 65 serverdat and re
1c10: 63 65 69 76 65 20 72 65 73 75 6c 74 0a 28 64 65 ceive result.(de
1c20: 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
1c30: 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 73 65 6e 64 port:client-send
1c40: 2d 72 65 63 65 69 76 65 20 73 65 72 76 65 72 64 -receive serverd
1c50: 61 74 20 6d 73 67 20 23 21 6b 65 79 20 28 6e 75 at msg #!key (nu
1c60: 6d 72 65 74 72 69 65 73 20 33 30 29 29 0a 20 20 mretries 30)).
1c70: 28 6c 65 74 2a 20 28 3b 3b 20 28 75 72 6c 20 20 (let* (;; (url
1c80: 20 20 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e (http-tran
1c90: 73 70 6f 72 74 3a 6d 61 6b 65 2d 73 65 72 76 65 sport:make-serve
1ca0: 72 2d 75 72 6c 20 73 65 72 76 65 72 64 61 74 29 r-url serverdat)
1cb0: 29 0a 09 20 28 66 75 6c 6c 75 72 6c 20 20 20 20 ).. (fullurl
1cc0: 28 63 61 64 64 72 20 73 65 72 76 65 72 64 61 74 (caddr serverdat
1cd0: 29 29 20 3b 3b 20 28 63 6f 6e 63 20 75 72 6c 20 )) ;; (conc url
1ce0: 22 2f 63 74 72 6c 22 29 29 20 3b 3b 20 28 63 6f "/ctrl")) ;; (co
1cf0: 6e 63 20 75 72 6c 20 22 2f 3f 64 61 74 3d 22 20 nc url "/?dat="
1d00: 6d 73 67 29 29 29 0a 09 20 28 72 65 73 20 20 20 msg))).. (res
1d10: 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 28 68 #f)). (h
1d20: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
1d30: 0a 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 28 . exn. (
1d40: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 28 70 72 begin. (pr
1d50: 69 6e 74 20 22 45 52 52 4f 52 20 49 4e 20 68 74 int "ERROR IN ht
1d60: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 tp-transport:cli
1d70: 65 6e 74 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 ent-send-receive
1d80: 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
1d90: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
1da0: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
1db0: 65 78 6e 29 29 0a 20 20 20 20 20 20 20 28 74 68 exn)). (th
1dc0: 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a 20 read-sleep! 2).
1dd0: 20 20 20 20 20 20 28 69 66 20 28 3e 20 6e 75 6d (if (> num
1de0: 72 65 74 72 69 65 73 20 30 29 0a 09 20 20 20 28 retries 0).. (
1df0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 http-transport:c
1e00: 6c 69 65 6e 74 2d 73 65 6e 64 2d 72 65 63 65 69 lient-send-recei
1e10: 76 65 20 73 65 72 76 65 72 64 61 74 20 6d 73 67 ve serverdat msg
1e20: 20 6e 75 6d 72 65 74 72 69 65 73 3a 20 28 2d 20 numretries: (-
1e30: 6e 75 6d 72 65 74 72 69 65 73 20 31 29 29 29 29 numretries 1))))
1e40: 0a 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 . (begin.
1e50: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
1e60: 2d 69 6e 66 6f 20 31 31 20 22 66 75 6c 6c 75 72 -info 11 "fullur
1e70: 6c 3d 22 20 66 75 6c 6c 75 72 6c 20 22 5c 6e 22 l=" fullurl "\n"
1e80: 29 0a 20 20 20 20 20 20 20 3b 3b 20 73 65 74 20 ). ;; set
1e90: 75 70 20 74 68 65 20 68 74 74 70 2d 63 6c 69 65 up the http-clie
1ea0: 6e 74 20 68 65 72 65 0a 20 20 20 20 20 20 20 28 nt here. (
1eb0: 6d 61 78 2d 72 65 74 72 79 2d 61 74 74 65 6d 70 max-retry-attemp
1ec0: 74 73 20 35 29 0a 20 20 20 20 20 20 20 3b 3b 20 ts 5). ;;
1ed0: 63 6f 6e 73 69 64 65 72 20 61 6c 6c 20 72 65 71 consider all req
1ee0: 75 65 73 74 73 20 69 6e 64 65 6d 70 6f 74 65 6e uests indempoten
1ef0: 74 0a 20 20 20 20 20 20 20 28 72 65 74 72 79 2d t. (retry-
1f00: 72 65 71 75 65 73 74 3f 20 28 6c 61 6d 62 64 61 request? (lambda
1f10: 20 28 72 65 71 75 65 73 74 29 0a 09 09 09 20 23 (request).... #
1f20: 74 29 29 20 20 20 3b 3b 20 20 09 09 20 28 74 68 t)) ;; .. (th
1f30: 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2f 20 28 read-sleep! (/ (
1f40: 69 66 20 28 3e 20 6e 75 6d 72 65 74 72 69 65 73 if (> numretries
1f50: 20 31 30 30 29 20 31 30 30 20 6e 75 6d 72 65 74 100) 100 numret
1f60: 72 69 65 73 29 20 31 30 29 29 0a 20 20 20 20 20 ries) 10)).
1f70: 20 20 3b 3b 20 28 73 65 74 21 20 6e 75 6d 72 65 ;; (set! numre
1f80: 74 72 69 65 73 20 28 2d 20 6e 75 6d 72 65 74 72 tries (- numretr
1f90: 69 65 73 20 31 29 29 0a 20 20 20 20 20 20 20 3b ies 1)). ;
1fa0: 3b 20 20 09 09 20 23 74 29 29 0a 20 20 20 20 20 ; .. #t)).
1fb0: 20 20 3b 3b 20 73 65 6e 64 20 74 68 65 20 64 61 ;; send the da
1fc0: 74 61 20 61 6e 64 20 67 65 74 20 74 68 65 20 72 ta and get the r
1fd0: 65 73 70 6f 6e 73 65 0a 20 20 20 20 20 20 20 3b esponse. ;
1fe0: 3b 20 65 78 74 72 61 63 74 20 74 68 65 20 6e 65 ; extract the ne
1ff0: 65 64 65 64 20 69 6e 66 6f 20 66 72 6f 6d 20 74 eded info from t
2000: 68 65 20 68 74 74 70 20 64 61 74 61 20 61 6e 64 he http data and
2010: 20 0a 20 20 20 20 20 20 20 3b 3b 20 70 72 6f 63 . ;; proc
2020: 65 73 73 20 61 6e 64 20 72 65 74 75 72 6e 20 69 ess and return i
2030: 74 2e 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 t.. (let*
2040: 28 28 73 65 6e 64 2d 72 65 63 69 65 76 65 20 28 ((send-recieve (
2050: 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 lambda ()....
2060: 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 (mutex-lock!
2070: 2a 68 74 74 70 2d 6d 75 74 65 78 2a 29 0a 09 09 *http-mutex*)...
2080: 09 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 . (set! res
2090: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
20a0: 6d 2d 72 65 71 75 65 73 74 20 0a 09 09 09 09 09 m-request ......
20b0: 20 66 75 6c 6c 75 72 6c 20 0a 09 09 09 09 09 20 fullurl ......
20c0: 28 6c 69 73 74 20 28 63 6f 6e 73 20 27 64 61 74 (list (cons 'dat
20d0: 20 6d 73 67 29 29 20 0a 09 09 09 09 09 20 72 65 msg)) ...... re
20e0: 61 64 2d 73 74 72 69 6e 67 29 29 0a 09 09 09 20 ad-string))....
20f0: 20 20 20 20 20 28 63 6c 6f 73 65 2d 61 6c 6c 2d (close-all-
2100: 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 20 0a 09 connections!) ..
2110: 09 09 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 .. (mutex-u
2120: 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d 75 74 nlock! *http-mut
2130: 65 78 2a 29 29 29 0a 09 20 20 20 20 20 20 28 74 ex*))).. (t
2140: 69 6d 65 2d 6f 75 74 20 20 20 20 20 28 6c 61 6d ime-out (lam
2150: 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 bda ()....
2160: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 (thread-sleep! 5
2170: 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 28 ).... (if (
2180: 6e 6f 74 20 72 65 73 29 0a 09 09 09 09 20 20 28 not res)..... (
2190: 62 65 67 69 6e 0a 09 09 09 09 20 20 20 20 28 64 begin..... (d
21a0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
21b0: 52 4e 49 4e 47 3a 20 63 6f 6d 6d 75 6e 69 63 61 RNING: communica
21c0: 74 69 6f 6e 20 77 69 74 68 20 74 68 65 20 73 65 tion with the se
21d0: 72 76 65 72 20 74 69 6d 65 64 20 6f 75 74 2e 22 rver timed out."
21e0: 29 0a 09 09 09 09 20 20 20 20 28 6d 75 74 65 78 )..... (mutex
21f0: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 74 74 70 2d 6d -unlock! *http-m
2200: 75 74 65 78 2a 29 0a 09 09 09 09 20 20 20 20 28 utex*)..... (
2210: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 http-transport:c
2220: 6c 69 65 6e 74 2d 73 65 6e 64 2d 72 65 63 65 69 lient-send-recei
2230: 76 65 20 73 65 72 76 65 72 64 61 74 20 6d 73 67 ve serverdat msg
2240: 20 6e 75 6d 72 65 74 72 69 65 73 3a 20 28 2d 20 numretries: (-
2250: 6e 75 6d 72 65 74 72 69 65 73 20 31 29 29 0a 09 numretries 1))..
2260: 09 09 09 20 20 20 20 28 69 66 20 28 3c 20 6e 75 ... (if (< nu
2270: 6d 72 65 74 72 69 65 73 20 33 29 20 3b 3b 20 6f mretries 3) ;; o
2280: 6e 20 6c 61 73 74 20 74 72 79 20 6a 75 73 74 20 n last try just
2290: 65 78 69 74 0a 09 09 09 09 09 28 62 65 67 69 6e exit......(begin
22a0: 0a 09 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 ...... (debug:p
22b0: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 63 rint 0 "ERROR: c
22c0: 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 77 69 74 ommunication wit
22d0: 68 20 74 68 65 20 73 65 72 76 65 72 20 74 69 6d h the server tim
22e0: 65 64 20 6f 75 74 2e 20 47 69 76 69 6e 67 20 75 ed out. Giving u
22f0: 70 2e 22 29 0a 09 09 09 09 09 20 20 28 65 78 69 p.")...... (exi
2300: 74 20 31 29 29 29 29 29 29 29 0a 09 20 20 20 20 t 1)))))))..
2310: 20 20 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 (th1 (make-thr
2320: 65 61 64 20 73 65 6e 64 2d 72 65 63 69 65 76 65 ead send-recieve
2330: 20 22 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f "with-input-fro
2340: 6d 2d 72 65 71 75 65 73 74 22 29 29 0a 09 20 20 m-request"))..
2350: 20 20 20 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 (th2 (make-t
2360: 68 72 65 61 64 20 74 69 6d 65 2d 6f 75 74 20 20 hread time-out
2370: 20 20 20 22 74 69 6d 65 20 6f 75 74 22 29 29 29 "time out")))
2380: 0a 09 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 .. (thread-start
2390: 21 20 74 68 31 29 0a 09 20 28 74 68 72 65 61 64 ! th1).. (thread
23a0: 2d 73 74 61 72 74 21 20 74 68 32 29 0a 09 20 28 -start! th2).. (
23b0: 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 thread-join! th1
23c0: 29 0a 09 20 28 74 68 72 65 61 64 2d 74 65 72 6d ).. (thread-term
23d0: 69 6e 61 74 65 21 20 74 68 32 29 0a 09 20 28 64 inate! th2).. (d
23e0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
23f0: 31 31 20 22 67 6f 74 20 72 65 73 3d 22 20 72 65 11 "got res=" re
2400: 73 29 0a 09 20 28 6c 65 74 20 28 28 6d 61 74 63 s).. (let ((matc
2410: 68 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 h (string-search
2420: 20 28 72 65 67 65 78 70 20 22 3c 62 6f 64 79 3e (regexp "<body>
2430: 28 2e 2a 29 3c 2e 62 6f 64 79 3e 22 29 20 72 65 (.*)<.body>") re
2440: 73 29 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a s))).. (debug:
2450: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 31 20 22 6d print-info 11 "m
2460: 61 74 63 68 3d 22 20 6d 61 74 63 68 29 0a 09 20 atch=" match)..
2470: 20 20 28 6c 65 74 20 28 28 66 69 6e 61 6c 20 28 (let ((final (
2480: 63 61 64 72 20 6d 61 74 63 68 29 29 29 0a 09 20 cadr match)))..
2490: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
24a0: 2d 69 6e 66 6f 20 31 31 20 22 66 69 6e 61 6c 3d -info 11 "final=
24b0: 22 20 66 69 6e 61 6c 29 0a 09 20 20 20 20 20 66 " final).. f
24c0: 69 6e 61 6c 29 29 29 29 29 29 29 0a 0a 28 64 65 inal)))))))..(de
24d0: 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 fine (http-trans
24e0: 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 63 6f 6e 6e port:client-conn
24f0: 65 63 74 20 69 66 61 63 65 20 70 6f 72 74 29 0a ect iface port).
2500: 20 20 28 6c 65 74 2a 20 28 28 6c 6f 67 69 6e 2d (let* ((login-
2510: 72 65 73 20 20 20 23 66 29 0a 09 20 28 75 72 69 res #f).. (uri
2520: 2d 64 61 74 20 20 20 20 20 28 6d 61 6b 65 2d 72 -dat (make-r
2530: 65 71 75 65 73 74 20 6d 65 74 68 6f 64 3a 20 27 equest method: '
2540: 50 4f 53 54 20 75 72 69 3a 20 28 75 72 69 2d 72 POST uri: (uri-r
2550: 65 66 65 72 65 6e 63 65 20 28 63 6f 6e 63 20 22 eference (conc "
2560: 68 74 74 70 3a 2f 2f 22 20 69 66 61 63 65 20 22 http://" iface "
2570: 3a 22 20 70 6f 72 74 20 22 2f 63 74 72 6c 22 29 :" port "/ctrl")
2580: 29 29 29 0a 09 20 28 73 65 72 76 65 72 64 61 74 ))).. (serverdat
2590: 20 20 20 28 6c 69 73 74 20 69 66 61 63 65 20 70 (list iface p
25a0: 6f 72 74 20 75 72 69 2d 64 61 74 29 29 29 0a 20 ort uri-dat))).
25b0: 20 20 20 28 73 65 74 21 20 6c 6f 67 69 6e 2d 72 (set! login-r
25c0: 65 73 20 28 63 6c 69 65 6e 74 3a 6c 6f 67 69 6e es (client:login
25d0: 20 73 65 72 76 65 72 64 61 74 29 29 0a 20 20 20 serverdat)).
25e0: 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 (if (and (not (
25f0: 6e 75 6c 6c 3f 20 6c 6f 67 69 6e 2d 72 65 73 29 null? login-res)
2600: 29 0a 09 20 20 20 20 20 28 63 61 72 20 6c 6f 67 ).. (car log
2610: 69 6e 2d 72 65 73 29 29 0a 09 28 62 65 67 69 6e in-res))..(begin
2620: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
2630: 2d 69 6e 66 6f 20 32 20 22 4c 6f 67 67 65 64 20 -info 2 "Logged
2640: 69 6e 20 61 6e 64 20 63 6f 6e 6e 65 63 74 65 64 in and connected
2650: 20 74 6f 20 22 20 69 66 61 63 65 20 22 3a 22 20 to " iface ":"
2660: 70 6f 72 74 29 0a 09 20 20 28 73 65 74 21 20 2a port).. (set! *
2670: 72 75 6e 72 65 6d 6f 74 65 2a 20 73 65 72 76 65 runremote* serve
2680: 72 64 61 74 29 0a 09 20 20 73 65 72 76 65 72 64 rdat).. serverd
2690: 61 74 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 at)..(begin.. (
26a0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
26b0: 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 0 "ERROR: Faile
26c0: 64 20 74 6f 20 6c 6f 67 69 6e 20 6f 72 20 63 6f d to login or co
26d0: 6e 6e 65 63 74 20 74 6f 20 22 20 69 66 61 63 65 nnect to " iface
26e0: 20 22 3a 22 20 70 6f 72 74 29 0a 09 20 20 28 65 ":" port).. (e
26f0: 78 69 74 20 31 29 29 29 29 29 0a 3b 3b 20 09 20 xit 1))))).;; .
2700: 20 28 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 (set! *runremot
2710: 65 2a 20 23 66 29 0a 3b 3b 20 09 20 20 28 73 65 e* #f).;; . (se
2720: 74 21 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 t! *transport-ty
2730: 70 65 2a 20 27 66 73 29 0a 3b 3b 20 09 20 20 23 pe* 'fs).;; . #
2740: 66 29 29 29 29 0a 0a 0a 3b 3b 20 72 75 6e 20 68 f))))...;; run h
2750: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6b 65 ttp-transport:ke
2760: 65 70 2d 72 75 6e 6e 69 6e 67 20 69 6e 20 61 20 ep-running in a
2770: 70 61 72 61 6c 6c 65 6c 20 74 68 72 65 61 64 20 parallel thread
2780: 74 6f 20 6d 6f 6e 69 74 6f 72 20 74 68 61 74 20 to monitor that
2790: 74 68 65 20 64 62 20 69 73 20 62 65 69 6e 67 20 the db is being
27a0: 0a 3b 3b 20 75 73 65 64 20 61 6e 64 20 74 6f 20 .;; used and to
27b0: 73 68 75 74 64 6f 77 6e 20 61 66 74 65 72 20 73 shutdown after s
27c0: 6f 6d 65 74 69 6d 65 20 69 66 20 69 74 20 69 73 ometime if it is
27d0: 20 6e 6f 74 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 not..;;.(define
27e0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
27f0: 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 29 0a 20 :keep-running).
2800: 20 3b 3b 20 69 66 20 6e 6f 6e 65 20 72 75 6e 6e ;; if none runn
2810: 69 6e 67 20 6f 72 20 69 66 20 3e 20 32 30 20 73 ing or if > 20 s
2820: 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 0a 20 20 econds since .
2830: 3b 3b 20 73 65 72 76 65 72 20 6c 61 73 74 20 75 ;; server last u
2840: 73 65 64 20 74 68 65 6e 20 73 74 61 72 74 20 73 sed then start s
2850: 68 75 74 64 6f 77 6e 0a 20 20 3b 3b 20 54 68 69 hutdown. ;; Thi
2860: 73 20 74 68 72 65 61 64 20 77 61 69 74 73 20 66 s thread waits f
2870: 6f 72 20 74 68 65 20 73 65 72 76 65 72 20 74 6f or the server to
2880: 20 63 6f 6d 65 20 61 6c 69 76 65 0a 20 20 28 6c come alive. (l
2890: 65 74 2a 20 28 28 73 65 72 76 65 72 2d 69 6e 66 et* ((server-inf
28a0: 6f 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 20 o (let loop ().
28b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28c0: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 64 (let ((sd
28d0: 61 74 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 at #f)).
28e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28f0: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
2900: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
2910: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2920: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 (set
2930: 21 20 73 64 61 74 20 2a 72 75 6e 72 65 6d 6f 74 ! sdat *runremot
2940: 65 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e*).
2950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d (m
2960: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 utex-unlock! *he
2970: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
2980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2990: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 73 64 (if sd
29a0: 61 74 0a 09 09 09 20 20 20 20 20 20 73 64 61 74 at.... sdat
29b0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
29c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
29d0: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
29e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29f0: 20 20 20 20 20 20 28 73 6c 65 65 70 20 34 29 0a (sleep 4).
2a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a20: 28 6c 6f 6f 70 29 29 29 29 29 29 0a 20 20 20 20 (loop)))))).
2a30: 20 20 20 20 20 28 69 66 61 63 65 20 20 20 20 20 (iface
2a40: 20 20 28 63 61 72 20 73 65 72 76 65 72 2d 69 6e (car server-in
2a50: 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 28 70 fo)). (p
2a60: 6f 72 74 20 20 20 20 20 20 20 20 28 63 61 64 72 ort (cadr
2a70: 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 29 0a 20 server-info)).
2a80: 20 20 20 20 20 20 20 20 28 6c 61 73 74 2d 61 63 (last-ac
2a90: 63 65 73 73 20 30 29 0a 09 20 28 74 64 62 20 20 cess 0).. (tdb
2aa0: 20 20 20 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 (tasks:op
2ab0: 65 6e 2d 64 62 29 29 0a 09 20 28 73 70 69 64 20 en-db)).. (spid
2ac0: 20 20 20 20 20 20 20 3b 3b 28 6f 70 65 6e 2d 72 ;;(open-r
2ad0: 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 un-close tasks:s
2ae0: 65 72 76 65 72 2d 67 65 74 2d 73 65 72 76 65 72 erver-get-server
2af0: 2d 69 64 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 -id tasks:open-d
2b00: 62 20 23 66 20 69 66 61 63 65 20 70 6f 72 74 20 b #f iface port
2b10: 23 66 29 29 0a 09 20 20 20 28 74 61 73 6b 73 3a #f)).. (tasks:
2b20: 73 65 72 76 65 72 2d 67 65 74 2d 73 65 72 76 65 server-get-serve
2b30: 72 2d 69 64 20 74 64 62 20 23 66 20 69 66 61 63 r-id tdb #f ifac
2b40: 65 20 70 6f 72 74 20 23 66 29 29 0a 09 20 28 73 e port #f)).. (s
2b50: 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 20 28 6c erver-timeout (l
2b60: 65 74 20 28 28 74 6d 6f 20 28 63 6f 6e 66 69 67 et ((tmo (config
2b70: 2d 6c 6f 6f 6b 75 70 20 20 2a 63 6f 6e 66 69 67 -lookup *config
2b80: 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 74 dat* "server" "t
2b90: 69 6d 65 6f 75 74 22 29 29 29 0a 09 09 09 20 20 imeout")))....
2ba0: 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e (if (and (strin
2bb0: 67 3f 20 74 6d 6f 29 0a 09 09 09 09 20 20 20 20 g? tmo).....
2bc0: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
2bd0: 74 6d 6f 29 29 0a 09 09 09 20 20 20 20 20 20 20 tmo))....
2be0: 28 2a 20 36 30 20 36 30 20 28 73 74 72 69 6e 67 (* 60 60 (string
2bf0: 2d 3e 6e 75 6d 62 65 72 20 74 6d 6f 29 29 0a 09 ->number tmo))..
2c00: 09 09 20 20 20 20 20 20 20 3b 3b 20 64 65 66 61 .. ;; defa
2c10: 75 6c 74 20 74 6f 20 74 68 72 65 65 20 64 61 79 ult to three day
2c20: 73 0a 09 09 09 20 20 20 20 20 20 20 28 2a 20 33 s.... (* 3
2c30: 20 32 34 20 36 30 20 36 30 29 29 29 29 29 0a 20 24 60 60))))).
2c40: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
2c50: 69 6e 66 6f 20 32 20 22 73 65 72 76 65 72 2d 74 info 2 "server-t
2c60: 69 6d 65 6f 75 74 3a 20 22 20 73 65 72 76 65 72 imeout: " server
2c70: 2d 74 69 6d 65 6f 75 74 20 22 2c 20 73 65 72 76 -timeout ", serv
2c80: 65 72 20 70 69 64 3a 20 22 20 73 70 69 64 20 22 er pid: " spid "
2c90: 20 6f 6e 20 22 20 69 66 61 63 65 20 22 3a 22 20 on " iface ":"
2ca0: 70 6f 72 74 29 0a 20 20 20 20 28 6c 65 74 20 6c port). (let l
2cb0: 6f 6f 70 20 28 28 63 6f 75 6e 74 20 30 29 29 0a oop ((count 0)).
2cc0: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
2cd0: 65 65 70 21 20 34 29 20 3b 3b 20 6e 6f 20 6e 65 eep! 4) ;; no ne
2ce0: 65 64 20 74 6f 20 64 6f 20 74 68 69 73 20 76 65 ed to do this ve
2cf0: 72 79 20 6f 66 74 65 6e 0a 20 20 20 20 20 20 3b ry often. ;
2d00: 3b 20 4e 42 2f 2f 20 73 79 6e 63 20 63 75 72 72 ; NB// sync curr
2d10: 65 6e 74 6c 79 20 64 6f 65 73 20 4e 4f 54 20 72 ently does NOT r
2d20: 65 74 75 72 6e 20 71 75 65 75 65 2d 6c 65 6e 67 eturn queue-leng
2d30: 74 68 0a 20 20 20 20 20 20 28 6c 65 74 20 28 29 th. (let ()
2d40: 20 3b 3b 20 28 71 75 65 75 65 2d 6c 65 6e 20 28 ;; (queue-len (
2d50: 63 64 62 3a 63 6c 69 65 6e 74 2d 63 61 6c 6c 20 cdb:client-call
2d60: 73 65 72 76 65 72 2d 69 6e 66 6f 20 27 73 79 6e server-info 'syn
2d70: 63 20 23 74 20 31 29 29 29 0a 20 20 20 20 20 20 c #t 1))).
2d80: 3b 3b 20 28 70 72 69 6e 74 20 22 53 65 72 76 65 ;; (print "Serve
2d90: 72 20 72 75 6e 6e 69 6e 67 2c 20 63 6f 75 6e 74 r running, count
2da0: 20 69 73 20 22 20 63 6f 75 6e 74 29 0a 20 20 20 is " count).
2db0: 20 20 20 20 20 28 69 66 20 28 3c 20 63 6f 75 6e (if (< coun
2dc0: 74 20 31 29 20 3b 3b 20 33 78 33 20 3d 20 39 20 t 1) ;; 3x3 = 9
2dd0: 73 65 63 73 20 61 70 72 6f 78 0a 20 20 20 20 20 secs aprox.
2de0: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 2b 20 (loop (+
2df0: 63 6f 75 6e 74 20 31 29 29 29 0a 20 20 20 20 20 count 1))).
2e00: 20 20 20 0a 09 3b 3b 20 43 68 65 63 6b 20 74 68 ..;; Check th
2e10: 61 74 20 69 66 61 63 65 20 61 6e 64 20 70 6f 72 at iface and por
2e20: 74 20 68 61 76 65 20 6e 6f 74 20 63 68 61 6e 67 t have not chang
2e30: 65 64 20 28 63 61 6e 20 68 61 70 70 65 6e 20 69 ed (can happen i
2e40: 66 20 73 65 72 76 65 72 20 70 6f 72 74 20 63 6f f server port co
2e50: 6c 6c 69 64 65 73 29 0a 09 28 6d 75 74 65 78 2d llides)..(mutex-
2e60: 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 lock! *heartbeat
2e70: 2d 6d 75 74 65 78 2a 29 0a 09 28 73 65 74 21 20 -mutex*)..(set!
2e80: 73 64 61 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a sdat *runremote*
2e90: 29 0a 09 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b )..(mutex-unlock
2ea0: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
2eb0: 65 78 2a 29 0a 0a 09 28 69 66 20 28 6f 72 20 28 ex*)...(if (or (
2ec0: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 73 64 61 74 not (equal? sdat
2ed0: 20 28 6c 69 73 74 20 69 66 61 63 65 20 70 6f 72 (list iface por
2ee0: 74 29 29 29 0a 09 09 28 6e 6f 74 20 73 70 69 64 t)))...(not spid
2ef0: 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 20 0a )).. (begin .
2f00: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
2f10: 69 6e 74 2d 69 6e 66 6f 20 30 20 22 69 6e 74 65 int-info 0 "inte
2f20: 72 66 61 63 65 20 63 68 61 6e 67 65 64 2c 20 72 rface changed, r
2f30: 65 66 72 65 73 68 69 6e 67 20 69 66 61 63 65 20 efreshing iface
2f40: 61 6e 64 20 70 6f 72 74 20 69 6e 66 6f 22 29 0a and port info").
2f50: 09 20 20 20 20 20 20 28 73 65 74 21 20 69 66 61 . (set! ifa
2f60: 63 65 20 28 63 61 72 20 73 64 61 74 29 29 0a 09 ce (car sdat))..
2f70: 20 20 20 20 20 20 28 73 65 74 21 20 70 6f 72 74 (set! port
2f80: 20 20 28 63 61 64 72 20 73 64 61 74 29 29 0a 09 (cadr sdat))..
2f90: 20 20 20 20 20 20 28 73 65 74 21 20 73 70 69 64 (set! spid
2fa0: 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d (tasks:server-
2fb0: 67 65 74 2d 73 65 72 76 65 72 2d 69 64 20 74 64 get-server-id td
2fc0: 62 20 23 66 20 69 66 61 63 65 20 70 6f 72 74 20 b #f iface port
2fd0: 23 66 29 29 29 29 0a 0a 20 20 20 20 20 20 20 20 #f))))..
2fe0: 3b 3b 20 4e 4f 54 45 3a 20 47 65 74 20 72 69 64 ;; NOTE: Get rid
2ff0: 20 6f 66 20 74 68 69 73 20 6d 65 63 68 61 6e 69 of this mechani
3000: 73 6d 21 20 49 74 20 72 65 61 6c 6c 79 20 69 73 sm! It really is
3010: 20 6e 6f 74 20 6e 65 65 64 65 64 2e 2e 2e 0a 20 not needed....
3020: 20 20 20 20 20 20 20 3b 3b 20 28 6f 70 65 6e 2d ;; (open-
3030: 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a run-close tasks:
3040: 73 65 72 76 65 72 2d 75 70 64 61 74 65 2d 68 65 server-update-he
3050: 61 72 74 62 65 61 74 20 74 61 73 6b 73 3a 6f 70 artbeat tasks:op
3060: 65 6e 2d 64 62 20 73 70 69 64 29 0a 20 20 20 20 en-db spid).
3070: 20 20 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 (tasks:serve
3080: 72 2d 75 70 64 61 74 65 2d 68 65 61 72 74 62 65 r-update-heartbe
3090: 61 74 20 74 64 62 20 73 70 69 64 29 0a 20 20 20 at tdb spid).
30a0: 20 20 20 0a 20 20 20 20 20 20 20 20 3b 3b 20 28 . ;; (
30b0: 69 66 20 3b 3b 20 28 6f 72 20 28 3e 20 6e 75 6d if ;; (or (> num
30c0: 72 75 6e 6e 69 6e 67 20 30 29 20 3b 3b 20 73 74 running 0) ;; st
30d0: 61 79 20 61 6c 69 76 65 20 66 6f 72 20 74 77 6f ay alive for two
30e0: 20 64 61 79 73 20 61 66 74 65 72 20 6c 61 73 74 days after last
30f0: 20 61 63 63 65 73 73 0a 20 20 20 20 20 20 20 20 access.
3100: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 (mutex-lock! *he
3110: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
3120: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 6c 61 (set! la
3130: 73 74 2d 61 63 63 65 73 73 20 2a 6c 61 73 74 2d st-access *last-
3140: 64 62 2d 61 63 63 65 73 73 2a 29 0a 20 20 20 20 db-access*).
3150: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
3160: 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 k! *heartbeat-mu
3170: 74 65 78 2a 29 0a 09 3b 3b 20 28 64 65 62 75 67 tex*)..;; (debug
3180: 3a 70 72 69 6e 74 20 31 31 20 22 6c 61 73 74 2d :print 11 "last-
3190: 61 63 63 65 73 73 3d 22 20 6c 61 73 74 2d 61 63 access=" last-ac
31a0: 63 65 73 73 20 22 2c 20 73 65 72 76 65 72 2d 74 cess ", server-t
31b0: 69 6d 65 6f 75 74 3d 22 20 73 65 72 76 65 72 2d imeout=" server-
31c0: 74 69 6d 65 6f 75 74 29 0a 20 20 20 20 20 20 20 timeout).
31d0: 20 28 69 66 20 28 3e 20 28 2b 20 6c 61 73 74 2d (if (> (+ last-
31e0: 61 63 63 65 73 73 20 73 65 72 76 65 72 2d 74 69 access server-ti
31f0: 6d 65 6f 75 74 29 0a 20 20 20 20 20 20 20 20 20 meout).
3200: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 (current-s
3210: 65 63 6f 6e 64 73 29 29 0a 20 20 20 20 20 20 20 econds)).
3220: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
3230: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
3240: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 53 :print-info 2 "S
3250: 65 72 76 65 72 20 63 6f 6e 74 69 6e 75 69 6e 67 erver continuing
3260: 2c 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 , seconds since
3270: 6c 61 73 74 20 64 62 20 61 63 63 65 73 73 3a 20 last db access:
3280: 22 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 " (- (current-se
3290: 63 6f 6e 64 73 29 20 6c 61 73 74 2d 61 63 63 65 conds) last-acce
32a0: 73 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ss)).
32b0: 20 20 20 28 6c 6f 6f 70 20 30 29 29 0a 20 20 20 (loop 0)).
32c0: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
32d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
32e0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
32f0: 30 20 22 53 74 61 72 74 69 6e 67 20 74 6f 20 73 0 "Starting to s
3300: 68 75 74 64 6f 77 6e 20 74 68 65 20 73 65 72 76 hutdown the serv
3310: 65 72 2e 22 29 0a 20 20 20 20 20 20 20 20 20 20 er.").
3320: 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 64 ;; need to d
3330: 65 6c 65 74 65 20 6f 6e 6c 79 20 2a 6d 79 2a 20 elete only *my*
3340: 73 65 72 76 65 72 20 65 6e 74 72 79 20 28 66 75 server entry (fu
3350: 74 75 72 65 20 75 73 65 29 0a 20 20 20 20 20 20 ture use).
3360: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 2a 74 (set! *t
3370: 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 29 ime-to-exit* #t)
3380: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
3390: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 open-run-close t
33a0: 61 73 6b 73 3a 73 65 72 76 65 72 2d 64 65 72 65 asks:server-dere
33b0: 67 69 73 74 65 72 2d 73 65 6c 66 20 74 61 73 6b gister-self task
33c0: 73 3a 6f 70 65 6e 2d 64 62 20 28 67 65 74 2d 68 s:open-db (get-h
33d0: 6f 73 74 2d 6e 61 6d 65 29 29 0a 20 20 20 20 20 ost-name)).
33e0: 20 20 20 20 20 20 20 20 20 28 74 68 72 65 61 64 (thread
33f0: 2d 73 6c 65 65 70 21 20 31 29 0a 20 20 20 20 20 -sleep! 1).
3400: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
3410: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 4d 61 print-info 0 "Ma
3420: 78 20 63 61 63 68 65 64 20 71 75 65 72 69 65 73 x cached queries
3430: 20 77 61 73 20 20 20 20 22 20 2a 6d 61 78 2d 63 was " *max-c
3440: 61 63 68 65 2d 73 69 7a 65 2a 29 0a 09 20 20 20 ache-size*)..
3450: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
3460: 69 6e 66 6f 20 30 20 22 4e 75 6d 62 65 72 20 6f info 0 "Number o
3470: 66 20 63 61 63 68 65 64 20 77 72 69 74 65 73 20 f cached writes
3480: 20 20 22 20 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 " *number-of-w
3490: 72 69 74 65 73 2a 29 0a 09 20 20 20 20 20 20 28 rites*).. (
34a0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
34b0: 20 30 20 22 41 76 65 72 61 67 65 20 63 61 63 68 0 "Average cach
34c0: 65 64 20 77 72 69 74 65 20 74 69 6d 65 20 22 0a ed write time ".
34d0: 09 09 09 09 28 69 66 20 28 65 71 3f 20 2a 6e 75 ....(if (eq? *nu
34e0: 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a 20 mber-of-writes*
34f0: 30 29 0a 09 09 09 09 20 20 20 20 22 6e 2f 61 20 0)..... "n/a
3500: 28 6e 6f 20 77 72 69 74 65 73 29 22 0a 09 09 09 (no writes)"....
3510: 09 20 20 20 20 28 2f 20 2a 77 72 69 74 65 73 2d . (/ *writes-
3520: 74 6f 74 61 6c 2d 64 65 6c 61 79 2a 0a 09 09 09 total-delay*....
3530: 09 20 20 20 20 20 20 20 2a 6e 75 6d 62 65 72 2d . *number-
3540: 6f 66 2d 77 72 69 74 65 73 2a 29 29 0a 09 09 09 of-writes*))....
3550: 09 22 20 6d 73 22 29 0a 09 20 20 20 20 20 20 28 ." ms").. (
3560: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
3570: 20 30 20 22 4e 75 6d 62 65 72 20 6e 6f 6e 2d 63 0 "Number non-c
3580: 61 63 68 65 64 20 71 75 65 72 69 65 73 20 22 20 ached queries "
3590: 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 *number-non-wri
35a0: 74 65 2d 71 75 65 72 69 65 73 2a 29 0a 09 20 20 te-queries*)..
35b0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
35c0: 2d 69 6e 66 6f 20 30 20 22 41 76 65 72 61 67 65 -info 0 "Average
35d0: 20 6e 6f 6e 2d 63 61 63 68 65 64 20 74 69 6d 65 non-cached time
35e0: 20 20 20 22 0a 09 09 09 09 28 69 66 20 28 65 71 ".....(if (eq
35f0: 3f 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 ? *number-non-wr
3600: 69 74 65 2d 71 75 65 72 69 65 73 2a 20 30 29 0a ite-queries* 0).
3610: 09 09 09 09 20 20 20 20 22 6e 2f 61 20 28 6e 6f .... "n/a (no
3620: 20 71 75 65 72 69 65 73 29 22 0a 09 09 09 09 20 queries)".....
3630: 20 20 20 28 2f 20 2a 74 6f 74 61 6c 2d 6e 6f 6e (/ *total-non
3640: 2d 77 72 69 74 65 2d 64 65 6c 61 79 2a 20 0a 09 -write-delay* ..
3650: 09 09 09 20 20 20 20 20 20 20 2a 6e 75 6d 62 65 ... *numbe
3660: 72 2d 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 r-non-write-quer
3670: 69 65 73 2a 29 29 0a 09 09 09 09 22 20 6d 73 22 ies*))....." ms"
3680: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3690: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
36a0: 6f 20 30 20 22 53 65 72 76 65 72 20 73 68 75 74 o 0 "Server shut
36b0: 64 6f 77 6e 20 63 6f 6d 70 6c 65 74 65 2e 20 45 down complete. E
36c0: 78 69 74 69 6e 67 22 29 0a 20 20 20 20 20 20 20 xiting").
36d0: 20 20 20 20 20 20 20 28 65 78 69 74 29 29 29 29 (exit))))
36e0: 29 29 29 0a 0a 3b 3b 20 61 6c 6c 20 72 6f 75 74 )))..;; all rout
36f0: 65 73 20 74 68 6f 75 67 68 20 68 65 72 65 20 65 es though here e
3700: 6e 64 20 69 6e 20 65 78 69 74 20 2e 2e 2e 0a 28 nd in exit ....(
3710: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
3720: 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 29 0a 20 nsport:launch).
3730: 20 28 69 66 20 28 6e 6f 74 20 2a 74 6f 70 70 61 (if (not *toppa
3740: 74 68 2a 29 0a 20 20 20 20 20 20 28 69 66 20 28 th*). (if (
3750: 6e 6f 74 20 28 73 65 74 75 70 2d 66 6f 72 2d 72 not (setup-for-r
3760: 75 6e 29 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 un)).. (begin..
3770: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
3780: 20 30 20 22 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 0 "ERROR: canno
3790: 74 20 66 69 6e 64 20 6d 65 67 61 74 65 73 74 2e t find megatest.
37a0: 63 6f 6e 66 69 67 2c 20 65 78 69 74 69 6e 67 22 config, exiting"
37b0: 29 0a 09 20 20 20 20 28 65 78 69 74 29 29 29 29 ).. (exit))))
37c0: 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
37d0: 69 6e 66 6f 20 32 20 22 53 74 61 72 74 69 6e 67 info 2 "Starting
37e0: 20 74 68 65 20 73 74 61 6e 64 61 6c 6f 6e 65 20 the standalone
37f0: 73 65 72 76 65 72 22 29 0a 20 20 28 69 66 20 28 server"). (if (
3800: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 64 args:get-arg "-d
3810: 61 65 6d 6f 6e 69 7a 65 22 29 0a 20 20 20 20 20 aemonize").
3820: 20 28 64 61 65 6d 6f 6e 3a 69 7a 65 29 29 0a 20 (daemon:ize)).
3830: 20 28 6c 65 74 20 28 28 68 6f 73 74 69 6e 66 6f (let ((hostinfo
3840: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
3850: 20 74 61 73 6b 73 3a 67 65 74 2d 62 65 73 74 2d tasks:get-best-
3860: 73 65 72 76 65 72 20 74 61 73 6b 73 3a 6f 70 65 server tasks:ope
3870: 6e 2d 64 62 29 29 29 0a 20 20 20 20 28 64 65 62 n-db))). (deb
3880: 75 67 3a 70 72 69 6e 74 20 31 31 20 22 68 74 74 ug:print 11 "htt
3890: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e p-transport:laun
38a0: 63 68 20 68 6f 73 74 69 6e 66 6f 3d 22 20 68 6f ch hostinfo=" ho
38b0: 73 74 69 6e 66 6f 29 0a 20 20 20 20 3b 3b 20 23 stinfo). ;; #
38c0: 28 31 20 22 31 34 33 2e 31 38 32 2e 32 30 37 2e (1 "143.182.207.
38d0: 32 34 22 20 35 37 33 36 20 2d 31 20 22 68 74 74 24" 5736 -1 "htt
38e0: 70 22 20 32 32 37 37 31 20 22 68 6f 73 74 6e 61 p" 22771 "hostna
38f0: 6d 65 22 29 0a 20 20 20 20 28 69 66 20 68 6f 73 me"). (if hos
3900: 74 69 6e 66 6f 0a 09 28 64 65 62 75 67 3a 70 72 tinfo..(debug:pr
3910: 69 6e 74 2d 69 6e 66 6f 20 32 20 22 4e 4f 54 20 int-info 2 "NOT
3920: 73 74 61 72 74 69 6e 67 20 6e 65 77 20 73 65 72 starting new ser
3930: 76 65 72 2c 20 6f 6e 65 20 69 73 20 61 6c 72 65 ver, one is alre
3940: 61 64 79 20 72 75 6e 6e 69 6e 67 20 6f 6e 20 22 ady running on "
3950: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 68 6f 73 (vector-ref hos
3960: 74 69 6e 66 6f 20 31 29 20 22 3a 22 20 28 76 65 tinfo 1) ":" (ve
3970: 63 74 6f 72 2d 72 65 66 20 68 6f 73 74 69 6e 66 ctor-ref hostinf
3980: 6f 20 32 29 29 0a 09 28 69 66 20 2a 74 6f 70 70 o 2))..(if *topp
3990: 61 74 68 2a 20 0a 09 20 20 20 20 28 6c 65 74 2a ath* .. (let*
39a0: 20 28 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 ((th2 (make-thr
39b0: 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 ead (lambda ()..
39c0: 09 09 09 20 20 20 20 20 20 20 28 68 74 74 70 2d ... (http-
39d0: 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 20 0a 09 transport:run ..
39e0: 09 09 09 09 28 69 66 20 28 61 72 67 73 3a 67 65 ....(if (args:ge
39f0: 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 t-arg "-server")
3a00: 0a 09 09 09 09 09 20 20 20 20 28 61 72 67 73 3a ...... (args:
3a10: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
3a20: 22 29 0a 09 09 09 09 09 20 20 20 20 22 2d 22 29 ")...... "-")
3a30: 29 29 20 22 53 65 72 76 65 72 20 72 75 6e 22 29 )) "Server run")
3a40: 29 0a 09 09 20 20 20 28 74 68 33 20 28 6d 61 6b )... (th3 (mak
3a50: 65 2d 74 68 72 65 61 64 20 68 74 74 70 2d 74 72 e-thread http-tr
3a60: 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 6e ansport:keep-run
3a70: 6e 69 6e 67 20 22 4b 65 65 70 20 72 75 6e 6e 69 ning "Keep runni
3a80: 6e 67 22 29 29 0a 09 09 20 20 20 28 74 68 31 20 ng"))... (th1
3a90: 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 73 65 72 (make-thread ser
3aa0: 76 65 72 3a 77 72 69 74 65 2d 71 75 65 75 65 2d ver:write-queue-
3ab0: 68 61 6e 64 6c 65 72 20 20 22 77 72 69 74 65 20 handler "write
3ac0: 71 75 65 75 65 22 29 29 29 0a 09 20 20 20 20 20 queue")))..
3ad0: 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 (thread-start!
3ae0: 74 68 32 29 0a 09 20 20 20 20 20 20 28 74 68 72 th2).. (thr
3af0: 65 61 64 2d 73 74 61 72 74 21 20 74 68 33 29 0a ead-start! th3).
3b00: 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
3b10: 74 61 72 74 21 20 74 68 31 29 0a 09 20 20 20 20 tart! th1)..
3b20: 20 20 28 73 65 74 21 20 2a 64 69 64 73 6f 6d 65 (set! *didsome
3b30: 74 68 69 6e 67 2a 20 23 74 29 0a 09 20 20 20 20 thing* #t)..
3b40: 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 (thread-join!
3b50: 74 68 32 29 29 0a 09 20 20 20 20 28 64 65 62 75 th2)).. (debu
3b60: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
3b70: 3a 20 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 : Failed to setu
3b80: 70 20 66 6f 72 20 6d 65 67 61 74 65 73 74 22 29 p for megatest")
3b90: 29 29 0a 20 20 20 20 28 65 78 69 74 29 29 29 0a )). (exit))).
3ba0: 0a 3b 3b 20 28 75 73 65 20 74 72 61 63 65 29 0a .;; (use trace).
3bb0: 3b 3b 20 28 74 72 61 63 65 20 68 74 74 70 2d 74 ;; (trace http-t
3bc0: 72 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 ransport:keep-ru
3bd0: 6e 6e 69 6e 67 20 0a 3b 3b 20 20 20 20 20 20 20 nning .;;
3be0: 20 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 75 70 tasks:server-up
3bf0: 64 61 74 65 2d 68 65 61 72 74 62 65 61 74 0a 3b date-heartbeat.;
3c00: 3b 20 20 20 20 20 20 20 20 74 61 73 6b 73 3a 73 ; tasks:s
3c10: 65 72 76 65 72 2d 67 65 74 2d 73 65 72 76 65 72 erver-get-server
3c20: 2d 69 64 29 0a 3b 3b 20 20 20 20 20 20 20 20 74 -id).;; t
3c30: 61 73 6b 73 3a 67 65 74 2d 62 65 73 74 2d 73 65 asks:get-best-se
3c40: 72 76 65 72 0a 3b 3b 20 20 20 20 20 20 20 20 68 rver.;; h
3c50: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 ttp-transport:ru
3c60: 6e 0a 3b 3b 20 20 20 20 20 20 20 20 68 74 74 70 n.;; http
3c70: 2d 74 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 -transport:launc
3c80: 68 0a 3b 3b 20 20 20 20 20 20 20 20 68 74 74 70 h.;; http
3c90: 2d 74 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 -transport:try-s
3ca0: 74 61 72 74 2d 73 65 72 76 65 72 0a 3b 3b 20 20 tart-server.;;
3cb0: 20 20 20 20 20 20 68 74 74 70 2d 74 72 61 6e 73 http-trans
3cc0: 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 73 65 6e 64 port:client-send
3cd0: 2d 72 65 63 65 69 76 65 0a 3b 3b 20 20 20 20 20 -receive.;;
3ce0: 20 20 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 http-transpor
3cf0: 74 3a 6d 61 6b 65 2d 73 65 72 76 65 72 2d 75 72 t:make-server-ur
3d00: 6c 0a 3b 3b 20 20 20 20 20 20 20 20 74 61 73 6b l.;; task
3d10: 73 3a 73 65 72 76 65 72 2d 72 65 67 69 73 74 65 s:server-registe
3d20: 72 0a 3b 3b 20 20 20 20 20 20 20 20 74 61 73 6b r.;; task
3d30: 73 3a 73 65 72 76 65 72 2d 64 65 6c 65 74 65 0a s:server-delete.
3d40: 3b 3b 20 20 20 20 20 20 20 20 73 74 61 72 74 2d ;; start-
3d50: 73 65 72 76 65 72 0a 3b 3b 20 20 20 20 20 20 20 server.;;
3d60: 20 68 6f 73 74 6e 61 6d 65 2d 3e 69 70 0a 3b 3b hostname->ip.;;
3d70: 20 20 20 20 20 20 20 20 77 69 74 68 2d 69 6e 70 with-inp
3d80: 75 74 2d 66 72 6f 6d 2d 72 65 71 75 65 73 74 0a ut-from-request.
3d90: 3b 3b 20 20 20 20 20 20 20 20 74 61 73 6b 73 3a ;; tasks:
3da0: 73 65 72 76 65 72 2d 64 65 72 65 67 69 73 74 65 server-deregiste
3db0: 72 2d 73 65 6c 66 29 0a 0a 28 64 65 66 69 6e 65 r-self)..(define
3dc0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
3dd0: 3a 73 65 72 76 65 72 2d 73 69 67 6e 61 6c 2d 68 :server-signal-h
3de0: 61 6e 64 6c 65 72 20 73 69 67 6e 75 6d 29 0a 20 andler signum).
3df0: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
3e00: 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 64 ons. exn. (d
3e10: 65 62 75 67 3a 70 72 69 6e 74 20 22 20 2e 2e 2e ebug:print " ...
3e20: 20 65 78 69 74 69 6e 67 20 2e 2e 2e 22 29 0a 20 exiting ...").
3e30: 20 20 28 6c 65 74 20 28 28 74 68 31 20 28 6d 61 (let ((th1 (ma
3e40: 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 ke-thread (lambd
3e50: 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 74 68 a ().... (th
3e60: 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 29 0a read-sleep! 1)).
3e70: 09 09 09 20 20 20 20 20 3b 3b 20 28 69 66 20 28 ... ;; (if (
3e80: 6e 6f 74 20 2a 72 65 63 65 69 76 65 64 2d 72 65 not *received-re
3e90: 73 70 6f 6e 73 65 2a 29 0a 09 09 09 20 20 20 20 sponse*)....
3ea0: 20 3b 3b 09 20 28 72 65 63 65 69 76 65 2d 6d 65 ;;. (receive-me
3eb0: 73 73 61 67 65 2a 20 2a 72 75 6e 72 65 6d 6f 74 ssage* *runremot
3ec0: 65 2a 29 29 29 20 3b 3b 20 66 6c 75 73 68 20 6f e*))) ;; flush o
3ed0: 75 74 20 6c 61 73 74 20 63 61 6c 6c 20 69 66 20 ut last call if
3ee0: 61 70 70 6c 69 63 61 62 6c 65 0a 09 09 09 20 20 applicable....
3ef0: 20 22 65 61 74 20 72 65 73 70 6f 6e 73 65 22 29 "eat response")
3f00: 29 0a 09 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 ).. (th2 (make-t
3f10: 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 hread (lambda ()
3f20: 0a 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a .... (debug:
3f30: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
3f40: 52 65 63 65 69 76 65 64 20 5e 43 2c 20 61 74 74 Received ^C, att
3f50: 65 6d 70 74 69 6e 67 20 63 6c 65 61 6e 20 65 78 empting clean ex
3f60: 69 74 2e 20 50 6c 65 61 73 65 20 62 65 20 70 61 it. Please be pa
3f70: 74 69 65 6e 74 20 61 6e 64 20 77 61 69 74 20 61 tient and wait a
3f80: 20 66 65 77 20 73 65 63 6f 6e 64 73 20 62 65 66 few seconds bef
3f90: 6f 72 65 20 68 69 74 74 69 6e 67 20 5e 43 20 61 ore hitting ^C a
3fa0: 67 61 69 6e 2e 22 29 0a 09 09 09 20 20 20 20 20 gain.")....
3fb0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 33 (thread-sleep! 3
3fc0: 29 20 3b 3b 20 67 69 76 65 20 74 68 65 20 66 6c ) ;; give the fl
3fd0: 75 73 68 20 74 68 72 65 65 20 73 65 63 6f 6e 64 ush three second
3fe0: 73 20 74 6f 20 64 6f 20 69 74 27 73 20 73 74 75 s to do it's stu
3ff0: 66 66 0a 09 09 09 20 20 20 20 20 28 64 65 62 75 ff.... (debu
4000: 67 3a 70 72 69 6e 74 20 30 20 22 20 20 20 20 20 g:print 0 "
4010: 20 20 44 6f 6e 65 2e 22 29 0a 09 09 09 20 20 20 Done.")....
4020: 20 20 28 65 78 69 74 20 34 29 29 0a 09 09 09 20 (exit 4))....
4030: 20 20 22 65 78 69 74 20 6f 6e 20 5e 43 20 74 69 "exit on ^C ti
4040: 6d 65 72 22 29 29 29 0a 20 20 20 20 20 28 74 68 mer"))). (th
4050: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 read-start! th2)
4060: 0a 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 . (thread-st
4070: 61 72 74 21 20 74 68 31 29 0a 20 20 20 20 20 28 art! th1). (
4080: 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 32 thread-join! th2
4090: 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
40a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
40b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
40c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
40d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
40e0: 3b 20 77 65 62 20 70 61 67 65 73 0a 3b 3b 3d 3d ; web pages.;;==
40f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4130: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 68 ====..(define (h
4140: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 6d 61 ttp-transport:ma
4150: 69 6e 2d 70 61 67 65 29 0a 20 20 28 6c 65 74 20 in-page). (let
4160: 28 28 6c 69 6e 6b 70 61 74 68 20 28 72 6f 6f 74 ((linkpath (root
4170: 2d 70 61 74 68 29 29 29 0a 20 20 20 20 28 63 6f -path))). (co
4180: 6e 63 20 22 3c 68 65 61 64 3e 3c 68 31 3e 22 20 nc "<head><h1>"
4190: 28 70 61 74 68 6e 61 6d 65 2d 73 74 72 69 70 2d (pathname-strip-
41a0: 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 directory *toppa
41b0: 74 68 2a 29 20 22 3c 2f 68 31 3e 3c 2f 68 65 61 th*) "</h1></hea
41c0: 64 3e 22 0a 09 20 20 22 3c 62 6f 64 79 3e 22 0a d>".. "<body>".
41d0: 09 20 20 22 52 75 6e 20 61 72 65 61 3a 20 22 20 . "Run area: "
41e0: 2a 74 6f 70 70 61 74 68 2a 0a 09 20 20 22 3c 68 *toppath*.. "<h
41f0: 32 3e 53 65 72 76 65 72 20 53 74 61 74 73 3c 2f 2>Server Stats</
4200: 68 32 3e 22 0a 09 20 20 28 68 74 74 70 2d 74 72 h2>".. (http-tr
4210: 61 6e 73 70 6f 72 74 3a 73 74 61 74 73 2d 74 61 ansport:stats-ta
4220: 62 6c 65 29 20 0a 09 20 20 22 3c 68 72 3e 22 0a ble) .. "<hr>".
4230: 09 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f . (http-transpo
4240: 72 74 3a 72 75 6e 73 20 6c 69 6e 6b 70 61 74 68 rt:runs linkpath
4250: 29 0a 09 20 20 22 3c 68 72 3e 22 0a 09 20 20 28 ).. "<hr>".. (
4260: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 72 http-transport:r
4270: 75 6e 2d 73 74 61 74 73 29 0a 09 20 20 22 3c 2f un-stats).. "</
4280: 62 6f 64 79 3e 22 0a 09 20 20 29 29 29 0a 0a 28 body>".. )))..(
4290: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
42a0: 6e 73 70 6f 72 74 3a 73 74 61 74 73 2d 74 61 62 nsport:stats-tab
42b0: 6c 65 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 le). (mutex-loc
42c0: 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 k! *heartbeat-mu
42d0: 74 65 78 2a 29 0a 20 20 28 6c 65 74 20 28 28 72 tex*). (let ((r
42e0: 65 73 20 0a 09 20 28 63 6f 6e 63 20 22 3c 74 61 es .. (conc "<ta
42f0: 62 6c 65 3e 22 0a 09 20 20 20 20 20 20 20 22 3c ble>".. "<
4300: 74 72 3e 3c 74 64 3e 4d 61 78 20 63 61 63 68 65 tr><td>Max cache
4310: 64 20 71 75 65 72 69 65 73 3c 2f 74 64 3e 20 20 d queries</td>
4320: 20 20 20 20 20 20 3c 74 64 3e 22 20 2a 6d 61 78 <td>" *max
4330: 2d 63 61 63 68 65 2d 73 69 7a 65 2a 20 22 3c 2f -cache-size* "</
4340: 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 td></tr>"..
4350: 20 20 22 3c 74 72 3e 3c 74 64 3e 4e 75 6d 62 65 "<tr><td>Numbe
4360: 72 20 6f 66 20 63 61 63 68 65 64 20 77 72 69 74 r of cached writ
4370: 65 73 3c 2f 74 64 3e 20 20 20 3c 74 64 3e 22 20 es</td> <td>"
4380: 2a 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 *number-of-write
4390: 73 2a 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 0a s* "</td></tr>".
43a0: 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 . "<tr><td
43b0: 3e 41 76 65 72 61 67 65 20 63 61 63 68 65 64 20 >Average cached
43c0: 77 72 69 74 65 20 74 69 6d 65 3c 2f 74 64 3e 20 write time</td>
43d0: 3c 74 64 3e 22 20 28 69 66 20 28 65 71 3f 20 2a <td>" (if (eq? *
43e0: 6e 75 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 number-of-writes
43f0: 2a 20 30 29 0a 09 09 09 09 09 09 09 09 20 22 6e * 0)......... "n
4400: 2f 61 20 28 6e 6f 20 77 72 69 74 65 73 29 22 0a /a (no writes)".
4410: 09 09 09 09 09 09 09 09 20 28 2f 20 2a 77 72 69 ........ (/ *wri
4420: 74 65 73 2d 74 6f 74 61 6c 2d 64 65 6c 61 79 2a tes-total-delay*
4430: 0a 09 09 09 09 09 09 09 09 20 20 20 20 2a 6e 75 ......... *nu
4440: 6d 62 65 72 2d 6f 66 2d 77 72 69 74 65 73 2a 29 mber-of-writes*)
4450: 29 0a 09 20 20 20 20 20 20 20 22 20 6d 73 3c 2f ).. " ms</
4460: 74 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 td></tr>"..
4470: 20 20 22 3c 74 72 3e 3c 74 64 3e 4e 75 6d 62 65 "<tr><td>Numbe
4480: 72 20 6e 6f 6e 2d 63 61 63 68 65 64 20 71 75 65 r non-cached que
4490: 72 69 65 73 3c 2f 74 64 3e 20 3c 74 64 3e 22 20 ries</td> <td>"
44a0: 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 72 69 *number-non-wri
44b0: 74 65 2d 71 75 65 72 69 65 73 2a 20 22 3c 2f 74 te-queries* "</t
44c0: 64 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 d></tr>"..
44d0: 20 22 3c 74 72 3e 3c 74 64 3e 41 76 65 72 61 67 "<tr><td>Averag
44e0: 65 20 6e 6f 6e 2d 63 61 63 68 65 64 20 74 69 6d e non-cached tim
44f0: 65 3c 2f 74 64 3e 20 20 20 3c 74 64 3e 22 20 28 e</td> <td>" (
4500: 69 66 20 28 65 71 3f 20 2a 6e 75 6d 62 65 72 2d if (eq? *number-
4510: 6e 6f 6e 2d 77 72 69 74 65 2d 71 75 65 72 69 65 non-write-querie
4520: 73 2a 20 30 29 0a 09 09 09 09 09 09 09 09 20 22 s* 0)......... "
4530: 6e 2f 61 20 28 6e 6f 20 71 75 65 72 69 65 73 29 n/a (no queries)
4540: 22 0a 09 09 09 09 09 09 09 09 20 28 2f 20 2a 74 "......... (/ *t
4550: 6f 74 61 6c 2d 6e 6f 6e 2d 77 72 69 74 65 2d 64 otal-non-write-d
4560: 65 6c 61 79 2a 20 0a 09 09 09 09 09 09 09 09 20 elay* .........
4570: 20 20 20 2a 6e 75 6d 62 65 72 2d 6e 6f 6e 2d 77 *number-non-w
4580: 72 69 74 65 2d 71 75 65 72 69 65 73 2a 29 29 0a rite-queries*)).
4590: 09 20 20 20 20 20 20 20 22 20 6d 73 3c 2f 74 64 . " ms</td
45a0: 3e 3c 2f 74 72 3e 22 0a 09 20 20 20 20 20 20 20 ></tr>"..
45b0: 22 3c 74 72 3e 3c 74 64 3e 4c 61 73 74 20 61 63 "<tr><td>Last ac
45c0: 63 65 73 73 3c 2f 74 64 3e 3c 74 64 3e 22 20 20 cess</td><td>"
45d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 63 (sec
45e0: 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e onds->time-strin
45f0: 67 20 2a 6c 61 73 74 2d 64 62 2d 61 63 63 65 73 g *last-db-acces
4600: 73 2a 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 s*) "</td></tr>"
4610: 0a 09 20 20 20 20 20 20 20 22 3c 2f 74 61 62 6c .. "</tabl
4620: 65 3e 22 29 29 29 0a 20 20 20 20 28 6d 75 74 65 e>"))). (mute
4630: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 x-unlock! *heart
4640: 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 beat-mutex*).
4650: 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 res))..(define
4660: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
4670: 72 75 6e 73 20 6c 69 6e 6b 70 61 74 68 29 0a 20 runs linkpath).
4680: 20 28 63 6f 6e 63 20 22 3c 68 33 3e 52 75 6e 73 (conc "<h3>Runs
4690: 3c 2f 68 33 3e 22 0a 09 28 73 74 72 69 6e 67 2d </h3>"..(string-
46a0: 69 6e 74 65 72 73 70 65 72 73 65 0a 09 20 28 6c intersperse.. (l
46b0: 65 74 20 28 28 66 69 6c 65 73 20 28 6d 61 70 20 et ((files (map
46c0: 70 61 74 68 6e 61 6d 65 2d 73 74 72 69 70 2d 64 pathname-strip-d
46d0: 69 72 65 63 74 6f 72 79 20 28 67 6c 6f 62 20 28 irectory (glob (
46e0: 63 6f 6e 63 20 6c 69 6e 6b 70 61 74 68 20 22 2f conc linkpath "/
46f0: 2a 22 29 29 29 29 29 0a 09 20 20 20 28 6d 61 70 *"))))).. (map
4700: 20 28 6c 61 6d 62 64 61 20 28 70 29 0a 09 09 20 (lambda (p)...
4710: 20 28 63 6f 6e 63 20 22 3c 61 20 68 72 65 66 3d (conc "<a href=
4720: 5c 22 22 20 70 20 22 5c 22 3e 22 20 70 20 22 3c \"" p "\">" p "<
4730: 2f 61 3e 3c 62 72 3e 22 29 29 0a 09 09 66 69 6c /a><br>"))...fil
4740: 65 73 29 29 0a 09 20 22 20 22 29 29 29 0a 0a 28 es)).. " ")))..(
4750: 64 65 66 69 6e 65 20 28 68 74 74 70 2d 74 72 61 define (http-tra
4760: 6e 73 70 6f 72 74 3a 72 75 6e 2d 73 74 61 74 73 nsport:run-stats
4770: 29 0a 20 20 28 6c 65 74 20 28 28 73 74 61 74 73 ). (let ((stats
4780: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
4790: 20 64 62 3a 67 65 74 2d 72 75 6e 6e 69 6e 67 2d db:get-running-
47a0: 73 74 61 74 73 20 23 66 29 29 29 0a 20 20 20 20 stats #f))).
47b0: 28 63 6f 6e 63 20 22 3c 74 61 62 6c 65 3e 22 0a (conc "<table>".
47c0: 09 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 . (string-inter
47d0: 73 70 65 72 73 65 0a 09 20 20 20 28 6d 61 70 20 sperse.. (map
47e0: 28 6c 61 6d 62 64 61 20 28 73 74 61 74 29 0a 09 (lambda (stat)..
47f0: 09 20 20 28 63 6f 6e 63 20 22 3c 74 72 3e 3c 74 . (conc "<tr><t
4800: 64 3e 22 20 28 63 61 72 20 73 74 61 74 29 20 22 d>" (car stat) "
4810: 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 63 61 64 72 </td><td>" (cadr
4820: 20 73 74 61 74 29 20 22 3c 2f 74 64 3e 3c 2f 74 stat) "</td></t
4830: 72 3e 22 29 29 0a 09 09 73 74 61 74 73 29 0a 09 r>"))...stats)..
4840: 20 20 20 22 20 22 29 0a 09 20 20 22 3c 2f 74 61 " ").. "</ta
4850: 62 6c 65 3e 22 29 29 29 ble>")))