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 36 2c 20 4d 61 74 74 68 65 77 06-2016, 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 28 64 65 66 69 6e 65 20 2a 68 65 61 72 74 62 .(define *heartb
0310: 65 61 74 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 eat-mutex* (make
0320: 2d 6d 75 74 65 78 29 29 0a 28 64 65 66 69 6e 65 -mutex)).(define
0330: 20 2a 73 65 72 76 65 72 2d 6c 6f 6f 70 2d 68 65 *server-loop-he
0340: 61 72 74 2d 62 65 61 74 2a 20 28 63 75 72 72 65 art-beat* (curre
0350: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 0a 0a 3b nt-seconds))...;
0360: 3b 20 70 72 6f 63 73 74 72 20 69 73 20 74 68 65 ; procstr is the
0370: 20 6e 61 6d 65 20 6f 66 20 74 68 65 20 70 72 6f name of the pro
0380: 63 65 64 75 72 65 20 74 6f 20 62 65 20 63 61 6c cedure to be cal
0390: 6c 65 64 20 61 73 20 61 20 73 74 72 69 6e 67 0a led as a string.
03a0: 28 64 65 66 69 6e 65 20 28 72 70 63 2d 74 72 61 (define (rpc-tra
03b0: 6e 73 70 6f 72 74 3a 61 75 74 6f 72 65 6d 6f 74 nsport:autoremot
03c0: 65 20 70 72 6f 63 73 74 72 20 70 61 72 61 6d 73 e procstr params
03d0: 29 20 20 3b 3b 20 6d 61 79 20 62 65 20 75 6e 75 ) ;; may be unu
03e0: 73 65 64 2c 20 49 20 74 68 69 6e 6b 20 61 70 69 sed, I think api
03f0: 2d 65 78 65 63 20 64 65 70 72 65 63 61 74 65 73 -exec deprecates
0400: 20 74 68 69 73 20 6f 6e 65 2e 0a 20 20 28 6c 65 this one.. (le
0410: 74 2a 20 28 28 70 72 6f 63 73 79 6d 20 28 69 66 t* ((procsym (if
0420: 20 28 73 79 6d 62 6f 6c 3f 20 70 72 6f 63 73 74 (symbol? procst
0430: 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 r).
0440: 20 20 20 20 20 20 20 20 70 72 6f 63 73 74 72 0a procstr.
0450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0460: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 (string->sy
0470: 6d 62 6f 6c 20 28 2d 3e 73 74 72 69 6e 67 20 70 mbol (->string p
0480: 72 6f 63 73 74 72 29 29 29 29 0a 20 20 20 20 20 rocstr)))).
0490: 20 20 20 28 72 65 73 0a 20 20 20 20 20 20 20 20 (res.
04a0: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
04b0: 20 20 20 28 61 70 70 6c 79 20 28 65 76 61 6c 20 (apply (eval
04c0: 70 72 6f 63 73 79 6d 29 20 70 61 72 61 6d 73 29 procsym) params)
04d0: 29 29 29 0a 20 20 20 20 72 65 73 29 29 0a 0a 0a ))). res))...
04e0: 3b 3b 20 72 70 63 20 72 65 63 65 69 76 65 72 0a ;; rpc receiver.
04f0: 28 64 65 66 69 6e 65 20 28 72 70 63 2d 74 72 61 (define (rpc-tra
0500: 6e 73 70 6f 72 74 3a 61 70 69 2d 65 78 65 63 20 nsport:api-exec
0510: 63 6d 64 20 70 61 72 61 6d 73 29 0a 20 20 28 6c cmd params). (l
0520: 65 74 2a 20 28 20 28 72 65 73 64 61 74 20 20 28 et* ( (resdat (
0530: 61 70 69 3a 65 78 65 63 75 74 65 2d 72 65 71 75 api:execute-requ
0540: 65 73 74 73 20 2a 69 6e 6d 65 6d 64 62 2a 20 28 ests *inmemdb* (
0550: 76 65 63 74 6f 72 20 63 6d 64 20 70 61 72 61 6d vector cmd param
0560: 73 29 29 29 20 3b 3b 20 23 28 20 66 6c 61 67 20 s))) ;; #( flag
0570: 72 65 73 75 6c 74 20 29 0a 20 20 20 20 20 20 20 result ).
0580: 20 20 20 28 66 6c 61 67 20 20 20 20 28 76 65 63 (flag (vec
0590: 74 6f 72 2d 72 65 66 20 72 65 73 64 61 74 20 30 tor-ref resdat 0
05a0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 72 65 )). (re
05b0: 73 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 s (vector-re
05c0: 66 20 72 65 73 64 61 74 20 31 29 29 29 0a 0a 20 f resdat 1)))..
05d0: 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 (mutex-lock!
05e0: 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 *heartbeat-mutex
05f0: 2a 29 0a 0a 20 20 20 20 28 73 65 74 21 20 2a 6c *).. (set! *l
0600: 61 73 74 2d 64 62 2d 61 63 63 65 73 73 2a 20 28 ast-db-access* (
0610: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
0620: 29 20 3b 3b 20 62 75 6d 70 20 2a 6c 61 73 74 2d ) ;; bump *last-
0630: 64 62 2d 61 63 63 65 73 73 2a 3b 20 74 68 69 73 db-access*; this
0640: 20 77 69 6c 6c 20 72 65 6e 65 77 20 6b 65 65 70 will renew keep
0650: 2d 72 75 6e 6e 69 6e 67 20 74 68 72 65 61 64 27 -running thread'
0660: 73 20 6c 65 61 73 65 20 6f 6e 20 6c 69 66 65 20 s lease on life
0670: 66 6f 72 20 61 6e 6f 74 68 65 72 20 28 73 65 72 for another (ser
0680: 76 65 72 3a 67 65 74 2d 74 69 6d 65 6f 75 74 29 ver:get-timeout)
0690: 20 73 65 63 6f 6e 64 73 0a 20 20 20 20 3b 3b 28 seconds. ;;(
06a0: 42 42 3e 20 22 69 6e 20 61 70 69 2d 65 78 65 63 BB> "in api-exec
06b0: 3b 20 6c 61 73 74 2d 64 62 2d 61 63 63 65 73 73 ; last-db-access
06c0: 20 75 70 64 61 74 65 64 20 74 6f 20 22 2a 6c 61 updated to "*la
06d0: 73 74 2d 64 62 2d 61 63 63 65 73 73 2a 29 0a 20 st-db-access*).
06e0: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
06f0: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
0700: 65 78 2a 29 0a 0a 20 20 20 20 72 65 73 29 29 0a ex*).. res)).
0710: 0a 0a 20 20 3b 3b 20 28 68 61 6e 64 6c 65 2d 65 .. ;; (handle-e
0720: 78 63 65 70 74 69 6f 6e 73 0a 20 20 3b 3b 20 20 xceptions. ;;
0730: 65 78 6e 0a 20 20 3b 3b 20 20 28 62 65 67 69 6e exn. ;; (begin
0740: 0a 20 20 3b 3b 20 20 20 20 28 64 65 62 75 67 3a . ;; (debug:
0750: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
0760: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 65 6d 6f -log-port* "Remo
0770: 74 65 20 66 61 69 6c 65 64 20 66 6f 72 20 22 20 te failed for "
0780: 70 72 6f 63 20 22 20 22 20 70 61 72 61 6d 73 20 proc " " params
0790: 22 20 65 78 6e 3d 22 65 78 6e 29 0a 20 20 3b 3b " exn="exn). ;;
07a0: 20 20 20 20 28 61 70 70 6c 79 20 28 65 76 61 6c (apply (eval
07b0: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
07c0: 20 70 72 6f 63 73 74 72 29 29 20 70 61 72 61 6d procstr)) param
07d0: 73 29 29 0a 20 20 3b 3b 20 20 3b 3b 20 28 69 66 s)). ;; ;; (if
07e0: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 0a 20 20 3b *runremote*. ;
07f0: 3b 20 20 3b 3b 20 20 20 20 28 61 70 70 6c 79 20 ; ;; (apply
0800: 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 (eval (string->s
0810: 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 72 65 6d ymbol (conc "rem
0820: 6f 74 65 3a 22 20 70 72 6f 63 73 74 72 29 29 29 ote:" procstr)))
0830: 20 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 20 28 params). ;; (
0840: 61 70 70 6c 79 20 28 65 76 61 6c 20 28 73 74 72 apply (eval (str
0850: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 ing->symbol proc
0860: 73 74 72 29 29 20 70 61 72 61 6d 73 29 29 29 0a str)) params))).
0870: 0a 3b 3b 20 72 65 74 72 79 20 61 6e 20 6f 70 65 .;; retry an ope
0880: 72 61 74 69 6f 6e 20 28 64 65 70 65 6e 64 73 20 ration (depends
0890: 6f 6e 20 73 72 66 69 2d 31 38 29 0a 3b 3b 20 3d on srfi-18).;; =
08a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08b0: 3d 0a 3b 3b 20 69 64 65 61 20 68 65 72 65 20 69 =.;; idea here i
08c0: 73 20 74 6f 20 61 76 6f 69 64 20 73 70 65 6e 64 s to avoid spend
08d0: 69 6e 67 20 74 69 6d 65 20 6f 6e 20 63 6f 64 69 ing time on codi
08e0: 6e 67 20 72 65 74 72 79 69 6e 67 20 73 6f 6d 65 ng retrying some
08f0: 74 68 69 6e 67 2e 20 20 54 72 79 69 6e 67 20 74 thing. Trying t
0900: 6f 20 62 65 20 67 65 6e 65 72 69 63 20 68 65 72 o be generic her
0910: 65 2e 0a 3b 3b 0a 3b 3b 20 45 78 63 65 70 74 69 e..;;.;; Excepti
0920: 6f 6e 20 68 61 6e 64 6c 69 6e 67 3a 0a 3b 3b 20 on handling:.;;
0930: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0940: 2d 2d 2d 0a 3b 3b 20 69 66 20 65 76 61 6c 75 61 ---.;; if evalua
0950: 74 69 6e 67 20 74 68 65 20 74 68 75 6e 6b 20 72 ting the thunk r
0960: 65 73 75 6c 74 73 20 69 6e 20 65 78 63 65 70 74 esults in except
0970: 69 6f 6e 2c 20 69 74 20 77 69 6c 6c 20 62 65 20 ion, it will be
0980: 72 65 74 72 69 65 64 2e 0a 3b 3b 20 6f 6e 20 6c retried..;; on l
0990: 61 73 74 20 74 72 79 2c 20 69 66 20 66 69 6e 61 ast try, if fina
09a0: 6c 2d 66 61 69 6c 75 72 65 2d 72 65 74 75 72 6e l-failure-return
09b0: 73 2d 61 63 74 75 61 6c 20 69 73 20 74 72 75 65 s-actual is true
09c0: 2c 20 74 68 65 20 65 78 63 65 70 74 69 6f 6e 20 , the exception
09d0: 77 69 6c 6c 20 62 65 20 72 65 2d 74 68 72 6f 77 will be re-throw
09e0: 6e 20 74 6f 20 63 61 6c 6c 65 72 2e 0a 3b 3b 0a n to caller..;;.
09f0: 3b 3b 20 6c 6f 6f 6b 20 61 74 20 6f 70 74 69 6f ;; look at optio
0a00: 6e 73 20 62 65 6c 6f 77 20 23 21 6b 65 79 20 74 ns below #!key t
0a10: 6f 20 73 65 65 20 68 6f 77 20 74 6f 20 63 6f 6e o see how to con
0a20: 66 69 67 75 72 65 20 62 65 68 61 76 69 6f 72 0a figure behavior.
0a30: 3b 3b 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 ;;.;;.(define (r
0a40: 65 74 72 79 2d 74 68 75 6e 6b 0a 20 20 20 20 20 etry-thunk.
0a50: 20 20 20 20 74 68 65 2d 74 68 75 6e 6b 0a 20 20 the-thunk.
0a60: 20 20 20 20 20 20 20 23 21 6b 65 79 20 3b 3b 3b #!key ;;;
0a70: 3b 20 6f 70 74 69 6f 6e 73 20 62 65 6c 6f 77 0a ; options below.
0a80: 20 20 20 20 20 20 20 20 20 28 61 63 63 65 70 74 (accept
0a90: 2d 72 65 73 75 6c 74 3f 20 20 20 28 6c 61 6d 62 -result? (lamb
0aa0: 64 61 20 28 78 29 20 78 29 29 20 3b 3b 20 72 65 da (x) x)) ;; re
0ab0: 74 72 79 20 69 66 20 70 72 65 64 69 63 61 74 65 try if predicate
0ac0: 20 61 70 70 6c 69 65 64 20 74 6f 20 74 68 75 6e applied to thun
0ad0: 6b 27 73 20 72 65 73 75 6c 74 20 69 73 20 66 61 k's result is fa
0ae0: 6c 73 65 20 0a 20 20 20 20 20 20 20 20 20 28 72 lse . (r
0af0: 65 74 72 69 65 73 20 20 20 20 20 20 20 20 20 20 etries
0b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 34 29 20 4)
0b10: 3b 3b 20 68 6f 77 20 6d 61 6e 79 20 74 72 69 65 ;; how many trie
0b20: 73 0a 20 20 20 20 20 20 20 20 20 28 66 61 69 6c s. (fail
0b30: 75 72 65 2d 76 61 6c 75 65 20 20 20 20 20 20 20 ure-value
0b40: 20 20 20 20 20 20 20 20 20 23 66 29 20 3b 3b 20 #f) ;;
0b50: 72 65 74 75 72 6e 20 74 68 69 73 20 6f 6e 20 66 return this on f
0b60: 69 6e 61 6c 20 66 61 69 6c 75 72 65 2c 20 75 6e inal failure, un
0b70: 6c 65 73 73 20 66 6f 6c 6c 6f 77 69 6e 67 20 6f less following o
0b80: 70 74 69 6f 6e 20 69 73 20 65 6e 61 62 6c 65 64 ption is enabled
0b90: 3a 0a 20 20 20 20 20 20 20 20 20 28 66 69 6e 61 :. (fina
0ba0: 6c 2d 66 61 69 6c 75 72 65 2d 72 65 74 75 72 6e l-failure-return
0bb0: 73 2d 61 63 74 75 61 6c 20 23 66 29 20 3b 3b 20 s-actual #f) ;;
0bc0: 6f 6e 20 66 61 69 6c 75 72 65 2c 20 6f 6e 20 74 on failure, on t
0bd0: 68 65 20 6c 61 73 74 20 74 72 79 2c 20 6a 75 73 he last try, jus
0be0: 74 20 72 65 74 75 72 6e 20 74 68 65 20 72 65 73 t return the res
0bf0: 75 6c 74 2c 20 6e 6f 74 20 66 61 69 6c 75 72 65 ult, not failure
0c00: 2d 76 61 6c 75 65 0a 0a 20 20 20 20 20 20 20 20 -value..
0c10: 20 28 72 65 74 72 79 2d 64 65 6c 61 79 20 20 20 (retry-delay
0c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 30 2e 0.
0c30: 31 29 20 3b 3b 20 64 65 6c 61 79 20 62 65 74 77 1) ;; delay betw
0c40: 65 65 6e 20 74 72 69 65 73 0a 20 20 20 20 20 20 een tries.
0c50: 20 20 20 28 62 61 63 6b 2d 6f 66 66 2d 66 61 63 (back-off-fac
0c60: 74 6f 72 20 20 20 20 20 20 20 20 20 20 20 20 20 tor
0c70: 20 20 31 29 20 3b 3b 20 6d 75 6c 74 69 70 6c 79 1) ;; multiply
0c80: 20 72 65 74 72 79 2d 64 65 6c 61 79 20 62 79 20 retry-delay by
0c90: 74 68 69 73 20 66 61 63 74 6f 72 20 6f 6e 20 72 this factor on r
0ca0: 65 74 72 79 0a 20 20 20 20 20 20 20 20 20 28 72 etry. (r
0cb0: 61 6e 64 6f 6d 2d 64 65 6c 61 79 20 20 20 20 20 andom-delay
0cc0: 20 20 20 20 20 20 20 20 20 20 20 30 2e 31 29 20 0.1)
0cd0: 3b 3b 20 61 64 64 20 61 20 72 61 6e 64 6f 6d 20 ;; add a random
0ce0: 70 6f 72 74 69 6f 6e 20 6f 66 20 74 68 69 73 20 portion of this
0cf0: 76 61 6c 75 65 20 74 6f 20 77 61 69 74 0a 0a 20 value to wait..
0d00: 20 20 20 20 20 20 20 20 28 63 68 61 74 74 79 20 (chatty
0d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0d20: 20 20 20 20 20 20 23 66 29 20 3b 3b 20 70 72 69 #f) ;; pri
0d30: 6e 74 20 73 74 61 74 75 73 20 61 73 20 77 65 20 nt status as we
0d40: 67 6f 2c 20 66 6f 72 20 64 65 62 75 67 67 69 6e go, for debuggin
0d50: 67 2e 0a 20 20 20 20 20 20 20 20 20 29 0a 20 20 g.. ).
0d60: 0a 20 20 28 77 68 65 6e 20 63 68 61 74 74 79 20 . (when chatty
0d70: 28 70 72 69 6e 74 29 20 28 70 72 69 6e 74 20 22 (print) (print "
0d80: 45 6e 74 65 72 65 64 20 72 65 74 72 79 2d 74 68 Entered retry-th
0d90: 75 6e 6b 22 29 20 28 70 72 69 6e 74 20 22 2d 3d unk") (print "-=
0da0: 2d 3d 2d 3d 2d 3d 2d 3d 2d 22 29 29 0a 20 20 28 -=-=-=-=-")). (
0db0: 6c 65 74 2a 20 28 28 67 75 61 72 64 65 64 2d 74 let* ((guarded-t
0dc0: 68 75 6e 6b 20 3b 3b 20 77 65 20 61 72 65 20 67 hunk ;; we are g
0dd0: 75 61 72 64 69 6e 67 20 74 68 65 20 74 68 75 6e uarding the thun
0de0: 6b 20 61 67 61 69 6e 73 74 20 65 78 63 65 70 74 k against except
0df0: 69 6f 6e 73 2e 20 20 57 65 20 77 69 6c 6c 20 72 ions. We will r
0e00: 65 63 6f 72 64 20 77 68 65 74 68 65 72 20 72 65 ecord whether re
0e10: 73 75 6c 74 20 6f 66 20 65 76 61 6c 75 61 74 69 sult of evaluati
0e20: 6f 6e 20 69 73 20 61 6e 20 65 78 63 65 70 74 69 on is an excepti
0e30: 6f 6e 20 6f 72 20 61 20 72 65 67 75 6c 61 72 20 on or a regular
0e40: 72 65 73 75 6c 74 2e 0a 20 20 20 20 20 20 20 20 result..
0e50: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 (lambda ().
0e60: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
0e70: 45 58 43 45 50 54 49 4f 4e 20 28 67 65 6e 73 79 EXCEPTION (gensy
0e80: 6d 29 29 20 3b 3b 20 75 73 69 6e 67 20 67 65 6e m)) ;; using gen
0e90: 73 79 6d 20 74 6f 20 61 76 6f 69 64 20 70 6f 74 sym to avoid pot
0ea0: 65 6e 74 69 61 6c 20 63 6f 6c 6c 69 73 69 6f 6e ential collision
0eb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0ec0: 20 20 20 28 72 65 73 0a 20 20 20 20 20 20 20 20 (res.
0ed0: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 (cond
0ee0: 69 74 69 6f 6e 2d 63 61 73 65 0a 20 20 20 20 20 ition-case.
0ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
0f00: 74 68 65 2d 74 68 75 6e 6b 29 20 3b 3b 20 74 68 the-thunk) ;; th
0f10: 69 73 20 69 73 20 77 68 61 74 20 77 65 20 61 72 is is what we ar
0f20: 65 20 67 75 61 72 64 69 6e 67 20 74 68 65 20 65 e guarding the e
0f30: 78 65 63 75 74 69 6f 6e 20 6f 66 0a 20 20 20 20 xecution of.
0f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0f50: 5b 78 20 28 29 20 28 63 6f 6e 73 20 45 58 43 45 [x () (cons EXCE
0f60: 50 54 49 4f 4e 20 78 29 5d 0a 20 20 20 20 20 20 PTION x)].
0f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 29 ))
0f80: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ). (
0f90: 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 cond.
0fa0: 20 20 20 28 28 61 6e 64 20 28 70 61 69 72 3f 20 ((and (pair?
0fb0: 72 65 73 29 20 28 65 71 3f 20 28 63 61 72 20 72 res) (eq? (car r
0fc0: 65 73 29 20 45 58 43 45 50 54 49 4f 4e 29 29 0a es) EXCEPTION)).
0fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
0fe0: 69 66 20 63 68 61 74 74 79 0a 20 20 20 20 20 20 if chatty.
0ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 (pr
1000: 69 6e 74 20 22 20 2d 20 74 68 65 2d 74 68 75 6e int " - the-thun
1010: 6b 20 74 68 72 65 77 20 65 78 63 65 70 74 69 6f k threw exceptio
1020: 6e 20 3e 22 28 63 64 72 20 72 65 73 29 22 3c 22 n >"(cdr res)"<"
1030: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
1040: 20 20 28 63 6f 6e 73 20 27 65 78 63 65 70 74 69 (cons 'excepti
1050: 6f 6e 20 28 63 64 72 20 72 65 73 29 29 29 0a 20 on (cdr res))).
1060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
1070: 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 lse.
1080: 20 20 20 20 28 69 66 20 63 68 61 74 74 79 0a 20 (if chatty.
1090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10a0: 20 20 20 28 70 72 69 6e 74 20 22 20 2d 20 74 68 (print " - th
10b0: 65 2d 74 68 75 6e 6b 20 72 65 74 75 72 6e 65 64 e-thunk returned
10c0: 20 72 65 73 75 6c 74 20 3e 22 72 65 73 22 3c 22 result >"res"<"
10d0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
10e0: 20 20 20 28 63 6f 6e 73 20 27 72 65 67 75 6c 61 (cons 'regula
10f0: 72 2d 72 65 73 75 6c 74 20 72 65 73 29 29 29 29 r-result res))))
1100: 29 29 29 0a 20 20 20 20 0a 20 20 20 20 28 6c 65 ))). . (le
1110: 74 20 6c 6f 6f 70 20 28 28 67 75 61 72 64 65 64 t loop ((guarded
1120: 2d 72 65 73 20 28 67 75 61 72 64 65 64 2d 74 68 -res (guarded-th
1130: 75 6e 6b 29 29 0a 20 20 20 20 20 20 20 20 20 20 unk)).
1140: 20 20 20 20 20 28 72 65 74 72 69 65 73 2d 6c 65 (retries-le
1150: 66 74 20 72 65 74 72 69 65 73 29 0a 20 20 20 20 ft retries).
1160: 20 20 20 20 20 20 20 20 20 20 20 28 66 61 69 6c (fail
1170: 2d 77 61 69 74 20 72 65 74 72 79 2d 64 65 6c 61 -wait retry-dela
1180: 79 29 29 0a 20 20 20 20 20 20 28 69 66 20 63 68 y)). (if ch
1190: 61 74 74 79 20 28 70 72 69 6e 74 20 22 20 20 20 atty (print "
11a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 22 29 29 0a 20 20 ==========")).
11b0: 20 20 20 20 28 6c 65 74 2a 20 28 28 77 61 69 74 (let* ((wait
11c0: 2d 74 69 6d 65 20 28 2b 20 66 61 69 6c 2d 77 61 -time (+ fail-wa
11d0: 69 74 20 28 2b 20 28 2a 20 66 61 69 6c 2d 77 61 it (+ (* fail-wa
11e0: 69 74 20 62 61 63 6b 2d 6f 66 66 2d 66 61 63 74 it back-off-fact
11f0: 6f 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 or).
1200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1210: 20 20 20 20 20 20 20 20 20 20 20 20 28 2a 20 72 (* r
1220: 61 6e 64 6f 6d 2d 64 65 6c 61 79 0a 20 20 20 20 andom-delay.
1230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1250: 20 20 20 20 20 20 20 28 2f 20 28 72 61 6e 64 6f (/ (rando
1260: 6d 20 31 30 32 34 29 20 31 30 32 34 29 20 29 29 m 1024) 1024) ))
1270: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
1280: 28 72 65 73 2d 74 79 70 65 20 28 63 61 72 20 67 (res-type (car g
1290: 75 61 72 64 65 64 2d 72 65 73 29 29 0a 20 20 20 uarded-res)).
12a0: 20 20 20 20 20 20 20 20 20 20 28 72 65 73 2d 76 (res-v
12b0: 61 6c 75 65 20 28 63 64 72 20 67 75 61 72 64 65 alue (cdr guarde
12c0: 64 2d 72 65 73 29 29 29 0a 20 20 20 20 20 20 20 d-res))).
12d0: 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 (cond.
12e0: 28 28 61 6e 64 20 28 65 71 3f 20 72 65 73 2d 74 ((and (eq? res-t
12f0: 79 70 65 20 27 72 65 67 75 6c 61 72 2d 72 65 73 ype 'regular-res
1300: 75 6c 74 29 20 28 61 63 63 65 70 74 2d 72 65 73 ult) (accept-res
1310: 75 6c 74 3f 20 72 65 73 2d 76 61 6c 75 65 29 29 ult? res-value))
1320: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1330: 20 20 20 20 28 69 66 20 63 68 61 74 74 79 20 28 (if chatty (
1340: 70 72 69 6e 74 20 22 20 2b 20 72 65 74 75 72 6e print " + return
1350: 20 72 65 73 75 6c 74 20 74 68 61 74 20 73 61 74 result that sat
1360: 69 73 66 69 65 64 20 61 63 63 65 70 74 2d 72 65 isfied accept-re
1370: 73 75 6c 74 3f 20 3e 22 72 65 73 2d 76 61 6c 75 sult? >"res-valu
1380: 65 22 3c 22 29 29 0a 20 20 20 20 20 20 20 20 20 e"<")).
1390: 20 20 20 20 20 20 20 20 20 20 72 65 73 2d 76 61 res-va
13a0: 6c 75 65 29 0a 0a 20 20 20 20 20 20 20 20 20 28 lue).. (
13b0: 28 3e 20 72 65 74 72 69 65 73 2d 6c 65 66 74 20 (> retries-left
13c0: 30 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 0). (if
13d0: 20 63 68 61 74 74 79 20 28 70 72 69 6e 74 20 22 chatty (print "
13e0: 20 2d 20 73 6c 65 65 70 20 22 77 61 69 74 2d 74 - sleep "wait-t
13f0: 69 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 ime)).
1400: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 77 (thread-sleep! w
1410: 61 69 74 2d 74 69 6d 65 29 0a 20 20 20 20 20 20 ait-time).
1420: 20 20 20 20 28 69 66 20 63 68 61 74 74 79 20 28 (if chatty (
1430: 70 72 69 6e 74 20 22 20 2b 20 72 65 74 72 79 20 print " + retry
1440: 5b 22 72 65 74 72 69 65 73 2d 6c 65 66 74 22 20 ["retries-left"
1450: 74 72 69 65 73 20 6c 65 66 74 5d 22 29 29 0a 20 tries left]")).
1460: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 (loop (
1470: 67 75 61 72 64 65 64 2d 74 68 75 6e 6b 29 0a 20 guarded-thunk).
1480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1490: 73 75 62 31 20 72 65 74 72 69 65 73 2d 6c 65 66 sub1 retries-lef
14a0: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
14b0: 20 20 20 77 61 69 74 2d 74 69 6d 65 29 29 0a 20 wait-time)).
14c0: 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 .
14d0: 20 20 28 28 65 71 3f 20 72 65 73 2d 74 79 70 65 ((eq? res-type
14e0: 20 27 72 65 67 75 6c 61 72 2d 72 65 73 75 6c 74 'regular-result
14f0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 ). (if
1500: 66 69 6e 61 6c 2d 66 61 69 6c 75 72 65 2d 72 65 final-failure-re
1510: 74 75 72 6e 73 2d 61 63 74 75 61 6c 0a 20 20 20 turns-actual.
1520: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
1530: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
1540: 20 20 28 69 66 20 63 68 61 74 74 79 20 28 70 72 (if chatty (pr
1550: 69 6e 74 20 22 20 2b 20 6c 61 73 74 20 74 72 79 int " + last try
1560: 20 66 61 69 6c 65 64 2d 20 72 65 74 75 72 6e 20 failed- return
1570: 74 68 65 20 72 65 73 75 6c 74 20 3e 22 72 65 73 the result >"res
1580: 2d 76 61 6c 75 65 22 3c 22 29 29 0a 20 20 20 20 -value"<")).
1590: 20 20 20 20 20 20 20 20 20 20 20 20 72 65 73 2d res-
15a0: 76 61 6c 75 65 29 0a 20 20 20 20 20 20 20 20 20 value).
15b0: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
15c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
15d0: 63 68 61 74 74 79 20 28 70 72 69 6e 74 20 22 20 chatty (print "
15e0: 2b 20 6c 61 73 74 20 74 72 79 20 66 61 69 6c 65 + last try faile
15f0: 64 2d 20 72 65 74 75 72 6e 20 63 61 6e 6e 65 64 d- return canned
1600: 20 66 61 69 6c 75 72 65 20 76 61 6c 75 65 20 3e failure value >
1610: 22 66 61 69 6c 75 72 65 2d 76 61 6c 75 65 22 3c "failure-value"<
1620: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
1630: 20 20 66 61 69 6c 75 72 65 2d 76 61 6c 75 65 29 failure-value)
1640: 29 29 0a 20 20 20 20 20 20 20 20 20 0a 20 20 20 )). .
1650: 20 20 20 20 20 20 28 65 6c 73 65 20 3b 3b 20 6e (else ;; n
1660: 6f 20 72 65 74 72 69 65 73 20 6c 65 66 74 3b 20 o retries left;
1670: 72 65 73 75 6c 74 20 77 61 73 20 6e 6f 74 20 61 result was not a
1680: 63 63 65 70 74 65 64 20 61 6e 64 20 72 65 73 2d ccepted and res-
1690: 74 79 70 65 20 63 61 6e 20 6f 6e 6c 79 20 62 65 type can only be
16a0: 20 27 65 78 63 65 70 74 69 6f 6e 0a 20 20 20 20 'exception.
16b0: 20 20 20 20 20 20 28 69 66 20 66 69 6e 61 6c 2d (if final-
16c0: 66 61 69 6c 75 72 65 2d 72 65 74 75 72 6e 73 2d failure-returns-
16d0: 61 63 74 75 61 6c 20 0a 20 20 20 20 20 20 20 20 actual .
16e0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
16f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
1700: 20 63 68 61 74 74 79 20 28 70 72 69 6e 74 20 22 chatty (print "
1710: 20 2b 20 6c 61 73 74 20 74 72 79 20 66 61 69 6c + last try fail
1720: 65 64 20 77 69 74 68 20 65 78 63 65 70 74 69 6f ed with exceptio
1730: 6e 2d 20 72 65 2d 74 68 72 6f 77 20 69 74 20 3e n- re-throw it >
1740: 22 72 65 73 2d 76 61 6c 75 65 22 3c 22 29 29 0a "res-value"<")).
1750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1760: 28 61 62 6f 72 74 20 72 65 73 2d 76 61 6c 75 65 (abort res-value
1770: 29 29 3b 20 72 65 2d 72 61 69 73 65 20 74 68 65 )); re-raise the
1780: 20 65 78 63 65 70 74 69 6f 6e 2e 20 54 4f 44 4f exception. TODO
1790: 3a 20 66 69 6e 64 20 61 20 77 61 79 20 66 6f 72 : find a way for
17a0: 20 63 61 6c 6c 2d 68 69 73 74 6f 72 79 20 74 6f call-history to
17b0: 20 73 68 6f 77 20 61 73 20 74 68 6f 75 67 68 20 show as though
17c0: 66 72 6f 6d 20 65 6e 74 72 79 20 74 6f 20 74 68 from entry to th
17d0: 69 73 20 66 75 6e 63 74 69 6f 6e 0a 20 20 20 20 is function.
17e0: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
17f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1800: 20 28 69 66 20 63 68 61 74 74 79 20 28 70 72 69 (if chatty (pri
1810: 6e 74 20 22 20 2b 20 6c 61 73 74 20 74 72 79 20 nt " + last try
1820: 66 61 69 6c 65 64 20 77 69 74 68 20 65 78 63 65 failed with exce
1830: 70 74 69 6f 6e 2d 20 72 65 74 75 72 6e 20 63 61 ption- return ca
1840: 6e 6e 65 64 20 66 61 69 6c 75 72 65 20 76 61 6c nned failure val
1850: 75 65 20 3e 22 66 61 69 6c 75 72 65 2d 76 61 6c ue >"failure-val
1860: 75 65 22 3c 22 29 29 0a 20 20 20 20 20 20 20 20 ue"<")).
1870: 20 20 20 20 20 20 20 20 66 61 69 6c 75 72 65 2d failure-
1880: 76 61 6c 75 65 29 29 29 29 29 29 29 29 0a 0a 0a value))))))))...
1890: 28 64 65 66 69 6e 65 20 28 72 70 63 2d 74 72 61 (define (rpc-tra
18a0: 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 73 68 nsport:server-sh
18b0: 75 74 64 6f 77 6e 20 73 65 72 76 65 72 2d 69 64 utdown server-id
18c0: 20 72 70 63 3a 6c 69 73 74 65 6e 65 72 20 23 21 rpc:listener #!
18d0: 6b 65 79 20 28 66 72 6f 6d 2d 6f 6e 2d 65 78 69 key (from-on-exi
18e0: 74 20 23 66 29 29 0a 20 20 28 6f 6e 2d 65 78 69 t #f)). (on-exi
18f0: 74 20 28 6c 61 6d 62 64 61 20 28 29 20 23 74 29 t (lambda () #t)
1900: 29 20 3b 3b 20 74 75 72 6e 20 6f 66 66 20 6f 6e ) ;; turn off on
1910: 2d 65 78 69 74 20 73 74 75 66 66 0a 20 20 3b 3b -exit stuff. ;;
1920: 28 74 63 70 2d 63 6c 6f 73 65 20 72 70 63 3a 6c (tcp-close rpc:l
1930: 69 73 74 65 6e 65 72 29 20 3b 3b 20 67 6f 74 74 istener) ;; gott
1940: 61 20 65 78 69 74 20 6e 69 63 65 6c 79 0a 20 20 a exit nicely.
1950: 3b 3b 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d ;;(tasks:server-
1960: 73 65 74 2d 73 74 61 74 65 21 20 28 64 62 3a 64 set-state! (db:d
1970: 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 28 74 61 elay-if-busy (ta
1980: 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 20 73 65 sks:open-db)) se
1990: 72 76 65 72 2d 69 64 20 22 73 74 6f 70 70 65 64 rver-id "stopped
19a0: 22 29 0a 0a 0a 20 20 3b 3b 20 54 4f 44 4f 3a 20 ")... ;; TODO:
19b0: 28 6c 6f 77 29 20 74 68 65 20 66 6f 6c 6c 6f 77 (low) the follow
19c0: 69 6e 67 20 69 73 20 65 78 74 72 61 6f 72 64 69 ing is extraordi
19d0: 6e 61 72 69 74 6c 79 20 73 6c 6f 77 2e 20 20 4d naritly slow. M
19e0: 61 79 62 65 20 77 65 20 64 6f 6e 27 74 20 65 76 aybe we don't ev
19f0: 65 6e 20 6e 65 65 64 20 70 6f 72 74 6c 6f 67 67 en need portlogg
1a00: 65 72 20 66 6f 72 20 72 70 63 20 61 6e 79 77 61 er for rpc anywa
1a10: 79 3f 3f 20 20 74 68 65 20 65 78 63 65 70 74 69 y?? the excepti
1a20: 6f 6e 2d 62 61 73 65 64 20 66 61 69 6c 6f 76 65 on-based failove
1a30: 72 20 77 68 65 6e 20 70 6f 72 74 73 20 61 72 65 r when ports are
1a40: 20 74 61 6b 65 6e 20 69 73 20 66 61 73 74 21 0a taken is fast!.
1a50: 20 20 3b 3b 28 70 6f 72 74 6c 6f 67 67 65 72 3a ;;(portlogger:
1a60: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 open-run-close p
1a70: 6f 72 74 6c 6f 67 67 65 72 3a 73 65 74 2d 70 6f ortlogger:set-po
1a80: 72 74 20 28 72 70 63 3a 64 65 66 61 75 6c 74 2d rt (rpc:default-
1a90: 73 65 72 76 65 72 2d 70 6f 72 74 29 20 22 72 65 server-port) "re
1aa0: 6c 65 61 73 65 64 22 29 0a 20 20 0a 20 20 28 73 leased"). . (s
1ab0: 65 74 21 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 et! *time-to-exi
1ac0: 74 2a 20 23 74 29 0a 20 20 28 69 66 20 2a 69 6e t* #t). (if *in
1ad0: 6d 65 6d 64 62 2a 20 28 64 62 3a 73 79 6e 63 2d memdb* (db:sync-
1ae0: 74 6f 75 63 68 65 64 20 2a 69 6e 6d 65 6d 64 62 touched *inmemdb
1af0: 2a 20 2a 72 75 6e 2d 69 64 2a 20 66 6f 72 63 65 * *run-id* force
1b00: 2d 73 79 6e 63 3a 20 23 74 29 29 0a 0a 0a 20 20 -sync: #t))...
1b10: 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 64 65 (tasks:server-de
1b20: 6c 65 74 65 2d 72 65 63 6f 72 64 20 28 64 62 3a lete-record (db:
1b30: 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 28 74 delay-if-busy (t
1b40: 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 20 73 asks:open-db)) s
1b50: 65 72 76 65 72 2d 69 64 20 22 20 72 70 63 2d 74 erver-id " rpc-t
1b60: 72 61 6e 73 70 6f 72 74 3a 6b 65 65 70 2d 72 75 ransport:keep-ru
1b70: 6e 6e 69 6e 67 20 63 6f 6d 70 6c 65 74 65 22 29 nning complete")
1b80: 0a 20 20 0a 0a 20 20 3b 3b 28 42 42 3e 20 22 42 . .. ;;(BB> "B
1b90: 65 66 6f 72 65 20 28 65 78 69 74 29 20 28 66 72 efore (exit) (fr
1ba0: 6f 6d 2d 6f 6e 2d 65 78 69 74 3d 22 66 72 6f 6d om-on-exit="from
1bb0: 2d 6f 6e 2d 65 78 69 74 22 29 22 29 0a 20 20 28 -on-exit")"). (
1bc0: 75 6e 6c 65 73 73 20 66 72 6f 6d 2d 6f 6e 2d 65 unless from-on-e
1bd0: 78 69 74 20 28 65 78 69 74 29 29 20 20 3b 3b 20 xit (exit)) ;;
1be0: 73 6f 6d 65 74 69 6d 65 73 20 77 65 20 68 61 6e sometimes we han
1bf0: 67 20 28 61 72 6f 75 6e 64 29 20 68 65 72 65 20 g (around) here
1c00: 77 69 74 68 20 31 30 30 25 20 63 70 75 2e 0a 20 with 100% cpu..
1c10: 20 3b 3b 28 42 42 3e 20 22 41 66 74 65 72 22 29 ;;(BB> "After")
1c20: 0a 20 20 3b 3b 20 73 74 72 61 63 65 20 72 65 76 . ;; strace rev
1c30: 65 61 6c 73 20 65 6e 64 6c 65 73 73 3a 0a 20 20 eals endless:.
1c40: 3b 3b 20 67 65 74 72 75 73 61 67 65 28 52 55 53 ;; getrusage(RUS
1c50: 41 47 45 5f 53 45 4c 46 2c 20 7b 72 75 5f 75 74 AGE_SELF, {ru_ut
1c60: 69 6d 65 3d 7b 34 31 33 2c 20 39 31 37 38 36 38 ime={413, 917868
1c70: 7d 2c 20 72 75 5f 73 74 69 6d 65 3d 7b 30 2c 20 }, ru_stime={0,
1c80: 36 30 30 30 33 7d 2c 20 2e 2e 2e 7d 29 20 3d 20 60003}, ...}) =
1c90: 30 0a 20 20 3b 3b 20 67 65 74 72 75 73 61 67 65 0. ;; getrusage
1ca0: 28 52 55 53 41 47 45 5f 53 45 4c 46 2c 20 7b 72 (RUSAGE_SELF, {r
1cb0: 75 5f 75 74 69 6d 65 3d 7b 34 31 34 2c 20 39 38 u_utime={414, 98
1cc0: 37 34 7d 2c 20 72 75 5f 73 74 69 6d 65 3d 7b 30 74}, ru_stime={0
1cd0: 2c 20 36 30 30 30 33 7d 2c 20 2e 2e 2e 7d 29 20 , 60003}, ...})
1ce0: 3d 20 30 0a 20 20 3b 3b 20 67 65 74 72 75 73 61 = 0. ;; getrusa
1cf0: 67 65 28 52 55 53 41 47 45 5f 53 45 4c 46 2c 20 ge(RUSAGE_SELF,
1d00: 7b 72 75 5f 75 74 69 6d 65 3d 7b 34 31 34 2c 20 {ru_utime={414,
1d10: 31 33 38 37 34 7d 2c 20 72 75 5f 73 74 69 6d 65 13874}, ru_stime
1d20: 3d 7b 30 2c 20 36 30 30 30 33 7d 2c 20 2e 2e 2e ={0, 60003}, ...
1d30: 7d 29 20 3d 20 30 0a 20 20 3b 3b 20 67 65 74 72 }) = 0. ;; getr
1d40: 75 73 61 67 65 28 52 55 53 41 47 45 5f 53 45 4c usage(RUSAGE_SEL
1d50: 46 2c 20 7b 72 75 5f 75 74 69 6d 65 3d 7b 34 31 F, {ru_utime={41
1d60: 34 2c 20 31 30 35 38 38 30 7d 2c 20 72 75 5f 73 4, 105880}, ru_s
1d70: 74 69 6d 65 3d 7b 30 2c 20 36 30 30 30 33 7d 2c time={0, 60003},
1d80: 20 2e 2e 2e 7d 29 20 3d 20 30 0a 20 20 3b 3b 20 ...}) = 0. ;;
1d90: 67 65 74 72 75 73 61 67 65 28 52 55 53 41 47 45 getrusage(RUSAGE
1da0: 5f 53 45 4c 46 2c 20 7b 72 75 5f 75 74 69 6d 65 _SELF, {ru_utime
1db0: 3d 7b 34 31 34 2c 20 31 30 39 38 38 30 7d 2c 20 ={414, 109880},
1dc0: 72 75 5f 73 74 69 6d 65 3d 7b 30 2c 20 36 30 30 ru_stime={0, 600
1dd0: 30 33 7d 2c 20 2e 2e 2e 7d 29 20 3d 20 30 0a 20 03}, ...}) = 0.
1de0: 20 3b 3b 20 67 65 74 72 75 73 61 67 65 28 52 55 ;; getrusage(RU
1df0: 53 41 47 45 5f 53 45 4c 46 2c 20 7b 72 75 5f 75 SAGE_SELF, {ru_u
1e00: 74 69 6d 65 3d 7b 34 31 34 2c 20 32 30 31 38 38 time={414, 20188
1e10: 36 7d 2c 20 72 75 5f 73 74 69 6d 65 3d 7b 30 2c 6}, ru_stime={0,
1e20: 20 36 30 30 30 33 7d 2c 20 2e 2e 2e 7d 29 20 3d 60003}, ...}) =
1e30: 20 30 0a 20 20 3b 3b 20 67 65 74 72 75 73 61 67 0. ;; getrusag
1e40: 65 28 52 55 53 41 47 45 5f 53 45 4c 46 2c 20 7b e(RUSAGE_SELF, {
1e50: 72 75 5f 75 74 69 6d 65 3d 7b 34 31 34 2c 20 32 ru_utime={414, 2
1e60: 30 35 38 38 36 7d 2c 20 72 75 5f 73 74 69 6d 65 05886}, ru_stime
1e70: 3d 7b 30 2c 20 36 30 30 30 33 7d 2c 20 2e 2e 2e ={0, 60003}, ...
1e80: 7d 29 20 3d 20 30 0a 20 20 3b 3b 20 67 65 74 72 }) = 0. ;; getr
1e90: 75 73 61 67 65 28 52 55 53 41 47 45 5f 53 45 4c usage(RUSAGE_SEL
1ea0: 46 2c 20 7b 72 75 5f 75 74 69 6d 65 3d 7b 34 31 F, {ru_utime={41
1eb0: 34 2c 20 32 39 37 38 39 32 7d 2c 20 72 75 5f 73 4, 297892}, ru_s
1ec0: 74 69 6d 65 3d 7b 30 2c 20 36 30 30 30 33 7d 2c time={0, 60003},
1ed0: 20 2e 2e 2e 7d 29 20 3d 20 30 0a 20 20 3b 3b 20 ...}) = 0. ;;
1ee0: 67 65 74 72 75 73 61 67 65 28 52 55 53 41 47 45 getrusage(RUSAGE
1ef0: 5f 53 45 4c 46 2c 20 7b 72 75 5f 75 74 69 6d 65 _SELF, {ru_utime
1f00: 3d 7b 34 31 34 2c 20 33 30 31 38 39 32 7d 2c 20 ={414, 301892},
1f10: 72 75 5f 73 74 69 6d 65 3d 7b 30 2c 20 36 30 30 ru_stime={0, 600
1f20: 30 33 7d 2c 20 2e 2e 2e 7d 29 20 3d 20 30 0a 20 03}, ...}) = 0.
1f30: 20 3b 3b 20 67 65 74 72 75 73 61 67 65 28 52 55 ;; getrusage(RU
1f40: 53 41 47 45 5f 53 45 4c 46 2c 20 7b 72 75 5f 75 SAGE_SELF, {ru_u
1f50: 74 69 6d 65 3d 7b 34 31 34 2c 20 33 39 33 38 39 time={414, 39389
1f60: 38 7d 2c 20 72 75 5f 73 74 69 6d 65 3d 7b 30 2c 8}, ru_stime={0,
1f70: 20 36 30 30 30 33 7d 2c 20 2e 2e 2e 7d 29 20 3d 60003}, ...}) =
1f80: 20 30 0a 20 20 3b 3b 20 67 65 74 72 75 73 61 67 0. ;; getrusag
1f90: 65 28 52 55 53 41 47 45 5f 53 45 4c 46 2c 20 7b e(RUSAGE_SELF, {
1fa0: 72 75 5f 75 74 69 6d 65 3d 7b 34 31 34 2c 20 33 ru_utime={414, 3
1fb0: 39 37 38 39 38 7d 2c 20 72 75 5f 73 74 69 6d 65 97898}, ru_stime
1fc0: 3d 7b 30 2c 20 36 30 30 30 33 7d 2c 20 2e 2e 2e ={0, 60003}, ...
1fd0: 7d 29 20 3d 20 30 0a 20 20 3b 3b 20 6d 61 6b 65 }) = 0. ;; make
1fe0: 20 61 20 70 6f 73 74 20 74 6f 20 63 68 69 63 6b a post to chick
1ff0: 65 6e 2d 75 73 65 72 73 20 77 2f 20 68 74 74 70 en-users w/ http
2000: 3a 2f 2f 70 61 73 74 65 2e 63 61 6c 6c 2d 63 63 ://paste.call-cc
2010: 2e 6f 72 67 2f 70 61 73 74 65 3f 69 64 3d 36 30 .org/paste?id=60
2020: 61 34 62 36 36 61 32 39 63 63 66 37 64 31 31 33 a4b66a29ccf7d113
2030: 35 39 65 61 38 36 36 64 62 36 34 32 63 39 37 30 59ea866db642c970
2040: 37 33 35 39 37 38 0a 20 20 28 69 66 20 66 72 6f 735978. (if fro
2050: 6d 2d 6f 6e 2d 65 78 69 74 0a 20 20 20 20 20 20 m-on-exit.
2060: 3b 3b 20 61 76 6f 69 64 20 61 62 6f 76 65 20 63 ;; avoid above c
2070: 6f 6e 64 69 74 69 6f 6e 21 20 20 45 6e 64 20 63 ondition! End c
2080: 75 72 72 65 6e 74 20 70 72 6f 63 65 73 73 20 65 urrent process e
2090: 78 74 65 72 6e 61 6c 6c 79 20 20 73 69 6e 63 65 xternally since
20a0: 20 31 20 69 6e 20 32 30 20 28 65 78 69 74 29 27 1 in 20 (exit)'
20b0: 73 20 72 65 73 75 6c 74 20 69 6e 20 68 75 6e 67 s result in hung
20c0: 2c 20 31 30 30 25 20 63 70 75 20 7a 6f 6d 62 69 , 100% cpu zombi
20d0: 65 73 2e 20 28 73 65 65 20 61 62 6f 76 65 29 0a es. (see above).
20e0: 20 20 20 20 20 20 28 73 79 73 74 65 6d 20 28 63 (system (c
20f0: 6f 6e 63 20 20 22 6b 69 6c 6c 20 2d 39 20 20 22 onc "kill -9 "
2100: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
2110: 2d 69 64 29 29 29 29 0a 20 20 29 0a 0a 0a 3b 3b -id)))). )...;;
2120: 20 61 6c 6c 20 72 6f 75 74 65 73 20 74 68 6f 75 all routes thou
2130: 67 68 20 68 65 72 65 20 65 6e 64 20 69 6e 20 65 gh here end in e
2140: 78 69 74 20 2e 2e 2e 0a 3b 3b 0a 3b 3b 20 73 74 xit ....;;.;; st
2150: 61 72 74 5f 73 65 72 76 65 72 3f 20 0a 3b 3b 0a art_server? .;;.
2160: 28 64 65 66 69 6e 65 20 28 72 70 63 2d 74 72 61 (define (rpc-tra
2170: 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 20 72 75 nsport:launch ru
2180: 6e 2d 69 64 29 0a 20 20 28 73 65 74 21 20 2a 72 n-id). (set! *r
2190: 75 6e 2d 69 64 2a 20 20 20 72 75 6e 2d 69 64 29 un-id* run-id)
21a0: 0a 0a 20 20 3b 3b 20 3b 3b 20 73 65 6e 64 20 74 .. ;; ;; send t
21b0: 6f 20 62 61 63 6b 67 72 6f 75 6e 64 20 69 66 20 o background if
21c0: 72 65 71 75 65 73 74 65 64 0a 20 20 3b 3b 20 28 requested. ;; (
21d0: 77 68 65 6e 20 28 61 72 67 73 3a 67 65 74 2d 61 when (args:get-a
21e0: 72 67 20 22 2d 64 61 65 6d 6f 6e 69 7a 65 22 29 rg "-daemonize")
21f0: 0a 20 20 3b 3b 20 20 20 20 20 28 64 61 65 6d 6f . ;; (daemo
2200: 6e 3a 69 7a 65 29 0a 20 20 3b 3b 20 20 20 20 20 n:ize). ;;
2210: 28 77 68 65 6e 20 2a 61 6c 74 2d 6c 6f 67 2d 66 (when *alt-log-f
2220: 69 6c 65 2a 20 3b 3b 20 77 65 20 73 68 6f 75 6c ile* ;; we shoul
2230: 64 20 72 65 2d 63 6f 6e 6e 65 63 74 20 74 6f 20 d re-connect to
2240: 74 68 69 73 20 70 6f 72 74 2c 20 49 20 74 68 69 this port, I thi
2250: 6e 6b 20 64 61 65 6d 6f 6e 3a 69 7a 65 20 64 69 nk daemon:ize di
2260: 73 72 75 70 74 73 20 69 74 0a 20 20 3b 3b 20 20 srupts it. ;;
2270: 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 65 72 (current-er
2280: 72 6f 72 2d 70 6f 72 74 20 2a 61 6c 74 2d 6c 6f ror-port *alt-lo
2290: 67 2d 66 69 6c 65 2a 29 0a 20 20 3b 3b 20 20 20 g-file*). ;;
22a0: 20 20 20 20 28 63 75 72 72 65 6e 74 2d 6f 75 74 (current-out
22b0: 70 75 74 2d 70 6f 72 74 20 2a 61 6c 74 2d 6c 6f put-port *alt-lo
22c0: 67 2d 66 69 6c 65 2a 29 29 29 0a 0a 20 20 3b 3b g-file*))).. ;;
22d0: 20 64 6f 75 62 6c 65 20 63 68 65 63 6b 20 77 65 double check we
22e0: 20 64 6f 6e 74 20 61 6c 72 61 64 79 20 68 61 76 dont alrady hav
22f0: 65 20 61 20 72 75 6e 6e 69 6e 67 20 73 65 72 76 e a running serv
2300: 65 72 20 66 6f 72 20 74 68 69 73 20 72 75 6e 2d er for this run-
2310: 69 64 0a 20 20 28 77 68 65 6e 20 28 73 65 72 76 id. (when (serv
2320: 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e er:check-if-runn
2330: 69 6e 67 20 72 75 6e 2d 69 64 29 0a 20 20 20 20 ing run-id).
2340: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
2350: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2360: 2a 20 22 49 4e 46 4f 3a 20 53 65 72 76 65 72 20 * "INFO: Server
2370: 66 6f 72 20 72 75 6e 2d 69 64 20 22 20 72 75 6e for run-id " run
2380: 2d 69 64 20 22 20 61 6c 72 65 61 64 79 20 72 75 -id " already ru
2390: 6e 6e 69 6e 67 22 29 0a 20 20 20 20 28 65 78 69 nning"). (exi
23a0: 74 20 30 29 29 0a 0a 20 20 3b 3b 20 6c 65 74 27 t 0)).. ;; let'
23b0: 73 20 67 65 74 20 61 20 73 65 72 76 65 72 2d 69 s get a server-i
23c0: 64 20 66 6f 72 20 74 68 69 73 20 73 65 72 76 65 d for this serve
23d0: 72 0a 20 20 3b 3b 20 20 20 69 66 20 61 74 20 66 r. ;; if at f
23e0: 69 72 73 74 20 77 65 20 64 6f 20 6e 6f 74 20 73 irst we do not s
23f0: 75 63 65 65 64 2c 20 74 72 79 20 33 20 6d 6f 72 uceed, try 3 mor
2400: 65 20 74 69 6d 65 73 2e 0a 20 20 28 6c 65 74 20 e times.. (let
2410: 28 28 73 65 72 76 65 72 2d 69 64 20 28 72 65 74 ((server-id (ret
2420: 72 79 2d 74 68 75 6e 6b 0a 20 20 20 20 20 20 20 ry-thunk.
2430: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 (la
2440: 6d 62 64 61 20 28 29 20 28 74 61 73 6b 73 3a 73 mbda () (tasks:s
2450: 65 72 76 65 72 2d 6c 6f 63 6b 2d 73 6c 6f 74 20 erver-lock-slot
2460: 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 (db:delay-if-bus
2470: 79 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 y (tasks:open-db
2480: 29 29 20 72 75 6e 2d 69 64 20 27 72 70 63 29 29 )) run-id 'rpc))
2490: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
24a0: 20 20 20 20 20 63 68 61 74 74 79 3a 20 23 66 0a chatty: #f.
24b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
24c0: 20 20 20 20 72 65 74 72 69 65 73 3a 20 34 29 29 retries: 4))
24d0: 29 0a 20 20 20 20 28 77 68 65 6e 20 28 6e 6f 74 ). (when (not
24e0: 20 73 65 72 76 65 72 2d 69 64 29 20 3b 3b 20 64 server-id) ;; d
24f0: 61 6e 67 20 77 65 20 63 6f 75 6c 64 6e 27 74 20 ang we couldn't
2500: 67 65 74 20 61 20 73 65 72 76 65 72 2d 69 64 2e get a server-id.
2510: 0a 20 20 20 20 20 20 3b 3b 20 73 69 6e 63 65 20 . ;; since
2520: 77 65 20 64 69 64 6e 27 74 20 67 65 74 20 74 68 we didn't get th
2530: 65 20 73 65 72 76 65 72 20 6c 6f 63 6b 20 77 65 e server lock we
2540: 20 61 72 65 20 67 6f 69 6e 67 20 74 6f 20 63 6c are going to cl
2550: 65 61 6e 20 75 70 20 61 6e 64 20 62 61 69 6c 20 ean up and bail
2560: 6f 75 74 0a 20 20 20 20 20 20 28 64 65 62 75 67 out. (debug
2570: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 :print-info 2 *d
2580: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2590: 20 22 49 4e 46 4f 3a 20 73 65 72 76 65 72 20 70 "INFO: server p
25a0: 69 64 3d 22 20 28 63 75 72 72 65 6e 74 2d 70 72 id=" (current-pr
25b0: 6f 63 65 73 73 2d 69 64 29 20 22 2c 20 68 6f 73 ocess-id) ", hos
25c0: 74 6e 61 6d 65 3d 22 20 28 67 65 74 2d 68 6f 73 tname=" (get-hos
25d0: 74 2d 6e 61 6d 65 29 20 22 20 6e 6f 74 20 73 74 t-name) " not st
25e0: 61 72 74 69 6e 67 20 64 75 65 20 74 6f 20 6f 74 arting due to ot
25f0: 68 65 72 20 63 61 6e 64 69 64 61 74 65 73 20 61 her candidates a
2600: 68 65 61 64 20 69 6e 20 73 74 61 72 74 20 71 75 head in start qu
2610: 65 75 65 22 29 0a 20 20 20 20 20 20 28 74 61 73 eue"). (tas
2620: 6b 73 3a 73 65 72 76 65 72 2d 64 65 6c 65 74 65 ks:server-delete
2630: 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d 74 68 69 -records-for-thi
2640: 73 2d 70 69 64 20 28 64 62 3a 64 65 6c 61 79 2d s-pid (db:delay-
2650: 69 66 2d 62 75 73 79 20 28 74 61 73 6b 73 3a 6f if-busy (tasks:o
2660: 70 65 6e 2d 64 62 29 29 20 22 20 72 70 63 2d 74 pen-db)) " rpc-t
2670: 72 61 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 22 ransport:launch"
2680: 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 31 29 ). (exit 1)
2690: 29 0a 0a 20 20 20 20 3b 3b 20 77 65 20 67 6f 74 ).. ;; we got
26a0: 20 61 20 73 65 72 76 65 72 2d 69 64 20 28 61 6e a server-id (an
26b0: 64 20 61 20 63 6f 72 72 65 73 70 6f 6e 64 69 6e d a correspondin
26c0: 67 20 65 6e 74 72 79 20 69 6e 20 73 65 72 76 65 g entry in serve
26d0: 72 73 20 74 61 62 6c 65 20 69 6e 20 67 6c 6f 62 rs table in glob
26e0: 61 6c 6c 79 20 73 68 61 72 65 64 20 6d 64 62 29 ally shared mdb)
26f0: 0a 20 20 20 20 3b 3b 20 61 6c 6c 20 73 79 73 74 . ;; all syst
2700: 65 6d 73 20 67 6f 2e 20 20 50 72 6f 63 65 65 64 ems go. Proceed
2710: 20 74 6f 20 73 65 74 75 70 20 72 70 63 20 73 65 to setup rpc se
2720: 72 76 65 72 2e 20 20 0a 20 20 20 20 28 72 70 63 rver. . (rpc
2730: 2d 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 0a 20 -transport:run.
2740: 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 (if (args:ge
2750: 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 t-arg "-server")
2760: 0a 20 20 20 20 20 20 20 20 20 28 61 72 67 73 3a . (args:
2770: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
2780: 22 29 0a 20 20 20 20 20 20 20 20 20 22 2d 22 29 "). "-")
2790: 0a 20 20 20 20 20 72 75 6e 2d 69 64 0a 20 20 20 . run-id.
27a0: 20 20 73 65 72 76 65 72 2d 69 64 29 0a 20 20 20 server-id).
27b0: 20 28 65 78 69 74 29 29 29 0a 0a 28 64 65 66 69 (exit)))..(defi
27c0: 6e 65 20 2a 72 70 63 2d 6c 69 73 74 65 6e 65 72 ne *rpc-listener
27d0: 2d 70 6f 72 74 2a 20 23 66 29 0a 28 64 65 66 69 -port* #f).(defi
27e0: 6e 65 20 2a 72 70 63 2d 6c 69 73 74 65 6e 65 72 ne *rpc-listener
27f0: 2d 70 6f 72 74 2d 62 69 6e 64 2d 74 69 6d 65 73 -port-bind-times
2800: 74 61 6d 70 2a 20 23 66 29 0a 0a 28 64 65 66 69 tamp* #f)..(defi
2810: 6e 65 20 2a 6f 6e 2d 65 78 69 74 2d 66 6c 61 67 ne *on-exit-flag
2820: 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 #f)..(define (r
2830: 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 pc-transport:ser
2840: 76 65 72 2d 64 61 74 2d 67 65 74 2d 69 66 61 63 ver-dat-get-ifac
2850: 65 20 20 20 20 20 20 20 20 20 76 65 63 29 20 20 e vec)
2860: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 76 (vector-ref v
2870: 65 63 20 30 29 29 0a 28 64 65 66 69 6e 65 20 28 ec 0)).(define (
2880: 72 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 rpc-transport:se
2890: 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 70 6f 72 rver-dat-get-por
28a0: 74 20 20 20 20 20 20 20 20 20 20 76 65 63 29 20 t vec)
28b0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
28c0: 76 65 63 20 31 29 29 0a 28 64 65 66 69 6e 65 20 vec 1)).(define
28d0: 28 72 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a 73 (rpc-transport:s
28e0: 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 6c 61 erver-dat-get-la
28f0: 73 74 2d 61 63 63 65 73 73 20 20 20 76 65 63 29 st-access vec)
2900: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
2910: 20 76 65 63 20 35 29 29 0a 28 64 65 66 69 6e 65 vec 5)).(define
2920: 20 28 72 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a (rpc-transport:
2930: 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 74 server-dat-get-t
2940: 72 61 6e 73 70 6f 72 74 20 20 20 20 20 76 65 63 ransport vec
2950: 29 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (vector-ref
2960: 20 20 76 65 63 20 36 29 29 0a 28 64 65 66 69 6e vec 6)).(defin
2970: 65 20 28 72 70 63 2d 74 72 61 6e 73 70 6f 72 74 e (rpc-transport
2980: 3a 73 65 72 76 65 72 2d 64 61 74 2d 75 70 64 61 :server-dat-upda
2990: 74 65 2d 6c 61 73 74 2d 61 63 63 65 73 73 20 76 te-last-access v
29a0: 65 63 29 0a 20 20 28 69 66 20 28 76 65 63 74 6f ec). (if (vecto
29b0: 72 3f 20 76 65 63 29 0a 20 20 20 20 20 20 28 76 r? vec). (v
29c0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 35 ector-set! vec 5
29d0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
29e0: 73 29 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e s)). (begin
29f0: 0a 09 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 ..(print-call-ch
2a00: 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 ain (current-err
2a10: 6f 72 2d 70 6f 72 74 29 29 0a 09 28 64 65 62 75 or-port))..(debu
2a20: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
2a30: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2a40: 74 2a 20 22 63 61 6c 6c 20 74 6f 20 72 70 63 2d t* "call to rpc-
2a50: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
2a60: 2d 64 61 74 2d 75 70 64 61 74 65 2d 6c 61 73 74 -dat-update-last
2a70: 2d 61 63 63 65 73 73 20 77 69 74 68 20 6e 6f 6e -access with non
2a80: 2d 76 65 63 74 6f 72 21 21 22 29 29 29 29 0a 0a -vector!!"))))..
2a90: 0a 28 64 65 66 69 6e 65 20 2a 61 70 69 2d 65 78 .(define *api-ex
2aa0: 65 63 2d 68 74 2a 20 28 6d 61 6b 65 2d 68 61 73 ec-ht* (make-has
2ab0: 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 69 6e h-table)).(defin
2ac0: 65 20 2a 61 70 69 2d 65 78 65 63 2d 6d 75 74 65 e *api-exec-mute
2ad0: 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 x* (make-mutex))
2ae0: 0a 3b 3b 20 6c 65 74 27 73 20 73 65 65 20 69 66 .;; let's see if
2af0: 20 63 61 63 68 69 6e 67 20 74 68 65 20 72 70 63 caching the rpc
2b00: 20 73 74 75 62 20 63 75 72 62 73 20 74 68 72 65 stub curbs thre
2b10: 61 64 2d 70 72 6f 66 75 73 69 6f 6e 20 6f 6e 20 ad-profusion on
2b20: 73 65 72 76 65 72 20 73 69 64 65 0a 28 64 65 66 server side.(def
2b30: 69 6e 65 20 28 72 70 63 2d 74 72 61 6e 73 70 6f ine (rpc-transpo
2b40: 72 74 3a 67 65 74 2d 61 70 69 2d 65 78 65 63 20 rt:get-api-exec
2b50: 69 66 61 63 65 20 70 6f 72 74 29 0a 20 20 28 6d iface port). (m
2b60: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 61 70 69 2d utex-lock! *api-
2b70: 65 78 65 63 2d 6d 75 74 65 78 2a 29 0a 20 20 28 exec-mutex*). (
2b80: 6c 65 74 2a 20 28 28 6c 75 20 28 68 61 73 68 2d let* ((lu (hash-
2b90: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
2ba0: 74 20 2a 61 70 69 2d 65 78 65 63 2d 68 74 2a 20 t *api-exec-ht*
2bb0: 28 63 6f 6e 73 20 69 66 61 63 65 20 20 70 6f 72 (cons iface por
2bc0: 74 29 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 t) #f))). (if
2bd0: 20 6c 75 0a 20 20 20 20 20 20 20 20 28 62 65 67 lu. (beg
2be0: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 28 6d 75 in. (mu
2bf0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 61 70 69 tex-unlock! *api
2c00: 2d 65 78 65 63 2d 6d 75 74 65 78 2a 29 0a 20 20 -exec-mutex*).
2c10: 20 20 20 20 20 20 20 20 6c 75 29 0a 20 20 20 20 lu).
2c20: 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 (let ((res (
2c30: 72 70 63 3a 70 72 6f 63 65 64 75 72 65 20 27 61 rpc:procedure 'a
2c40: 70 69 2d 65 78 65 63 20 69 66 61 63 65 20 70 6f pi-exec iface po
2c50: 72 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 rt))).
2c60: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
2c70: 20 2a 61 70 69 2d 65 78 65 63 2d 68 74 2a 20 28 *api-exec-ht* (
2c80: 63 6f 6e 73 20 69 66 61 63 65 20 70 6f 72 74 29 cons iface port)
2c90: 20 72 65 73 29 0a 20 20 20 20 20 20 20 20 20 20 res).
2ca0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
2cb0: 61 70 69 2d 65 78 65 63 2d 6d 75 74 65 78 2a 29 api-exec-mutex*)
2cc0: 0a 20 20 20 20 20 20 20 20 20 20 72 65 73 29 29 . res))
2cd0: 29 29 0a 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ))..;;;;;;;;;;;;
2ce0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2cf0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2d00: 3b 3b 3b 3b 3b 3b 0a 3b 3b 20 74 68 69 73 20 63 ;;;;;;.;; this c
2d10: 6c 69 65 6e 74 2d 73 69 64 65 20 70 72 6f 63 65 lient-side proce
2d20: 64 75 72 65 20 6d 61 6b 65 73 20 72 70 63 20 63 dure makes rpc c
2d30: 61 6c 6c 20 74 6f 20 73 65 72 76 65 72 20 61 6e all to server an
2d40: 64 20 72 65 74 75 72 6e 73 20 72 65 73 75 6c 74 d returns result
2d50: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 70 63 .;;.(define (rpc
2d60: 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e -transport:clien
2d70: 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 t-api-send-recei
2d80: 76 65 20 72 75 6e 2d 69 64 20 73 65 72 76 65 72 ve run-id server
2d90: 64 61 74 20 63 6d 64 20 70 61 72 61 6d 73 20 23 dat cmd params #
2da0: 21 6b 65 79 20 28 6e 75 6d 72 65 74 72 69 65 73 !key (numretries
2db0: 20 33 29 29 0a 20 20 3b 3b 28 42 42 3e 20 22 65 3)). ;;(BB> "e
2dc0: 6e 74 65 72 65 64 20 72 70 63 2d 74 72 61 6e 73 ntered rpc-trans
2dd0: 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d port:client-api-
2de0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 77 69 74 send-receive wit
2df0: 68 20 72 75 6e 2d 69 64 3d 22 72 75 6e 2d 69 64 h run-id="run-id
2e00: 20 22 20 73 65 72 76 65 72 64 61 74 3d 22 73 65 " serverdat="se
2e10: 72 76 65 72 64 61 74 22 20 63 6d 64 3d 22 63 6d rverdat" cmd="cm
2e20: 64 22 20 70 61 72 61 6d 73 3d 22 70 61 72 61 6d d" params="param
2e30: 73 22 20 6e 75 6d 72 65 74 72 69 65 73 3d 22 6e s" numretries="n
2e40: 75 6d 72 65 74 72 69 65 73 29 0a 20 20 28 69 66 umretries). (if
2e50: 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 73 (not (vector? s
2e60: 65 72 76 65 72 64 61 74 29 29 0a 20 20 20 20 20 erverdat)).
2e70: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
2e80: 28 42 42 3e 20 22 57 48 41 54 3f 3f 20 66 6f 72 (BB> "WHAT?? for
2e90: 20 72 75 6e 2d 69 64 3d 22 72 75 6e 2d 69 64 22 run-id="run-id"
2ea0: 2c 20 73 65 72 76 65 72 64 61 74 3d 22 73 65 72 , serverdat="ser
2eb0: 76 65 72 64 61 74 29 0a 20 20 20 20 20 20 20 20 verdat).
2ec0: 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 (print-call-chai
2ed0: 6e 29 0a 20 20 20 20 20 20 20 20 28 65 78 69 74 n). (exit
2ee0: 20 31 29 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 1))). (let* ((
2ef0: 69 66 61 63 65 20 28 72 70 63 2d 74 72 61 6e 73 iface (rpc-trans
2f00: 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
2f10: 67 65 74 2d 69 66 61 63 65 20 73 65 72 76 65 72 get-iface server
2f20: 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 28 dat)). (
2f30: 70 6f 72 74 20 20 28 72 70 63 2d 74 72 61 6e 73 port (rpc-trans
2f40: 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
2f50: 67 65 74 2d 70 6f 72 74 20 73 65 72 76 65 72 64 get-port serverd
2f60: 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 at)). (r
2f70: 65 73 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 es #f).
2f80: 28 61 70 69 2d 65 78 65 63 20 28 72 70 63 2d 74 (api-exec (rpc-t
2f90: 72 61 6e 73 70 6f 72 74 3a 67 65 74 2d 61 70 69 ransport:get-api
2fa0: 2d 65 78 65 63 20 69 66 61 63 65 20 70 6f 72 74 -exec iface port
2fb0: 29 29 20 20 3b 3b 20 63 68 61 63 68 65 64 20 62 )) ;; chached b
2fc0: 79 20 68 6f 73 74 2f 70 6f 72 74 2e 20 6d 61 79 y host/port. may
2fd0: 20 6e 65 65 64 20 74 6f 20 63 6c 65 61 72 2e 2e need to clear..
2fe0: 2e 0a 20 20 20 20 20 20 20 20 20 28 73 65 6e 64 .. (send
2ff0: 2d 72 65 63 65 69 76 65 20 28 6c 61 6d 62 64 61 -receive (lambda
3000: 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ().
3010: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 63 (tc
3020: 70 2d 62 75 66 66 65 72 2d 73 69 7a 65 20 30 29 p-buffer-size 0)
3030: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3040: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
3050: 72 65 73 20 28 72 65 74 72 79 2d 74 68 75 6e 6b res (retry-thunk
3060: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3080: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
3090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
30a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
30b0: 20 20 20 20 20 20 28 63 6f 6e 64 69 74 69 6f 6e (condition
30c0: 2d 63 61 73 65 0a 20 20 20 20 20 20 20 20 20 20 -case.
30d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
30e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 28 ;;(
30f0: 76 65 63 74 6f 72 20 23 74 20 28 72 75 6e 2d 72 vector #t (run-r
3100: 65 6d 6f 74 65 20 63 6d 64 20 70 61 72 61 6d 73 emote cmd params
3110: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
3120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3130: 20 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f (vecto
3140: 72 20 27 73 75 63 63 65 73 73 20 28 61 70 69 2d r 'success (api-
3150: 65 78 65 63 20 63 6d 64 20 70 61 72 61 6d 73 29 exec cmd params)
3160: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3180: 20 20 20 20 20 20 20 20 20 5b 78 20 28 65 78 6e [x (exn
3190: 20 69 2f 6f 20 6e 65 74 29 20 28 76 65 63 74 6f i/o net) (vecto
31a0: 72 20 27 63 6f 6d 6d 73 2d 66 61 69 6c 20 28 63 r 'comms-fail (c
31b0: 6f 6e 63 20 22 63 6f 6d 6d 75 6e 69 63 61 74 69 onc "communicati
31c0: 6f 6e 73 20 66 61 69 6c 20 5b 22 28 2d 3e 73 74 ons fail ["(->st
31d0: 72 69 6e 67 20 78 29 22 5d 22 29 20 78 29 5d 0a ring x)"]") x)].
31e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
31f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3200: 20 20 20 20 20 20 20 5b 78 20 28 29 20 28 76 65 [x () (ve
3210: 63 74 6f 72 20 27 6f 74 68 65 72 2d 66 61 69 6c ctor 'other-fail
3220: 20 22 6f 74 68 65 72 20 66 61 69 6c 20 5b 22 28 "other fail ["(
3230: 2d 3e 73 74 72 69 6e 67 20 78 29 22 5d 22 20 78 ->string x)"]" x
3240: 29 5d 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )])).
3250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3260: 20 20 20 20 20 20 20 20 20 63 68 61 74 74 79 3a chatty:
3270: 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 #f.
3280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3290: 20 20 20 20 20 20 20 20 61 63 63 65 70 74 2d 72 accept-r
32a0: 65 73 75 6c 74 3f 3a 20 28 6c 61 6d 62 64 61 28 esult?: (lambda(
32b0: 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 x).
32c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
32d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
32e0: 20 20 20 20 20 20 20 20 20 28 61 6e 64 20 28 76 (and (v
32f0: 65 63 74 6f 72 3f 20 78 29 20 28 76 65 63 74 6f ector? x) (vecto
3300: 72 2d 72 65 66 20 78 20 30 29 29 29 0a 20 20 20 r-ref x 0))).
3310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3330: 20 72 65 74 72 69 65 73 3a 20 38 0a 20 20 20 20 retries: 8.
3340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3360: 62 61 63 6b 2d 6f 66 66 2d 66 61 63 74 6f 72 3a back-off-factor:
3370: 20 31 2e 35 0a 20 20 20 20 20 20 20 20 20 20 20 1.5.
3380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3390: 20 20 20 20 20 20 20 20 20 72 61 6e 64 6f 6d 2d random-
33a0: 77 61 69 74 3a 20 30 2e 32 0a 20 20 20 20 20 20 wait: 0.2.
33b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
33c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 72 65 re
33d0: 74 72 79 2d 64 65 6c 61 79 3a 20 30 2e 31 0a 20 try-delay: 0.1.
33e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
33f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3400: 20 20 20 66 69 6e 61 6c 2d 66 61 69 6c 75 72 65 final-failure
3410: 2d 72 65 74 75 72 6e 73 2d 61 63 74 75 61 6c 3a -returns-actual:
3420: 20 23 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 #t)).
3430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
3440: 3b 28 42 42 3e 20 22 48 45 59 20 72 65 73 3d 22 ;(BB> "HEY res="
3450: 72 65 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 res).
3460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 72 65 re
3470: 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s.
3480: 20 20 20 20 20 20 20 20 20 20 20 29 29 0a 20 20 )).
3490: 20 20 20 20 20 20 20 28 74 68 31 20 28 6d 61 6b (th1 (mak
34a0: 65 2d 74 68 72 65 61 64 20 73 65 6e 64 2d 72 65 e-thread send-re
34b0: 63 65 69 76 65 20 22 73 65 6e 64 2d 72 65 63 65 ceive "send-rece
34c0: 69 76 65 22 29 29 0a 20 20 20 20 20 20 20 20 20 ive")).
34d0: 28 74 69 6d 65 2d 6f 75 74 2d 72 65 61 63 68 65 (time-out-reache
34e0: 64 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 28 d #f). (
34f0: 74 69 6d 65 2d 6f 75 74 20 20 20 20 20 28 6c 61 time-out (la
3500: 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 mbda ()....
3510: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
3520: 34 35 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 45).
3530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3540: 20 20 28 73 65 74 21 20 74 69 6d 65 2d 6f 75 74 (set! time-out
3550: 2d 72 65 61 63 68 65 64 20 23 74 29 0a 20 20 20 -reached #t).
3560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3570: 20 20 20 20 20 20 20 20 20 20 20 28 74 68 72 65 (thre
3580: 61 64 2d 74 65 72 6d 69 6e 61 74 65 21 20 74 68 ad-terminate! th
3590: 31 29 0a 09 09 09 20 20 20 20 20 20 23 66 29 29 1).... #f))
35a0: 0a 0a 20 20 20 20 20 20 20 20 20 28 74 68 32 20 .. (th2
35b0: 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 74 69 6d (make-thread tim
35c0: 65 2d 6f 75 74 20 20 20 20 20 22 74 69 6d 65 20 e-out "time
35d0: 6f 75 74 22 29 29 29 0a 09 20 28 74 68 72 65 61 out"))).. (threa
35e0: 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a 09 20 d-start! th1)..
35f0: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
3600: 68 32 29 0a 09 20 28 74 68 72 65 61 64 2d 6a 6f h2).. (thread-jo
3610: 69 6e 21 20 74 68 31 29 0a 09 20 28 74 68 72 65 in! th1).. (thre
3620: 61 64 2d 74 65 72 6d 69 6e 61 74 65 21 20 74 68 ad-terminate! th
3630: 32 29 0a 20 20 20 20 20 20 20 20 20 3b 3b 28 42 2). ;;(B
3640: 42 3e 20 22 61 6c 74 20 67 6f 74 20 72 65 73 3d B> "alt got res=
3650: 22 72 65 73 29 0a 09 20 28 64 65 62 75 67 3a 70 "res).. (debug:p
3660: 72 69 6e 74 2d 69 6e 66 6f 20 31 31 20 2a 64 65 rint-info 11 *de
3670: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
3680: 22 67 6f 74 20 72 65 73 3d 22 20 72 65 73 29 0a "got res=" res).
3690: 09 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 72 . (if (vector? r
36a0: 65 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 es).
36b0: 20 28 63 61 73 65 20 28 76 65 63 74 6f 72 2d 72 (case (vector-r
36c0: 65 66 20 72 65 73 20 30 29 0a 20 20 20 20 20 20 ef res 0).
36d0: 20 20 20 20 20 20 20 20 20 28 28 73 75 63 63 65 ((succe
36e0: 73 73 29 20 28 76 65 63 74 6f 72 20 23 74 20 28 ss) (vector #t (
36f0: 76 65 63 74 6f 72 2d 72 65 66 20 72 65 73 20 31 vector-ref res 1
3700: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
3710: 20 20 20 28 0a 20 20 20 20 20 20 20 20 20 20 20 (.
3720: 20 20 20 20 20 28 63 6f 6d 6d 73 2d 66 61 69 6c (comms-fail
3730: 20 6f 74 68 65 72 2d 66 61 69 6c 29 0a 20 20 20 other-fail).
3740: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 28 ;;(
3750: 63 6f 6d 6d 73 2d 66 61 69 6c 29 20 0a 20 20 20 comms-fail) .
3760: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
3770: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
3780: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
3790: 57 41 52 4e 49 4e 47 3a 20 63 6f 6d 6d 73 20 66 WARNING: comms f
37a0: 61 69 6c 75 72 65 20 66 6f 72 20 72 70 63 20 72 ailure for rpc r
37b0: 65 71 75 65 73 74 20 3e 3e 22 72 65 73 22 3c 3c equest >>"res"<<
37c0: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
37d0: 20 20 20 3b 3b 28 64 65 62 75 67 3a 70 72 69 6e ;;(debug:prin
37e0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
37f0: 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 65 -port* " message
3800: 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d : " ((condition-
3810: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
3820: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
3830: 20 65 78 6e 29 29 0a 20 20 20 20 20 20 20 20 20 exn)).
3840: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 20 23 (vector #
3850: 66 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 f (vector-ref re
3860: 73 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 20 s 1))).
3870: 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 (else.
3880: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
3890: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
38a0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
38b0: 72 74 2a 20 22 65 72 72 6f 72 20 6f 63 63 75 72 rt* "error occur
38c0: 65 64 20 61 74 20 73 65 72 76 65 72 2c 20 69 6e ed at server, in
38d0: 66 6f 3d 22 20 28 76 65 63 74 6f 72 2d 72 65 66 fo=" (vector-ref
38e0: 20 72 65 73 20 31 29 29 0a 20 20 20 20 20 20 20 res 1)).
38f0: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
3900: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
3910: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 63 6c 69 -log-port* " cli
3920: 65 6e 74 20 63 61 6c 6c 20 63 68 61 69 6e 3a 22 ent call chain:"
3930: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3940: 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 (print-call-ch
3950: 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 ain (current-err
3960: 6f 72 2d 70 6f 72 74 29 29 0a 20 20 20 20 20 20 or-port)).
3970: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
3980: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
3990: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 73 65 t-log-port* " se
39a0: 72 76 65 72 20 63 61 6c 6c 20 63 68 61 69 6e 3a rver call chain:
39b0: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
39c0: 20 20 20 28 70 70 20 28 76 65 63 74 6f 72 2d 72 (pp (vector-r
39d0: 65 66 20 72 65 73 20 31 29 20 28 63 75 72 72 65 ef res 1) (curre
39e0: 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a nt-error-port)).
39f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a00: 28 73 69 67 6e 61 6c 20 28 76 65 63 74 6f 72 2d (signal (vector-
3a10: 72 65 66 20 72 65 73 20 32 29 29 29 29 0a 20 20 ref res 2)))).
3a20: 20 20 20 20 20 20 20 20 20 20 20 28 73 69 67 6e (sign
3a30: 61 6c 20 28 6d 61 6b 65 2d 63 6f 6d 70 6f 73 69 al (make-composi
3a40: 74 65 2d 63 6f 6e 64 69 74 69 6f 6e 0a 20 20 20 te-condition.
3a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3a60: 20 20 20 28 6d 61 6b 65 2d 70 72 6f 70 65 72 74 (make-propert
3a70: 79 2d 63 6f 6e 64 69 74 69 6f 6e 20 0a 20 20 20 y-condition .
3a80: 20 20 20 20 20 20 20 20 20 20 09 20 20 20 20 20 .
3a90: 20 20 27 74 69 6d 65 6f 75 74 0a 20 20 20 20 20 'timeout.
3aa0: 20 20 20 20 20 20 20 20 09 20 20 20 20 20 20 20 .
3ab0: 27 6d 65 73 73 61 67 65 20 22 6e 6d 73 67 2d 74 'message "nmsg-t
3ac0: 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d ransport:client-
3ad0: 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 api-send-receive
3ae0: 2d 72 61 77 20 74 69 6d 65 64 20 6f 75 74 20 74 -raw timed out t
3af0: 61 6c 6b 69 6e 67 20 74 6f 20 73 65 72 76 65 72 alking to server
3b00: 22 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 ")))))).
3b10: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 72 70 63 2d ...(define (rpc-
3b20: 74 72 61 6e 73 70 6f 72 74 3a 72 75 6e 20 68 6f transport:run ho
3b30: 73 74 6e 20 72 75 6e 2d 69 64 20 73 65 72 76 65 stn run-id serve
3b40: 72 2d 69 64 29 0a 20 20 28 64 65 62 75 67 3a 70 r-id). (debug:p
3b50: 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d rint 2 *default-
3b60: 6c 6f 67 2d 70 6f 72 74 2a 20 22 41 74 74 65 6d log-port* "Attem
3b70: 70 74 69 6e 67 20 74 6f 20 73 74 61 72 74 20 74 pting to start t
3b80: 68 65 20 72 70 63 20 73 65 72 76 65 72 20 2e 2e he rpc server ..
3b90: 2e 22 29 0a 20 20 20 3b 3b 20 28 74 72 61 63 65 ."). ;; (trace
3ba0: 20 72 70 63 3a 70 75 62 6c 69 73 68 2d 70 72 6f rpc:publish-pro
3bb0: 63 65 64 75 72 65 21 29 0a 0a 20 20 3b 3b 3d 3d cedure!).. ;;==
3bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c00: 3d 3d 3d 3d 0a 20 20 3b 3b 09 20 20 73 74 61 72 ====. ;;. star
3c10: 74 20 6f 66 20 70 75 62 6c 69 73 68 2d 70 72 6f t of publish-pro
3c20: 63 65 64 75 72 65 20 73 65 63 74 69 6f 6e 0a 20 cedure section.
3c30: 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;=============
3c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 20 28 72 70 63 =========. (rpc
3c80: 3a 70 75 62 6c 69 73 68 2d 70 72 6f 63 65 64 75 :publish-procedu
3c90: 72 65 21 20 27 73 65 72 76 65 72 3a 6c 6f 67 69 re! 'server:logi
3ca0: 6e 20 73 65 72 76 65 72 3a 6c 6f 67 69 6e 29 20 n server:login)
3cb0: 3b 3b 20 74 68 69 73 20 61 6c 6c 6f 77 73 20 63 ;; this allows c
3cc0: 6c 69 65 6e 74 20 74 6f 20 76 61 6c 69 64 61 74 lient to validat
3cd0: 65 20 69 74 20 69 73 20 74 68 65 20 73 61 6d 65 e it is the same
3ce0: 20 6d 65 67 61 74 65 73 74 20 69 6e 73 74 61 6e megatest instan
3cf0: 63 65 20 61 73 20 74 68 65 20 73 65 72 76 65 72 ce as the server
3d00: 2e 20 20 4e 6f 20 73 65 63 75 72 69 74 79 20 68 . No security h
3d10: 65 72 65 2c 20 6a 75 73 74 20 6d 61 6b 69 6e 67 ere, just making
3d20: 20 73 75 72 65 20 77 65 27 72 65 20 69 6e 20 74 sure we're in t
3d30: 68 65 20 72 69 67 68 74 20 72 6f 6f 6d 2e 0a 20 he right room..
3d40: 20 28 72 70 63 3a 70 75 62 6c 69 73 68 2d 70 72 (rpc:publish-pr
3d50: 6f 63 65 64 75 72 65 21 0a 20 20 20 27 74 65 73 ocedure!. 'tes
3d60: 74 69 6e 67 0a 20 20 20 28 6c 61 6d 62 64 61 20 ting. (lambda
3d70: 28 29 0a 20 20 20 20 20 22 4a 75 73 74 20 74 65 (). "Just te
3d80: 73 74 69 6e 67 22 29 29 0a 0a 20 20 3b 3b 20 70 sting")).. ;; p
3d90: 72 6f 63 65 64 75 72 65 20 74 6f 20 72 65 63 65 rocedure to rece
3da0: 69 76 65 20 61 72 62 69 74 72 61 72 79 20 41 50 ive arbitrary AP
3db0: 49 20 72 65 71 75 65 73 74 20 66 72 6f 6d 20 63 I request from c
3dc0: 6c 69 65 6e 74 27 73 20 72 70 63 3a 73 65 6e 64 lient's rpc:send
3dd0: 2d 72 65 63 65 69 76 65 2f 72 70 63 2d 74 72 61 -receive/rpc-tra
3de0: 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 nsport:client-ap
3df0: 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 20 0a i-send-receive .
3e00: 20 20 28 72 70 63 3a 70 75 62 6c 69 73 68 2d 70 (rpc:publish-p
3e10: 72 6f 63 65 64 75 72 65 21 20 27 72 70 63 2d 74 rocedure! 'rpc-t
3e20: 72 61 6e 73 70 6f 72 74 3a 61 75 74 6f 72 65 6d ransport:autorem
3e30: 6f 74 65 20 72 70 63 2d 74 72 61 6e 73 70 6f 72 ote rpc-transpor
3e40: 74 3a 61 75 74 6f 72 65 6d 6f 74 65 29 0a 20 20 t:autoremote).
3e50: 3b 3b 20 63 61 6e 20 75 73 65 20 74 68 69 73 20 ;; can use this
3e60: 74 6f 20 72 75 6e 20 6d 6f 73 74 20 61 6e 79 74 to run most anyt
3e70: 68 69 6e 67 20 61 74 20 74 68 65 20 72 65 6d 6f hing at the remo
3e80: 74 65 0a 20 20 28 72 70 63 3a 70 75 62 6c 69 73 te. (rpc:publis
3e90: 68 2d 70 72 6f 63 65 64 75 72 65 21 20 27 61 70 h-procedure! 'ap
3ea0: 69 2d 65 78 65 63 20 72 70 63 2d 74 72 61 6e 73 i-exec rpc-trans
3eb0: 70 6f 72 74 3a 61 70 69 2d 65 78 65 63 29 0a 20 port:api-exec).
3ec0: 20 0a 20 20 0a 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d . . ;;=======
3ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
3f10: 20 20 3b 3b 09 20 20 65 6e 64 20 6f 66 20 70 75 ;;. end of pu
3f20: 62 6c 69 73 68 2d 70 72 6f 63 65 64 75 72 65 20 blish-procedure
3f30: 73 65 63 74 69 6f 6e 0a 20 20 3b 3b 3d 3d 3d 3d section. ;;====
3f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3f60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3f70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3f80: 3d 3d 0a 0a 0a 20 20 28 6c 65 74 2a 20 28 28 64 ==... (let* ((d
3f90: 62 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 b #
3fa0: 66 29 0a 09 20 28 68 6f 73 74 6e 61 6d 65 20 20 f).. (hostname
3fb0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
3fc0: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
3fd0: 29 29 20 20 72 65 73 29 29 0a 20 20 20 20 20 20 )) res)).
3fe0: 20 20 20 28 73 65 72 76 65 72 2d 73 74 61 72 74 (server-start
3ff0: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 -time (current-s
4000: 65 63 6f 6e 64 73 29 29 0a 20 20 20 20 20 20 20 econds)).
4010: 20 20 28 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 (server-timeou
4020: 74 20 28 73 65 72 76 65 72 3a 67 65 74 2d 74 69 t (server:get-ti
4030: 6d 65 6f 75 74 29 29 0a 09 20 28 69 70 61 64 64 meout)).. (ipadd
4040: 72 73 74 72 20 20 20 20 20 20 20 28 6c 65 74 2a rstr (let*
4050: 20 28 28 69 70 73 74 72 20 28 69 66 20 28 73 74 ((ipstr (if (st
4060: 72 69 6e 67 3d 3f 20 22 2d 22 20 68 6f 73 74 6e ring=? "-" hostn
4070: 29 0a 09 09 09 09 09 20 20 20 3b 3b 20 28 73 74 )...... ;; (st
4080: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
4090: 20 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e 73 74 (map number->st
40a0: 72 69 6e 67 20 28 75 38 76 65 63 74 6f 72 2d 3e ring (u8vector->
40b0: 6c 69 73 74 20 28 68 6f 73 74 6e 61 6d 65 2d 3e list (hostname->
40c0: 69 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 20 22 ip hostname))) "
40d0: 2e 22 29 0a 09 09 09 09 09 20 20 20 28 73 65 72 .")...... (ser
40e0: 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 ver:get-best-gue
40f0: 73 73 2d 61 64 64 72 65 73 73 20 68 6f 73 74 6e ss-address hostn
4100: 61 6d 65 29 0a 09 09 09 09 09 20 20 20 23 66 29 ame)...... #f)
4110: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4130: 20 20 20 28 72 65 73 20 28 69 66 20 69 70 73 74 (res (if ipst
4140: 72 20 69 70 73 74 72 20 68 6f 73 74 6e 29 29 29 r ipstr hostn)))
4150: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4160: 20 20 20 20 20 20 20 20 20 20 20 20 20 72 65 73 res
4170: 29 29 20 3b 3b 20 68 6f 73 74 6e 61 6d 65 29 29 )) ;; hostname))
4180: 29 20 0a 09 20 28 73 74 61 72 74 2d 70 6f 72 74 ) .. (start-port
4190: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
41a0: 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 (portlogger:ope
41b0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 n-run-close port
41c0: 6c 6f 67 67 65 72 3a 66 69 6e 64 2d 70 6f 72 74 logger:find-port
41d0: 29 29 29 20 20 20 20 20 20 3b 3b 20 42 42 3e 20 ))) ;; BB>
41e0: 54 4f 44 4f 3a 20 72 65 6d 6f 76 65 20 70 6f 72 TODO: remove por
41f0: 74 6c 6f 67 67 65 72 21 0a 20 20 20 20 20 20 20 tlogger!.
4200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4210: 20 20 20 20 20 72 65 73 29 29 0a 09 20 28 6c 69 res)).. (li
4220: 6e 6b 2d 74 72 65 65 2d 70 61 74 68 20 20 28 63 nk-tree-path (c
4230: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
4240: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 onfigdat* "setup
4250: 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 0a 0a " "linktree"))..
4260: 20 20 20 20 20 20 20 20 20 3b 3b 3b 3b 3b 3b 3b ;;;;;;;
4270: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4280: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4290: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
42a0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
42b0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
42c0: 3b 0a 20 20 20 20 20 20 20 20 20 3b 3b 20 72 70 ;. ;; rp
42d0: 63 3a 6c 69 73 74 65 6e 65 72 20 69 73 20 74 68 c:listener is th
42e0: 65 20 74 63 70 2d 6c 69 73 74 65 6e 20 72 65 73 e tcp-listen res
42f0: 75 6c 74 20 66 72 6f 6d 20 69 6e 73 69 64 65 20 ult from inside
4300: 74 68 65 20 66 69 6e 64 2d 66 72 65 65 2d 70 6f the find-free-po
4310: 72 74 2d 61 6e 64 2d 6f 70 65 6e 20 63 6f 6d 70 rt-and-open comp
4320: 6c 65 78 2e 0a 20 20 20 20 20 20 20 20 20 3b 3b lex.. ;;
4330: 20 20 20 49 74 20 69 73 20 6f 75 72 20 68 61 6e It is our han
4340: 64 6c 65 20 6f 6e 20 74 68 65 20 6c 69 73 74 65 dle on the liste
4350: 6e 69 6e 67 20 74 63 70 20 70 6f 72 74 0a 20 20 ning tcp port.
4360: 20 20 20 20 20 20 20 3b 3b 20 20 20 57 65 20 77 ;; We w
4370: 69 6c 6c 20 61 74 74 61 63 68 20 74 68 69 73 20 ill attach this
4380: 74 6f 20 6f 75 72 20 72 70 63 20 73 65 72 76 65 to our rpc serve
4390: 72 20 77 69 74 68 20 72 70 63 3a 6d 61 6b 65 2d r with rpc:make-
43a0: 73 65 72 76 65 72 20 69 6e 20 74 68 72 65 61 64 server in thread
43b0: 20 74 68 31 20 2e 0a 09 20 28 72 70 63 3a 6c 69 th1 ... (rpc:li
43c0: 73 74 65 6e 65 72 20 20 20 20 28 72 70 63 2d 74 stener (rpc-t
43d0: 72 61 6e 73 70 6f 72 74 3a 66 69 6e 64 2d 66 72 ransport:find-fr
43e0: 65 65 2d 70 6f 72 74 2d 61 6e 64 2d 6f 70 65 6e ee-port-and-open
43f0: 20 73 74 61 72 74 2d 70 6f 72 74 29 29 20 0a 09 start-port)) ..
4400: 20 28 74 68 31 20 20 20 20 20 20 20 20 20 20 20 (th1
4410: 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a 09 (make-thread..
4420: 09 09 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a .. (lambda ().
4430: 09 09 09 20 20 20 20 20 28 28 72 70 63 3a 6d 61 ... ((rpc:ma
4440: 6b 65 2d 73 65 72 76 65 72 20 72 70 63 3a 6c 69 ke-server rpc:li
4450: 73 74 65 6e 65 72 29 20 23 74 29 20 29 0a 09 09 stener) #t) )...
4460: 09 20 20 20 22 72 70 63 3a 73 65 72 76 65 72 22 . "rpc:server"
4470: 29 29 0a 0a 0a 20 20 20 20 20 20 20 20 20 28 68 ))... (h
4480: 6f 73 74 6e 61 6d 65 20 20 20 20 20 20 20 20 28 ostname (
4490: 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 22 2d 22 if (string=? "-"
44a0: 20 68 6f 73 74 6e 29 0a 09 09 09 20 20 20 20 20 hostn)....
44b0: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
44c0: 20 0a 09 09 09 20 20 20 20 20 20 68 6f 73 74 6e .... hostn
44d0: 29 29 0a 09 20 28 69 70 61 64 64 72 73 74 72 20 )).. (ipaddrstr
44e0: 20 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e (if (strin
44f0: 67 3d 3f 20 22 2d 22 20 68 6f 73 74 6e 29 0a 09 g=? "-" hostn)..
4500: 09 09 20 20 20 20 20 20 28 73 65 72 76 65 72 3a .. (server:
4510: 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 get-best-guess-a
4520: 64 64 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 ddress hostname)
4530: 20 3b 3b 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 ;; (string-inte
4540: 72 73 70 65 72 73 65 20 28 6d 61 70 20 6e 75 6d rsperse (map num
4550: 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 75 38 76 ber->string (u8v
4560: 65 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 6f 73 ector->list (hos
4570: 74 6e 61 6d 65 2d 3e 69 70 20 68 6f 73 74 6e 61 tname->ip hostna
4580: 6d 65 29 29 29 20 22 2e 22 29 0a 09 09 09 20 20 me))) ".")....
4590: 20 20 20 20 23 66 29 29 0a 09 20 28 70 6f 72 74 #f)).. (port
45a0: 6e 75 6d 20 20 20 20 20 20 20 20 20 28 6c 65 74 num (let
45b0: 20 28 28 72 65 73 20 28 72 70 63 3a 64 65 66 61 ((res (rpc:defa
45c0: 75 6c 74 2d 73 65 72 76 65 72 2d 70 6f 72 74 29 ult-server-port)
45d0: 29 29 20 20 72 65 73 29 29 0a 09 20 28 68 6f 73 )) res)).. (hos
45e0: 74 3a 70 6f 72 74 20 20 20 20 20 20 20 28 63 6f t:port (co
45f0: 6e 63 20 28 69 66 20 69 70 61 64 64 72 73 74 72 nc (if ipaddrstr
4600: 20 69 70 61 64 64 72 73 74 72 20 68 6f 73 74 6e ipaddrstr hostn
4610: 61 6d 65 29 20 22 3a 22 20 70 6f 72 74 6e 75 6d ame) ":" portnum
4620: 29 29 29 0a 0a 0a 20 20 20 20 3b 3b 20 42 42 3e )))... ;; BB>
4630: 20 54 4f 44 4f 3a 20 72 65 6d 6f 76 65 20 70 6f TODO: remove po
4640: 72 74 6c 6f 67 67 65 72 21 0a 20 20 20 20 3b 3b rtlogger!. ;;
4650: 20 69 66 20 72 70 63 20 66 6f 75 6e 64 20 69 74 if rpc found it
4660: 20 6e 65 65 64 65 64 20 61 20 64 69 66 66 65 72 needed a differ
4670: 65 6e 74 20 70 6f 72 74 20 74 68 61 6e 20 70 6f ent port than po
4680: 72 74 6c 6f 67 67 65 72 20 70 72 6f 76 69 64 65 rtlogger provide
4690: 64 2c 20 6b 65 65 70 20 70 6f 72 74 6c 6f 67 67 d, keep portlogg
46a0: 65 72 20 69 6e 20 74 68 65 20 6c 6f 6f 70 2e 0a er in the loop..
46b0: 20 20 20 20 3b 3b 20 28 77 68 65 6e 20 28 6e 6f ;; (when (no
46c0: 74 20 28 65 71 75 61 6c 3f 20 73 74 61 72 74 2d t (equal? start-
46d0: 70 6f 72 74 20 70 6f 72 74 6e 75 6d 29 29 0a 20 port portnum)).
46e0: 20 20 20 3b 3b 20 20 20 28 42 42 3e 20 22 70 6f ;; (BB> "po
46f0: 72 74 6c 6f 67 67 65 72 20 70 72 6f 66 66 65 72 rtlogger proffer
4700: 65 64 20 22 73 74 61 72 74 2d 70 6f 72 74 22 20 ed "start-port"
4710: 62 75 74 20 72 70 63 20 67 72 61 62 62 65 64 20 but rpc grabbed
4720: 22 70 6f 72 74 6e 75 6d 29 0a 20 20 20 20 3b 3b "portnum). ;;
4730: 20 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f (portlogger:o
4740: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f pen-run-close po
4750: 72 74 6c 6f 67 67 65 72 3a 73 65 74 2d 70 6f 72 rtlogger:set-por
4760: 74 20 73 74 61 72 74 2d 70 6f 72 74 20 22 72 65 t start-port "re
4770: 6c 65 61 73 65 64 22 29 0a 20 20 20 20 3b 3b 20 leased"). ;;
4780: 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 (portlogger:op
4790: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 en-run-close por
47a0: 74 6c 6f 67 67 65 72 3a 74 61 6b 65 2d 70 6f 72 tlogger:take-por
47b0: 74 20 70 6f 72 74 6e 75 6d 29 29 0a 0a 20 20 20 t portnum))..
47c0: 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 73 (tasks:server-s
47d0: 65 74 2d 69 6e 74 65 72 66 61 63 65 2d 70 6f 72 et-interface-por
47e0: 74 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 t (db:delay-if-b
47f0: 75 73 79 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d usy (tasks:open-
4800: 64 62 29 29 20 73 65 72 76 65 72 2d 69 64 20 69 db)) server-id i
4810: 70 61 64 64 72 73 74 72 20 70 6f 72 74 6e 75 6d paddrstr portnum
4820: 29 0a 0a 20 20 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d ).. ;;=======
4830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4860: 3d 3d 3d 3d 3d 0a 20 20 20 20 3b 3b 20 20 61 63 =====. ;; ac
4870: 74 69 76 61 74 65 20 74 68 72 65 61 64 20 74 68 tivate thread th
4880: 31 20 74 6f 20 61 74 74 61 63 68 20 6f 70 65 6e 1 to attach open
4890: 65 64 20 74 63 70 20 70 6f 72 74 20 74 6f 20 72 ed tcp port to r
48a0: 70 63 20 73 65 72 76 65 72 0a 20 20 20 20 3b 3b pc server. ;;
48b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
48c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
48d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
48e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 20 =============.
48f0: 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 (thread-start!
4900: 20 74 68 31 29 0a 20 20 20 20 28 73 65 74 21 20 th1). (set!
4910: 64 62 20 2a 69 6e 6d 65 6d 64 62 2a 29 0a 0a 20 db *inmemdb*)..
4920: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
4930: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
4940: 6f 72 74 2a 20 22 53 65 72 76 65 72 20 73 74 61 ort* "Server sta
4950: 72 74 65 64 20 6f 6e 20 22 20 68 6f 73 74 3a 70 rted on " host:p
4960: 6f 72 74 29 0a 0a 20 20 20 20 3b 3b 20 28 74 68 ort).. ;; (th
4970: 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 0a 0a read-sleep! 5)..
4980: 20 20 20 20 28 69 66 20 28 72 65 74 72 79 2d 74 (if (retry-t
4990: 68 75 6e 6b 20 28 6c 61 6d 62 64 61 20 28 29 0a hunk (lambda ().
49a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
49b0: 20 20 20 20 20 20 20 28 72 70 63 2d 74 72 61 6e (rpc-tran
49c0: 73 70 6f 72 74 3a 73 65 6c 66 2d 74 65 73 74 20 sport:self-test
49d0: 72 75 6e 2d 69 64 20 69 70 61 64 64 72 73 74 72 run-id ipaddrstr
49e0: 20 70 6f 72 74 6e 75 6d 29 29 29 0a 20 20 20 20 portnum))).
49f0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4a00: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
4a10: 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 72 70 63 port* "INFO: rpc
4a20: 20 73 65 6c 66 20 74 65 73 74 20 70 61 73 73 65 self test passe
4a30: 64 21 22 29 0a 20 20 20 20 20 20 20 20 28 62 65 d!"). (be
4a40: 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 28 64 gin. (d
4a50: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
4a60: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
4a70: 22 45 72 72 6f 72 3a 20 72 70 63 20 6c 69 73 74 "Error: rpc list
4a80: 65 6e 65 72 20 64 69 64 20 6e 6f 74 20 70 61 73 ener did not pas
4a90: 73 20 73 65 6c 66 20 74 65 73 74 2e 20 20 53 68 s self test. Sh
4aa0: 75 74 74 69 6e 67 20 64 6f 77 6e 2e 20 20 4f 6e utting down. On
4ab0: 3a 20 22 20 68 6f 73 74 3a 70 6f 72 74 29 0a 20 : " host:port).
4ac0: 20 20 20 20 20 20 20 20 20 28 65 78 69 74 29 29 (exit))
4ad0: 29 0a 20 20 20 20 0a 20 20 20 20 28 6f 6e 2d 65 ). . (on-e
4ae0: 78 69 74 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 xit (lambda ().
4af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
4b00: 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 pc-transport:ser
4b10: 76 65 72 2d 73 68 75 74 64 6f 77 6e 20 73 65 72 ver-shutdown ser
4b20: 76 65 72 2d 69 64 20 72 70 63 3a 6c 69 73 74 65 ver-id rpc:liste
4b30: 6e 65 72 20 66 72 6f 6d 2d 6f 6e 2d 65 78 69 74 ner from-on-exit
4b40: 3a 20 23 74 29 29 29 0a 20 20 20 20 0a 20 20 20 : #t))). .
4b50: 20 3b 3b 20 63 68 65 63 6b 20 61 67 61 69 6e 20 ;; check again
4b60: 66 6f 72 20 72 75 6e 6e 69 6e 67 20 73 65 72 76 for running serv
4b70: 65 72 73 20 66 6f 72 20 74 68 69 73 20 72 75 6e ers for this run
4b80: 2d 69 64 20 69 6e 20 63 61 73 65 20 6f 6e 65 20 -id in case one
4b90: 68 61 73 20 73 6e 75 63 6b 20 69 6e 20 73 69 6e has snuck in sin
4ba0: 63 65 20 77 65 20 63 68 65 63 6b 65 64 20 6c 61 ce we checked la
4bb0: 73 74 20 69 6e 20 72 70 63 2d 74 72 61 6e 73 70 st in rpc-transp
4bc0: 6f 72 74 3a 6c 61 75 6e 63 68 0a 20 20 20 20 28 ort:launch. (
4bd0: 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 if (not (equal?
4be0: 73 65 72 76 65 72 2d 69 64 20 28 74 61 73 6b 73 server-id (tasks
4bf0: 3a 73 65 72 76 65 72 2d 61 6d 2d 69 2d 74 68 65 :server-am-i-the
4c00: 2d 73 65 72 76 65 72 3f 20 28 64 62 3a 64 65 6c -server? (db:del
4c10: 61 79 2d 69 66 2d 62 75 73 79 20 28 74 61 73 6b ay-if-busy (task
4c20: 73 3a 6f 70 65 6e 2d 64 62 29 29 20 72 75 6e 2d s:open-db)) run-
4c30: 69 64 29 29 29 3b 3b 20 74 72 79 20 74 6f 20 65 id)));; try to e
4c40: 6e 73 75 72 65 20 6e 6f 20 64 6f 75 62 6c 65 20 nsure no double
4c50: 72 65 67 69 73 74 65 72 69 6e 67 20 6f 66 20 73 registering of s
4c60: 65 72 76 65 72 73 0a 20 20 20 20 20 20 20 20 28 ervers. (
4c70: 62 65 67 69 6e 20 3b 3b 20 69 20 61 6d 20 6e 6f begin ;; i am no
4c80: 74 20 74 68 65 20 73 65 72 76 65 72 2c 20 61 6e t the server, an
4c90: 6f 74 68 65 72 20 73 65 72 76 65 72 20 73 6e 75 other server snu
4ca0: 63 6b 20 69 6e 20 61 6e 64 20 62 65 61 74 20 74 ck in and beat t
4cb0: 68 69 73 20 6f 6e 65 20 74 6f 20 74 68 65 20 70 his one to the p
4cc0: 75 6e 63 68 0a 20 20 20 20 20 20 20 20 20 20 28 unch. (
4cd0: 74 63 70 2d 63 6c 6f 73 65 20 72 70 63 3a 6c 69 tcp-close rpc:li
4ce0: 73 74 65 6e 65 72 29 20 3b 3b 20 67 6f 74 74 61 stener) ;; gotta
4cf0: 20 65 78 69 74 20 6e 69 63 65 6c 79 20 61 6e 64 exit nicely and
4d00: 20 66 72 65 65 20 75 70 20 74 68 61 74 20 74 63 free up that tc
4d10: 70 20 70 6f 72 74 0a 20 20 20 20 20 20 20 20 20 p port.
4d20: 20 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 73 (tasks:server-s
4d30: 65 74 2d 73 74 61 74 65 21 20 28 64 62 3a 64 65 et-state! (db:de
4d40: 6c 61 79 2d 69 66 2d 62 75 73 79 20 28 74 61 73 lay-if-busy (tas
4d50: 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 20 73 65 72 ks:open-db)) ser
4d60: 76 65 72 2d 69 64 20 22 63 6f 6c 6c 69 73 69 6f ver-id "collisio
4d70: 6e 22 29 29 0a 0a 20 20 20 20 20 20 20 20 28 62 n")).. (b
4d80: 65 67 69 6e 20 3b 3b 20 69 20 61 6d 20 74 68 65 egin ;; i am the
4d90: 20 73 65 72 76 65 72 0a 20 20 20 20 20 20 20 20 server.
4da0: 20 20 3b 3b 20 73 65 74 75 70 20 74 68 65 20 69 ;; setup the i
4db0: 6e 2d 6d 65 6d 6f 72 79 20 64 62 0a 20 20 20 20 n-memory db.
4dc0: 20 20 20 20 20 20 28 73 65 74 21 20 2a 69 6e 6d (set! *inm
4dd0: 65 6d 64 62 2a 20 20 28 64 62 3a 73 65 74 75 70 emdb* (db:setup
4de0: 20 72 75 6e 2d 69 64 29 29 0a 20 20 20 20 20 20 run-id)).
4df0: 20 20 20 20 28 64 62 3a 67 65 74 2d 64 62 20 2a (db:get-db *
4e00: 69 6e 6d 65 6d 64 62 2a 20 72 75 6e 2d 69 64 29 inmemdb* run-id)
4e10: 0a 0a 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6c .. ;; l
4e20: 65 74 27 73 20 6d 61 6b 65 20 69 74 20 6f 66 66 et's make it off
4e30: 69 63 69 61 6c 0a 20 20 20 20 20 20 20 20 20 20 icial.
4e40: 28 73 65 74 21 20 2a 72 70 63 3a 6c 69 73 74 65 (set! *rpc:liste
4e50: 6e 65 72 2a 20 72 70 63 3a 6c 69 73 74 65 6e 65 ner* rpc:listene
4e60: 72 29 20 0a 20 20 20 20 20 20 20 20 20 20 28 74 r) . (t
4e70: 61 73 6b 73 3a 73 65 72 76 65 72 2d 73 65 74 2d asks:server-set-
4e80: 73 74 61 74 65 21 20 28 64 62 3a 64 65 6c 61 79 state! (db:delay
4e90: 2d 69 66 2d 62 75 73 79 20 28 74 61 73 6b 73 3a -if-busy (tasks:
4ea0: 6f 70 65 6e 2d 64 62 29 29 20 73 65 72 76 65 72 open-db)) server
4eb0: 2d 69 64 20 22 72 75 6e 6e 69 6e 67 22 29 20 3b -id "running") ;
4ec0: 3b 20 75 70 64 61 74 65 20 6f 75 72 20 6d 64 62 ; update our mdb
4ed0: 20 73 65 72 76 65 72 73 20 65 6e 74 72 79 0a 0a servers entry..
4ee0: 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 .
4ef0: 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 .
4f00: 3b 3b 20 74 68 69 73 20 6c 65 74 20 6c 6f 6f 70 ;; this let loop
4f10: 20 77 69 6c 6c 20 68 6f 6c 64 20 6f 70 65 6e 20 will hold open
4f20: 74 68 69 73 20 74 68 72 65 61 64 20 75 6e 74 69 this thread unti
4f30: 6c 20 77 65 20 77 61 6e 74 20 74 68 65 20 73 65 l we want the se
4f40: 72 76 65 72 20 74 6f 20 73 68 75 74 20 64 6f 77 rver to shut dow
4f50: 6e 2e 0a 20 20 20 20 20 20 20 20 20 20 3b 3b 20 n.. ;;
4f60: 20 20 69 66 20 6e 6f 20 72 65 71 75 65 73 74 73 if no requests
4f70: 20 72 65 63 65 69 76 65 64 20 77 69 74 68 69 6e received within
4f80: 20 74 68 65 20 6c 61 73 74 20 32 30 20 73 65 63 the last 20 sec
4f90: 6f 6e 64 73 20 3a 0a 20 20 20 20 20 20 20 20 20 onds :.
4fa0: 20 3b 3b 20 20 20 64 61 74 61 62 61 73 65 20 68 ;; database h
4fb0: 61 73 6e 74 20 63 68 61 6e 67 65 64 20 69 6e 20 asnt changed in
4fc0: 3f 3f 0a 20 20 20 20 20 20 20 20 20 20 3b 3b 0a ??. ;;.
4fd0: 0a 20 20 20 20 20 20 20 20 20 20 3b 3b 20 62 65 . ;; be
4fe0: 67 69 6e 20 6e 65 77 20 6c 6f 6f 70 0a 20 20 20 gin new loop.
4ff0: 20 20 20 20 20 20 20 3b 3b 20 6b 65 65 70 2d 72 ;; keep-r
5000: 75 6e 6e 69 6e 67 20 6c 6f 6f 70 3a 20 70 6f 6c unning loop: pol
5010: 6c 73 20 6c 61 73 74 2d 64 62 2d 61 63 63 65 73 ls last-db-acces
5020: 73 20 74 6f 20 73 65 65 20 69 66 20 77 65 20 68 s to see if we h
5030: 61 76 65 20 74 69 6d 65 64 20 6f 75 74 2e 20 20 ave timed out.
5040: 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 . (let
5050: 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 20 20 20 loop ((count
5060: 20 20 20 20 20 20 30 29 0a 20 20 20 20 20 20 20 0).
5070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
5080: 61 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 30 29 ad-sync-count 0)
5090: 29 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 3b ).. ;
50a0: 3b 20 55 73 65 20 74 68 69 73 20 6f 70 70 6f 72 ; Use this oppor
50b0: 74 75 6e 69 74 79 20 74 6f 20 73 79 6e 63 20 74 tunity to sync t
50c0: 68 65 20 69 6e 6d 65 6d 64 62 20 74 6f 20 64 62 he inmemdb to db
50d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 . (le
50e0: 74 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 28 t ((start-time (
50f0: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
5100: 6f 6e 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 onds)).
5110: 20 20 20 20 20 20 20 20 20 28 73 79 6e 63 2d 74 (sync-t
5120: 69 6d 65 20 20 23 66 29 0a 20 20 20 20 20 20 20 ime #f).
5130: 20 20 20 20 20 20 20 20 20 20 20 28 72 65 6d 2d (rem-
5140: 74 69 6d 65 20 20 20 23 66 29 29 0a 20 20 20 20 time #f)).
5150: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 69 6e 6d ;; inm
5160: 65 6d 64 62 20 69 73 20 61 20 64 62 73 74 72 75 emdb is a dbstru
5170: 63 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ct.
5180: 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 (condition-case
5190: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
51a0: 28 64 62 3a 73 79 6e 63 2d 74 6f 75 63 68 65 64 (db:sync-touched
51b0: 20 2a 69 6e 6d 65 6d 64 62 2a 20 2a 72 75 6e 2d *inmemdb* *run-
51c0: 69 64 2a 20 66 6f 72 63 65 2d 73 79 6e 63 3a 20 id* force-sync:
51d0: 23 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 #t).
51e0: 20 20 20 28 28 73 79 6e 63 2d 66 61 69 6c 65 64 ((sync-failed
51f0: 29 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 )(cond.
5200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5210: 20 20 20 20 20 28 28 3e 20 62 61 64 2d 73 79 6e ((> bad-syn
5220: 63 2d 63 6f 75 6e 74 20 31 30 29 20 3b 3b 20 74 c-count 10) ;; t
5230: 69 6d 65 20 74 6f 20 67 69 76 65 20 75 70 0a 20 ime to give up.
5240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
5260: 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 pc-transport:ser
5270: 76 65 72 2d 73 68 75 74 64 6f 77 6e 20 73 65 72 ver-shutdown ser
5280: 76 65 72 2d 69 64 20 72 70 63 3a 6c 69 73 74 65 ver-id rpc:liste
5290: 6e 65 72 29 29 0a 20 20 20 20 20 20 20 20 20 20 ner)).
52a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
52b0: 20 20 20 20 28 65 6c 73 65 20 3b 3b 20 28 3e 20 (else ;; (>
52c0: 62 61 64 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 30 bad-sync-count 0
52d0: 29 20 20 3b 3b 20 77 65 27 76 65 20 68 61 64 20 ) ;; we've had
52e0: 61 20 66 61 69 6c 20 6f 72 20 74 77 6f 2c 20 64 a fail or two, d
52f0: 65 6c 61 79 20 61 6e 64 20 6c 6f 6f 70 0a 20 20 elay and loop.
5300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5310: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 68 (th
5320: 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 0a 20 read-sleep! 5).
5330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
5350: 6f 6f 70 20 63 6f 75 6e 74 20 28 2b 20 62 61 64 oop count (+ bad
5360: 2d 73 79 6e 63 2d 63 6f 75 6e 74 20 31 29 29 29 -sync-count 1)))
5370: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
5380: 20 20 28 28 65 78 6e 29 0a 20 20 20 20 20 20 20 ((exn).
5390: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
53a0: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
53b0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
53c0: 20 22 65 72 72 6f 72 20 66 72 6f 6d 20 73 79 6e "error from syn
53d0: 63 20 63 6f 64 65 20 6f 74 68 65 72 20 74 68 61 c code other tha
53e0: 6e 20 27 73 79 6e 63 2d 66 61 69 6c 65 64 2e 20 n 'sync-failed.
53f0: 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 67 72 Attempting to gr
5400: 61 63 65 66 75 6c 6c 79 20 73 68 75 74 64 6f 77 acefully shutdow
5410: 6e 20 74 68 65 20 73 65 72 76 65 72 22 29 0a 20 n the server").
5420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5430: 72 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 rpc-transport:se
5440: 72 76 65 72 2d 73 68 75 74 64 6f 77 6e 20 73 65 rver-shutdown se
5450: 72 76 65 72 2d 69 64 20 72 70 63 3a 6c 69 73 74 rver-id rpc:list
5460: 65 6e 65 72 29 29 29 0a 20 20 20 20 20 20 20 20 ener))).
5470: 20 20 20 20 20 20 28 73 65 74 21 20 73 79 6e 63 (set! sync
5480: 2d 74 69 6d 65 20 20 28 2d 20 28 63 75 72 72 65 -time (- (curre
5490: 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 nt-milliseconds)
54a0: 20 73 74 61 72 74 2d 74 69 6d 65 29 29 0a 20 20 start-time)).
54b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 (set
54c0: 21 20 72 65 6d 2d 74 69 6d 65 20 28 71 75 6f 74 ! rem-time (quot
54d0: 69 65 6e 74 20 28 2d 20 34 30 30 30 20 73 79 6e ient (- 4000 syn
54e0: 63 2d 74 69 6d 65 29 20 31 30 30 30 29 29 0a 20 c-time) 1000)).
54f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
5500: 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 bug:print 4 *def
5510: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5520: 53 59 4e 43 3a 20 74 69 6d 65 3d 20 22 20 73 79 SYNC: time= " sy
5530: 6e 63 2d 74 69 6d 65 20 22 2c 20 72 65 6d 2d 74 nc-time ", rem-t
5540: 69 6d 65 3d 22 20 72 65 6d 2d 74 69 6d 65 29 0a ime=" rem-time).
5550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 .
5560: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
5570: 20 28 61 6e 64 20 28 3c 3d 20 72 65 6d 2d 74 69 (and (<= rem-ti
5580: 6d 65 20 34 29 0a 20 20 20 20 20 20 20 20 20 20 me 4).
5590: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 3e 20 (>
55a0: 72 65 6d 2d 74 69 6d 65 20 30 29 29 0a 20 20 20 rem-time 0)).
55b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
55c0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 72 65 thread-sleep! re
55d0: 6d 2d 74 69 6d 65 29 0a 20 20 20 20 20 20 20 20 m-time).
55e0: 20 20 20 20 20 20 20 20 20 20 28 74 68 72 65 61 (threa
55f0: 64 2d 73 6c 65 65 70 21 20 34 29 29 29 20 3b 3b d-sleep! 4))) ;;
5600: 20 66 61 6c 6c 62 61 63 6b 20 66 6f 72 20 69 66 fallback for if
5610: 20 74 68 65 20 6d 61 74 68 20 69 73 20 63 68 61 the math is cha
5620: 6e 67 65 64 20 2e 2e 2e 0a 20 20 20 20 20 20 20 nged ....
5630: 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 .
5640: 20 20 28 69 66 20 28 3c 20 63 6f 75 6e 74 20 31 (if (< count 1
5650: 29 20 3b 3b 20 33 78 33 20 3d 20 39 20 73 65 63 ) ;; 3x3 = 9 sec
5660: 73 20 61 70 72 6f 78 0a 20 20 20 20 20 20 20 20 s aprox.
5670: 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 2b (loop (+
5680: 20 63 6f 75 6e 74 20 31 29 20 62 61 64 2d 73 79 count 1) bad-sy
5690: 6e 63 2d 63 6f 75 6e 74 29 29 0a 0a 20 20 20 20 nc-count))..
56a0: 20 20 20 20 20 20 20 20 3b 3b 20 42 42 3a 20 64 ;; BB: d
56b0: 6f 6e 27 74 20 73 65 65 20 68 6f 77 20 74 68 69 on't see how thi
56c0: 73 20 69 73 20 70 6f 73 73 69 62 6c 65 20 77 69 s is possible wi
56d0: 74 68 20 52 50 43 0a 20 20 20 20 20 20 20 20 20 th RPC.
56e0: 20 20 20 3b 3b 20 3b 3b 20 43 68 65 63 6b 20 74 ;; ;; Check t
56f0: 68 61 74 20 69 66 61 63 65 20 61 6e 64 20 70 6f hat iface and po
5700: 72 74 20 68 61 76 65 20 6e 6f 74 20 63 68 61 6e rt have not chan
5710: 67 65 64 20 28 63 61 6e 20 68 61 70 70 65 6e 20 ged (can happen
5720: 69 66 20 73 65 72 76 65 72 20 70 6f 72 74 20 63 if server port c
5730: 6f 6c 6c 69 64 65 73 29 0a 20 20 20 20 20 20 20 ollides).
5740: 20 20 20 20 20 3b 3b 20 28 6d 75 74 65 78 2d 6c ;; (mutex-l
5750: 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d ock! *heartbeat-
5760: 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 20 20 mutex*).
5770: 20 20 20 20 3b 3b 20 28 73 65 74 21 20 73 64 61 ;; (set! sda
5780: 74 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 29 t *server-info*)
5790: 0a 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 . ;;
57a0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
57b0: 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a heartbeat-mutex*
57c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 ). .
57d0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 69 ;; (i
57e0: 66 20 28 6f 72 20 28 6e 6f 74 20 28 65 71 75 61 f (or (not (equa
57f0: 6c 3f 20 73 64 61 74 20 28 6c 69 73 74 20 69 66 l? sdat (list if
5800: 61 63 65 20 70 6f 72 74 29 29 29 0a 20 20 20 20 ace port))).
5810: 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 ;;
5820: 20 20 20 28 6e 6f 74 20 73 65 72 76 65 72 2d 69 (not server-i
5830: 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 d)).
5840: 3b 3b 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 ;; (begin .
5850: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 ;;
5860: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5870: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
5880: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 6e 74 65 -log-port* "inte
5890: 72 66 61 63 65 20 63 68 61 6e 67 65 64 2c 20 72 rface changed, r
58a0: 65 66 72 65 73 68 69 6e 67 20 69 66 61 63 65 20 efreshing iface
58b0: 61 6e 64 20 70 6f 72 74 20 69 6e 66 6f 22 29 0a and port info").
58c0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 ;;
58d0: 20 20 20 20 20 28 73 65 74 21 20 69 66 61 63 65 (set! iface
58e0: 20 28 63 61 72 20 73 64 61 74 29 29 0a 20 20 20 (car sdat)).
58f0: 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ;;
5900: 20 20 28 73 65 74 21 20 70 6f 72 74 20 20 28 63 (set! port (c
5910: 61 64 72 20 73 64 61 74 29 29 29 29 0a 20 20 20 adr sdat)))).
5920: 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 .
5930: 20 20 20 20 20 20 3b 3b 20 54 72 61 6e 73 66 65 ;; Transfe
5940: 72 20 2a 6c 61 73 74 2d 64 62 2d 61 63 63 65 73 r *last-db-acces
5950: 73 2a 20 74 6f 20 6c 61 73 74 2d 61 63 63 65 73 s* to last-acces
5960: 73 20 74 6f 20 75 73 65 20 69 6e 20 63 68 65 63 s to use in chec
5970: 6b 69 6e 67 20 74 68 61 74 20 77 65 20 61 72 65 king that we are
5980: 20 73 74 69 6c 6c 20 61 6c 69 76 65 0a 20 20 20 still alive.
5990: 20 20 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d (mutex-
59a0: 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 lock! *heartbeat
59b0: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 20 -mutex*).
59c0: 20 20 20 20 20 28 73 65 74 21 20 6c 61 73 74 2d (set! last-
59d0: 61 63 63 65 73 73 20 2a 6c 61 73 74 2d 64 62 2d access *last-db-
59e0: 61 63 63 65 73 73 2a 29 0a 20 20 20 20 20 20 20 access*).
59f0: 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f (mutex-unlo
5a00: 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
5a10: 75 74 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 utex*).
5a20: 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 .
5a30: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
5a40: 31 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 11 *default-log-
5a50: 70 6f 72 74 2a 20 22 6c 61 73 74 2d 61 63 63 65 port* "last-acce
5a60: 73 73 3d 22 20 6c 61 73 74 2d 61 63 63 65 73 73 ss=" last-access
5a70: 20 22 2c 20 73 65 72 76 65 72 2d 74 69 6d 65 6f ", server-timeo
5a80: 75 74 3d 22 20 73 65 72 76 65 72 2d 74 69 6d 65 ut=" server-time
5a90: 6f 75 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 out).
5aa0: 20 3b 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 ;;.
5ab0: 3b 3b 20 6e 6f 5f 74 72 61 66 66 69 63 2c 20 6e ;; no_traffic, n
5ac0: 6f 20 72 75 6e 6e 69 6e 67 20 74 65 73 74 73 2c o running tests,
5ad0: 20 69 66 20 73 65 72 76 65 72 20 30 2c 20 6e 6f if server 0, no
5ae0: 20 72 75 6e 6e 69 6e 67 20 73 65 72 76 65 72 73 running servers
5af0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 0a . ;;.
5b00: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 ;; (
5b10: 6c 65 74 20 28 28 77 61 69 74 2d 6f 6e 2d 72 75 let ((wait-on-ru
5b20: 6e 6e 69 6e 67 20 28 63 6f 6e 66 69 67 66 3a 6c nning (configf:l
5b30: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
5b40: 2a 20 22 73 65 72 76 65 72 22 20 62 22 77 61 69 * "server" b"wai
5b50: 74 2d 6f 6e 2d 72 75 6e 6e 69 6e 67 22 29 29 29 t-on-running")))
5b60: 20 3b 3b 20 77 61 69 74 20 6f 6e 20 72 75 6e 6e ;; wait on runn
5b70: 69 6e 67 20 74 61 73 6b 73 20 28 69 66 20 6e 6f ing tasks (if no
5b80: 74 20 74 72 75 65 20 74 68 65 6e 20 65 78 69 74 t true then exit
5b90: 20 6f 6e 20 74 69 6d 65 20 6f 75 74 29 0a 20 20 on time out).
5ba0: 20 20 20 20 20 20 20 20 20 20 3b 3b 0a 20 20 20 ;;.
5bb0: 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 (let* (
5bc0: 28 68 72 73 2d 73 69 6e 63 65 2d 73 74 61 72 74 (hrs-since-start
5bd0: 20 20 28 2f 20 28 2d 20 28 63 75 72 72 65 6e 74 (/ (- (current
5be0: 2d 73 65 63 6f 6e 64 73 29 20 73 65 72 76 65 72 -seconds) server
5bf0: 2d 73 74 61 72 74 2d 74 69 6d 65 29 20 33 36 30 -start-time) 360
5c00: 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0)).
5c10: 20 20 20 20 20 20 20 28 61 64 6a 75 73 74 65 64 (adjusted
5c20: 2d 74 69 6d 65 6f 75 74 20 28 69 66 20 28 3e 20 -timeout (if (>
5c30: 68 72 73 2d 73 69 6e 63 65 2d 73 74 61 72 74 20 hrs-since-start
5c40: 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 1).
5c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c60: 20 20 20 20 20 20 20 20 20 20 20 20 28 2d 20 73 (- s
5c70: 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 20 28 69 erver-timeout (i
5c80: 6e 65 78 61 63 74 2d 3e 65 78 61 63 74 20 28 72 nexact->exact (r
5c90: 6f 75 6e 64 20 28 2a 20 68 72 73 2d 73 69 6e 63 ound (* hrs-sinc
5ca0: 65 2d 73 74 61 72 74 20 36 30 29 29 29 29 20 20 e-start 60))))
5cb0: 3b 3b 20 73 75 62 74 72 61 63 74 20 36 30 20 73 ;; subtract 60 s
5cc0: 65 63 6f 6e 64 73 20 70 65 72 20 68 6f 75 72 0a econds per hour.
5cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5cf0: 20 20 20 20 20 20 20 20 20 73 65 72 76 65 72 2d server-
5d00: 74 69 6d 65 6f 75 74 29 29 29 0a 20 20 20 20 20 timeout))).
5d10: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 63 6f (if (co
5d20: 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 mmon:low-noise-p
5d30: 72 69 6e 74 20 31 32 30 20 22 73 65 72 76 65 72 rint 120 "server
5d40: 20 74 69 6d 65 6f 75 74 22 29 0a 20 20 20 20 20 timeout").
5d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
5d60: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
5d70: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5d80: 72 74 2a 20 22 41 64 6a 75 73 74 65 64 20 73 65 rt* "Adjusted se
5d90: 72 76 65 72 20 74 69 6d 65 6f 75 74 3a 20 22 20 rver timeout: "
5da0: 61 64 6a 75 73 74 65 64 2d 74 69 6d 65 6f 75 74 adjusted-timeout
5db0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
5dc0: 20 28 69 66 20 28 61 6e 64 20 2a 73 65 72 76 65 (if (and *serve
5dd0: 72 2d 72 75 6e 2a 0a 20 20 20 20 20 20 20 20 20 r-run*.
5de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 3e (>
5df0: 20 28 2b 20 6c 61 73 74 2d 61 63 63 65 73 73 20 (+ last-access
5e00: 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 29 0a server-timeout).
5e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e20: 20 20 20 20 20 20 20 20 20 20 28 63 75 72 72 65 (curre
5e30: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 nt-seconds))).
5e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e50: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
5e60: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
5e70: 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 common:low-noise
5e80: 2d 70 72 69 6e 74 20 31 32 30 20 22 73 65 72 76 -print 120 "serv
5e90: 65 72 20 63 6f 6e 74 69 6e 75 69 6e 67 22 29 0a er continuing").
5ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5eb0: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
5ec0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
5ed0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5ee0: 53 65 72 76 65 72 20 63 6f 6e 74 69 6e 75 69 6e Server continuin
5ef0: 67 2c 20 73 65 63 6f 6e 64 73 20 73 69 6e 63 65 g, seconds since
5f00: 20 6c 61 73 74 20 64 62 20 61 63 63 65 73 73 3a last db access:
5f10: 20 22 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 " (- (current-s
5f20: 65 63 6f 6e 64 73 29 20 6c 61 73 74 2d 61 63 63 econds) last-acc
5f30: 65 73 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 ess))).
5f40: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 0a 20 20 ;;.
5f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f60: 20 20 3b 3b 20 43 6f 6e 73 69 64 65 72 20 69 6d ;; Consider im
5f70: 70 6c 65 6d 65 6e 74 69 6e 67 20 73 6f 6d 65 20 plementing some
5f80: 73 6d 61 72 74 73 20 68 65 72 65 20 74 6f 20 72 smarts here to r
5f90: 65 2d 69 6e 73 65 72 74 20 74 68 65 20 72 65 63 e-insert the rec
5fa0: 6f 72 64 20 6f 72 20 6b 69 6c 6c 20 73 65 6c 66 ord or kill self
5fb0: 20 69 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 is.
5fc0: 20 20 20 20 20 20 20 20 3b 3b 20 74 68 65 20 64 ;; the d
5fd0: 62 20 69 6e 64 69 63 61 74 65 73 20 73 6f 0a 20 b indicates so.
5fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ff0: 20 20 20 3b 3b 0a 20 20 20 20 20 20 20 20 20 20 ;;.
6000: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 74 (if (t
6010: 61 73 6b 73 3a 73 65 72 76 65 72 2d 61 6d 2d 69 asks:server-am-i
6020: 2d 74 68 65 2d 73 65 72 76 65 72 3f 20 28 64 62 -the-server? (db
6030: 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 28 :delay-if-busy (
6040: 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 20 tasks:open-db))
6050: 72 75 6e 2d 69 64 29 0a 20 20 20 20 20 20 20 20 run-id).
6060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6070: 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 73 65 (tasks:server-se
6080: 74 2d 73 74 61 74 65 21 20 28 64 62 3a 64 65 6c t-state! (db:del
6090: 61 79 2d 69 66 2d 62 75 73 79 20 28 74 61 73 6b ay-if-busy (task
60a0: 73 3a 6f 70 65 6e 2d 64 62 29 29 20 73 65 72 76 s:open-db)) serv
60b0: 65 72 2d 69 64 20 22 72 75 6e 6e 69 6e 67 22 29 er-id "running")
60c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
60d0: 20 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 20 20 ;;.
60e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f (lo
60f0: 6f 70 20 30 20 62 61 64 2d 73 79 6e 63 2d 63 6f op 0 bad-sync-co
6100: 75 6e 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 unt)).
6110: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
6120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6130: 20 20 20 3b 3b 28 42 42 3e 20 22 53 45 52 56 45 ;;(BB> "SERVE
6140: 52 20 53 48 55 54 44 4f 57 4e 20 43 41 4c 4c 45 R SHUTDOWN CALLE
6150: 44 21 20 20 6c 61 73 74 2d 61 63 63 65 73 73 3d D! last-access=
6160: 22 6c 61 73 74 2d 61 63 63 65 73 73 22 20 63 75 "last-access" cu
6170: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 3d 22 28 rrent-seconds="(
6180: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
6190: 22 20 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 " server-timeout
61a0: 3d 22 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 ="server-timeout
61b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
61c0: 20 20 20 20 20 20 28 72 70 63 2d 74 72 61 6e 73 (rpc-trans
61d0: 70 6f 72 74 3a 73 65 72 76 65 72 2d 73 68 75 74 port:server-shut
61e0: 64 6f 77 6e 20 73 65 72 76 65 72 2d 69 64 20 72 down server-id r
61f0: 70 63 3a 6c 69 73 74 65 6e 65 72 29 29 29 29 29 pc:listener)))))
6200: 0a 20 20 20 20 20 20 20 20 20 20 3b 3b 20 65 6e . ;; en
6210: 64 20 6e 65 77 20 6c 6f 6f 70 0a 20 20 20 20 20 d new loop.
6220: 20 20 20 20 20 29 29 29 29 0a 0a 0a 28 64 65 66 ))))...(def
6230: 69 6e 65 20 28 72 70 63 2d 74 72 61 6e 73 70 6f ine (rpc-transpo
6240: 72 74 3a 66 69 6e 64 2d 66 72 65 65 2d 70 6f 72 rt:find-free-por
6250: 74 2d 61 6e 64 2d 6f 70 65 6e 20 70 6f 72 74 20 t-and-open port
6260: 23 21 6b 65 79 20 29 0a 20 20 28 68 61 6e 64 6c #!key ). (handl
6270: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 e-exceptions.
6280: 65 78 6e 0a 20 20 20 28 62 65 67 69 6e 0a 20 20 exn. (begin.
6290: 20 20 20 28 70 72 69 6e 74 20 22 46 61 69 6c 65 (print "Faile
62a0: 64 20 74 6f 20 62 69 6e 64 20 74 6f 20 70 6f 72 d to bind to por
62b0: 74 20 22 20 28 72 70 63 3a 64 65 66 61 75 6c 74 t " (rpc:default
62c0: 2d 73 65 72 76 65 72 2d 70 6f 72 74 29 20 22 2c -server-port) ",
62d0: 20 74 72 79 69 6e 67 20 6e 65 78 74 20 70 6f 72 trying next por
62e0: 74 22 29 0a 20 20 20 20 20 28 72 70 63 2d 74 72 t"). (rpc-tr
62f0: 61 6e 73 70 6f 72 74 3a 66 69 6e 64 2d 66 72 65 ansport:find-fre
6300: 65 2d 70 6f 72 74 2d 61 6e 64 2d 6f 70 65 6e 20 e-port-and-open
6310: 28 61 64 64 31 20 70 6f 72 74 29 29 29 0a 20 20 (add1 port))).
6320: 20 28 72 70 63 3a 64 65 66 61 75 6c 74 2d 73 65 (rpc:default-se
6330: 72 76 65 72 2d 70 6f 72 74 20 70 6f 72 74 29 0a rver-port port).
6340: 20 20 20 28 73 65 74 21 20 2a 72 70 63 2d 6c 69 (set! *rpc-li
6350: 73 74 65 6e 65 72 2d 70 6f 72 74 2a 20 70 6f 72 stener-port* por
6360: 74 29 20 3b 3b 20 61 20 62 69 74 20 70 61 72 61 t) ;; a bit para
6370: 6e 6f 69 64 20 61 62 6f 75 74 20 72 70 63 3a 64 noid about rpc:d
6380: 65 66 61 75 6c 74 2d 73 65 72 76 65 72 2d 70 6f efault-server-po
6390: 72 74 20 70 61 72 61 6d 65 74 65 72 20 6e 6f 74 rt parameter not
63a0: 20 63 68 61 6e 67 69 6e 67 20 61 63 72 6f 73 73 changing across
63b0: 20 74 68 72 65 61 64 73 20 28 61 73 20 70 61 72 threads (as par
63c0: 61 6d 73 20 61 72 65 20 77 6f 6e 74 20 74 6f 20 ams are wont to
63d0: 64 6f 29 2e 20 20 6b 65 65 70 69 6e 67 20 74 68 do). keeping th
63e0: 69 73 20 67 6c 6f 62 61 6c 20 69 6e 20 6d 79 20 is global in my
63f0: 62 61 63 6b 20 70 6f 63 6b 65 74 20 69 6e 20 63 back pocket in c
6400: 61 73 65 20 74 68 69 73 20 63 61 75 73 65 73 20 ase this causes
6410: 70 72 6f 62 6c 65 6d 73 0a 20 20 20 28 73 65 74 problems. (set
6420: 21 20 2a 72 70 63 2d 6c 69 73 74 65 6e 65 72 2d ! *rpc-listener-
6430: 70 6f 72 74 2d 62 69 6e 64 2d 74 69 6d 65 73 74 port-bind-timest
6440: 61 6d 70 2a 20 28 63 75 72 72 65 6e 74 2d 6d 69 amp* (current-mi
6450: 6c 6c 69 73 65 63 6f 6e 64 73 29 29 20 3b 3b 20 lliseconds)) ;;
6460: 6d 61 79 20 77 61 6e 74 20 74 6f 20 74 65 73 74 may want to test
6470: 20 68 6f 77 20 6c 6f 6e 67 20 69 74 20 68 61 73 how long it has
6480: 20 62 65 65 6e 20 73 69 6e 63 65 20 74 68 65 20 been since the
6490: 6c 61 73 74 20 62 69 6e 64 20 61 74 74 65 6d 70 last bind attemp
64a0: 74 20 68 61 70 70 65 6e 65 64 2e 2e 2e 0a 20 20 t happened....
64b0: 20 28 74 63 70 2d 72 65 61 64 2d 74 69 6d 65 6f (tcp-read-timeo
64c0: 75 74 20 32 34 30 30 30 30 29 0a 20 20 20 28 74 ut 240000). (t
64d0: 63 70 2d 62 75 66 66 65 72 2d 73 69 7a 65 20 30 cp-buffer-size 0
64e0: 29 20 3b 3b 20 67 6f 74 74 61 20 64 6f 20 74 68 ) ;; gotta do th
64f0: 69 73 20 62 65 63 61 75 73 65 20 68 74 74 70 2d is because http-
6500: 74 72 61 6e 73 70 6f 72 74 20 75 6e 64 6f 65 73 transport undoes
6510: 20 69 74 2e 0a 20 20 20 28 74 63 70 2d 6c 69 73 it.. (tcp-lis
6520: 74 65 6e 20 28 72 70 63 3a 64 65 66 61 75 6c 74 ten (rpc:default
6530: 2d 73 65 72 76 65 72 2d 70 6f 72 74 29 20 31 30 -server-port) 10
6540: 30 30 30 29 0a 20 20 20 29 29 0a 20 20 0a 28 64 000). )). .(d
6550: 65 66 69 6e 65 20 28 72 70 63 2d 74 72 61 6e 73 efine (rpc-trans
6560: 70 6f 72 74 3a 70 69 6e 67 20 72 75 6e 2d 69 64 port:ping run-id
6570: 20 68 6f 73 74 20 70 6f 72 74 29 0a 20 20 28 68 host port). (h
6580: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
6590: 0a 20 20 20 65 78 6e 0a 20 20 20 28 62 65 67 69 . exn. (begi
65a0: 6e 0a 20 20 20 20 20 28 70 72 69 6e 74 20 22 53 n. (print "S
65b0: 45 52 56 45 52 5f 4e 4f 54 5f 46 4f 55 4e 44 20 ERVER_NOT_FOUND
65c0: 65 78 6e 3d 22 65 78 6e 29 0a 20 20 20 20 20 28 exn="exn). (
65d0: 65 78 69 74 20 31 29 29 0a 20 20 20 28 6c 65 74 exit 1)). (let
65e0: 20 28 28 6c 6f 67 69 6e 2d 72 65 73 20 28 28 72 ((login-res ((r
65f0: 70 63 3a 70 72 6f 63 65 64 75 72 65 20 27 73 65 pc:procedure 'se
6600: 72 76 65 72 3a 6c 6f 67 69 6e 20 68 6f 73 74 20 rver:login host
6610: 70 6f 72 74 29 20 2a 74 6f 70 70 61 74 68 2a 29 port) *toppath*)
6620: 29 29 0a 20 20 20 20 20 28 69 66 20 6c 6f 67 69 )). (if logi
6630: 6e 2d 72 65 73 0a 09 20 28 62 65 67 69 6e 0a 09 n-res.. (begin..
6640: 20 20 20 28 70 72 69 6e 74 20 22 4c 4f 47 49 4e (print "LOGIN
6650: 5f 4f 4b 22 29 0a 09 20 20 20 28 65 78 69 74 20 _OK").. (exit
6660: 30 29 29 0a 09 20 28 62 65 67 69 6e 0a 09 20 20 0)).. (begin..
6670: 20 28 70 72 69 6e 74 20 22 4c 4f 47 49 4e 5f 46 (print "LOGIN_F
6680: 41 49 4c 45 44 22 29 0a 09 20 20 20 28 65 78 69 AILED").. (exi
6690: 74 20 31 29 29 29 29 29 29 0a 0a 28 64 65 66 69 t 1))))))..(defi
66a0: 6e 65 20 28 72 70 63 2d 74 72 61 6e 73 70 6f 72 ne (rpc-transpor
66b0: 74 3a 73 65 6c 66 2d 74 65 73 74 20 72 75 6e 2d t:self-test run-
66c0: 69 64 20 68 6f 73 74 20 70 6f 72 74 29 0a 20 20 id host port).
66d0: 28 74 63 70 2d 62 75 66 66 65 72 2d 73 69 7a 65 (tcp-buffer-size
66e0: 20 30 29 20 3b 3b 20 67 6f 74 74 61 20 64 6f 20 0) ;; gotta do
66f0: 74 68 69 73 20 62 65 63 61 75 73 65 20 68 74 74 this because htt
6700: 70 2d 74 72 61 6e 73 70 6f 72 74 20 75 6e 64 6f p-transport undo
6710: 65 73 20 69 74 2e 0a 20 20 28 6c 65 74 2a 20 28 es it.. (let* (
6720: 28 74 65 73 74 69 6e 67 2d 72 65 73 20 28 28 72 (testing-res ((r
6730: 70 63 3a 70 72 6f 63 65 64 75 72 65 20 27 74 65 pc:procedure 'te
6740: 73 74 69 6e 67 20 68 6f 73 74 20 70 6f 72 74 29 sting host port)
6750: 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c 6f 67 )). (log
6760: 69 6e 2d 72 65 73 20 28 28 72 70 63 3a 70 72 6f in-res ((rpc:pro
6770: 63 65 64 75 72 65 20 27 73 65 72 76 65 72 3a 6c cedure 'server:l
6780: 6f 67 69 6e 20 68 6f 73 74 20 70 6f 72 74 29 20 ogin host port)
6790: 2a 74 6f 70 70 61 74 68 2a 29 29 0a 20 20 20 20 *toppath*)).
67a0: 20 20 20 20 20 28 72 65 73 20 28 61 6e 64 20 6c (res (and l
67b0: 6f 67 69 6e 2d 72 65 73 20 28 65 71 75 61 6c 3f ogin-res (equal?
67c0: 20 74 65 73 74 69 6e 67 2d 72 65 73 20 22 4a 75 testing-res "Ju
67d0: 73 74 20 74 65 73 74 69 6e 67 22 29 29 29 29 0a st testing")))).
67e0: 20 20 20 20 0a 20 20 20 20 28 69 66 20 6c 6f 67 . (if log
67f0: 69 6e 2d 72 65 73 0a 20 20 20 20 20 20 20 20 28 in-res. (
6800: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
6810: 3b 3b 28 42 42 3e 20 22 53 65 6c 66 20 74 65 73 ;;(BB> "Self tes
6820: 74 20 50 41 53 53 2e 20 20 6c 6f 67 69 6e 2d 72 t PASS. login-r
6830: 65 73 3d 22 6c 6f 67 69 6e 2d 72 65 73 22 20 74 es="login-res" t
6840: 65 73 74 69 6e 67 2d 72 65 73 3d 22 74 65 73 74 esting-res="test
6850: 69 6e 67 2d 72 65 73 22 20 2a 74 6f 70 70 61 74 ing-res" *toppat
6860: 68 2a 3d 22 2a 74 6f 70 70 61 74 68 2a 29 0a 20 h*="*toppath*).
6870: 20 20 20 20 20 20 20 20 20 23 74 29 0a 20 20 20 #t).
6880: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
6890: 20 20 20 20 20 20 3b 3b 28 42 42 3e 20 22 53 65 ;;(BB> "Se
68a0: 6c 66 20 74 65 73 74 20 66 61 69 6c 2e 20 20 6c lf test fail. l
68b0: 6f 67 69 6e 2d 72 65 73 3d 22 6c 6f 67 69 6e 2d ogin-res="login-
68c0: 72 65 73 22 20 74 65 73 74 69 6e 67 2d 72 65 73 res" testing-res
68d0: 3d 22 74 65 73 74 69 6e 67 2d 72 65 73 22 20 2a ="testing-res" *
68e0: 74 6f 70 70 61 74 68 2a 3d 22 2a 74 6f 70 70 61 toppath*="*toppa
68f0: 74 68 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 th*).
6900: 0a 20 20 20 20 20 20 20 20 20 20 23 66 29 29 0a . #f)).
6910: 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 res))..(defi
6920: 6e 65 20 28 72 70 63 2d 74 72 61 6e 73 70 6f 72 ne (rpc-transpor
6930: 74 3a 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 72 t:client-setup r
6940: 75 6e 2d 69 64 20 73 65 72 76 65 72 2d 64 61 74 un-id server-dat
6950: 20 23 21 6b 65 79 20 28 72 65 6d 74 72 69 65 73 #!key (remtries
6960: 20 31 30 29 29 0a 20 20 3b 3b 28 42 42 3e 20 22 10)). ;;(BB> "
6970: 65 6e 74 65 72 65 64 20 72 70 63 2d 74 72 61 6e entered rpc-tran
6980: 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 73 65 74 sport:client-set
6990: 75 70 20 77 69 74 68 20 72 75 6e 2d 69 64 3d 22 up with run-id="
69a0: 72 75 6e 2d 69 64 22 20 61 6e 64 20 73 65 72 76 run-id" and serv
69b0: 65 72 2d 64 61 74 3d 22 73 65 72 76 65 72 2d 64 er-dat="server-d
69c0: 61 74 22 20 61 6e 64 20 72 65 74 72 69 65 73 3d at" and retries=
69d0: 22 72 65 6d 74 72 69 65 73 29 0a 20 20 28 74 63 "remtries). (tc
69e0: 70 2d 62 75 66 66 65 72 2d 73 69 7a 65 20 30 29 p-buffer-size 0)
69f0: 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
6a00: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
6a10: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 70 63 2d 74 log-port* "rpc-t
6a20: 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d ransport:client-
6a30: 73 65 74 75 70 20 72 75 6e 2d 69 64 3d 22 72 75 setup run-id="ru
6a40: 6e 2d 69 64 22 20 73 65 72 76 65 72 2d 64 61 74 n-id" server-dat
6a50: 3d 22 20 73 65 72 76 65 72 2d 64 61 74 20 22 2c =" server-dat ",
6a60: 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 69 65 73 remaining-tries
6a70: 3d 22 20 72 65 6d 74 72 69 65 73 29 0a 20 20 28 =" remtries). (
6a80: 6c 65 74 2a 20 28 28 69 66 61 63 65 20 20 20 20 let* ((iface
6a90: 20 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f (tasks:hostinfo
6aa0: 2d 67 65 74 2d 69 6e 74 65 72 66 61 63 65 20 73 -get-interface s
6ab0: 65 72 76 65 72 2d 64 61 74 29 29 0a 20 20 20 20 erver-dat)).
6ac0: 20 20 20 20 20 28 68 6f 73 74 6e 61 6d 65 20 20 (hostname
6ad0: 28 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d (tasks:hostinfo-
6ae0: 67 65 74 2d 68 6f 73 74 6e 61 6d 65 20 20 73 65 get-hostname se
6af0: 72 76 65 72 2d 64 61 74 29 29 0a 20 20 20 20 20 rver-dat)).
6b00: 20 20 20 20 28 70 6f 72 74 20 20 20 20 20 20 28 (port (
6b10: 74 61 73 6b 73 3a 68 6f 73 74 69 6e 66 6f 2d 67 tasks:hostinfo-g
6b20: 65 74 2d 70 6f 72 74 20 20 20 20 20 20 73 65 72 et-port ser
6b30: 76 65 72 2d 64 61 74 29 29 0a 20 20 20 20 20 20 ver-dat)).
6b40: 20 20 20 28 72 75 6e 72 65 6d 6f 74 65 2d 73 65 (runremote-se
6b50: 72 76 65 72 2d 64 61 74 20 28 76 65 63 74 6f 72 rver-dat (vector
6b60: 20 69 66 61 63 65 20 70 6f 72 74 20 23 66 20 23 iface port #f #
6b70: 66 20 23 66 20 28 63 75 72 72 65 6e 74 2d 73 65 f #f (current-se
6b80: 63 6f 6e 64 73 29 20 27 72 70 63 29 29 20 3b 3b conds) 'rpc)) ;;
6b90: 20 68 74 74 70 20 76 65 72 73 69 6f 6e 20 3a 3d http version :=
6ba0: 20 28 76 65 63 74 6f 72 20 69 66 61 63 65 20 70 (vector iface p
6bb0: 6f 72 74 20 61 70 69 2d 75 72 69 20 61 70 69 2d ort api-uri api-
6bc0: 75 72 6c 20 61 70 69 2d 72 65 71 20 28 63 75 72 url api-req (cur
6bd0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 27 68 rent-seconds) 'h
6be0: 74 74 70 20 20 29 0a 20 20 20 20 20 20 20 20 20 ttp ).
6bf0: 28 70 69 6e 67 2d 72 65 73 20 28 72 65 74 72 79 (ping-res (retry
6c00: 2d 74 68 75 6e 6b 20 28 6c 61 6d 62 64 61 20 28 -thunk (lambda (
6c10: 29 20 20 3b 3b 20 6d 61 6b 65 20 33 20 61 74 74 ) ;; make 3 att
6c20: 65 6d 70 74 73 20 74 6f 20 70 69 6e 67 2e 0a 20 empts to ping..
6c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6c50: 20 28 28 72 70 63 3a 70 72 6f 63 65 64 75 72 65 ((rpc:procedure
6c60: 20 27 73 65 72 76 65 72 3a 6c 6f 67 69 6e 20 69 'server:login i
6c70: 66 61 63 65 20 70 6f 72 74 29 20 2a 74 6f 70 70 face port) *topp
6c80: 61 74 68 2a 29 29 0a 20 20 20 20 20 20 20 20 20 ath*)).
6c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ca0: 20 20 20 20 20 20 20 63 68 61 74 74 79 3a 20 23 chatty: #
6cb0: 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 f.
6cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6cd0: 20 20 72 65 74 72 69 65 73 3a 20 33 29 29 29 0a retries: 3))).
6ce0: 20 20 20 20 3b 3b 20 77 65 20 67 6f 74 20 68 65 ;; we got he
6cf0: 72 65 20 66 72 6f 6d 20 72 6d 74 3a 67 65 74 2d re from rmt:get-
6d00: 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 connection-info
6d10: 6f 6e 20 74 68 65 20 63 6f 6e 64 69 74 69 6f 6e on the condition
6d20: 20 74 68 61 74 20 2a 72 75 6e 72 65 6d 6f 74 65 that *runremote
6d30: 2a 20 68 61 73 20 6e 6f 20 65 6e 74 72 79 20 66 * has no entry f
6d40: 6f 72 20 72 75 6e 2d 69 64 2e 2e 2e 0a 20 20 20 or run-id....
6d50: 20 28 69 66 20 70 69 6e 67 2d 72 65 73 0a 20 20 (if ping-res.
6d60: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
6d70: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
6d80: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
6d90: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 ult-log-port* "r
6da0: 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 pc-transport:cli
6db0: 65 6e 74 2d 73 65 74 75 70 20 43 4f 4e 4e 45 43 ent-setup CONNEC
6dc0: 54 49 4f 4e 20 45 53 54 41 42 4c 49 53 48 45 44 TION ESTABLISHED
6dd0: 20 72 75 6e 2d 69 64 3d 22 72 75 6e 2d 69 64 22 run-id="run-id"
6de0: 20 73 65 72 76 65 72 2d 64 61 74 3d 22 20 73 65 server-dat=" se
6df0: 72 76 65 72 2d 64 61 74 29 0a 20 20 20 20 20 20 rver-dat).
6e00: 20 20 20 20 28 72 6d 74 3a 73 65 74 2d 63 69 6e (rmt:set-cin
6e10: 66 6f 20 72 75 6e 2d 69 64 20 72 75 6e 72 65 6d fo run-id runrem
6e20: 6f 74 65 2d 73 65 72 76 65 72 2d 64 61 74 29 20 ote-server-dat)
6e30: 3b 3b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 ;; (hash-table-s
6e40: 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 et! *runremote*
6e50: 72 75 6e 2d 69 64 20 72 75 6e 72 65 6d 6f 74 65 run-id runremote
6e60: 2d 73 65 72 76 65 72 2d 64 61 74 29 20 20 3b 3b -server-dat) ;;
6e70: 20 73 69 64 65 2d 65 66 66 65 63 74 20 2d 20 2a side-effect - *
6e80: 72 75 6e 72 65 6d 6f 74 65 2a 20 63 61 63 68 65 runremote* cache
6e90: 20 69 6e 69 74 20 66 70 72 20 72 6d 74 3a 2a 0a init fpr rmt:*.
6ea0: 20 20 20 20 20 20 20 20 20 20 72 75 6e 72 65 6d runrem
6eb0: 6f 74 65 2d 73 65 72 76 65 72 2d 64 61 74 29 0a ote-server-dat).
6ec0: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 3b (begin ;
6ed0: 3b 20 6c 6f 67 69 6e 20 66 61 69 6c 65 64 20 62 ; login failed b
6ee0: 75 74 20 68 61 76 65 20 61 20 73 65 72 76 65 72 ut have a server
6ef0: 20 72 65 63 6f 72 64 2c 20 63 6c 65 61 6e 20 6f record, clean o
6f00: 75 74 20 74 68 65 20 72 65 63 6f 72 64 20 61 6e ut the record an
6f10: 64 20 74 72 79 20 61 67 61 69 6e 0a 20 20 20 20 d try again.
6f20: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
6f30: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
6f40: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 70 lt-log-port* "rp
6f50: 63 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 c-transport:clie
6f60: 6e 74 2d 73 65 74 75 70 20 55 4e 41 42 4c 45 20 nt-setup UNABLE
6f70: 54 4f 20 43 4f 4e 4e 45 43 54 20 72 75 6e 2d 69 TO CONNECT run-i
6f80: 64 3d 22 72 75 6e 2d 69 64 22 20 73 65 72 76 65 d="run-id" serve
6f90: 72 2d 64 61 74 3d 22 20 73 65 72 76 65 72 2d 64 r-dat=" server-d
6fa0: 61 74 29 0a 20 20 20 20 20 20 20 20 20 20 28 74 at). (t
6fb0: 61 73 6b 73 3a 6b 69 6c 6c 2d 73 65 72 76 65 72 asks:kill-server
6fc0: 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 29 0a -run-id run-id).
6fd0: 20 20 20 20 20 20 20 20 20 20 28 74 61 73 6b 73 (tasks
6fe0: 3a 73 65 72 76 65 72 2d 66 6f 72 63 65 2d 63 6c :server-force-cl
6ff0: 65 61 6e 2d 72 75 6e 2d 72 65 63 6f 72 64 20 20 ean-run-record
7000: 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 73 (db:delay-if-bus
7010: 79 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 y (tasks:open-db
7020: 29 29 20 72 75 6e 2d 69 64 20 69 66 61 63 65 20 )) run-id iface
7030: 70 6f 72 74 0a 20 20 20 20 20 20 20 20 20 20 20 port.
7040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7060: 20 20 20 20 20 20 20 20 22 20 72 70 63 2d 74 72 " rpc-tr
7070: 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 73 ansport:client-s
7080: 65 74 75 70 20 28 73 65 72 76 65 72 2d 64 61 74 etup (server-dat
7090: 20 3d 20 23 74 29 22 29 0a 20 20 20 20 20 20 20 = #t)").
70a0: 20 20 20 28 69 66 20 28 3e 20 72 65 6d 74 72 69 (if (> remtri
70b0: 65 73 20 32 29 0a 20 20 20 20 20 20 20 20 20 20 es 2).
70c0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
70d0: 70 21 20 28 2b 20 31 20 28 72 61 6e 64 6f 6d 20 p! (+ 1 (random
70e0: 35 29 29 29 20 3b 3b 20 73 70 72 65 61 64 20 6f 5))) ;; spread o
70f0: 75 74 20 74 68 65 20 73 74 61 72 74 73 20 61 20 ut the starts a
7100: 6c 69 74 74 6c 65 0a 20 20 20 20 20 20 20 20 20 little.
7110: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
7120: 65 70 21 20 28 2b 20 31 35 20 28 72 61 6e 64 6f ep! (+ 15 (rando
7130: 6d 20 32 30 29 29 29 29 20 3b 3b 20 69 74 20 69 m 20)))) ;; it i
7140: 73 6e 27 74 20 67 6f 69 6e 67 20 77 65 6c 6c 2e sn't going well.
7150: 20 67 69 76 65 20 69 74 20 70 6c 65 6e 74 79 20 give it plenty
7160: 6f 66 20 74 69 6d 65 0a 20 20 20 20 20 20 20 20 of time.
7170: 20 20 28 73 65 72 76 65 72 3a 74 72 79 2d 72 75 (server:try-ru
7180: 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 29 0a 20 20 nning run-id).
7190: 20 20 20 20 20 20 20 20 28 74 68 72 65 61 64 2d (thread-
71a0: 73 6c 65 65 70 21 20 35 29 20 20 20 3b 3b 20 67 sleep! 5) ;; g
71b0: 69 76 65 20 73 65 72 76 65 72 20 61 20 6c 69 74 ive server a lit
71c0: 74 6c 65 20 74 69 6d 65 20 74 6f 20 73 74 61 72 tle time to star
71d0: 74 20 75 70 0a 20 20 20 20 20 20 20 20 20 20 28 t up. (
71e0: 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 72 75 6e client:setup run
71f0: 2d 69 64 20 72 65 6d 61 69 6e 69 6e 67 2d 74 72 -id remaining-tr
7200: 69 65 73 3a 20 28 73 75 62 31 20 72 65 6d 74 72 ies: (sub1 remtr
7210: 69 65 73 29 29 29 29 29 29 0a ies)))))).