Artifact
1ba0421ee52a4fd47e869d3888b49aa04a0155d1:
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: 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 rfi-1 posix rege
0190: 78 20 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 x regex-case srf
01a0: 69 2d 36 39 20 68 6f 73 74 69 6e 66 6f 20 6d 64 i-69 hostinfo md
01b0: 35 20 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 5 message-digest
01c0: 20 64 69 72 65 63 74 6f 72 79 2d 75 74 69 6c 73 directory-utils
01d0: 29 0a 3b 3b 20 28 75 73 65 20 7a 6d 71 29 0a 0a ).;; (use zmq)..
01e0: 28 75 73 65 20 73 70 69 66 66 79 20 75 72 69 2d (use spiffy uri-
01f0: 63 6f 6d 6d 6f 6e 20 69 6e 74 61 72 77 65 62 20 common intarweb
0200: 68 74 74 70 2d 63 6c 69 65 6e 74 20 73 70 69 66 http-client spif
0210: 66 79 2d 72 65 71 75 65 73 74 2d 76 61 72 73 29 fy-request-vars)
0220: 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 ..(declare (unit
0230: 20 73 65 72 76 65 72 29 29 0a 0a 28 64 65 63 6c server))..(decl
0240: 61 72 65 20 28 75 73 65 73 20 63 6f 6d 6d 6f 6e are (uses common
0250: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0260: 73 20 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 s db)).(declare
0270: 28 75 73 65 73 20 74 61 73 6b 73 29 29 20 3b 3b (uses tasks)) ;;
0280: 20 74 61 73 6b 73 20 61 72 65 20 77 68 65 72 65 tasks are where
0290: 20 73 74 75 66 66 20 69 73 20 6d 61 69 6e 74 61 stuff is mainta
02a0: 69 6e 65 64 20 61 62 6f 75 74 20 77 68 61 74 20 ined about what
02b0: 69 73 20 72 75 6e 6e 69 6e 67 2e 0a 28 64 65 63 is running..(dec
02c0: 6c 61 72 65 20 28 75 73 65 73 20 73 79 6e 63 68 lare (uses synch
02d0: 61 73 68 29 29 0a 28 64 65 63 6c 61 72 65 20 28 ash)).(declare (
02e0: 75 73 65 73 20 68 74 74 70 2d 74 72 61 6e 73 70 uses http-transp
02f0: 6f 72 74 29 29 0a 28 64 65 63 6c 61 72 65 20 28 ort)).(declare (
0300: 75 73 65 73 20 72 70 63 2d 74 72 61 6e 73 70 6f uses rpc-transpo
0310: 72 74 29 29 0a 3b 3b 28 64 65 63 6c 61 72 65 20 rt)).;;(declare
0320: 28 75 73 65 73 20 6e 6d 73 67 2d 74 72 61 6e 73 (uses nmsg-trans
0330: 70 6f 72 74 29 29 0a 28 64 65 63 6c 61 72 65 20 port)).(declare
0340: 28 75 73 65 73 20 6c 61 75 6e 63 68 29 29 0a 28 (uses launch)).(
0350: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 61 declare (uses da
0360: 65 6d 6f 6e 29 29 0a 0a 28 69 6e 63 6c 75 64 65 emon))..(include
0370: 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 "common_records
0380: 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 .scm").(include
0390: 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 "db_records.scm"
03a0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 )..(define (serv
03b0: 65 72 3a 6d 61 6b 65 2d 73 65 72 76 65 72 2d 75 er:make-server-u
03c0: 72 6c 20 68 6f 73 74 70 6f 72 74 29 0a 20 20 28 rl hostport). (
03d0: 69 66 20 28 6e 6f 74 20 68 6f 73 74 70 6f 72 74 if (not hostport
03e0: 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 ). #f.
03f0: 20 28 63 6f 6e 63 20 22 68 74 74 70 3a 2f 2f 22 (conc "http://"
0400: 20 28 63 61 72 20 68 6f 73 74 70 6f 72 74 29 20 (car hostport)
0410: 22 3a 22 20 28 63 61 64 72 20 68 6f 73 74 70 6f ":" (cadr hostpo
0420: 72 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 rt))))..(define
0430: 20 2a 73 65 72 76 65 72 2d 6c 6f 6f 70 2d 68 65 *server-loop-he
0440: 61 72 74 2d 62 65 61 74 2a 20 28 63 75 72 72 65 art-beat* (curre
0450: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 28 64 65 nt-seconds)).(de
0460: 66 69 6e 65 20 2a 68 65 61 72 74 62 65 61 74 2d fine *heartbeat-
0470: 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 mutex* (make-mut
0480: 65 78 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ex))..;;========
0490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
04d0: 3b 20 53 20 45 20 52 20 56 20 45 20 52 0a 3b 3b ; S E R V E R.;;
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0520: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 43 61 6c 6c 20 ======..;; Call
0530: 74 68 69 73 20 74 6f 20 73 74 61 72 74 20 74 68 this to start th
0540: 65 20 61 63 74 75 61 6c 20 73 65 72 76 65 72 0a e actual server.
0550: 3b 3b 0a 0a 3b 3b 20 61 6c 6c 20 72 6f 75 74 65 ;;..;; all route
0560: 73 20 74 68 6f 75 67 68 20 68 65 72 65 20 65 6e s though here en
0570: 64 20 69 6e 20 65 78 69 74 20 2e 2e 2e 0a 3b 3b d in exit ....;;
0580: 0a 3b 3b 20 73 74 61 72 74 5f 73 65 72 76 65 72 .;; start_server
0590: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 72 .;;.(define (ser
05a0: 76 65 72 3a 6c 61 75 6e 63 68 20 72 75 6e 2d 69 ver:launch run-i
05b0: 64 29 0a 20 20 28 63 61 73 65 20 2a 74 72 61 6e d). (case *tran
05c0: 73 70 6f 72 74 2d 74 79 70 65 2a 0a 20 20 20 20 sport-type*.
05d0: 28 28 68 74 74 70 29 28 68 74 74 70 2d 74 72 61 ((http)(http-tra
05e0: 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 20 72 75 nsport:launch ru
05f0: 6e 2d 69 64 29 29 0a 20 20 20 20 3b 3b 28 28 6e n-id)). ;;((n
0600: 6d 73 67 29 28 6e 6d 73 67 2d 74 72 61 6e 73 70 msg)(nmsg-transp
0610: 6f 72 74 3a 6c 61 75 6e 63 68 20 72 75 6e 2d 69 ort:launch run-i
0620: 64 29 29 0a 20 20 20 20 28 28 72 70 63 29 20 20 d)). ((rpc)
0630: 28 72 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a 6c (rpc-transport:l
0640: 61 75 6e 63 68 20 72 75 6e 2d 69 64 29 29 0a 20 aunch run-id)).
0650: 20 20 20 28 65 6c 73 65 20 28 64 65 62 75 67 3a (else (debug:
0660: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
0670: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
0680: 20 22 75 6e 6b 6e 6f 77 6e 20 73 65 72 76 65 72 "unknown server
0690: 20 74 79 70 65 20 22 20 2a 74 72 61 6e 73 70 6f type " *transpo
06a0: 72 74 2d 74 79 70 65 2a 29 29 29 29 0a 3b 3b 20 rt-type*)))).;;
06b0: 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 28 64 (else (d
06c0: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
06d0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
06e0: 70 6f 72 74 2a 20 22 4e 6f 20 6b 6e 6f 77 6e 20 port* "No known
06f0: 74 72 61 6e 73 70 6f 72 74 20 73 65 74 2c 20 74 transport set, t
0700: 72 61 6e 73 70 6f 72 74 3d 22 20 74 72 61 6e 73 ransport=" trans
0710: 70 6f 72 74 20 22 2c 20 75 73 69 6e 67 20 72 70 port ", using rp
0720: 63 22 29 0a 3b 3b 20 09 20 20 20 20 20 20 28 72 c").;; . (r
0730: 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a 6c 61 75 pc-transport:lau
0740: 6e 63 68 20 72 75 6e 2d 69 64 29 29 29 29 29 0a nch run-id))))).
0750: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
0760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 =========.;; S E
07a0: 20 52 20 56 20 45 20 52 20 20 20 55 20 54 20 49 R V E R U T I
07b0: 20 4c 20 49 20 54 20 49 20 45 20 53 20 0a 3b 3b L I T I E S .;;
07c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0800: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 74 20 74 ======..;; Get t
0810: 68 65 20 74 72 61 6e 73 70 6f 72 74 0a 28 64 65 he transport.(de
0820: 66 69 6e 65 20 28 73 65 72 76 65 72 3a 67 65 74 fine (server:get
0830: 2d 74 72 61 6e 73 70 6f 72 74 29 0a 20 20 28 69 -transport). (i
0840: 66 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 f *transport-typ
0850: 65 2a 0a 20 20 20 20 20 20 2a 74 72 61 6e 73 70 e*. *transp
0860: 6f 72 74 2d 74 79 70 65 2a 0a 20 20 20 20 20 20 ort-type*.
0870: 28 6c 65 74 20 28 28 74 74 79 70 65 20 28 73 74 (let ((ttype (st
0880: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 0a 09 09 20 ring->symbol...
0890: 20 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 (or (args:get
08a0: 2d 61 72 67 20 22 2d 74 72 61 6e 73 70 6f 72 74 -arg "-transport
08b0: 22 29 0a 09 09 09 28 63 6f 6e 66 69 67 66 3a 6c ")....(configf:l
08c0: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
08d0: 2a 20 22 73 65 72 76 65 72 22 20 22 74 72 61 6e * "server" "tran
08e0: 73 70 6f 72 74 22 29 0a 09 09 09 22 72 70 63 22 sport")...."rpc"
08f0: 29 29 29 29 0a 09 28 73 65 74 21 20 2a 74 72 61 ))))..(set! *tra
0900: 6e 73 70 6f 72 74 2d 74 79 70 65 2a 20 74 74 79 nsport-type* tty
0910: 70 65 29 0a 09 74 74 79 70 65 29 29 29 0a 09 20 pe)..ttype)))..
0920: 20 20 20 0a 3b 3b 20 47 65 6e 65 72 61 74 65 20 .;; Generate
0930: 61 20 75 6e 69 71 75 65 20 73 69 67 6e 61 74 75 a unique signatu
0940: 72 65 20 66 6f 72 20 74 68 69 73 20 73 65 72 76 re for this serv
0950: 65 72 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 er.(define (serv
0960: 65 72 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 er:mk-signature)
0970: 0a 20 20 28 6d 65 73 73 61 67 65 2d 64 69 67 65 . (message-dige
0980: 73 74 2d 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 st-string (md5-p
0990: 72 69 6d 69 74 69 76 65 29 20 0a 09 09 09 20 28 rimitive) .... (
09a0: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 with-output-to-s
09b0: 74 72 69 6e 67 0a 09 09 09 20 20 20 28 6c 61 6d tring.... (lam
09c0: 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 bda ().... (
09d0: 77 72 69 74 65 20 28 6c 69 73 74 20 28 63 75 72 write (list (cur
09e0: 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 0a rent-directory).
09f0: 09 09 09 09 09 20 20 28 61 72 67 76 29 29 29 29 ..... (argv))))
0a00: 29 29 29 0a 0a 3b 3b 20 57 68 65 6e 20 75 73 69 )))..;; When usi
0a10: 6e 67 20 7a 6d 71 20 74 68 69 73 20 77 6f 75 6c ng zmq this woul
0a20: 64 20 73 65 6e 64 20 74 68 65 20 6d 65 73 73 61 d send the messa
0a30: 67 65 20 62 61 63 6b 20 28 74 77 6f 20 73 74 65 ge back (two ste
0a40: 70 20 70 72 6f 63 65 73 73 29 0a 3b 3b 20 77 69 p process).;; wi
0a50: 74 68 20 73 70 69 66 66 79 20 6f 72 20 72 70 63 th spiffy or rpc
0a60: 20 74 68 69 73 20 73 69 6d 70 6c 79 20 72 65 74 this simply ret
0a70: 75 72 6e 73 20 74 68 65 20 72 65 74 75 72 6e 20 urns the return
0a80: 64 61 74 61 20 74 6f 20 62 65 20 72 65 74 75 72 data to be retur
0a90: 6e 65 64 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 ned.;; .(define
0aa0: 28 73 65 72 76 65 72 3a 72 65 70 6c 79 20 72 65 (server:reply re
0ab0: 74 75 72 6e 2d 61 64 64 72 20 71 75 65 72 79 2d turn-addr query-
0ac0: 73 69 67 20 73 75 63 63 65 73 73 2f 66 61 69 6c sig success/fail
0ad0: 20 72 65 73 75 6c 74 29 0a 20 20 28 64 65 62 75 result). (debu
0ae0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 31 20 g:print-info 11
0af0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
0b00: 74 2a 20 22 73 65 72 76 65 72 3a 72 65 70 6c 79 t* "server:reply
0b10: 20 72 65 74 75 72 6e 2d 61 64 64 72 3d 22 20 72 return-addr=" r
0b20: 65 74 75 72 6e 2d 61 64 64 72 20 22 2c 20 72 65 eturn-addr ", re
0b30: 73 75 6c 74 3d 22 20 72 65 73 75 6c 74 29 0a 20 sult=" result).
0b40: 20 3b 3b 20 28 73 65 6e 64 2d 6d 65 73 73 61 67 ;; (send-messag
0b50: 65 20 70 75 62 73 6f 63 6b 20 74 61 72 67 65 74 e pubsock target
0b60: 20 73 65 6e 64 2d 6d 6f 72 65 3a 20 23 74 29 0a send-more: #t).
0b70: 20 20 3b 3b 20 28 73 65 6e 64 2d 6d 65 73 73 61 ;; (send-messa
0b80: 67 65 20 70 75 62 73 6f 63 6b 20 0a 20 20 28 63 ge pubsock . (c
0b90: 61 73 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d ase (server:get-
0ba0: 74 72 61 6e 73 70 6f 72 74 29 0a 20 20 20 20 28 transport). (
0bb0: 28 72 70 63 29 20 20 28 64 62 3a 6f 62 6a 2d 3e (rpc) (db:obj->
0bc0: 73 74 72 69 6e 67 20 28 76 65 63 74 6f 72 20 73 string (vector s
0bd0: 75 63 63 65 73 73 2f 66 61 69 6c 20 71 75 65 72 uccess/fail quer
0be0: 79 2d 73 69 67 20 72 65 73 75 6c 74 29 29 29 0a y-sig result))).
0bf0: 20 20 20 20 28 28 68 74 74 70 29 20 28 64 62 3a ((http) (db:
0c00: 6f 62 6a 2d 3e 73 74 72 69 6e 67 20 28 76 65 63 obj->string (vec
0c10: 74 6f 72 20 73 75 63 63 65 73 73 2f 66 61 69 6c tor success/fail
0c20: 20 71 75 65 72 79 2d 73 69 67 20 72 65 73 75 6c query-sig resul
0c30: 74 29 29 29 0a 20 20 20 20 28 28 7a 6d 71 29 0a t))). ((zmq).
0c40: 20 20 20 20 20 28 6c 65 74 20 28 28 70 75 62 2d (let ((pub-
0c50: 73 6f 63 6b 65 74 20 28 76 65 63 74 6f 72 2d 72 socket (vector-r
0c60: 65 66 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 31 ef *runremote* 1
0c70: 29 29 29 0a 20 20 20 20 20 20 20 28 73 65 6e 64 ))). (send
0c80: 2d 6d 65 73 73 61 67 65 20 70 75 62 2d 73 6f 63 -message pub-soc
0c90: 6b 65 74 20 72 65 74 75 72 6e 2d 61 64 64 72 20 ket return-addr
0ca0: 73 65 6e 64 2d 6d 6f 72 65 3a 20 23 74 29 0a 20 send-more: #t).
0cb0: 20 20 20 20 20 20 28 73 65 6e 64 2d 6d 65 73 73 (send-mess
0cc0: 61 67 65 20 70 75 62 2d 73 6f 63 6b 65 74 20 28 age pub-socket (
0cd0: 64 62 3a 6f 62 6a 2d 3e 73 74 72 69 6e 67 20 28 db:obj->string (
0ce0: 76 65 63 74 6f 72 20 73 75 63 63 65 73 73 2f 66 vector success/f
0cf0: 61 69 6c 20 71 75 65 72 79 2d 73 69 67 20 72 65 ail query-sig re
0d00: 73 75 6c 74 29 29 29 29 29 0a 20 20 20 20 28 28 sult))))). ((
0d10: 66 73 29 20 20 20 72 65 73 75 6c 74 29 0a 20 20 fs) result).
0d20: 20 20 28 65 6c 73 65 20 0a 20 20 20 20 20 28 64 (else . (d
0d30: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
0d40: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
0d50: 70 6f 72 74 2a 20 22 75 6e 72 65 63 6f 67 6e 69 port* "unrecogni
0d60: 73 65 64 20 74 72 61 6e 73 70 6f 72 74 20 74 79 sed transport ty
0d70: 70 65 3a 20 22 20 2a 74 72 61 6e 73 70 6f 72 74 pe: " *transport
0d80: 2d 74 79 70 65 2a 29 0a 20 20 20 20 20 72 65 73 -type*). res
0d90: 75 6c 74 29 29 29 0a 0a 3b 3b 20 47 69 76 65 6e ult)))..;; Given
0da0: 20 61 20 72 75 6e 20 69 64 20 73 74 61 72 74 20 a run id start
0db0: 61 20 73 65 72 76 65 72 20 70 72 6f 63 65 73 73 a server process
0dc0: 20 20 20 20 23 23 23 20 4e 4f 54 45 20 23 23 23 ### NOTE ###
0dd0: 20 3e 20 66 69 6c 65 20 32 3e 26 31 20 0a 3b 3b > file 2>&1 .;;
0de0: 20 69 66 20 74 68 65 20 72 75 6e 2d 69 64 20 69 if the run-id i
0df0: 73 20 7a 65 72 6f 20 61 6e 64 20 74 68 65 20 74 s zero and the t
0e00: 61 72 67 65 74 2d 68 6f 73 74 20 69 73 20 73 65 arget-host is se
0e10: 74 20 0a 3b 3b 20 74 72 79 20 72 75 6e 6e 69 6e t .;; try runnin
0e20: 67 20 6f 6e 20 74 68 61 74 20 68 6f 73 74 0a 3b g on that host.;
0e30: 3b 0a 28 64 65 66 69 6e 65 20 20 28 73 65 72 76 ;.(define (serv
0e40: 65 72 3a 72 75 6e 20 72 75 6e 2d 69 64 29 0a 20 er:run run-id).
0e50: 20 28 6c 65 74 2a 20 28 28 63 75 72 72 2d 68 6f (let* ((curr-ho
0e60: 73 74 20 20 20 28 67 65 74 2d 68 6f 73 74 2d 6e st (get-host-n
0e70: 61 6d 65 29 29 0a 09 20 28 63 75 72 72 2d 69 70 ame)).. (curr-ip
0e80: 20 20 20 20 20 28 73 65 72 76 65 72 3a 67 65 74 (server:get
0e90: 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 -best-guess-addr
0ea0: 65 73 73 20 63 75 72 72 2d 68 6f 73 74 29 29 0a ess curr-host)).
0eb0: 09 20 28 74 61 72 67 65 74 2d 68 6f 73 74 20 28 . (target-host (
0ec0: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
0ed0: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 configdat* "serv
0ee0: 65 72 22 20 22 68 6f 6d 65 68 6f 73 74 22 20 29 er" "homehost" )
0ef0: 29 0a 09 20 28 74 65 73 74 73 75 69 74 65 20 20 ).. (testsuite
0f00: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 (common:get-tes
0f10: 74 73 75 69 74 65 2d 6e 61 6d 65 29 29 0a 09 20 tsuite-name))..
0f20: 28 6c 6f 67 66 69 6c 65 20 20 20 20 20 28 63 6f (logfile (co
0f30: 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 6c nc *toppath* "/l
0f40: 6f 67 73 2f 22 20 72 75 6e 2d 69 64 20 22 2e 6c ogs/" run-id ".l
0f50: 6f 67 22 29 29 0a 09 20 28 63 6d 64 6c 6e 20 28 og")).. (cmdln (
0f60: 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 conc (common:get
0f70: 2d 6d 65 67 61 74 65 73 74 2d 65 78 65 29 0a 09 -megatest-exe)..
0f80: 09 20 20 20 20 20 20 22 20 2d 73 65 72 76 65 72 . " -server
0f90: 20 22 20 28 6f 72 20 74 61 72 67 65 74 2d 68 6f " (or target-ho
0fa0: 73 74 20 22 2d 22 29 20 22 20 2d 72 75 6e 2d 69 st "-") " -run-i
0fb0: 64 20 22 20 72 75 6e 2d 69 64 20 28 69 66 20 28 d " run-id (if (
0fc0: 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 3a equal? (configf:
0fd0: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
0fe0: 74 2a 20 22 73 65 72 76 65 72 22 20 22 64 61 65 t* "server" "dae
0ff0: 6d 6f 6e 69 7a 65 22 29 20 22 79 65 73 22 29 0a monize") "yes").
1000: 09 09 09 09 09 09 09 09 09 20 20 20 20 20 20 28 ......... (
1010: 63 6f 6e 63 20 22 20 2d 64 61 65 6d 6f 6e 69 7a conc " -daemoniz
1020: 65 20 2d 6c 6f 67 20 22 20 6c 6f 67 66 69 6c 65 e -log " logfile
1030: 29 0a 09 09 09 09 09 09 09 09 09 20 20 20 20 20 )..........
1040: 20 22 22 29 0a 09 09 20 20 20 20 20 20 22 20 2d "")... " -
1050: 6d 20 74 65 73 74 73 75 69 74 65 3a 22 20 74 65 m testsuite:" te
1060: 73 74 73 75 69 74 65 29 29 29 20 3b 3b 20 28 63 stsuite))) ;; (c
1070: 6f 6e 63 20 22 20 3e 3e 20 22 20 6c 6f 67 66 69 onc " >> " logfi
1080: 6c 65 20 22 20 32 3e 26 31 20 26 22 29 29 29 29 le " 2>&1 &"))))
1090: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
10a0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
10b0: 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 53 g-port* "INFO: S
10c0: 74 61 72 74 69 6e 67 20 73 65 72 76 65 72 20 28 tarting server (
10d0: 22 20 63 6d 64 6c 6e 20 22 29 20 61 73 20 6e 6f " cmdln ") as no
10e0: 6e 65 20 72 75 6e 6e 69 6e 67 20 2e 2e 2e 22 29 ne running ...")
10f0: 0a 20 20 20 20 28 70 75 73 68 2d 64 69 72 65 63 . (push-direc
1100: 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 0a tory *toppath*).
1110: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 64 69 (if (not (di
1120: 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 rectory-exists?
1130: 22 6c 6f 67 73 22 29 29 28 63 72 65 61 74 65 2d "logs"))(create-
1140: 64 69 72 65 63 74 6f 72 79 20 22 6c 6f 67 73 22 directory "logs"
1150: 29 29 0a 20 20 20 20 3b 3b 20 52 6f 74 61 74 65 )). ;; Rotate
1160: 20 6c 6f 67 73 2c 20 6c 6f 67 69 63 3a 20 0a 20 logs, logic: .
1170: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;
1180: 20 20 20 20 20 20 69 66 20 3e 20 35 30 30 6b 20 if > 500k
1190: 61 6e 64 20 6f 6c 64 65 72 20 74 68 61 6e 20 31 and older than 1
11a0: 20 77 65 65 6b 2c 20 72 65 6d 6f 76 65 20 70 72 week, remove pr
11b0: 65 76 69 6f 75 73 20 63 6f 6d 70 72 65 73 73 65 evious compresse
11c0: 64 20 6c 6f 67 20 61 6e 64 20 63 6f 6d 70 72 65 d log and compre
11d0: 73 73 20 74 68 69 73 20 6c 6f 67 0a 20 20 20 20 ss this log.
11e0: 28 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c 64 20 (directory-fold
11f0: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 66 . (lambda (f
1200: 69 6c 65 20 72 65 6d 29 0a 20 20 20 20 20 20 20 ile rem).
1210: 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (if (and (string
1220: 2d 6d 61 74 63 68 20 22 5e 2e 2a 2e 6c 6f 67 22 -match "^.*.log"
1230: 20 66 69 6c 65 29 0a 09 09 28 3e 20 28 66 69 6c file)...(> (fil
1240: 65 2d 73 69 7a 65 20 28 63 6f 6e 63 20 22 6c 6f e-size (conc "lo
1250: 67 73 2f 22 20 66 69 6c 65 29 29 20 32 30 30 30 gs/" file)) 2000
1260: 30 30 29 29 0a 09 20 20 20 28 6c 65 74 20 28 28 00)).. (let ((
1270: 67 7a 66 69 6c 65 20 28 63 6f 6e 63 20 22 6c 6f gzfile (conc "lo
1280: 67 73 2f 22 20 66 69 6c 65 20 22 2e 67 7a 22 29 gs/" file ".gz")
1290: 29 29 0a 09 20 20 20 20 20 28 69 66 20 28 66 69 )).. (if (fi
12a0: 6c 65 2d 65 78 69 73 74 73 3f 20 67 7a 66 69 6c le-exists? gzfil
12b0: 65 29 0a 09 09 20 28 62 65 67 69 6e 0a 09 09 20 e)... (begin...
12c0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
12d0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
12e0: 6f 67 2d 70 6f 72 74 2a 20 22 72 65 6d 6f 76 69 og-port* "removi
12f0: 6e 67 20 22 20 67 7a 66 69 6c 65 29 0a 09 09 20 ng " gzfile)...
1300: 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 67 (delete-file g
1310: 7a 66 69 6c 65 29 29 29 0a 09 20 20 20 20 20 28 zfile))).. (
1320: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
1330: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
1340: 70 6f 72 74 2a 20 22 63 6f 6d 70 72 65 73 73 69 port* "compressi
1350: 6e 67 20 22 20 66 69 6c 65 29 0a 09 20 20 20 20 ng " file)..
1360: 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 (system (conc "
1370: 67 7a 69 70 20 6c 6f 67 73 2f 22 20 66 69 6c 65 gzip logs/" file
1380: 29 29 29 29 29 0a 20 20 20 20 20 27 28 29 0a 20 ))))). '().
1390: 20 20 20 20 22 6c 6f 67 73 22 29 0a 20 20 20 20 "logs").
13a0: 0a 20 20 20 20 3b 3b 20 68 6f 73 74 2e 64 6f 6d . ;; host.dom
13b0: 61 69 6e 2e 74 6c 64 20 6d 61 74 63 68 20 68 6f ain.tld match ho
13c0: 73 74 3f 0a 20 20 20 20 28 69 66 20 28 61 6e 64 st?. (if (and
13d0: 20 74 61 72 67 65 74 2d 68 6f 73 74 20 0a 09 20 target-host ..
13e0: 20 20 20 20 3b 3b 20 6c 6f 6f 6b 20 61 74 20 74 ;; look at t
13f0: 61 72 67 65 74 20 68 6f 73 74 2c 20 69 73 20 69 arget host, is i
1400: 74 20 68 6f 73 74 2e 64 6f 6d 61 69 6e 2e 74 6c t host.domain.tl
1410: 64 20 6f 72 20 69 70 20 61 64 64 72 65 73 73 20 d or ip address
1420: 61 6e 64 20 64 6f 65 73 20 69 74 20 0a 09 20 20 and does it ..
1430: 20 20 20 3b 3b 20 6d 61 74 63 68 20 63 75 72 72 ;; match curr
1440: 65 6e 74 20 69 70 20 6f 72 20 68 6f 73 74 6e 61 ent ip or hostna
1450: 6d 65 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 73 me.. (not (s
1460: 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 63 6f 6e tring-match (con
1470: 63 20 22 28 22 63 75 72 72 2d 68 6f 73 74 20 22 c "("curr-host "
1480: 7c 22 20 63 75 72 72 2d 68 6f 73 74 22 5c 5c 2e |" curr-host"\\.
1490: 2e 2a 29 22 29 20 74 61 72 67 65 74 2d 68 6f 73 .*)") target-hos
14a0: 74 29 29 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 t)).. (not (
14b0: 65 71 75 61 6c 3f 20 63 75 72 72 2d 69 70 20 74 equal? curr-ip t
14c0: 61 72 67 65 74 2d 68 6f 73 74 29 29 29 0a 09 28 arget-host)))..(
14d0: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug:
14e0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
14f0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1500: 22 53 74 61 72 74 69 6e 67 20 73 65 72 76 65 72 "Starting server
1510: 20 6f 6e 20 22 20 74 61 72 67 65 74 2d 68 6f 73 on " target-hos
1520: 74 20 22 2c 20 6c 6f 67 66 69 6c 65 20 69 73 20 t ", logfile is
1530: 22 20 6c 6f 67 66 69 6c 65 29 0a 09 20 20 28 73 " logfile).. (s
1540: 65 74 65 6e 76 20 22 54 41 52 47 45 54 48 4f 53 etenv "TARGETHOS
1550: 54 22 20 74 61 72 67 65 74 2d 68 6f 73 74 29 29 T" target-host))
1560: 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 54 ). (setenv "T
1570: 41 52 47 45 54 48 4f 53 54 5f 4c 4f 47 46 22 20 ARGETHOST_LOGF"
1580: 6c 6f 67 66 69 6c 65 29 0a 20 20 20 20 28 63 6f logfile). (co
1590: 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 6e 6f mmon:wait-for-no
15a0: 72 6d 61 6c 69 7a 65 64 2d 6c 6f 61 64 20 34 20 rmalized-load 4
15b0: 22 20 64 65 6c 61 79 69 6e 67 20 73 65 72 76 65 " delaying serve
15c0: 72 20 73 74 61 72 74 20 64 75 65 20 74 6f 20 6c r start due to l
15d0: 6f 61 64 22 20 72 65 6d 6f 74 65 2d 68 6f 73 74 oad" remote-host
15e0: 3a 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 : (get-environme
15f0: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 54 41 52 nt-variable "TAR
1600: 47 45 54 48 4f 53 54 22 29 29 20 3b 3b 20 64 6f GETHOST")) ;; do
1610: 20 6e 6f 74 20 74 72 79 20 73 74 61 72 74 69 6e not try startin
1620: 67 20 73 65 72 76 65 72 73 20 6f 6e 20 61 6e 20 g servers on an
1630: 61 6c 72 65 61 64 79 20 6f 76 65 72 6c 6f 61 64 already overload
1640: 65 64 20 6d 61 63 68 69 6e 65 2c 20 6a 75 73 74 ed machine, just
1650: 20 77 61 69 74 20 66 6f 72 65 76 65 72 0a 20 20 wait forever.
1660: 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 (system (conc
1670: 22 6e 62 66 61 6b 65 20 22 20 63 6d 64 6c 6e 29 "nbfake " cmdln)
1680: 29 0a 20 20 20 20 28 75 6e 73 65 74 65 6e 76 20 ). (unsetenv
1690: 22 54 41 52 47 45 54 48 4f 53 54 5f 4c 4f 47 46 "TARGETHOST_LOGF
16a0: 22 29 0a 20 20 20 20 28 69 66 20 28 67 65 74 2d "). (if (get-
16b0: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
16c0: 61 62 6c 65 20 22 54 41 52 47 45 54 48 4f 53 54 able "TARGETHOST
16d0: 22 29 28 75 6e 73 65 74 65 6e 76 20 22 54 41 52 ")(unsetenv "TAR
16e0: 47 45 54 48 4f 53 54 22 29 29 0a 20 20 20 20 3b GETHOST")). ;
16f0: 3b 20 28 73 79 73 74 65 6d 20 63 6d 64 6c 6e 29 ; (system cmdln)
1700: 0a 20 20 20 20 28 70 6f 70 2d 64 69 72 65 63 74 . (pop-direct
1710: 6f 72 79 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ory)))..(define
1720: 28 73 65 72 76 65 72 3a 67 65 74 2d 63 6c 69 65 (server:get-clie
1730: 6e 74 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 20 nt-signature).
1740: 28 69 66 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 (if *my-client-s
1750: 69 67 6e 61 74 75 72 65 2a 20 2a 6d 79 2d 63 6c ignature* *my-cl
1760: 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 0a ient-signature*.
1770: 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 69 67 (let ((sig
1780: 20 28 73 65 72 76 65 72 3a 6d 6b 2d 73 69 67 6e (server:mk-sign
1790: 61 74 75 72 65 29 29 29 0a 09 28 73 65 74 21 20 ature)))..(set!
17a0: 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 *my-client-signa
17b0: 74 75 72 65 2a 20 73 69 67 29 0a 09 2a 6d 79 2d ture* sig)..*my-
17c0: 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 client-signature
17d0: 2a 29 29 29 0a 0a 3b 3b 20 6b 69 6e 64 20 73 74 *)))..;; kind st
17e0: 61 72 74 20 75 70 20 6f 66 20 73 65 72 76 65 72 art up of server
17f0: 73 2c 20 77 61 69 74 20 34 30 20 73 65 63 6f 6e s, wait 40 secon
1800: 64 73 20 62 65 66 6f 72 65 20 61 6c 6c 6f 77 69 ds before allowi
1810: 6e 67 20 61 6e 6f 74 68 65 72 20 73 65 72 76 65 ng another serve
1820: 72 20 66 6f 72 20 61 20 67 69 76 65 6e 0a 3b 3b r for a given.;;
1830: 20 72 75 6e 2d 69 64 20 74 6f 20 62 65 20 6c 61 run-id to be la
1840: 75 6e 63 68 65 64 0a 28 64 65 66 69 6e 65 20 28 unched.(define (
1850: 73 65 72 76 65 72 3a 6b 69 6e 64 2d 72 75 6e 20 server:kind-run
1860: 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 74 20 28 run-id). (let (
1870: 28 6c 61 73 74 2d 72 75 6e 2d 74 69 6d 65 20 28 (last-run-time (
1880: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
1890: 65 66 61 75 6c 74 20 2a 73 65 72 76 65 72 2d 6b efault *server-k
18a0: 69 6e 64 2d 72 75 6e 2a 20 72 75 6e 2d 69 64 20 ind-run* run-id
18b0: 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6f #f))). (if (o
18c0: 72 20 28 6e 6f 74 20 6c 61 73 74 2d 72 75 6e 2d r (not last-run-
18d0: 74 69 6d 65 29 0a 09 20 20 20 20 28 3e 20 28 2d time).. (> (-
18e0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
18f0: 73 29 20 6c 61 73 74 2d 72 75 6e 2d 74 69 6d 65 s) last-run-time
1900: 29 20 33 30 29 29 0a 09 28 62 65 67 69 6e 0a 09 ) 30))..(begin..
1910: 20 20 28 73 65 72 76 65 72 3a 72 75 6e 20 72 75 (server:run ru
1920: 6e 2d 69 64 29 0a 09 20 20 28 68 61 73 68 2d 74 n-id).. (hash-t
1930: 61 62 6c 65 2d 73 65 74 21 20 2a 73 65 72 76 65 able-set! *serve
1940: 72 2d 6b 69 6e 64 2d 72 75 6e 2a 20 72 75 6e 2d r-kind-run* run-
1950: 69 64 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f id (current-seco
1960: 6e 64 73 29 29 29 29 29 29 0a 0a 3b 3b 20 54 68 nds))))))..;; Th
1970: 65 20 67 65 6e 65 72 69 63 20 72 75 6e 20 61 20 e generic run a
1980: 73 65 72 76 65 72 20 63 6f 6d 6d 61 6e 64 2e 20 server command.
1990: 44 69 73 70 61 74 63 68 65 73 20 74 68 65 20 63 Dispatches the c
19a0: 61 6c 6c 20 74 6f 20 73 65 72 76 65 72 20 30 20 all to server 0
19b0: 69 66 20 72 75 6e 2d 69 64 20 21 3d 20 30 0a 3b if run-id != 0.;
19c0: 3b 20 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 ; .(define (serv
19d0: 65 72 3a 74 72 79 2d 72 75 6e 6e 69 6e 67 20 72 er:try-running r
19e0: 75 6e 2d 69 64 29 0a 20 20 28 69 66 20 28 65 71 un-id). (if (eq
19f0: 3f 20 72 75 6e 2d 69 64 20 30 29 0a 20 20 20 20 ? run-id 0).
1a00: 20 20 28 73 65 72 76 65 72 3a 72 75 6e 20 72 75 (server:run ru
1a10: 6e 2d 69 64 29 0a 20 20 20 20 20 20 28 72 6d 74 n-id). (rmt
1a20: 3a 73 74 61 72 74 2d 73 65 72 76 65 72 20 72 75 :start-server ru
1a30: 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 n-id)))..(define
1a40: 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 (server:check-i
1a50: 66 2d 72 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 f-running run-id
1a60: 29 0a 20 20 28 6c 65 74 20 28 28 74 64 62 64 61 ). (let ((tdbda
1a70: 74 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 t (tasks:open-db
1a80: 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f ))). (let loo
1a90: 70 20 28 28 73 65 72 76 65 72 20 28 74 61 73 6b p ((server (task
1aa0: 73 3a 67 65 74 2d 73 65 72 76 65 72 20 28 64 62 s:get-server (db
1ab0: 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 :delay-if-busy t
1ac0: 64 62 64 61 74 29 20 72 75 6e 2d 69 64 29 29 0a dbdat) run-id)).
1ad0: 09 20 20 20 20 20 20 20 28 74 72 79 63 6f 75 6e . (trycoun
1ae0: 74 20 30 29 29 0a 20 20 20 20 28 69 66 20 73 65 t 0)). (if se
1af0: 72 76 65 72 0a 09 3b 3b 20 6e 6f 74 65 3a 20 63 rver..;; note: c
1b00: 6c 69 65 6e 74 3a 73 74 61 72 74 20 77 69 6c 6c lient:start will
1b10: 20 73 65 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a set *runremote*
1b20: 2e 20 74 68 69 73 20 6e 65 65 64 73 20 74 6f 20 . this needs to
1b30: 62 65 20 63 68 61 6e 67 65 64 0a 09 3b 3b 20 20 be changed..;;
1b40: 20 20 20 20 20 61 6c 73 6f 2c 20 63 6c 69 65 6e also, clien
1b50: 74 3a 73 74 61 72 74 20 77 69 6c 6c 20 6c 6f 67 t:start will log
1b60: 69 6e 20 74 6f 20 74 68 65 20 73 65 72 76 65 72 in to the server
1b70: 2c 20 61 6c 73 6f 20 6e 65 65 64 20 74 6f 20 63 , also need to c
1b80: 68 61 6e 67 65 20 74 68 61 74 2e 0a 09 3b 3b 0a hange that...;;.
1b90: 09 3b 3b 20 63 6c 69 65 6e 74 3a 73 74 61 72 74 .;; client:start
1ba0: 20 72 65 74 75 72 6e 73 20 23 74 20 69 66 20 6c returns #t if l
1bb0: 6f 67 69 6e 20 77 61 73 20 73 75 63 63 65 73 73 ogin was success
1bc0: 66 75 6c 2e 0a 09 3b 3b 0a 09 28 6c 65 74 20 28 ful...;;..(let (
1bd0: 28 72 65 73 20 28 63 61 73 65 20 2a 74 72 61 6e (res (case *tran
1be0: 73 70 6f 72 74 2d 74 79 70 65 2a 0a 09 09 20 20 sport-type*...
1bf0: 20 20 20 28 28 68 74 74 70 29 28 73 65 72 76 65 ((http)(serve
1c00: 72 3a 70 69 6e 67 2d 73 65 72 76 65 72 20 72 75 r:ping-server ru
1c10: 6e 2d 69 64 20 0a 09 09 09 09 09 09 28 74 61 73 n-id .......(tas
1c20: 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d ks:hostinfo-get-
1c30: 69 6e 74 65 72 66 61 63 65 20 73 65 72 76 65 72 interface server
1c40: 29 0a 09 09 09 09 09 09 28 74 61 73 6b 73 3a 68 ).......(tasks:h
1c50: 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 70 6f 72 74 ostinfo-get-port
1c60: 20 20 20 20 20 20 73 65 72 76 65 72 29 29 29 0a server))).
1c70: 09 09 20 20 20 20 20 3b 3b 20 28 28 6e 6d 73 67 .. ;; ((nmsg
1c80: 29 28 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 )(nmsg-transport
1c90: 3a 70 69 6e 67 20 28 74 61 73 6b 73 3a 68 6f 73 :ping (tasks:hos
1ca0: 74 69 6e 66 6f 2d 67 65 74 2d 69 6e 74 65 72 66 tinfo-get-interf
1cb0: 61 63 65 20 73 65 72 76 65 72 29 0a 09 09 20 20 ace server)...
1cc0: 20 20 20 3b 3b 20 20 20 20 09 09 09 20 28 74 61 ;; ... (ta
1cd0: 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 sks:hostinfo-get
1ce0: 2d 70 6f 72 74 20 20 20 20 20 20 73 65 72 76 65 -port serve
1cf0: 72 29 0a 09 09 20 20 20 20 20 3b 3b 20 20 20 20 r)... ;;
1d00: 09 09 09 20 74 69 6d 65 6f 75 74 3a 20 32 29 29 ... timeout: 2))
1d10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1d20: 20 20 20 20 20 20 29 29 29 0a 09 20 20 3b 3b 20 ))).. ;;
1d30: 69 66 20 74 68 65 20 73 65 72 76 65 72 20 64 69 if the server di
1d40: 64 6e 27 74 20 72 65 73 70 6f 6e 64 20 77 65 20 dn't respond we
1d50: 6d 75 73 74 20 72 65 6d 6f 76 65 20 74 68 65 20 must remove the
1d60: 72 65 63 6f 72 64 0a 09 20 20 28 69 66 20 72 65 record.. (if re
1d70: 73 0a 09 20 20 20 20 20 20 23 74 0a 09 20 20 20 s.. #t..
1d80: 20 20 20 28 62 65 67 69 6e 0a 09 09 28 64 65 62 (begin...(deb
1d90: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
1da0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
1db0: 74 2a 20 22 73 65 72 76 65 72 20 61 74 20 22 20 t* "server at "
1dc0: 73 65 72 76 65 72 20 22 20 6e 6f 74 20 72 65 73 server " not res
1dd0: 70 6f 6e 64 69 6e 67 2c 20 72 65 6d 6f 76 69 6e ponding, removin
1de0: 67 20 72 65 63 6f 72 64 22 29 0a 09 09 28 74 61 g record")...(ta
1df0: 73 6b 73 3a 73 65 72 76 65 72 2d 66 6f 72 63 65 sks:server-force
1e00: 2d 63 6c 65 61 6e 2d 72 75 6e 6e 69 6e 67 2d 72 -clean-running-r
1e10: 65 63 6f 72 64 73 2d 66 6f 72 2d 72 75 6e 2d 69 ecords-for-run-i
1e20: 64 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 d (db:delay-if-b
1e30: 75 73 79 20 74 64 62 64 61 74 29 20 72 75 6e 2d usy tdbdat) run-
1e40: 69 64 20 0a 09 09 09 09 22 20 73 65 72 76 65 72 id ....." server
1e50: 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e :check-if-runnin
1e60: 67 22 29 0a 09 09 72 65 73 29 29 29 0a 09 23 66 g")...res)))..#f
1e70: 29 29 29 29 0a 0a 3b 3b 20 63 61 6c 6c 65 64 20 ))))..;; called
1e80: 69 6e 20 6d 65 67 61 74 65 73 74 2e 73 63 6d 2c in megatest.scm,
1e90: 20 68 6f 73 74 2d 70 6f 72 74 20 69 73 20 73 74 host-port is st
1ea0: 72 69 6e 67 20 68 6f 73 74 6e 61 6d 65 3a 70 6f ring hostname:po
1eb0: 72 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 rt.;;.(define (s
1ec0: 65 72 76 65 72 3a 70 69 6e 67 20 72 75 6e 2d 69 erver:ping run-i
1ed0: 64 20 68 6f 73 74 3a 70 6f 72 74 29 0a 20 20 28 d host:port). (
1ee0: 6c 65 74 20 28 28 74 64 62 64 61 74 20 28 74 61 let ((tdbdat (ta
1ef0: 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 sks:open-db))).
1f00: 20 20 20 28 6c 65 74 2a 20 28 28 68 6f 73 74 2d (let* ((host-
1f10: 70 6f 72 74 20 28 6c 65 74 20 28 28 73 6c 73 74 port (let ((slst
1f20: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 20 (string-split
1f30: 20 68 6f 73 74 3a 70 6f 72 74 20 22 3a 22 29 29 host:port ":"))
1f40: 29 0a 09 09 09 28 69 66 20 28 65 71 3f 20 28 6c )....(if (eq? (l
1f50: 65 6e 67 74 68 20 73 6c 73 74 29 20 32 29 0a 09 ength slst) 2)..
1f60: 09 09 20 20 20 20 28 6c 69 73 74 20 28 63 61 72 .. (list (car
1f70: 20 73 6c 73 74 29 28 73 74 72 69 6e 67 2d 3e 6e slst)(string->n
1f80: 75 6d 62 65 72 20 28 63 61 64 72 20 73 6c 73 74 umber (cadr slst
1f90: 29 29 29 0a 09 09 09 20 20 20 20 23 66 29 29 29 ))).... #f)))
1fa0: 0a 09 20 20 20 28 74 6f 70 70 61 74 68 20 20 20 .. (toppath
1fb0: 20 20 20 20 28 6c 61 75 6e 63 68 3a 73 65 74 75 (launch:setu
1fc0: 70 29 29 0a 09 20 20 20 28 73 65 72 76 65 72 2d p)).. (server-
1fd0: 64 62 2d 64 61 74 20 28 69 66 20 28 6e 6f 74 20 db-dat (if (not
1fe0: 68 6f 73 74 2d 70 6f 72 74 29 28 74 61 73 6b 73 host-port)(tasks
1ff0: 3a 67 65 74 2d 73 65 72 76 65 72 20 28 64 62 3a :get-server (db:
2000: 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 74 64 delay-if-busy td
2010: 62 64 61 74 29 20 72 75 6e 2d 69 64 29 20 23 66 bdat) run-id) #f
2020: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e ))). (if (n
2030: 6f 74 20 72 75 6e 2d 69 64 29 0a 09 20 20 28 62 ot run-id).. (b
2040: 65 67 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 egin.. (debug
2050: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
2060: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2070: 2a 20 22 6d 75 73 74 20 73 70 65 63 69 66 79 20 * "must specify
2080: 72 75 6e 2d 69 64 20 77 68 65 6e 20 64 6f 69 6e run-id when doin
2090: 67 20 70 69 6e 67 2c 20 2d 72 75 6e 2d 69 64 20 g ping, -run-id
20a0: 6e 22 29 0a 09 20 20 20 20 28 70 72 69 6e 74 20 n").. (print
20b0: 22 45 52 52 4f 52 3a 20 4e 6f 20 72 75 6e 2d 69 "ERROR: No run-i
20c0: 64 22 29 0a 09 20 20 20 20 28 65 78 69 74 20 31 d").. (exit 1
20d0: 29 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 28 )).. (if (and (
20e0: 6e 6f 74 20 68 6f 73 74 2d 70 6f 72 74 29 0a 09 not host-port)..
20f0: 09 20 20 20 28 6e 6f 74 20 73 65 72 76 65 72 2d . (not server-
2100: 64 62 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 db-dat))..
2110: 28 62 65 67 69 6e 0a 09 09 28 70 72 69 6e 74 20 (begin...(print
2120: 22 45 52 52 4f 52 3a 20 62 61 64 20 68 6f 73 74 "ERROR: bad host
2130: 3a 70 6f 72 74 22 29 0a 09 09 28 65 78 69 74 20 :port")...(exit
2140: 31 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 1)).. (let*
2150: 20 28 28 69 66 61 63 65 20 20 20 20 20 20 28 69 ((iface (i
2160: 66 20 68 6f 73 74 2d 70 6f 72 74 20 28 63 61 72 f host-port (car
2170: 20 68 6f 73 74 2d 70 6f 72 74 29 20 28 74 61 73 host-port) (tas
2180: 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d ks:hostinfo-get-
2190: 69 6e 74 65 72 66 61 63 65 20 73 65 72 76 65 72 interface server
21a0: 2d 64 62 2d 64 61 74 29 29 29 0a 09 09 20 20 20 -db-dat)))...
21b0: 20 20 28 70 6f 72 74 20 20 20 20 20 20 20 28 69 (port (i
21c0: 66 20 68 6f 73 74 2d 70 6f 72 74 20 28 63 61 64 f host-port (cad
21d0: 72 20 68 6f 73 74 2d 70 6f 72 74 29 28 74 61 73 r host-port)(tas
21e0: 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d ks:hostinfo-get-
21f0: 70 6f 72 74 20 20 20 20 20 20 73 65 72 76 65 72 port server
2200: 2d 64 62 2d 64 61 74 29 29 29 0a 09 09 20 20 20 -db-dat)))...
2210: 20 20 28 73 65 72 76 65 72 2d 64 61 74 20 28 68 (server-dat (h
2220: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c ttp-transport:cl
2230: 69 65 6e 74 2d 63 6f 6e 6e 65 63 74 20 69 66 61 ient-connect ifa
2240: 63 65 20 70 6f 72 74 29 29 0a 09 09 20 20 20 20 ce port))...
2250: 20 28 6c 6f 67 69 6e 2d 72 65 73 20 20 28 72 6d (login-res (rm
2260: 74 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 6f 2d t:login-no-auto-
2270: 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 73 65 72 client-setup ser
2280: 76 65 72 2d 64 61 74 20 72 75 6e 2d 69 64 29 29 ver-dat run-id))
2290: 29 0a 09 09 28 69 66 20 28 61 6e 64 20 28 6c 69 )...(if (and (li
22a0: 73 74 3f 20 6c 6f 67 69 6e 2d 72 65 73 29 0a 09 st? login-res)..
22b0: 09 09 20 28 63 61 72 20 6c 6f 67 69 6e 2d 72 65 .. (car login-re
22c0: 73 29 29 0a 09 09 20 20 20 20 28 62 65 67 69 6e s))... (begin
22d0: 0a 09 09 20 20 20 20 20 20 28 70 72 69 6e 74 20 ... (print
22e0: 22 4c 4f 47 49 4e 5f 4f 4b 22 29 0a 09 09 20 20 "LOGIN_OK")...
22f0: 20 20 20 20 28 65 78 69 74 20 30 29 29 0a 09 09 (exit 0))...
2300: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 (begin...
2310: 20 20 20 28 70 72 69 6e 74 20 22 4c 4f 47 49 4e (print "LOGIN
2320: 5f 46 41 49 4c 45 44 22 29 0a 09 09 20 20 20 20 _FAILED")...
2330: 20 20 28 65 78 69 74 20 31 29 29 29 29 29 29 29 (exit 1)))))))
2340: 29 29 0a 0a 3b 3b 20 72 75 6e 20 70 69 6e 67 20 ))..;; run ping
2350: 69 6e 20 73 65 70 61 72 61 74 65 20 70 72 6f 63 in separate proc
2360: 65 73 73 2c 20 73 61 66 65 73 74 20 77 61 79 20 ess, safest way
2370: 69 6e 20 73 6f 6d 65 20 63 61 73 65 73 0a 3b 3b in some cases.;;
2380: 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 .(define (server
2390: 3a 70 69 6e 67 2d 73 65 72 76 65 72 20 72 75 6e :ping-server run
23a0: 2d 69 64 20 69 66 61 63 65 20 70 6f 72 74 29 0a -id iface port).
23b0: 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
23c0: 6f 6d 2d 70 69 70 65 20 0a 20 20 20 28 63 6f 6e om-pipe . (con
23d0: 63 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6d 65 c (common:get-me
23e0: 67 61 74 65 73 74 2d 65 78 65 29 20 22 20 2d 72 gatest-exe) " -r
23f0: 75 6e 2d 69 64 20 22 20 72 75 6e 2d 69 64 20 22 un-id " run-id "
2400: 20 2d 70 69 6e 67 20 22 20 28 63 6f 6e 63 20 69 -ping " (conc i
2410: 66 61 63 65 20 22 3a 22 20 70 6f 72 74 29 29 0a face ":" port)).
2420: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 (lambda ().
2430: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 (let loop ((i
2440: 6e 6c 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 0a nl (read-line)).
2450: 09 09 28 72 65 73 20 22 4e 4f 52 45 50 4c 59 22 ..(res "NOREPLY"
2460: 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 65 )). (if (e
2470: 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 0a of-object? inl).
2480: 09 20 20 20 28 63 61 73 65 20 28 73 74 72 69 6e . (case (strin
2490: 67 2d 3e 73 79 6d 62 6f 6c 20 72 65 73 29 0a 09 g->symbol res)..
24a0: 20 20 20 20 20 28 28 4e 4f 52 45 50 4c 59 29 20 ((NOREPLY)
24b0: 20 23 66 29 0a 09 20 20 20 20 20 28 28 4c 4f 47 #f).. ((LOG
24c0: 49 4e 5f 4f 4b 29 20 23 74 29 0a 09 20 20 20 20 IN_OK) #t)..
24d0: 20 28 65 6c 73 65 20 20 20 20 20 20 20 23 66 29 (else #f)
24e0: 29 0a 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 ).. (loop (rea
24f0: 64 2d 6c 69 6e 65 29 20 69 6e 6c 29 29 29 29 29 d-line) inl)))))
2500: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 )..(define (serv
2510: 65 72 3a 6c 6f 67 69 6e 20 74 6f 70 70 61 74 68 er:login toppath
2520: 29 0a 20 20 28 6c 61 6d 62 64 61 20 28 74 6f 70 ). (lambda (top
2530: 70 61 74 68 29 0a 20 20 20 20 28 73 65 74 21 20 path). (set!
2540: 2a 6c 61 73 74 2d 64 62 2d 61 63 63 65 73 73 2a *last-db-access*
2550: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
2560: 73 29 29 0a 20 20 20 20 28 69 66 20 28 65 71 75 s)). (if (equ
2570: 61 6c 3f 20 2a 74 6f 70 70 61 74 68 2a 20 74 6f al? *toppath* to
2580: 70 70 61 74 68 29 0a 09 28 62 65 67 69 6e 0a 09 ppath)..(begin..
2590: 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
25a0: 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c t-info 2 *defaul
25b0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6c 6f 67 t-log-port* "log
25c0: 69 6e 20 73 75 63 63 65 73 73 66 75 6c 22 29 0a in successful").
25d0: 09 20 20 23 74 29 0a 09 28 62 65 67 69 6e 0a 09 . #t)..(begin..
25e0: 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
25f0: 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c t-info 2 *defaul
2600: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6c 6f 67 t-log-port* "log
2610: 69 6e 20 66 61 69 6c 65 64 22 29 0a 09 20 20 23 in failed").. #
2620: 66 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 f))))..(define (
2630: 73 65 72 76 65 72 3a 67 65 74 2d 74 69 6d 65 6f server:get-timeo
2640: 75 74 29 0a 20 20 28 6c 65 74 20 28 28 74 6d 6f ut). (let ((tmo
2650: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
2660: 20 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 *configdat* "s
2670: 65 72 76 65 72 22 20 22 74 69 6d 65 6f 75 74 22 erver" "timeout"
2680: 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 ))). (if (and
2690: 20 28 73 74 72 69 6e 67 3f 20 74 6d 6f 29 0a 09 (string? tmo)..
26a0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (string->nu
26b0: 6d 62 65 72 20 74 6d 6f 29 29 0a 09 28 2a 20 36 mber tmo))..(* 6
26c0: 30 20 36 30 20 28 73 74 72 69 6e 67 2d 3e 6e 75 0 60 (string->nu
26d0: 6d 62 65 72 20 74 6d 6f 29 29 0a 09 3b 3b 20 28 mber tmo))..;; (
26e0: 2a 20 33 20 32 34 20 36 30 20 36 30 29 20 3b 3b * 3 24 60 60) ;;
26f0: 20 64 65 66 61 75 6c 74 20 74 6f 20 74 68 72 65 default to thre
2700: 65 20 64 61 79 73 0a 09 28 2a 20 36 30 20 31 29 e days..(* 60 1)
2710: 20 20 20 20 20 20 20 20 20 3b 3b 20 64 65 66 61 ;; defa
2720: 75 6c 74 20 74 6f 20 6f 6e 65 20 6d 69 6e 75 74 ult to one minut
2730: 65 0a 09 3b 3b 20 28 2a 20 36 30 20 36 30 20 32 e..;; (* 60 60 2
2740: 35 29 20 20 20 20 20 20 3b 3b 20 64 65 66 61 75 5) ;; defau
2750: 6c 74 20 74 6f 20 32 35 20 68 6f 75 72 73 0a 09 lt to 25 hours..
2760: 29 29 29 0a 0a )))..