Artifact 26ebbfd6a6769f1427a1044c8d6b9488bbf253e2:
- File http-transport.scm — part of check-in [aab3b2a0d7] at 2013-05-10 12:00:14 on branch v1.54 — Added very basic informative page to server (user: mrwellan size: 18520)
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>")))