Artifact
7e38f4f2de47d51248d61e12407e530aa5f656f9:
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 20 72 70 63 29 0a 28 69 6d cp s11n rpc).(im
0180: 70 6f 72 74 20 28 70 72 65 66 69 78 20 72 70 63 port (prefix rpc
0190: 20 72 70 63 3a 29 29 0a 0a 28 75 73 65 20 73 71 rpc:))..(use sq
01a0: 6c 69 74 65 33 20 73 72 66 69 2d 31 20 70 6f 73 lite3 srfi-1 pos
01b0: 69 78 20 72 65 67 65 78 20 72 65 67 65 78 2d 63 ix regex regex-c
01c0: 61 73 65 20 73 72 66 69 2d 36 39 20 68 6f 73 74 ase srfi-69 host
01d0: 69 6e 66 6f 20 6d 64 35 20 6d 65 73 73 61 67 65 info md5 message
01e0: 2d 64 69 67 65 73 74 29 0a 28 69 6d 70 6f 72 74 -digest).(import
01f0: 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 (prefix sqlite3
0200: 20 73 71 6c 69 74 65 33 3a 29 29 0a 0a 28 64 65 sqlite3:))..(de
0210: 63 6c 61 72 65 20 28 75 6e 69 74 20 72 70 63 2d clare (unit rpc-
0220: 74 72 61 6e 73 70 6f 72 74 29 29 0a 0a 28 64 65 transport))..(de
0230: 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6d 6d clare (uses comm
0240: 6f 6e 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 on)).(declare (u
0250: 73 65 73 20 64 62 29 29 0a 28 64 65 63 6c 61 72 ses db)).(declar
0260: 65 20 28 75 73 65 73 20 74 65 73 74 73 29 29 0a e (uses tests)).
0270: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 (declare (uses t
0280: 61 73 6b 73 29 29 20 3b 3b 20 74 61 73 6b 73 20 asks)) ;; tasks
0290: 61 72 65 20 77 68 65 72 65 20 73 74 75 66 66 20 are where stuff
02a0: 69 73 20 6d 61 69 6e 74 61 69 6e 65 64 20 61 62 is maintained ab
02b0: 6f 75 74 20 77 68 61 74 20 69 73 20 72 75 6e 6e out what is runn
02c0: 69 6e 67 2e 0a 0a 28 69 6e 63 6c 75 64 65 20 22 ing...(include "
02d0: 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 common_records.s
02e0: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 cm").(include "d
02f0: 62 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a b_records.scm").
0300: 0a 3b 3b 20 70 72 6f 63 73 74 72 20 69 73 20 74 .;; procstr is t
0310: 68 65 20 6e 61 6d 65 20 6f 66 20 74 68 65 20 70 he name of the p
0320: 72 6f 63 65 64 75 72 65 20 74 6f 20 62 65 20 63 rocedure to be c
0330: 61 6c 6c 65 64 20 61 73 20 61 20 73 74 72 69 6e alled as a strin
0340: 67 0a 28 64 65 66 69 6e 65 20 28 72 70 63 2d 74 g.(define (rpc-t
0350: 72 61 6e 73 70 6f 72 74 3a 61 75 74 6f 72 65 6d ransport:autorem
0360: 6f 74 65 20 70 72 6f 63 73 74 72 20 70 61 72 61 ote procstr para
0370: 6d 73 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 ms). (handle-ex
0380: 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a ceptions. exn.
0390: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 28 (begin. (
03a0: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 2a 64 debug:print 1 *d
03b0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
03c0: 20 22 52 65 6d 6f 74 65 20 66 61 69 6c 65 64 20 "Remote failed
03d0: 66 6f 72 20 22 20 70 72 6f 63 20 22 20 22 20 70 for " proc " " p
03e0: 61 72 61 6d 73 29 0a 20 20 20 20 20 28 61 70 70 arams). (app
03f0: 6c 79 20 28 65 76 61 6c 20 28 73 74 72 69 6e 67 ly (eval (string
0400: 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 73 74 72 ->symbol procstr
0410: 29 29 20 70 61 72 61 6d 73 29 29 0a 20 20 20 3b )) params)). ;
0420: 3b 20 28 69 66 20 2a 72 75 6e 72 65 6d 6f 74 65 ; (if *runremote
0430: 2a 0a 20 20 20 3b 3b 20 20 20 20 28 61 70 70 6c *. ;; (appl
0440: 79 20 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d y (eval (string-
0450: 3e 73 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 72 >symbol (conc "r
0460: 65 6d 6f 74 65 3a 22 20 70 72 6f 63 73 74 72 29 emote:" procstr)
0470: 29 29 20 70 61 72 61 6d 73 29 0a 20 20 20 28 61 )) params). (a
0480: 70 70 6c 79 20 28 65 76 61 6c 20 28 73 74 72 69 pply (eval (stri
0490: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 73 ng->symbol procs
04a0: 74 72 29 29 20 70 61 72 61 6d 73 29 29 29 0a 0a tr)) params)))..
04b0: 3b 3b 20 61 6c 6c 20 72 6f 75 74 65 73 20 74 68 ;; all routes th
04c0: 6f 75 67 68 20 68 65 72 65 20 65 6e 64 20 69 6e ough here end in
04d0: 20 65 78 69 74 20 2e 2e 2e 0a 3b 3b 0a 3b 3b 20 exit ....;;.;;
04e0: 73 74 61 72 74 5f 73 65 72 76 65 72 3f 20 0a 3b start_server? .;
04f0: 3b 0a 28 64 65 66 69 6e 65 20 28 72 70 63 2d 74 ;.(define (rpc-t
0500: 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 20 ransport:launch
0510: 72 75 6e 2d 69 64 29 0a 20 20 28 73 65 74 21 20 run-id). (set!
0520: 2a 72 75 6e 2d 69 64 2a 20 20 20 72 75 6e 2d 69 *run-id* run-i
0530: 64 29 0a 20 20 28 69 66 20 28 61 72 67 73 3a 67 d). (if (args:g
0540: 65 74 2d 61 72 67 20 22 2d 64 61 65 6d 6f 6e 69 et-arg "-daemoni
0550: 7a 65 22 29 0a 20 20 20 20 20 20 28 64 61 65 6d ze"). (daem
0560: 6f 6e 3a 69 7a 65 29 29 0a 20 20 28 69 66 20 28 on:ize)). (if (
0570: 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d server:check-if-
0580: 72 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 29 0a running run-id).
0590: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 64 (begin..(d
05a0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
05b0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
05c0: 22 49 4e 46 4f 3a 20 53 65 72 76 65 72 20 66 6f "INFO: Server fo
05d0: 72 20 72 75 6e 2d 69 64 20 22 20 72 75 6e 2d 69 r run-id " run-i
05e0: 64 20 22 20 61 6c 72 65 61 64 79 20 72 75 6e 6e d " already runn
05f0: 69 6e 67 22 29 0a 09 28 65 78 69 74 20 30 29 29 ing")..(exit 0))
0600: 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 ). (let loop ((
0610: 73 65 72 76 65 72 2d 69 64 20 28 6f 70 65 6e 2d server-id (open-
0620: 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a run-close tasks:
0630: 73 65 72 76 65 72 2d 6c 6f 63 6b 2d 73 6c 6f 74 server-lock-slot
0640: 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 72 tasks:open-db r
0650: 75 6e 2d 69 64 29 29 0a 09 20 20 20 20 20 28 72 un-id)).. (r
0660: 65 6d 74 72 69 65 73 20 20 34 29 29 0a 20 20 20 emtries 4)).
0670: 20 28 69 66 20 28 6e 6f 74 20 73 65 72 76 65 72 (if (not server
0680: 2d 69 64 29 0a 09 28 69 66 20 28 3e 20 72 65 6d -id)..(if (> rem
0690: 74 72 69 65 73 20 30 29 0a 09 20 20 20 20 28 62 tries 0).. (b
06a0: 65 67 69 6e 0a 09 20 20 20 20 20 20 28 74 68 72 egin.. (thr
06b0: 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a 09 20 ead-sleep! 2)..
06c0: 20 20 20 20 20 28 6c 6f 6f 70 20 28 6f 70 65 6e (loop (open
06d0: 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 -run-close tasks
06e0: 3a 73 65 72 76 65 72 2d 6c 6f 63 6b 2d 73 6c 6f :server-lock-slo
06f0: 74 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 t tasks:open-db
0700: 72 75 6e 2d 69 64 29 0a 09 09 20 20 20 20 28 2d run-id)... (-
0710: 20 72 65 6d 74 72 69 65 73 20 31 29 29 29 0a 09 remtries 1)))..
0720: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
0730: 20 20 3b 3b 20 73 69 6e 63 65 20 77 65 20 64 69 ;; since we di
0740: 64 6e 27 74 20 67 65 74 20 74 68 65 20 73 65 72 dn't get the ser
0750: 76 65 72 20 6c 6f 63 6b 20 77 65 20 61 72 65 20 ver lock we are
0760: 67 6f 69 6e 67 20 74 6f 20 63 6c 65 61 6e 20 75 going to clean u
0770: 70 20 61 6e 64 20 62 61 69 6c 20 6f 75 74 0a 09 p and bail out..
0780: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
0790: 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 nt-info 2 *defau
07a0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e lt-log-port* "IN
07b0: 46 4f 3a 20 73 65 72 76 65 72 20 70 69 64 3d 22 FO: server pid="
07c0: 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
07d0: 73 2d 69 64 29 20 22 2c 20 68 6f 73 74 6e 61 6d s-id) ", hostnam
07e0: 65 3d 22 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 e=" (get-host-na
07f0: 6d 65 29 20 22 20 6e 6f 74 20 73 74 61 72 74 69 me) " not starti
0800: 6e 67 20 64 75 65 20 74 6f 20 6f 74 68 65 72 20 ng due to other
0810: 63 61 6e 64 69 64 61 74 65 73 20 61 68 65 61 64 candidates ahead
0820: 20 69 6e 20 73 74 61 72 74 20 71 75 65 75 65 22 in start queue"
0830: 29 0a 09 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 ).. (open-r
0840: 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 un-close tasks:s
0850: 65 72 76 65 72 2d 64 65 6c 65 74 65 2d 72 65 63 erver-delete-rec
0860: 6f 72 64 73 2d 66 6f 72 2d 74 68 69 73 2d 70 69 ords-for-this-pi
0870: 64 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 d tasks:open-db
0880: 22 20 72 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a " rpc-transport:
0890: 6c 61 75 6e 63 68 22 29 29 29 0a 09 28 62 65 67 launch")))..(beg
08a0: 69 6e 0a 09 20 20 28 72 70 63 2d 74 72 61 6e 73 in.. (rpc-trans
08b0: 70 6f 72 74 3a 72 75 6e 20 28 69 66 20 28 61 72 port:run (if (ar
08c0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 gs:get-arg "-ser
08d0: 76 65 72 22 29 28 61 72 67 73 3a 67 65 74 2d 61 ver")(args:get-a
08e0: 72 67 20 22 2d 73 65 72 76 65 72 22 29 20 22 2d rg "-server") "-
08f0: 22 29 20 72 75 6e 2d 69 64 20 73 65 72 76 65 72 ") run-id server
0900: 2d 69 64 29 0a 09 20 20 28 65 78 69 74 29 29 29 -id).. (exit)))
0910: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 70 63 ))..(define (rpc
0920: 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 20 68 -transport:run h
0930: 6f 73 74 6e 20 72 75 6e 2d 69 64 20 73 65 72 76 ostn run-id serv
0940: 65 72 2d 69 64 29 0a 20 20 28 64 65 62 75 67 3a er-id). (debug:
0950: 70 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 print 2 *default
0960: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 41 74 74 65 -log-port* "Atte
0970: 6d 70 74 69 6e 67 20 74 6f 20 73 74 61 72 74 20 mpting to start
0980: 74 68 65 20 72 70 63 20 73 65 72 76 65 72 20 2e the rpc server .
0990: 2e 2e 22 29 0a 20 20 20 3b 3b 20 28 74 72 61 63 .."). ;; (trac
09a0: 65 20 72 70 63 3a 70 75 62 6c 69 73 68 2d 70 72 e rpc:publish-pr
09b0: 6f 63 65 64 75 72 65 21 29 0a 0a 20 20 28 72 70 ocedure!).. (rp
09c0: 63 3a 70 75 62 6c 69 73 68 2d 70 72 6f 63 65 64 c:publish-proced
09d0: 75 72 65 21 20 27 73 65 72 76 65 72 3a 6c 6f 67 ure! 'server:log
09e0: 69 6e 20 73 65 72 76 65 72 3a 6c 6f 67 69 6e 29 in server:login)
09f0: 0a 20 20 28 72 70 63 3a 70 75 62 6c 69 73 68 2d . (rpc:publish-
0a00: 70 72 6f 63 65 64 75 72 65 21 20 27 74 65 73 74 procedure! 'test
0a10: 69 6e 67 20 28 6c 61 6d 62 64 61 20 28 29 20 22 ing (lambda () "
0a20: 4a 75 73 74 20 74 65 73 74 69 6e 67 22 29 29 0a Just testing")).
0a30: 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 . (let* ((db
0a40: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 #f)..
0a50: 20 28 68 6f 73 74 6e 61 6d 65 20 20 20 20 20 20 (hostname
0a60: 20 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 (get-host-name
0a70: 29 29 0a 09 20 28 69 70 61 64 64 72 73 74 72 20 )).. (ipaddrstr
0a80: 20 20 20 20 20 20 28 6c 65 74 20 28 28 69 70 73 (let ((ips
0a90: 74 72 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f tr (if (string=?
0aa0: 20 22 2d 22 20 68 6f 73 74 6e 29 0a 09 09 09 09 "-" hostn).....
0ab0: 09 20 20 20 3b 3b 20 28 73 74 72 69 6e 67 2d 69 . ;; (string-i
0ac0: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
0ad0: 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 number->string (
0ae0: 75 38 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 28 u8vector->list (
0af0: 68 6f 73 74 6e 61 6d 65 2d 3e 69 70 20 68 6f 73 hostname->ip hos
0b00: 74 6e 61 6d 65 29 29 29 20 22 2e 22 29 0a 09 09 tname))) ".")...
0b10: 09 09 09 20 20 20 28 73 65 72 76 65 72 3a 67 65 ... (server:ge
0b20: 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 t-best-guess-add
0b30: 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 0a 09 ress hostname)..
0b40: 09 09 09 09 20 20 20 23 66 29 29 29 0a 09 09 09 .... #f)))....
0b50: 20 20 20 20 28 69 66 20 69 70 73 74 72 20 69 70 (if ipstr ip
0b60: 73 74 72 20 68 6f 73 74 6e 29 29 29 20 3b 3b 20 str hostn))) ;;
0b70: 68 6f 73 74 6e 61 6d 65 29 29 29 20 0a 09 20 28 hostname))) .. (
0b80: 73 74 61 72 74 2d 70 6f 72 74 20 20 20 20 20 20 start-port
0b90: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
0ba0: 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 67 65 74 tasks:server-get
0bb0: 2d 6e 65 78 74 2d 70 6f 72 74 20 74 61 73 6b 73 -next-port tasks
0bc0: 3a 6f 70 65 6e 2d 64 62 29 29 0a 09 20 28 6c 69 :open-db)).. (li
0bd0: 6e 6b 2d 74 72 65 65 2d 70 61 74 68 20 20 28 63 nk-tree-path (c
0be0: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
0bf0: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 onfigdat* "setup
0c00: 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 0a 09 " "linktree"))..
0c10: 20 28 72 70 63 3a 6c 69 73 74 65 6e 65 72 20 20 (rpc:listener
0c20: 20 20 28 72 70 63 2d 74 72 61 6e 73 70 6f 72 74 (rpc-transport
0c30: 3a 66 69 6e 64 2d 66 72 65 65 2d 70 6f 72 74 2d :find-free-port-
0c40: 61 6e 64 2d 6f 70 65 6e 20 28 72 70 63 3a 64 65 and-open (rpc:de
0c50: 66 61 75 6c 74 2d 73 65 72 76 65 72 2d 70 6f 72 fault-server-por
0c60: 74 29 29 29 0a 09 20 28 74 68 31 20 20 20 20 20 t))).. (th1
0c70: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 74 68 (make-th
0c80: 72 65 61 64 0a 09 09 09 20 20 20 28 6c 61 6d 62 read.... (lamb
0c90: 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 28 28 da ().... ((
0ca0: 72 70 63 3a 6d 61 6b 65 2d 73 65 72 76 65 72 20 rpc:make-server
0cb0: 72 70 63 3a 6c 69 73 74 65 6e 65 72 29 20 23 74 rpc:listener) #t
0cc0: 29 29 0a 09 09 09 20 20 20 22 72 70 63 3a 73 65 )).... "rpc:se
0cd0: 72 76 65 72 22 29 29 0a 09 09 09 20 20 20 3b 3b rver")).... ;;
0ce0: 20 28 63 75 74 65 20 28 72 70 63 3a 6d 61 6b 65 (cute (rpc:make
0cf0: 2d 73 65 72 76 65 72 20 72 70 63 3a 6c 69 73 74 -server rpc:list
0d00: 65 6e 65 72 29 20 22 72 70 63 3a 73 65 72 76 65 ener) "rpc:serve
0d10: 72 22 29 0a 09 09 09 20 20 20 3b 3b 20 27 72 70 r").... ;; 'rp
0d20: 63 3a 73 65 72 76 65 72 29 29 0a 09 20 28 68 6f c:server)).. (ho
0d30: 73 74 6e 61 6d 65 20 20 20 20 20 20 20 20 28 69 stname (i
0d40: 66 20 28 73 74 72 69 6e 67 3d 3f 20 22 2d 22 20 f (string=? "-"
0d50: 68 6f 73 74 6e 29 0a 09 09 09 20 20 20 20 20 20 hostn)....
0d60: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 (get-host-name)
0d70: 0a 09 09 09 20 20 20 20 20 20 68 6f 73 74 6e 29 .... hostn)
0d80: 29 0a 09 20 28 69 70 61 64 64 72 73 74 72 20 20 ).. (ipaddrstr
0d90: 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 (if (string
0da0: 3d 3f 20 22 2d 22 20 68 6f 73 74 6e 29 0a 09 09 =? "-" hostn)...
0db0: 09 20 20 20 20 20 20 28 73 65 72 76 65 72 3a 67 . (server:g
0dc0: 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 et-best-guess-ad
0dd0: 64 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 20 dress hostname)
0de0: 3b 3b 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 ;; (string-inter
0df0: 73 70 65 72 73 65 20 28 6d 61 70 20 6e 75 6d 62 sperse (map numb
0e00: 65 72 2d 3e 73 74 72 69 6e 67 20 28 75 38 76 65 er->string (u8ve
0e10: 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 ctor->list (host
0e20: 6e 61 6d 65 2d 3e 69 70 20 68 6f 73 74 6e 61 6d name->ip hostnam
0e30: 65 29 29 29 20 22 2e 22 29 0a 09 09 09 20 20 20 e))) ".")....
0e40: 20 20 20 23 66 29 29 0a 09 20 28 70 6f 72 74 6e #f)).. (portn
0e50: 75 6d 20 20 20 20 20 20 20 20 20 28 72 70 63 3a um (rpc:
0e60: 64 65 66 61 75 6c 74 2d 73 65 72 76 65 72 2d 70 default-server-p
0e70: 6f 72 74 29 29 0a 09 20 28 68 6f 73 74 3a 70 6f ort)).. (host:po
0e80: 72 74 20 20 20 20 20 20 20 28 63 6f 6e 63 20 28 rt (conc (
0e90: 69 66 20 69 70 61 64 64 72 73 74 72 20 69 70 61 if ipaddrstr ipa
0ea0: 64 64 72 73 74 72 20 68 6f 73 74 6e 61 6d 65 29 ddrstr hostname)
0eb0: 20 22 3a 22 20 70 6f 72 74 6e 75 6d 29 29 0a 09 ":" portnum))..
0ec0: 20 28 74 64 62 20 20 20 20 20 20 20 20 20 20 20 (tdb
0ed0: 20 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 (tasks:open-db
0ee0: 29 29 29 0a 20 20 20 20 28 74 68 72 65 61 64 2d ))). (thread-
0ef0: 73 74 61 72 74 21 20 74 68 31 29 0a 20 20 20 20 start! th1).
0f00: 28 73 65 74 21 20 64 62 20 2a 69 6e 6d 65 6d 64 (set! db *inmemd
0f10: 62 2a 29 0a 20 20 20 20 28 6f 70 65 6e 2d 72 75 b*). (open-ru
0f20: 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 n-close tasks:se
0f30: 72 76 65 72 2d 73 65 74 2d 69 6e 74 65 72 66 61 rver-set-interfa
0f40: 63 65 2d 70 6f 72 74 20 0a 09 09 20 20 20 20 74 ce-port ... t
0f50: 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 0a 09 09 asks:open-db ...
0f60: 20 20 20 20 73 65 72 76 65 72 2d 69 64 20 0a 09 server-id ..
0f70: 09 20 20 20 20 69 70 61 64 64 72 73 74 72 20 70 . ipaddrstr p
0f80: 6f 72 74 6e 75 6d 29 0a 20 20 20 20 28 64 65 62 ortnum). (deb
0f90: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
0fa0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 ult-log-port* "S
0fb0: 65 72 76 65 72 20 73 74 61 72 74 65 64 20 6f 6e erver started on
0fc0: 20 22 20 68 6f 73 74 3a 70 6f 72 74 29 0a 20 20 " host:port).
0fd0: 20 20 0a 20 20 20 20 3b 3b 20 28 74 72 61 63 65 . ;; (trace
0fe0: 20 72 70 63 3a 70 75 62 6c 69 73 68 2d 70 72 6f rpc:publish-pro
0ff0: 63 65 64 75 72 65 21 29 0a 20 20 20 20 3b 3b 20 cedure!). ;;
1000: 28 72 70 63 3a 70 75 62 6c 69 73 68 2d 70 72 6f (rpc:publish-pro
1010: 63 65 64 75 72 65 21 20 27 73 65 72 76 65 72 3a cedure! 'server:
1020: 6c 6f 67 69 6e 20 73 65 72 76 65 72 3a 6c 6f 67 login server:log
1030: 69 6e 29 0a 20 20 20 20 3b 3b 20 28 72 70 63 3a in). ;; (rpc:
1040: 70 75 62 6c 69 73 68 2d 70 72 6f 63 65 64 75 72 publish-procedur
1050: 65 21 20 27 74 65 73 74 69 6e 67 20 28 6c 61 6d e! 'testing (lam
1060: 62 64 61 20 28 29 20 22 4a 75 73 74 20 74 65 73 bda () "Just tes
1070: 74 69 6e 67 22 29 29 0a 0a 20 20 20 20 3b 3b 3d ting")).. ;;=
1080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10c0: 3d 3d 3d 3d 3d 0a 20 20 20 20 3b 3b 09 20 20 3b =====. ;;. ;
10d0: 3b 20 65 6e 64 20 6f 66 20 70 75 62 6c 69 73 68 ; end of publish
10e0: 2d 70 72 6f 63 65 64 75 72 65 20 73 65 63 74 69 -procedure secti
10f0: 6f 6e 0a 20 20 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d on. ;;=======
1100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
1140: 20 20 20 20 3b 3b 0a 20 20 20 20 28 6f 6e 2d 65 ;;. (on-e
1150: 78 69 74 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 xit (lambda ()..
1160: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e (open-run
1170: 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 -close tasks:ser
1180: 76 65 72 2d 73 65 74 2d 73 74 61 74 65 21 20 74 ver-set-state! t
1190: 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 73 65 72 asks:open-db ser
11a0: 76 65 72 2d 69 64 20 22 73 74 6f 70 70 65 64 22 ver-id "stopped"
11b0: 29 29 29 0a 0a 20 20 20 20 28 73 65 74 21 20 2a ))).. (set! *
11c0: 72 70 63 3a 6c 69 73 74 65 6e 65 72 2a 20 72 70 rpc:listener* rp
11d0: 63 3a 6c 69 73 74 65 6e 65 72 29 0a 20 20 20 20 c:listener).
11e0: 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 73 65 (tasks:server-se
11f0: 74 2d 73 74 61 74 65 21 20 74 64 62 20 73 65 72 t-state! tdb ser
1200: 76 65 72 2d 69 64 20 22 72 75 6e 6e 69 6e 67 22 ver-id "running"
1210: 29 0a 20 20 20 20 28 73 65 74 21 20 2a 69 6e 6d ). (set! *inm
1220: 65 6d 64 62 2a 20 20 28 64 62 3a 73 65 74 75 70 emdb* (db:setup
1230: 20 72 75 6e 2d 69 64 29 29 0a 20 20 20 20 3b 3b run-id)). ;;
1240: 20 69 66 20 6e 6f 6e 65 20 72 75 6e 6e 69 6e 67 if none running
1250: 20 6f 72 20 69 66 20 3e 20 32 30 20 73 65 63 6f or if > 20 seco
1260: 6e 64 73 20 73 69 6e 63 65 20 0a 20 20 20 20 3b nds since . ;
1270: 3b 20 73 65 72 76 65 72 20 6c 61 73 74 20 75 73 ; server last us
1280: 65 64 20 74 68 65 6e 20 73 74 61 72 74 20 73 68 ed then start sh
1290: 75 74 64 6f 77 6e 0a 20 20 20 20 28 6c 65 74 20 utdown. (let
12a0: 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 30 29 29 loop ((count 0))
12b0: 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
12c0: 6c 65 65 70 21 20 35 29 20 3b 3b 20 6e 6f 20 6e leep! 5) ;; no n
12d0: 65 65 64 20 74 6f 20 64 6f 20 74 68 69 73 20 76 eed to do this v
12e0: 65 72 79 20 6f 66 74 65 6e 0a 20 20 20 20 20 20 ery often.
12f0: 28 6c 65 74 20 28 28 6e 75 6d 72 75 6e 6e 69 6e (let ((numrunnin
1300: 67 20 2d 31 29 29 20 3b 3b 20 28 64 62 3a 67 65 g -1)) ;; (db:ge
1310: 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 t-count-tests-ru
1320: 6e 6e 69 6e 67 20 64 62 29 29 29 0a 09 28 69 66 nning db)))..(if
1330: 20 28 6f 72 20 28 3e 20 6e 75 6d 72 75 6e 6e 69 (or (> numrunni
1340: 6e 67 20 30 29 0a 09 09 28 3e 20 28 2b 20 2a 6c ng 0)...(> (+ *l
1350: 61 73 74 2d 64 62 2d 61 63 63 65 73 73 2a 20 36 ast-db-access* 6
1360: 30 29 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 0)(current-secon
1370: 64 73 29 29 29 0a 09 20 20 20 20 28 62 65 67 69 ds))).. (begi
1380: 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a n.. (debug:
1390: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
13a0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
13b0: 22 53 65 72 76 65 72 20 63 6f 6e 74 69 6e 75 69 "Server continui
13c0: 6e 67 2c 20 74 65 73 74 73 20 72 75 6e 6e 69 6e ng, tests runnin
13d0: 67 3a 20 22 20 6e 75 6d 72 75 6e 6e 69 6e 67 20 g: " numrunning
13e0: 22 2c 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 ", seconds since
13f0: 20 6c 61 73 74 20 64 62 20 61 63 63 65 73 73 3a last db access:
1400: 20 22 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 " (- (current-s
1410: 65 63 6f 6e 64 73 29 20 2a 6c 61 73 74 2d 64 62 econds) *last-db
1420: 2d 61 63 63 65 73 73 2a 29 29 0a 09 20 20 20 20 -access*))..
1430: 20 20 28 6c 6f 6f 70 20 28 2b 20 31 20 63 6f 75 (loop (+ 1 cou
1440: 6e 74 29 29 29 0a 09 20 20 20 20 28 62 65 67 69 nt))).. (begi
1450: 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a n.. (debug:
1460: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
1470: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1480: 22 53 74 61 72 74 69 6e 67 20 74 6f 20 73 68 75 "Starting to shu
1490: 74 64 6f 77 6e 20 74 68 65 20 73 65 72 76 65 72 tdown the server
14a0: 20 73 69 64 65 22 29 0a 09 20 20 20 20 20 20 28 side").. (
14b0: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 open-run-close t
14c0: 61 73 6b 73 3a 73 65 72 76 65 72 2d 64 65 6c 65 asks:server-dele
14d0: 74 65 2d 72 65 63 6f 72 64 20 74 61 73 6b 73 3a te-record tasks:
14e0: 6f 70 65 6e 2d 64 62 20 73 65 72 76 65 72 2d 69 open-db server-i
14f0: 64 20 22 20 72 70 63 2d 74 72 61 6e 73 70 6f 72 d " rpc-transpor
1500: 74 3a 74 72 79 2d 73 74 61 72 74 2d 73 65 72 76 t:try-start-serv
1510: 65 72 20 73 74 6f 70 22 29 0a 09 20 20 20 20 20 er stop")..
1520: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
1530: 31 30 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 10).. (debu
1540: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
1550: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1560: 2a 20 22 4d 61 78 20 63 61 63 68 65 64 20 71 75 * "Max cached qu
1570: 65 72 69 65 73 20 77 61 73 20 22 20 2a 6d 61 78 eries was " *max
1580: 2d 63 61 63 68 65 2d 73 69 7a 65 2a 29 0a 09 20 -cache-size*)..
1590: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
15a0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
15b0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 t-log-port* "Ser
15c0: 76 65 72 20 73 68 75 74 64 6f 77 6e 20 63 6f 6d ver shutdown com
15d0: 70 6c 65 74 65 2e 20 45 78 69 74 69 6e 67 22 29 plete. Exiting")
15e0: 0a 09 20 20 20 20 20 20 29 29 29 29 29 29 0a 0a .. ))))))..
15f0: 28 64 65 66 69 6e 65 20 28 72 70 63 2d 74 72 61 (define (rpc-tra
1600: 6e 73 70 6f 72 74 3a 66 69 6e 64 2d 66 72 65 65 nsport:find-free
1610: 2d 70 6f 72 74 2d 61 6e 64 2d 6f 70 65 6e 20 70 -port-and-open p
1620: 6f 72 74 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 ort). (handle-e
1630: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e xceptions. exn
1640: 0a 09 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 .. (begin.
1650: 28 70 72 69 6e 74 20 22 46 61 69 6c 65 64 20 74 (print "Failed t
1660: 6f 20 62 69 6e 64 20 74 6f 20 70 6f 72 74 20 22 o bind to port "
1670: 20 28 72 70 63 3a 64 65 66 61 75 6c 74 2d 73 65 (rpc:default-se
1680: 72 76 65 72 2d 70 6f 72 74 29 20 22 2c 20 74 72 rver-port) ", tr
1690: 79 69 6e 67 20 6e 65 78 74 20 70 6f 72 74 22 29 ying next port")
16a0: 0a 20 20 20 20 20 28 72 70 63 2d 74 72 61 6e 73 . (rpc-trans
16b0: 70 6f 72 74 3a 66 69 6e 64 2d 66 72 65 65 2d 70 port:find-free-p
16c0: 6f 72 74 2d 61 6e 64 2d 6f 70 65 6e 20 28 2b 20 ort-and-open (+
16d0: 70 6f 72 74 20 31 29 29 29 0a 20 20 20 28 72 70 port 1))). (rp
16e0: 63 3a 64 65 66 61 75 6c 74 2d 73 65 72 76 65 72 c:default-server
16f0: 2d 70 6f 72 74 20 70 6f 72 74 29 0a 20 20 20 28 -port port). (
1700: 74 63 70 2d 72 65 61 64 2d 74 69 6d 65 6f 75 74 tcp-read-timeout
1710: 20 32 34 30 30 30 30 29 0a 20 20 20 28 74 63 70 240000). (tcp
1720: 2d 6c 69 73 74 65 6e 20 28 72 70 63 3a 64 65 66 -listen (rpc:def
1730: 61 75 6c 74 2d 73 65 72 76 65 72 2d 70 6f 72 74 ault-server-port
1740: 29 20 31 30 30 30 30 29 29 29 0a 0a 28 64 65 66 ) 10000)))..(def
1750: 69 6e 65 20 28 72 70 63 2d 74 72 61 6e 73 70 6f ine (rpc-transpo
1760: 72 74 3a 70 69 6e 67 20 72 75 6e 2d 69 64 20 68 rt:ping run-id h
1770: 6f 73 74 20 70 6f 72 74 29 0a 20 20 28 68 61 6e ost port). (han
1780: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 dle-exceptions.
1790: 20 20 65 78 6e 0a 20 20 20 28 62 65 67 69 6e 0a exn. (begin.
17a0: 20 20 20 20 20 28 70 72 69 6e 74 20 22 53 45 52 (print "SER
17b0: 56 45 52 5f 4e 4f 54 5f 46 4f 55 4e 44 22 29 0a VER_NOT_FOUND").
17c0: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 20 (exit 1)).
17d0: 20 20 28 6c 65 74 20 28 28 6c 6f 67 69 6e 2d 72 (let ((login-r
17e0: 65 73 20 28 28 72 70 63 3a 70 72 6f 63 65 64 75 es ((rpc:procedu
17f0: 72 65 20 27 73 65 72 76 65 72 3a 6c 6f 67 69 6e re 'server:login
1800: 20 68 6f 73 74 20 70 6f 72 74 29 20 2a 74 6f 70 host port) *top
1810: 70 61 74 68 2a 29 29 29 0a 20 20 20 20 20 28 69 path*))). (i
1820: 66 20 28 61 6e 64 20 28 6c 69 73 74 3f 20 6c 6f f (and (list? lo
1830: 67 69 6e 2d 72 65 73 29 0a 09 20 20 20 20 20 20 gin-res)..
1840: 28 63 61 72 20 6c 6f 67 69 6e 2d 72 65 73 29 29 (car login-res))
1850: 0a 09 20 28 62 65 67 69 6e 0a 09 20 20 20 28 70 .. (begin.. (p
1860: 72 69 6e 74 20 22 4c 4f 47 49 4e 5f 4f 4b 22 29 rint "LOGIN_OK")
1870: 0a 09 20 20 20 28 65 78 69 74 20 30 29 29 0a 09 .. (exit 0))..
1880: 20 28 62 65 67 69 6e 0a 09 20 20 20 28 70 72 69 (begin.. (pri
1890: 6e 74 20 22 4c 4f 47 49 4e 5f 46 41 49 4c 45 44 nt "LOGIN_FAILED
18a0: 22 29 0a 09 20 20 20 28 65 78 69 74 20 31 29 29 ").. (exit 1))
18b0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 ))))..(define (r
18c0: 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 pc-transport:cli
18d0: 65 6e 74 2d 73 65 74 75 70 20 72 75 6e 2d 69 64 ent-setup run-id
18e0: 20 23 21 6b 65 79 20 28 72 65 6d 74 72 69 65 73 #!key (remtries
18f0: 20 31 30 29 29 0a 20 20 28 69 66 20 2a 72 75 6e 10)). (if *run
1900: 72 65 6d 6f 74 65 2a 0a 20 20 20 20 20 20 28 62 remote*. (b
1910: 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 egin..(debug:pri
1920: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
1930: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 41 ult-log-port* "A
1940: 74 74 65 6d 70 74 20 74 6f 20 63 6f 6e 6e 65 63 ttempt to connec
1950: 74 20 74 6f 20 73 65 72 76 65 72 20 62 75 74 20 t to server but
1960: 61 6c 72 65 61 64 79 20 63 6f 6e 6e 65 63 74 65 already connecte
1970: 64 22 29 0a 09 23 66 29 0a 20 20 20 20 20 20 28 d")..#f). (
1980: 6c 65 74 2a 20 28 28 68 6f 73 74 2d 69 6e 66 6f let* ((host-info
1990: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
19a0: 2f 64 65 66 61 75 6c 74 20 2a 72 75 6e 72 65 6d /default *runrem
19b0: 6f 74 65 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 ote* run-id #f))
19c0: 29 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 ) ;; (open-run-c
19d0: 6c 6f 73 65 20 64 62 3a 67 65 74 2d 76 61 72 20 lose db:get-var
19e0: 23 66 20 22 53 45 52 56 45 52 22 29 29 0a 09 28 #f "SERVER"))..(
19f0: 69 66 20 68 6f 73 74 2d 69 6e 66 6f 0a 09 20 20 if host-info..
1a00: 20 20 28 6c 65 74 20 28 28 69 66 61 63 65 20 20 (let ((iface
1a10: 20 20 28 63 61 72 20 68 6f 73 74 2d 69 6e 66 6f (car host-info
1a20: 29 29 0a 09 09 20 20 28 70 6f 72 74 20 20 20 20 ))... (port
1a30: 20 28 63 61 64 72 20 68 6f 73 74 2d 69 6e 66 6f (cadr host-info
1a40: 29 29 0a 09 09 20 20 28 70 69 6e 67 2d 72 65 73 ))... (ping-res
1a50: 20 28 28 72 70 63 3a 70 72 6f 63 65 64 75 72 65 ((rpc:procedure
1a60: 20 27 73 65 72 76 65 72 3a 6c 6f 67 69 6e 20 68 'server:login h
1a70: 6f 73 74 20 70 6f 72 74 29 20 2a 74 6f 70 70 61 ost port) *toppa
1a80: 74 68 2a 29 29 29 0a 09 20 20 20 20 20 20 28 69 th*))).. (i
1a90: 66 20 70 69 6e 67 2d 72 65 73 0a 09 09 20 20 28 f ping-res... (
1aa0: 6c 65 74 20 28 28 73 65 72 76 65 72 2d 64 61 74 let ((server-dat
1ab0: 20 28 6c 69 73 74 20 69 66 61 63 65 20 70 6f 72 (list iface por
1ac0: 74 20 23 66 20 23 66 20 23 66 29 29 29 0a 09 09 t #f #f #f)))...
1ad0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
1ae0: 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a set! *runremote*
1af0: 20 72 75 6e 2d 69 64 20 73 65 72 76 65 72 2d 64 run-id server-d
1b00: 61 74 29 0a 09 09 20 20 20 20 73 65 72 76 65 72 at)... server
1b10: 2d 64 61 74 29 0a 09 09 20 20 28 62 65 67 69 6e -dat)... (begin
1b20: 0a 09 09 20 20 20 20 28 73 65 72 76 65 72 3a 74 ... (server:t
1b30: 72 79 2d 72 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 ry-running run-i
1b40: 64 29 0a 09 09 20 20 20 20 28 74 68 72 65 61 64 d)... (thread
1b50: 2d 73 6c 65 65 70 21 20 32 29 0a 09 09 20 20 20 -sleep! 2)...
1b60: 20 28 72 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a (rpc-transport:
1b70: 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 72 75 6e client-setup run
1b80: 2d 69 64 20 28 2d 20 72 65 6d 74 72 69 65 73 20 -id (- remtries
1b90: 31 29 29 29 29 29 0a 20 09 20 20 20 20 28 6c 65 1))))). . (le
1ba0: 74 2a 20 28 28 73 65 72 76 65 72 2d 64 62 2d 69 t* ((server-db-i
1bb0: 6e 66 6f 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c nfo (open-run-cl
1bc0: 6f 73 65 20 74 61 73 6b 73 3a 67 65 74 2d 73 65 ose tasks:get-se
1bd0: 72 76 65 72 20 74 61 73 6b 73 3a 6f 70 65 6e 2d rver tasks:open-
1be0: 64 62 20 72 75 6e 2d 69 64 29 29 29 0a 20 09 20 db run-id))). .
1bf0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1c00: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
1c10: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6c 69 t-log-port* "cli
1c20: 65 6e 74 3a 73 65 74 75 70 20 73 65 72 76 65 72 ent:setup server
1c30: 2d 64 61 74 3d 22 20 73 65 72 76 65 72 2d 64 61 -dat=" server-da
1c40: 74 20 22 2c 20 72 65 6d 61 69 6e 69 6e 67 2d 74 t ", remaining-t
1c50: 72 69 65 73 3d 22 20 72 65 6d 61 69 6e 69 6e 67 ries=" remaining
1c60: 2d 74 72 69 65 73 29 0a 09 20 20 20 20 20 20 28 -tries).. (
1c70: 69 66 20 73 65 72 76 65 72 2d 64 62 2d 69 6e 66 if server-db-inf
1c80: 6f 0a 20 09 09 20 20 28 6c 65 74 2a 20 28 28 69 o. .. (let* ((i
1c90: 66 61 63 65 20 20 20 20 20 28 74 61 73 6b 73 3a face (tasks:
1ca0: 68 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 69 6e 74 hostinfo-get-int
1cb0: 65 72 66 61 63 65 20 73 65 72 76 65 72 2d 64 62 erface server-db
1cc0: 2d 69 6e 66 6f 29 29 0a 20 09 09 09 20 28 70 6f -info)). ... (po
1cd0: 72 74 20 20 20 20 20 20 28 74 61 73 6b 73 3a 68 rt (tasks:h
1ce0: 6f 73 74 69 6e 66 6f 2d 67 65 74 2d 70 6f 72 74 ostinfo-get-port
1cf0: 20 20 20 20 20 20 73 65 72 76 65 72 2d 64 62 2d server-db-
1d00: 69 6e 66 6f 29 29 0a 09 09 09 20 28 73 65 72 76 info)).... (serv
1d10: 65 72 2d 64 61 74 20 28 6c 69 73 74 20 69 66 61 er-dat (list ifa
1d20: 63 65 20 70 6f 72 74 20 23 66 20 23 66 20 23 66 ce port #f #f #f
1d30: 29 29 0a 20 09 09 09 20 28 70 69 6e 67 2d 72 65 )). ... (ping-re
1d40: 73 20 20 28 28 72 70 63 3a 70 72 6f 63 65 64 75 s ((rpc:procedu
1d50: 72 65 20 27 73 65 72 76 65 72 3a 6c 6f 67 69 6e re 'server:login
1d60: 20 68 6f 73 74 20 70 6f 72 74 29 20 2a 74 6f 70 host port) *top
1d70: 70 61 74 68 2a 29 29 29 0a 20 09 09 20 20 20 20 path*))). ..
1d80: 28 69 66 20 73 74 61 72 74 2d 72 65 73 0a 20 09 (if start-res. .
1d90: 09 09 28 62 65 67 69 6e 0a 20 09 09 09 20 20 28 ..(begin. ... (
1da0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
1db0: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d *runremote* run-
1dc0: 69 64 20 73 65 72 76 65 72 2d 64 61 74 29 0a 09 id server-dat)..
1dd0: 09 09 20 20 73 65 72 76 65 72 2d 64 61 74 29 0a .. server-dat).
1de0: 09 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 28 ...(begin.... (
1df0: 73 65 72 76 65 72 3a 74 72 79 2d 72 75 6e 6e 69 server:try-runni
1e00: 6e 67 20 72 75 6e 2d 69 64 29 0a 09 09 09 20 20 ng run-id)....
1e10: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 (thread-sleep! 2
1e20: 29 0a 09 09 09 20 20 28 72 70 63 2d 74 72 61 6e ).... (rpc-tran
1e30: 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 73 65 74 sport:client-set
1e40: 75 70 20 72 75 6e 2d 69 64 20 28 2d 20 72 65 6d up run-id (- rem
1e50: 74 72 69 65 73 20 31 29 29 29 29 29 0a 09 09 20 tries 1)))))...
1e60: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 73 (begin... (s
1e70: 65 72 76 65 72 3a 74 72 79 2d 72 75 6e 6e 69 6e erver:try-runnin
1e80: 67 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 20 20 g run-id)...
1e90: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 (thread-sleep! 2
1ea0: 29 0a 09 09 20 20 20 20 28 72 70 63 2d 74 72 61 )... (rpc-tra
1eb0: 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 73 65 nsport:client-se
1ec0: 74 75 70 20 72 75 6e 2d 69 64 20 28 2d 20 72 65 tup run-id (- re
1ed0: 6d 74 72 69 65 73 20 31 29 29 29 29 29 29 29 29 mtries 1))))))))
1ee0: 29 0a 3b 3b 20 0a 3b 3b 20 09 20 20 20 20 20 28 ).;; .;; . (
1ef0: 70 6f 72 74 20 20 20 20 20 28 69 66 20 28 61 6e port (if (an
1f00: 64 20 68 6f 73 74 69 6e 66 6f 20 28 3e 20 28 6c d hostinfo (> (l
1f10: 65 6e 67 74 68 20 68 6f 73 74 64 61 74 29 20 31 ength hostdat) 1
1f20: 29 29 28 63 61 64 72 20 68 6f 73 74 64 61 74 29 ))(cadr hostdat)
1f30: 20 23 66 29 29 29 0a 3b 3b 20 09 28 69 66 20 28 #f))).;; .(if (
1f40: 61 6e 64 20 70 6f 72 74 0a 3b 3b 20 09 09 20 28 and port.;; .. (
1f50: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 string->number p
1f60: 6f 72 74 29 29 0a 3b 3b 20 09 20 20 20 20 28 6c ort)).;; . (l
1f70: 65 74 20 28 28 70 6f 72 74 6e 20 28 73 74 72 69 et ((portn (stri
1f80: 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 6f 72 74 29 ng->number port)
1f90: 29 29 0a 3b 3b 20 09 20 20 20 20 20 20 28 64 65 )).;; . (de
1fa0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 bug:print-info 2
1fb0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1fc0: 72 74 2a 20 22 53 65 74 74 69 6e 67 20 75 70 20 rt* "Setting up
1fd0: 74 6f 20 63 6f 6e 6e 65 63 74 20 74 6f 20 68 6f to connect to ho
1fe0: 73 74 20 22 20 68 6f 73 74 20 22 3a 22 20 70 6f st " host ":" po
1ff0: 72 74 29 0a 3b 3b 20 09 20 20 20 20 20 20 28 68 rt).;; . (h
2000: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
2010: 0a 3b 3b 20 09 20 20 20 20 20 20 20 65 78 6e 0a .;; . exn.
2020: 3b 3b 20 09 20 20 20 20 20 20 20 28 62 65 67 69 ;; . (begi
2030: 6e 0a 3b 3b 20 09 09 20 28 64 65 62 75 67 3a 70 n.;; .. (debug:p
2040: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
2050: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
2060: 22 46 61 69 6c 65 64 20 74 6f 20 6f 70 65 6e 20 "Failed to open
2070: 61 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 74 6f 20 a connection to
2080: 74 68 65 20 73 65 72 76 65 72 20 61 74 20 68 6f the server at ho
2090: 73 74 3a 20 22 20 68 6f 73 74 20 22 20 70 6f 72 st: " host " por
20a0: 74 3a 20 22 20 70 6f 72 74 29 0a 3b 3b 20 09 09 t: " port).;; ..
20b0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
20c0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
20d0: 74 2a 20 22 20 20 20 45 58 43 45 50 54 49 4f 4e t* " EXCEPTION
20e0: 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d : " ((condition-
20f0: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
2100: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
2110: 20 65 78 6e 29 29 0a 3b 3b 20 09 09 20 3b 3b 20 exn)).;; .. ;;
2120: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
2130: 0a 3b 3b 20 09 09 20 3b 3b 20 20 28 6c 61 6d 62 .;; .. ;; (lamb
2140: 64 61 20 28 64 62 20 2e 20 70 61 72 61 6d 29 20 da (db . param)
2150: 0a 3b 3b 20 09 09 20 3b 3b 20 20 20 20 28 73 71 .;; .. ;; (sq
2160: 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 lite3:execute db
2170: 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 6d 65 "DELETE FROM me
2180: 74 61 64 61 74 20 57 48 45 52 45 20 76 61 72 3d tadat WHERE var=
2190: 27 53 45 52 56 45 52 27 22 29 29 0a 3b 3b 20 09 'SERVER'")).;; .
21a0: 09 20 3b 3b 20 20 23 66 29 0a 3b 3b 20 09 09 20 . ;; #f).;; ..
21b0: 28 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 (set! *runremote
21c0: 2a 20 23 66 29 29 0a 3b 3b 20 09 20 20 20 20 20 * #f)).;; .
21d0: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 (if (and (not
21e0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
21f0: 73 65 72 76 65 72 22 29 29 20 3b 3b 20 6e 6f 20 server")) ;; no
2200: 70 6f 69 6e 74 20 69 6e 20 74 68 65 20 73 65 72 point in the ser
2210: 76 65 72 20 75 73 69 6e 67 20 74 68 65 20 73 65 ver using the se
2220: 72 76 65 72 20 75 73 69 6e 67 20 74 68 65 20 73 rver using the s
2230: 65 72 76 65 72 0a 3b 3b 20 09 09 09 28 28 72 70 erver.;; ...((rp
2240: 63 3a 70 72 6f 63 65 64 75 72 65 20 27 73 65 72 c:procedure 'ser
2250: 76 65 72 3a 6c 6f 67 69 6e 20 68 6f 73 74 20 70 ver:login host p
2260: 6f 72 74 6e 29 20 2a 74 6f 70 70 61 74 68 2a 29 ortn) *toppath*)
2270: 29 0a 3b 3b 20 09 09 20 20 20 28 62 65 67 69 6e ).;; .. (begin
2280: 0a 3b 3b 20 09 09 20 20 20 20 20 28 64 65 62 75 .;; .. (debu
2290: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a g:print-info 2 *
22a0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
22b0: 2a 20 22 4c 6f 67 67 65 64 20 69 6e 20 61 6e 64 * "Logged in and
22c0: 20 63 6f 6e 6e 65 63 74 65 64 20 74 6f 20 22 20 connected to "
22d0: 68 6f 73 74 20 22 3a 22 20 70 6f 72 74 29 0a 3b host ":" port).;
22e0: 3b 20 09 09 20 20 20 20 20 28 73 65 74 21 20 2a ; .. (set! *
22f0: 72 75 6e 72 65 6d 6f 74 65 2a 20 28 76 65 63 74 runremote* (vect
2300: 6f 72 20 68 6f 73 74 20 70 6f 72 74 6e 29 29 29 or host portn)))
2310: 0a 3b 3b 20 09 09 20 20 20 28 62 65 67 69 6e 0a .;; .. (begin.
2320: 3b 3b 20 09 09 20 20 20 20 20 28 64 65 62 75 67 ;; .. (debug
2330: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 :print-info 2 *d
2340: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2350: 20 22 46 61 69 6c 65 64 20 74 6f 20 6c 6f 67 69 "Failed to logi
2360: 6e 20 6f 72 20 63 6f 6e 6e 65 63 74 20 74 6f 20 n or connect to
2370: 22 20 68 6f 73 74 20 22 3a 22 20 70 6f 72 74 29 " host ":" port)
2380: 0a 3b 3b 20 09 09 20 20 20 20 20 28 73 65 74 21 .;; .. (set!
2390: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 23 66 29 *runremote* #f)
23a0: 29 29 29 29 0a 3b 3b 20 09 20 20 20 20 28 64 65 )))).;; . (de
23b0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 bug:print-info 2
23c0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
23d0: 72 74 2a 20 22 6e 6f 20 73 65 72 76 65 72 20 61 rt* "no server a
23e0: 76 61 69 6c 61 62 6c 65 22 29 29 29 29 29 0a 0a vailable")))))..