Artifact
c41c92f350ecf2643b4b805fbab958f7e345136f:
0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 32 2c 20 4d 61 74 74 68 65 77 06-2012, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 28 72 65 71 75 PURPOSE...(requ
0150: 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 73 ire-extension (s
0160: 72 66 69 20 31 38 29 20 65 78 74 72 61 73 20 74 rfi 18) extras t
0170: 63 70 20 73 31 31 6e 20 72 70 63 29 0a 28 69 6d cp s11n rpc).(im
0180: 70 6f 72 74 20 28 70 72 65 66 69 78 20 72 70 63 port (prefix rpc
0190: 20 72 70 63 3a 29 29 0a 0a 28 75 73 65 20 73 71 rpc:))..(use sq
01a0: 6c 69 74 65 33 20 73 72 66 69 2d 31 20 70 6f 73 lite3 srfi-1 pos
01b0: 69 78 20 72 65 67 65 78 20 72 65 67 65 78 2d 63 ix regex regex-c
01c0: 61 73 65 20 73 72 66 69 2d 36 39 20 68 6f 73 74 ase srfi-69 host
01d0: 69 6e 66 6f 20 6d 64 35 20 6d 65 73 73 61 67 65 info md5 message
01e0: 2d 64 69 67 65 73 74 29 0a 28 69 6d 70 6f 72 74 -digest).(import
01f0: 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 (prefix sqlite3
0200: 20 73 71 6c 69 74 65 33 3a 29 29 0a 0a 28 64 65 sqlite3:))..(de
0210: 63 6c 61 72 65 20 28 75 6e 69 74 20 72 70 63 2d clare (unit rpc-
0220: 74 72 61 6e 73 70 6f 72 74 29 29 0a 0a 28 64 65 transport))..(de
0230: 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6d 6d clare (uses comm
0240: 6f 6e 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 on)).(declare (u
0250: 73 65 73 20 64 62 29 29 0a 28 64 65 63 6c 61 72 ses db)).(declar
0260: 65 20 28 75 73 65 73 20 74 65 73 74 73 29 29 0a e (uses tests)).
0270: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 (declare (uses t
0280: 61 73 6b 73 29 29 20 3b 3b 20 74 61 73 6b 73 20 asks)) ;; tasks
0290: 61 72 65 20 77 68 65 72 65 20 73 74 75 66 66 20 are where stuff
02a0: 69 73 20 6d 61 69 6e 74 61 69 6e 65 64 20 61 62 is maintained ab
02b0: 6f 75 74 20 77 68 61 74 20 69 73 20 72 75 6e 6e out what is runn
02c0: 69 6e 67 2e 0a 0a 28 69 6e 63 6c 75 64 65 20 22 ing...(include "
02d0: 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 common_records.s
02e0: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 cm").(include "d
02f0: 62 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a b_records.scm").
0300: 0a 3b 3b 20 70 72 6f 63 73 74 72 20 69 73 20 74 .;; procstr is t
0310: 68 65 20 6e 61 6d 65 20 6f 66 20 74 68 65 20 70 he name of the p
0320: 72 6f 63 65 64 75 72 65 20 74 6f 20 62 65 20 63 rocedure to be c
0330: 61 6c 6c 65 64 20 61 73 20 61 20 73 74 72 69 6e alled as a strin
0340: 67 0a 28 64 65 66 69 6e 65 20 28 72 70 63 2d 74 g.(define (rpc-t
0350: 72 61 6e 73 70 6f 72 74 3a 61 75 74 6f 72 65 6d ransport:autorem
0360: 6f 74 65 20 70 72 6f 63 73 74 72 20 70 61 72 61 ote procstr para
0370: 6d 73 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 ms). (handle-ex
0380: 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a ceptions. exn.
0390: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 28 (begin. (
03a0: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 debug:print 1 "R
03b0: 65 6d 6f 74 65 20 66 61 69 6c 65 64 20 66 6f 72 emote failed for
03c0: 20 22 20 70 72 6f 63 20 22 20 22 20 70 61 72 61 " proc " " para
03d0: 6d 73 29 0a 20 20 20 20 20 28 61 70 70 6c 79 20 ms). (apply
03e0: 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 (eval (string->s
03f0: 79 6d 62 6f 6c 20 70 72 6f 63 73 74 72 29 29 20 ymbol procstr))
0400: 70 61 72 61 6d 73 29 29 0a 20 20 20 3b 3b 20 28 params)). ;; (
0410: 69 66 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 0a 20 if *runremote*.
0420: 20 20 3b 3b 20 20 20 20 28 61 70 70 6c 79 20 28 ;; (apply (
0430: 65 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 eval (string->sy
0440: 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 72 65 6d 6f mbol (conc "remo
0450: 74 65 3a 22 20 70 72 6f 63 73 74 72 29 29 29 20 te:" procstr)))
0460: 70 61 72 61 6d 73 29 0a 20 20 20 28 61 70 70 6c params). (appl
0470: 79 20 28 65 76 61 6c 20 28 73 74 72 69 6e 67 2d y (eval (string-
0480: 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 73 74 72 29 >symbol procstr)
0490: 29 20 70 61 72 61 6d 73 29 29 29 0a 0a 3b 3b 20 ) params)))..;;
04a0: 61 6c 6c 20 72 6f 75 74 65 73 20 74 68 6f 75 67 all routes thoug
04b0: 68 20 68 65 72 65 20 65 6e 64 20 69 6e 20 65 78 h here end in ex
04c0: 69 74 20 2e 2e 2e 0a 3b 3b 0a 3b 3b 20 73 74 61 it ....;;.;; sta
04d0: 72 74 5f 73 65 72 76 65 72 3f 20 0a 3b 3b 0a 28 rt_server? .;;.(
04e0: 64 65 66 69 6e 65 20 28 72 70 63 2d 74 72 61 6e define (rpc-tran
04f0: 73 70 6f 72 74 3a 6c 61 75 6e 63 68 20 72 75 6e sport:launch run
0500: 2d 69 64 29 0a 20 20 28 73 65 74 21 20 2a 72 75 -id). (set! *ru
0510: 6e 2d 69 64 2a 20 20 20 72 75 6e 2d 69 64 29 0a n-id* run-id).
0520: 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d (if (args:get-
0530: 61 72 67 20 22 2d 64 61 65 6d 6f 6e 69 7a 65 22 arg "-daemonize"
0540: 29 0a 20 20 20 20 20 20 28 64 61 65 6d 6f 6e 3a ). (daemon:
0550: 69 7a 65 29 29 0a 20 20 28 69 66 20 28 73 65 72 ize)). (if (ser
0560: 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e ver:check-if-run
0570: 6e 69 6e 67 20 72 75 6e 2d 69 64 29 0a 20 20 20 ning run-id).
0580: 20 20 20 28 62 65 67 69 6e 0a 09 28 64 65 62 75 (begin..(debu
0590: 67 3a 70 72 69 6e 74 20 30 20 22 49 4e 46 4f 3a g:print 0 "INFO:
05a0: 20 53 65 72 76 65 72 20 66 6f 72 20 72 75 6e 2d Server for run-
05b0: 69 64 20 22 20 72 75 6e 2d 69 64 20 22 20 61 6c id " run-id " al
05c0: 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 22 29 0a ready running").
05d0: 09 28 65 78 69 74 20 30 29 29 29 0a 20 20 28 6c .(exit 0))). (l
05e0: 65 74 20 6c 6f 6f 70 20 28 28 73 65 72 76 65 72 et loop ((server
05f0: 2d 69 64 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c -id (open-run-cl
0600: 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 76 65 72 ose tasks:server
0610: 2d 6c 6f 63 6b 2d 73 6c 6f 74 20 74 61 73 6b 73 -lock-slot tasks
0620: 3a 6f 70 65 6e 2d 64 62 20 72 75 6e 2d 69 64 29 :open-db run-id)
0630: 29 0a 09 20 20 20 20 20 28 72 65 6d 74 72 69 65 ).. (remtrie
0640: 73 20 20 34 29 29 0a 20 20 20 20 28 69 66 20 28 s 4)). (if (
0650: 6e 6f 74 20 73 65 72 76 65 72 2d 69 64 29 0a 09 not server-id)..
0660: 28 69 66 20 28 3e 20 72 65 6d 74 72 69 65 73 20 (if (> remtries
0670: 30 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 0).. (begin..
0680: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
0690: 65 65 70 21 20 32 29 0a 09 20 20 20 20 20 20 28 eep! 2).. (
06a0: 6c 6f 6f 70 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 loop (open-run-c
06b0: 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 72 76 65 lose tasks:serve
06c0: 72 2d 6c 6f 63 6b 2d 73 6c 6f 74 20 74 61 73 6b r-lock-slot task
06d0: 73 3a 6f 70 65 6e 2d 64 62 20 72 75 6e 2d 69 64 s:open-db run-id
06e0: 29 0a 09 09 20 20 20 20 28 2d 20 72 65 6d 74 72 )... (- remtr
06f0: 69 65 73 20 31 29 29 29 0a 09 20 20 20 20 28 62 ies 1))).. (b
0700: 65 67 69 6e 0a 09 20 20 20 20 20 20 3b 3b 20 73 egin.. ;; s
0710: 69 6e 63 65 20 77 65 20 64 69 64 6e 27 74 20 67 ince we didn't g
0720: 65 74 20 74 68 65 20 73 65 72 76 65 72 20 6c 6f et the server lo
0730: 63 6b 20 77 65 20 61 72 65 20 67 6f 69 6e 67 20 ck we are going
0740: 74 6f 20 63 6c 65 61 6e 20 75 70 20 61 6e 64 20 to clean up and
0750: 62 61 69 6c 20 6f 75 74 0a 09 20 20 20 20 20 20 bail out..
0760: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
0770: 6f 20 32 20 22 49 4e 46 4f 3a 20 73 65 72 76 65 o 2 "INFO: serve
0780: 72 20 70 69 64 3d 22 20 28 63 75 72 72 65 6e 74 r pid=" (current
0790: 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 22 2c 20 -process-id) ",
07a0: 68 6f 73 74 6e 61 6d 65 3d 22 20 28 67 65 74 2d hostname=" (get-
07b0: 68 6f 73 74 2d 6e 61 6d 65 29 20 22 20 6e 6f 74 host-name) " not
07c0: 20 73 74 61 72 74 69 6e 67 20 64 75 65 20 74 6f starting due to
07d0: 20 6f 74 68 65 72 20 63 61 6e 64 69 64 61 74 65 other candidate
07e0: 73 20 61 68 65 61 64 20 69 6e 20 73 74 61 72 74 s ahead in start
07f0: 20 71 75 65 75 65 22 29 0a 09 20 20 20 20 20 20 queue")..
0800: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
0810: 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 64 65 6c tasks:server-del
0820: 65 74 65 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d ete-records-for-
0830: 74 68 69 73 2d 70 69 64 20 74 61 73 6b 73 3a 6f this-pid tasks:o
0840: 70 65 6e 2d 64 62 20 22 20 72 70 63 2d 74 72 61 pen-db " rpc-tra
0850: 6e 73 70 6f 72 74 3a 6c 61 75 6e 63 68 22 29 0a nsport:launch").
0860: 09 20 20 20 20 20 20 29 29 0a 09 28 6c 65 74 2a . ))..(let*
0870: 20 28 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 ((th2 (make-thr
0880: 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 ead (lambda ()..
0890: 09 09 09 20 20 20 28 72 70 63 2d 74 72 61 6e 73 ... (rpc-trans
08a0: 70 6f 72 74 3a 72 75 6e 20 0a 09 09 09 09 20 20 port:run .....
08b0: 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d (if (args:get-
08c0: 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a 09 arg "-server")..
08d0: 09 09 09 09 28 61 72 67 73 3a 67 65 74 2d 61 72 ....(args:get-ar
08e0: 67 20 22 2d 73 65 72 76 65 72 22 29 0a 09 09 09 g "-server")....
08f0: 09 09 22 2d 22 29 0a 09 09 09 09 20 20 20 20 72 .."-")..... r
0900: 75 6e 2d 69 64 0a 09 09 09 09 20 20 20 20 73 65 un-id..... se
0910: 72 76 65 72 2d 69 64 29 29 20 22 53 65 72 76 65 rver-id)) "Serve
0920: 72 20 72 75 6e 22 29 29 0a 09 20 20 20 20 20 20 r run"))..
0930: 20 28 74 68 33 20 28 6d 61 6b 65 2d 74 68 72 65 (th3 (make-thre
0940: 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 ad (lambda ()...
0950: 09 09 20 20 20 28 72 70 63 2d 74 72 61 6e 73 70 .. (rpc-transp
0960: 6f 72 74 3a 6b 65 65 70 2d 72 75 6e 6e 69 6e 67 ort:keep-running
0970: 20 72 75 6e 2d 69 64 20 73 65 72 76 65 72 2d 69 run-id server-i
0980: 64 29 29 0a 09 09 09 09 20 22 4b 65 65 70 20 72 d))..... "Keep r
0990: 75 6e 6e 69 6e 67 22 29 29 29 0a 09 20 20 3b 3b unning"))).. ;;
09a0: 20 44 61 74 61 62 61 73 65 20 63 6f 6e 6e 65 63 Database connec
09b0: 74 69 6f 6e 0a 09 20 20 28 73 65 74 21 20 2a 69 tion.. (set! *i
09c0: 6e 6d 65 6d 64 62 2a 20 20 28 64 62 3a 73 65 74 nmemdb* (db:set
09d0: 75 70 20 72 75 6e 2d 69 64 29 29 0a 09 20 20 28 up run-id)).. (
09e0: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th
09f0: 32 29 0a 09 20 20 28 74 68 72 65 61 64 2d 73 74 2).. (thread-st
0a00: 61 72 74 21 20 74 68 33 29 0a 09 20 20 28 73 65 art! th3).. (se
0a10: 74 21 20 2a 64 69 64 73 6f 6d 65 74 68 69 6e 67 t! *didsomething
0a20: 2a 20 23 74 29 0a 09 20 20 28 74 68 72 65 61 64 * #t).. (thread
0a30: 2d 6a 6f 69 6e 21 20 74 68 33 29 0a 09 20 20 28 -join! th3).. (
0a40: 65 78 69 74 29 29 29 29 29 0a 0a 28 64 65 66 69 exit)))))..(defi
0a50: 6e 65 20 28 72 70 63 2d 74 72 61 6e 73 70 6f 72 ne (rpc-transpor
0a60: 74 3a 72 75 6e 20 68 6f 73 74 6e 20 72 75 6e 2d t:run hostn run-
0a70: 69 64 20 73 65 72 76 65 72 2d 69 64 29 0a 20 20 id server-id).
0a80: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 (debug:print 2 "
0a90: 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 73 74 Attempting to st
0aa0: 61 72 74 20 74 68 65 20 72 70 63 20 73 65 72 76 art the rpc serv
0ab0: 65 72 20 2e 2e 2e 22 29 0a 20 20 28 6c 65 74 2a er ..."). (let*
0ac0: 20 28 28 64 62 20 20 20 20 20 20 20 20 20 20 20 ((db
0ad0: 20 20 20 23 66 29 0a 09 20 28 68 6f 73 74 6e 61 #f).. (hostna
0ae0: 6d 65 20 20 20 20 20 20 20 20 28 67 65 74 2d 68 me (get-h
0af0: 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 69 70 ost-name)).. (ip
0b00: 61 64 64 72 73 74 72 20 20 20 20 20 20 20 28 6c addrstr (l
0b10: 65 74 20 28 28 69 70 73 74 72 20 28 69 66 20 28 et ((ipstr (if (
0b20: 73 74 72 69 6e 67 3d 3f 20 22 2d 22 20 68 6f 73 string=? "-" hos
0b30: 74 6e 29 0a 09 09 09 09 09 20 20 20 3b 3b 20 28 tn)...... ;; (
0b40: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
0b50: 73 65 20 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e se (map number->
0b60: 73 74 72 69 6e 67 20 28 75 38 76 65 63 74 6f 72 string (u8vector
0b70: 2d 3e 6c 69 73 74 20 28 68 6f 73 74 6e 61 6d 65 ->list (hostname
0b80: 2d 3e 69 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 ->ip hostname)))
0b90: 20 22 2e 22 29 0a 09 09 09 09 09 20 20 20 28 73 ".")...... (s
0ba0: 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 erver:get-best-g
0bb0: 75 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f 73 uess-address hos
0bc0: 74 6e 61 6d 65 29 0a 09 09 09 09 09 20 20 20 23 tname)...... #
0bd0: 66 29 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 f))).... (if
0be0: 69 70 73 74 72 20 69 70 73 74 72 20 68 6f 73 74 ipstr ipstr host
0bf0: 6e 29 29 29 20 3b 3b 20 68 6f 73 74 6e 61 6d 65 n))) ;; hostname
0c00: 29 29 29 20 0a 09 20 28 73 74 61 72 74 2d 70 6f ))) .. (start-po
0c10: 72 74 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 rt (open-ru
0c20: 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 65 n-close tasks:se
0c30: 72 76 65 72 2d 67 65 74 2d 6e 65 78 74 2d 70 6f rver-get-next-po
0c40: 72 74 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 rt tasks:open-db
0c50: 29 29 0a 09 20 28 6c 69 6e 6b 2d 74 72 65 65 2d )).. (link-tree-
0c60: 70 61 74 68 20 20 28 63 6f 6e 66 69 67 66 3a 6c path (configf:l
0c70: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
0c80: 2a 20 22 73 65 74 75 70 22 20 22 6c 69 6e 6b 74 * "setup" "linkt
0c90: 72 65 65 22 29 29 0a 09 20 28 72 70 63 3a 6c 69 ree")).. (rpc:li
0ca0: 73 74 65 6e 65 72 20 20 20 28 72 70 63 2d 74 72 stener (rpc-tr
0cb0: 61 6e 73 70 6f 72 74 3a 66 69 6e 64 2d 66 72 65 ansport:find-fre
0cc0: 65 2d 70 6f 72 74 2d 61 6e 64 2d 6f 70 65 6e 20 e-port-and-open
0cd0: 28 72 70 63 3a 64 65 66 61 75 6c 74 2d 73 65 72 (rpc:default-ser
0ce0: 76 65 72 2d 70 6f 72 74 29 29 29 0a 09 20 28 74 ver-port))).. (t
0cf0: 68 31 20 20 20 20 20 20 20 20 20 20 20 20 28 6d h1 (m
0d00: 61 6b 65 2d 74 68 72 65 61 64 0a 09 09 09 20 20 ake-thread....
0d10: 28 63 75 74 65 20 28 72 70 63 3a 6d 61 6b 65 2d (cute (rpc:make-
0d20: 73 65 72 76 65 72 20 72 70 63 3a 6c 69 73 74 65 server rpc:liste
0d30: 6e 65 72 29 20 22 72 70 63 3a 73 65 72 76 65 72 ner) "rpc:server
0d40: 22 29 0a 09 09 09 20 20 27 72 70 63 3a 73 65 72 ").... 'rpc:ser
0d50: 76 65 72 29 29 0a 09 20 28 68 6f 73 74 6e 61 6d ver)).. (hostnam
0d60: 65 20 20 20 20 20 20 20 28 69 66 20 28 73 74 72 e (if (str
0d70: 69 6e 67 3d 3f 20 22 2d 22 20 68 6f 73 74 6e 29 ing=? "-" hostn)
0d80: 0a 09 09 09 20 20 20 20 20 28 67 65 74 2d 68 6f .... (get-ho
0d90: 73 74 2d 6e 61 6d 65 29 20 0a 09 09 09 20 20 20 st-name) ....
0da0: 20 20 68 6f 73 74 6e 29 29 0a 09 20 28 69 70 61 hostn)).. (ipa
0db0: 64 64 72 73 74 72 20 20 20 20 20 20 28 69 66 20 ddrstr (if
0dc0: 28 73 74 72 69 6e 67 3d 3f 20 22 2d 22 20 68 6f (string=? "-" ho
0dd0: 73 74 6e 29 0a 09 09 09 20 20 20 20 20 28 73 65 stn).... (se
0de0: 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 rver:get-best-gu
0df0: 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f 73 74 ess-address host
0e00: 6e 61 6d 65 29 20 3b 3b 20 28 73 74 72 69 6e 67 name) ;; (string
0e10: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 -intersperse (ma
0e20: 70 20 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 p number->string
0e30: 20 28 75 38 76 65 63 74 6f 72 2d 3e 6c 69 73 74 (u8vector->list
0e40: 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 69 70 20 68 (hostname->ip h
0e50: 6f 73 74 6e 61 6d 65 29 29 29 20 22 2e 22 29 0a ostname))) ".").
0e60: 09 09 09 20 20 20 20 20 23 66 29 29 0a 09 20 28 ... #f)).. (
0e70: 70 6f 72 74 6e 75 6d 20 20 20 20 20 20 20 20 28 portnum (
0e80: 72 70 63 3a 64 65 66 61 75 6c 74 2d 73 65 72 76 rpc:default-serv
0e90: 65 72 2d 70 6f 72 74 29 29 0a 09 20 28 68 6f 73 er-port)).. (hos
0ea0: 74 3a 70 6f 72 74 20 20 20 20 20 20 28 63 6f 6e t:port (con
0eb0: 63 20 28 69 66 20 69 70 61 64 64 72 73 74 72 20 c (if ipaddrstr
0ec0: 69 70 61 64 64 72 73 74 72 20 68 6f 73 74 6e 61 ipaddrstr hostna
0ed0: 6d 65 29 20 22 3a 22 20 70 6f 72 74 6e 75 6d 29 me) ":" portnum)
0ee0: 29 0a 09 20 28 74 64 62 20 20 20 20 20 20 20 20 ).. (tdb
0ef0: 20 20 20 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d (tasks:open-
0f00: 64 62 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 db))). (set!
0f10: 64 62 20 2a 69 6e 6d 65 6d 64 62 2a 29 0a 20 20 db *inmemdb*).
0f20: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
0f30: 65 20 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 73 e tasks:server-s
0f40: 65 74 2d 69 6e 74 65 72 66 61 63 65 2d 70 6f 72 et-interface-por
0f50: 74 20 0a 09 09 20 20 20 20 74 61 73 6b 73 3a 6f t ... tasks:o
0f60: 70 65 6e 2d 64 62 20 0a 09 09 20 20 20 20 73 65 pen-db ... se
0f70: 72 76 65 72 2d 69 64 20 0a 09 09 20 20 20 20 69 rver-id ... i
0f80: 70 61 64 64 72 73 74 72 20 70 6f 72 74 6e 75 6d paddrstr portnum
0f90: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
0fa0: 6e 74 20 30 20 22 53 65 72 76 65 72 20 73 74 61 nt 0 "Server sta
0fb0: 72 74 65 64 20 6f 6e 20 22 20 68 6f 73 74 3a 70 rted on " host:p
0fc0: 6f 72 74 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b ort). . ;;
0fd0: 20 63 61 6e 20 75 73 65 20 74 68 69 73 20 74 6f can use this to
0fe0: 20 72 75 6e 20 6d 6f 73 74 20 61 6e 79 74 68 69 run most anythi
0ff0: 6e 67 20 61 74 20 74 68 65 20 72 65 6d 6f 74 65 ng at the remote
1000: 0a 20 20 20 20 28 72 70 63 3a 70 75 62 6c 69 73 . (rpc:publis
1010: 68 2d 70 72 6f 63 65 64 75 72 65 21 20 0a 20 20 h-procedure! .
1020: 20 20 20 27 72 65 6d 6f 74 65 3a 72 75 6e 20 0a 'remote:run .
1030: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 70 72 (lambda (pr
1040: 6f 63 73 74 72 20 2e 20 70 61 72 61 6d 73 29 0a ocstr . params).
1050: 20 20 20 20 20 20 20 28 72 70 63 2d 74 72 61 6e (rpc-tran
1060: 73 70 6f 72 74 3a 61 75 74 6f 72 65 6d 6f 74 65 sport:autoremote
1070: 20 70 72 6f 63 73 74 72 20 70 61 72 61 6d 73 29 procstr params)
1080: 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 20 )). . ;;
1090: 20 20 28 72 70 63 3a 70 75 62 6c 69 73 68 2d 70 (rpc:publish-p
10a0: 72 6f 63 65 64 75 72 65 21 0a 20 20 20 20 3b 3b rocedure!. ;;
10b0: 20 20 20 20 20 27 73 65 72 76 65 72 3a 6c 6f 67 'server:log
10c0: 69 6e 0a 20 20 20 20 3b 3b 20 20 20 20 20 28 6c in. ;; (l
10d0: 61 6d 62 64 61 20 28 74 6f 70 70 61 74 68 29 0a ambda (toppath).
10e0: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 73 65 ;; (se
10f0: 74 21 20 2a 6c 61 73 74 2d 64 62 2d 61 63 63 65 t! *last-db-acce
1100: 73 73 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ss* (current-sec
1110: 6f 6e 64 73 29 29 0a 20 20 20 20 3b 3b 20 20 20 onds)). ;;
1120: 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 (if (equal?
1130: 2a 74 6f 70 70 61 74 68 2a 20 74 6f 70 70 61 74 *toppath* toppat
1140: 68 29 0a 20 20 20 20 3b 3b 09 20 20 20 28 62 65 h). ;;. (be
1150: 67 69 6e 0a 20 20 20 20 3b 3b 09 20 20 20 20 20 gin. ;;.
1160: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
1170: 6f 20 32 20 22 6c 6f 67 69 6e 20 73 75 63 63 65 o 2 "login succe
1180: 73 73 66 75 6c 22 29 0a 20 20 20 20 3b 3b 09 20 ssful"). ;;.
1190: 20 20 20 20 23 74 29 0a 20 20 20 20 3b 3b 09 20 #t). ;;.
11a0: 20 20 23 66 29 29 29 0a 20 20 20 20 3b 3b 0a 20 #f))). ;;.
11b0: 20 20 20 3b 3b 09 20 20 3b 3b 3d 3d 3d 3d 3d 3d ;;. ;;======
11c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1200: 0a 20 20 20 20 3b 3b 09 20 20 3b 3b 20 64 62 20 . ;;. ;; db
1210: 73 70 65 63 69 61 6c 73 20 68 65 72 65 0a 20 20 specials here.
1220: 20 20 3b 3b 09 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d ;;. ;;=======
1230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
1270: 20 20 20 20 3b 3b 09 20 20 3b 3b 20 72 65 6d 6f ;;. ;; remo
1280: 74 65 20 63 61 6c 6c 20 74 6f 20 6f 70 65 6e 2d te call to open-
1290: 72 75 6e 2d 63 6c 6f 73 65 0a 20 20 20 20 3b 3b run-close. ;;
12a0: 09 20 20 28 72 70 63 3a 70 75 62 6c 69 73 68 2d . (rpc:publish-
12b0: 70 72 6f 63 65 64 75 72 65 21 0a 20 20 20 20 3b procedure!. ;
12c0: 3b 09 20 20 20 27 72 64 62 3a 6f 70 65 6e 2d 72 ;. 'rdb:open-r
12d0: 75 6e 2d 63 6c 6f 73 65 20 0a 20 20 20 20 3b 3b un-close . ;;
12e0: 09 20 20 20 28 6c 61 6d 62 64 61 20 28 70 72 6f . (lambda (pro
12f0: 63 6e 61 6d 65 20 2e 20 72 65 6d 61 72 67 73 29 cname . remargs)
1300: 0a 20 20 20 20 3b 3b 09 20 20 20 20 20 28 64 65 . ;;. (de
1310: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
1320: 32 20 22 52 65 6d 6f 74 65 20 63 61 6c 6c 20 6f 2 "Remote call o
1330: 66 20 72 64 62 3a 6f 70 65 6e 2d 72 75 6e 2d 63 f rdb:open-run-c
1340: 6c 6f 73 65 20 22 20 70 72 6f 63 6e 61 6d 65 20 lose " procname
1350: 22 20 22 20 72 65 6d 61 72 67 73 29 0a 20 20 20 " " remargs).
1360: 20 3b 3b 09 09 09 09 09 20 20 20 28 73 65 74 21 ;;..... (set!
1370: 20 2a 6c 61 73 74 2d 64 62 2d 61 63 63 65 73 73 *last-db-access
1380: 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e * (current-secon
1390: 64 73 29 29 0a 20 20 20 20 3b 3b 09 20 20 20 20 ds)). ;;.
13a0: 20 28 61 70 70 6c 79 20 6f 70 65 6e 2d 72 75 6e (apply open-run
13b0: 2d 63 6c 6f 73 65 20 28 65 76 61 6c 20 70 72 6f -close (eval pro
13c0: 63 6e 61 6d 65 29 20 72 65 6d 61 72 67 73 29 29 cname) remargs))
13d0: 29 0a 20 20 20 20 3b 3b 0a 20 20 20 20 3b 3b 09 ). ;;. ;;.
13e0: 20 20 28 72 70 63 3a 70 75 62 6c 69 73 68 2d 70 (rpc:publish-p
13f0: 72 6f 63 65 64 75 72 65 21 0a 20 20 20 20 3b 3b rocedure!. ;;
1400: 09 20 20 20 27 63 64 62 3a 74 65 73 74 2d 73 65 . 'cdb:test-se
1410: 74 2d 73 74 61 74 75 73 2d 73 74 61 74 65 0a 20 t-status-state.
1420: 20 20 20 3b 3b 09 20 20 20 28 6c 61 6d 62 64 61 ;;. (lambda
1430: 20 28 74 65 73 74 2d 69 64 20 73 74 61 74 75 73 (test-id status
1440: 20 73 74 61 74 65 20 6d 73 67 29 0a 20 20 20 20 state msg).
1450: 3b 3b 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ;;. (debug:p
1460: 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 22 52 65 rint-info 12 "Re
1470: 6d 6f 74 65 20 63 61 6c 6c 20 6f 66 20 63 64 62 mote call of cdb
1480: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 :test-set-status
1490: 2d 73 74 61 74 65 20 74 65 73 74 2d 69 64 3d 22 -state test-id="
14a0: 20 74 65 73 74 2d 69 64 20 22 2c 20 73 74 61 74 test-id ", stat
14b0: 75 73 3d 22 20 73 74 61 74 75 73 20 22 2c 20 73 us=" status ", s
14c0: 74 61 74 65 3d 22 20 73 74 61 74 65 20 22 2c 20 tate=" state ",
14d0: 6d 73 67 3d 22 20 6d 73 67 29 0a 20 20 20 20 3b msg=" msg). ;
14e0: 3b 09 20 20 20 20 20 28 63 64 62 3a 74 65 73 74 ;. (cdb:test
14f0: 2d 73 65 74 2d 73 74 61 74 75 73 2d 73 74 61 74 -set-status-stat
1500: 65 20 74 65 73 74 2d 69 64 20 73 74 61 74 75 73 e test-id status
1510: 20 73 74 61 74 65 20 6d 73 67 29 29 29 0a 20 20 state msg))).
1520: 20 20 3b 3b 0a 20 20 20 20 3b 3b 09 20 20 28 72 ;;. ;;. (r
1530: 70 63 3a 70 75 62 6c 69 73 68 2d 70 72 6f 63 65 pc:publish-proce
1540: 64 75 72 65 21 0a 20 20 20 20 3b 3b 09 20 20 20 dure!. ;;.
1550: 27 63 64 62 3a 74 65 73 74 2d 72 6f 6c 6c 75 70 'cdb:test-rollup
1560: 2d 74 65 73 74 5f 64 61 74 61 2d 70 61 73 73 2d -test_data-pass-
1570: 66 61 69 6c 0a 20 20 20 20 3b 3b 09 20 20 20 28 fail. ;;. (
1580: 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 69 64 29 lambda (test-id)
1590: 0a 20 20 20 20 3b 3b 09 20 20 20 20 20 28 64 65 . ;;. (de
15a0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
15b0: 32 20 22 52 65 6d 6f 74 65 20 63 61 6c 6c 20 6f 2 "Remote call o
15c0: 66 20 63 64 62 3a 74 65 73 74 2d 72 6f 6c 6c 75 f cdb:test-rollu
15d0: 70 2d 74 65 73 74 5f 64 61 74 61 2d 70 61 73 73 p-test_data-pass
15e0: 2d 66 61 69 6c 20 22 20 74 65 73 74 2d 69 64 29 -fail " test-id)
15f0: 0a 20 20 20 20 3b 3b 09 20 20 20 20 20 28 63 64 . ;;. (cd
1600: 62 3a 74 65 73 74 2d 72 6f 6c 6c 75 70 2d 74 65 b:test-rollup-te
1610: 73 74 5f 64 61 74 61 2d 70 61 73 73 2d 66 61 69 st_data-pass-fai
1620: 6c 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 20 l test-id))).
1630: 20 3b 3b 0a 20 20 20 20 3b 3b 09 20 20 28 72 70 ;;. ;;. (rp
1640: 63 3a 70 75 62 6c 69 73 68 2d 70 72 6f 63 65 64 c:publish-proced
1650: 75 72 65 21 0a 20 20 20 20 3b 3b 09 20 20 20 27 ure!. ;;. '
1660: 63 64 62 3a 70 61 73 73 2d 66 61 69 6c 2d 63 6f cdb:pass-fail-co
1670: 75 6e 74 73 0a 20 20 20 20 3b 3b 09 20 20 20 28 unts. ;;. (
1680: 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 69 64 20 lambda (test-id
1690: 66 61 69 6c 2d 63 6f 75 6e 74 20 70 61 73 73 2d fail-count pass-
16a0: 63 6f 75 6e 74 29 0a 20 20 20 20 3b 3b 09 20 20 count). ;;.
16b0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
16c0: 69 6e 66 6f 20 31 32 20 22 52 65 6d 6f 74 65 20 info 12 "Remote
16d0: 63 61 6c 6c 20 6f 66 20 63 64 62 3a 70 61 73 73 call of cdb:pass
16e0: 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 22 20 74 -fail-counts " t
16f0: 65 73 74 2d 69 64 20 22 20 70 61 73 73 65 73 3a est-id " passes:
1700: 20 22 20 70 61 73 73 2d 63 6f 75 6e 74 20 22 20 " pass-count "
1710: 66 61 69 6c 73 3a 20 22 20 66 61 69 6c 2d 63 6f fails: " fail-co
1720: 75 6e 74 29 0a 20 20 20 20 3b 3b 09 20 20 20 20 unt). ;;.
1730: 20 28 63 64 62 3a 70 61 73 73 2d 66 61 69 6c 2d (cdb:pass-fail-
1740: 63 6f 75 6e 74 73 20 74 65 73 74 2d 69 64 20 66 counts test-id f
1750: 61 69 6c 2d 63 6f 75 6e 74 20 70 61 73 73 2d 63 ail-count pass-c
1760: 6f 75 6e 74 29 29 29 0a 20 20 20 20 3b 3b 0a 20 ount))). ;;.
1770: 20 20 20 3b 3b 09 20 20 28 72 70 63 3a 70 75 62 ;;. (rpc:pub
1780: 6c 69 73 68 2d 70 72 6f 63 65 64 75 72 65 21 0a lish-procedure!.
1790: 20 20 20 20 3b 3b 09 20 20 20 27 63 64 62 3a 74 ;;. 'cdb:t
17a0: 65 73 74 73 2d 72 65 67 69 73 74 65 72 2d 74 65 ests-register-te
17b0: 73 74 0a 20 20 20 20 3b 3b 09 20 20 20 28 6c 61 st. ;;. (la
17c0: 6d 62 64 61 20 28 64 62 20 72 75 6e 2d 69 64 20 mbda (db run-id
17d0: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
17e0: 61 74 68 29 0a 20 20 20 20 3b 3b 09 20 20 20 20 ath). ;;.
17f0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
1800: 66 6f 20 31 32 20 22 52 65 6d 6f 74 65 20 63 61 fo 12 "Remote ca
1810: 6c 6c 20 6f 66 20 63 64 62 3a 74 65 73 74 73 2d ll of cdb:tests-
1820: 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 22 20 register-test "
1830: 72 75 6e 2d 69 64 20 22 20 74 65 73 74 6e 61 6d run-id " testnam
1840: 65 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 e: " test-name "
1850: 20 69 74 65 6d 2d 70 61 74 68 3a 20 22 20 69 74 item-path: " it
1860: 65 6d 2d 70 61 74 68 29 0a 20 20 20 20 3b 3b 09 em-path). ;;.
1870: 20 20 20 20 20 28 63 64 62 3a 74 65 73 74 73 2d (cdb:tests-
1880: 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 64 62 register-test db
1890: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
18a0: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 e item-path))).
18b0: 20 20 20 3b 3b 0a 20 20 20 20 3b 3b 09 20 20 28 ;;. ;;. (
18c0: 72 70 63 3a 70 75 62 6c 69 73 68 2d 70 72 6f 63 rpc:publish-proc
18d0: 65 64 75 72 65 21 0a 20 20 20 20 3b 3b 09 20 20 edure!. ;;.
18e0: 20 27 63 64 62 3a 66 6c 75 73 68 2d 71 75 65 75 'cdb:flush-queu
18f0: 65 0a 20 20 20 20 3b 3b 09 09 09 20 20 20 28 6c e. ;;... (l
1900: 61 6d 62 64 61 20 28 29 0a 20 20 20 20 3b 3b 09 ambda (). ;;.
1910: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1920: 74 2d 69 6e 66 6f 20 31 32 20 22 52 65 6d 6f 74 t-info 12 "Remot
1930: 65 20 63 61 6c 6c 20 6f 66 20 63 64 62 3a 66 6c e call of cdb:fl
1940: 75 73 68 2d 71 75 65 75 65 22 29 0a 20 20 20 20 ush-queue").
1950: 3b 3b 09 20 20 20 20 20 28 63 64 62 3a 66 6c 75 ;;. (cdb:flu
1960: 73 68 2d 71 75 65 75 65 29 29 29 0a 20 20 20 20 sh-queue))).
1970: 3b 3b 0a 0a 20 20 20 20 3b 3b 3d 3d 3d 3d 3d 3d ;;.. ;;======
1980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19c0: 0a 20 20 20 20 3b 3b 09 20 20 3b 3b 20 65 6e 64 . ;;. ;; end
19d0: 20 6f 66 20 70 75 62 6c 69 73 68 2d 70 72 6f 63 of publish-proc
19e0: 65 64 75 72 65 20 73 65 63 74 69 6f 6e 0a 20 20 edure section.
19f0: 20 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;============
1a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 3b ==========. ;
1a40: 3b 0a 20 20 20 20 28 6f 6e 2d 65 78 69 74 20 28 ;. (on-exit (
1a50: 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 lambda ()..
1a60: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
1a70: 65 20 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 73 e tasks:server-s
1a80: 65 74 2d 73 74 61 74 65 21 20 74 61 73 6b 73 3a et-state! tasks:
1a90: 6f 70 65 6e 2d 64 62 20 73 65 72 76 65 72 2d 69 open-db server-i
1aa0: 64 20 22 73 74 6f 70 70 65 64 22 29 29 29 0a 0a d "stopped")))..
1ab0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 (thread-star
1ac0: 74 21 20 74 68 31 29 0a 0a 20 20 20 20 28 73 65 t! th1).. (se
1ad0: 74 21 20 2a 72 70 63 3a 6c 69 73 74 65 6e 65 72 t! *rpc:listener
1ae0: 2a 20 72 70 63 3a 6c 69 73 74 65 6e 65 72 29 0a * rpc:listener).
1af0: 20 20 20 20 28 74 61 73 6b 73 3a 73 65 72 76 65 (tasks:serve
1b00: 72 2d 73 65 74 2d 73 74 61 74 65 21 20 74 64 62 r-set-state! tdb
1b10: 20 73 65 72 76 65 72 2d 69 64 20 22 72 75 6e 6e server-id "runn
1b20: 69 6e 67 22 29 0a 20 20 20 20 3b 20 28 73 71 6c ing"). ; (sql
1b30: 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 74 ite3:finalize! t
1b40: 64 62 29 0a 20 20 20 20 74 68 31 0a 20 20 20 20 db). th1.
1b50: 29 29 20 3b 3b 20 72 70 63 3a 73 65 72 76 65 72 )) ;; rpc:server
1b60: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 70 )))..(define (rp
1b70: 63 2d 74 72 61 6e 73 70 6f 72 74 3a 6b 65 65 70 c-transport:keep
1b80: 2d 72 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 20 -running run-id
1b90: 73 65 72 76 65 72 2d 69 64 29 0a 20 20 3b 3b 20 server-id). ;;
1ba0: 69 66 20 6e 6f 6e 65 20 72 75 6e 6e 69 6e 67 20 if none running
1bb0: 6f 72 20 69 66 20 3e 20 32 30 20 73 65 63 6f 6e or if > 20 secon
1bc0: 64 73 20 73 69 6e 63 65 20 0a 20 20 3b 3b 20 73 ds since . ;; s
1bd0: 65 72 76 65 72 20 6c 61 73 74 20 75 73 65 64 20 erver last used
1be0: 74 68 65 6e 20 73 74 61 72 74 20 73 68 75 74 64 then start shutd
1bf0: 6f 77 6e 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 own. (let loop
1c00: 28 28 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 20 ((count 0)).
1c10: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 (thread-sleep! 5
1c20: 29 20 3b 3b 20 6e 6f 20 6e 65 65 64 20 74 6f 20 ) ;; no need to
1c30: 64 6f 20 74 68 69 73 20 76 65 72 79 20 6f 66 74 do this very oft
1c40: 65 6e 0a 20 20 20 20 28 6c 65 74 20 28 28 6e 75 en. (let ((nu
1c50: 6d 72 75 6e 6e 69 6e 67 20 2d 31 29 29 20 3b 3b mrunning -1)) ;;
1c60: 20 28 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 (db:get-count-t
1c70: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 64 62 29 ests-running db)
1c80: 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 6f 72 )). (if (or
1c90: 20 28 3e 20 6e 75 6d 72 75 6e 6e 69 6e 67 20 30 (> numrunning 0
1ca0: 29 0a 09 20 20 20 20 20 20 28 3e 20 28 2b 20 2a ).. (> (+ *
1cb0: 6c 61 73 74 2d 64 62 2d 61 63 63 65 73 73 2a 20 last-db-access*
1cc0: 36 30 29 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 60)(current-seco
1cd0: 6e 64 73 29 29 29 0a 09 20 20 28 62 65 67 69 6e nds))).. (begin
1ce0: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
1cf0: 6e 74 2d 69 6e 66 6f 20 30 20 22 53 65 72 76 65 nt-info 0 "Serve
1d00: 72 20 63 6f 6e 74 69 6e 75 69 6e 67 2c 20 74 65 r continuing, te
1d10: 73 74 73 20 72 75 6e 6e 69 6e 67 3a 20 22 20 6e sts running: " n
1d20: 75 6d 72 75 6e 6e 69 6e 67 20 22 2c 20 73 65 63 umrunning ", sec
1d30: 6f 6e 64 73 20 73 69 6e 63 65 20 6c 61 73 74 20 onds since last
1d40: 64 62 20 61 63 63 65 73 73 3a 20 22 20 28 2d 20 db access: " (-
1d50: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
1d60: 29 20 2a 6c 61 73 74 2d 64 62 2d 61 63 63 65 73 ) *last-db-acces
1d70: 73 2a 29 29 0a 09 20 20 20 20 28 6c 6f 6f 70 20 s*)).. (loop
1d80: 28 2b 20 31 20 63 6f 75 6e 74 29 29 29 0a 09 20 (+ 1 count)))..
1d90: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 64 65 (begin.. (de
1da0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
1db0: 20 22 53 74 61 72 74 69 6e 67 20 74 6f 20 73 68 "Starting to sh
1dc0: 75 74 64 6f 77 6e 20 74 68 65 20 73 65 72 76 65 utdown the serve
1dd0: 72 20 73 69 64 65 22 29 0a 09 20 20 20 20 28 6f r side").. (o
1de0: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 pen-run-close ta
1df0: 73 6b 73 3a 73 65 72 76 65 72 2d 66 6f 72 63 65 sks:server-force
1e00: 2d 63 6c 65 61 6e 2d 72 75 6e 2d 72 65 63 6f 72 -clean-run-recor
1e10: 64 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 d tasks:open-db
1e20: 72 75 6e 2d 69 64 20 69 70 61 64 64 72 73 74 72 run-id ipaddrstr
1e30: 20 70 6f 72 74 6e 75 6d 20 22 20 72 70 63 2d 74 portnum " rpc-t
1e40: 72 61 6e 73 70 6f 72 74 3a 74 72 79 2d 73 74 61 ransport:try-sta
1e50: 72 74 2d 73 65 72 76 65 72 20 73 74 6f 70 22 29 rt-server stop")
1e60: 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c .. (thread-sl
1e70: 65 65 70 21 20 31 30 29 0a 09 20 20 20 20 28 64 eep! 10).. (d
1e80: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
1e90: 30 20 22 4d 61 78 20 63 61 63 68 65 64 20 71 75 0 "Max cached qu
1ea0: 65 72 69 65 73 20 77 61 73 20 22 20 2a 6d 61 78 eries was " *max
1eb0: 2d 63 61 63 68 65 2d 73 69 7a 65 2a 29 0a 09 20 -cache-size*)..
1ec0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
1ed0: 69 6e 66 6f 20 30 20 22 53 65 72 76 65 72 20 73 info 0 "Server s
1ee0: 68 75 74 64 6f 77 6e 20 63 6f 6d 70 6c 65 74 65 hutdown complete
1ef0: 2e 20 45 78 69 74 69 6e 67 22 29 0a 09 20 20 20 . Exiting")..
1f00: 20 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 )))))..(define
1f10: 28 72 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a 66 (rpc-transport:f
1f20: 69 6e 64 2d 66 72 65 65 2d 70 6f 72 74 2d 61 6e ind-free-port-an
1f30: 64 2d 6f 70 65 6e 20 70 6f 72 74 29 0a 20 20 28 d-open port). (
1f40: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
1f50: 73 0a 20 20 20 65 78 6e 0a 09 20 20 28 62 65 67 s. exn.. (beg
1f60: 69 6e 0a 20 20 20 20 20 28 70 72 69 6e 74 20 22 in. (print "
1f70: 46 61 69 6c 65 64 20 74 6f 20 62 69 6e 64 20 74 Failed to bind t
1f80: 6f 20 70 6f 72 74 20 22 20 28 72 70 63 3a 64 65 o port " (rpc:de
1f90: 66 61 75 6c 74 2d 73 65 72 76 65 72 2d 70 6f 72 fault-server-por
1fa0: 74 29 20 22 2c 20 74 72 79 69 6e 67 20 6e 65 78 t) ", trying nex
1fb0: 74 20 70 6f 72 74 22 29 0a 20 20 20 20 20 28 72 t port"). (r
1fc0: 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a 66 69 6e pc-transport:fin
1fd0: 64 2d 66 72 65 65 2d 70 6f 72 74 2d 61 6e 64 2d d-free-port-and-
1fe0: 6f 70 65 6e 20 28 2b 20 70 6f 72 74 20 31 29 29 open (+ port 1))
1ff0: 29 0a 20 20 20 28 72 70 63 3a 64 65 66 61 75 6c ). (rpc:defaul
2000: 74 2d 73 65 72 76 65 72 2d 70 6f 72 74 20 70 6f t-server-port po
2010: 72 74 29 0a 20 20 20 28 74 63 70 2d 72 65 61 64 rt). (tcp-read
2020: 2d 74 69 6d 65 6f 75 74 20 32 34 30 30 30 30 29 -timeout 240000)
2030: 0a 20 20 20 28 74 63 70 2d 6c 69 73 74 65 6e 20 . (tcp-listen
2040: 28 72 70 63 3a 64 65 66 61 75 6c 74 2d 73 65 72 (rpc:default-ser
2050: 76 65 72 2d 70 6f 72 74 29 20 31 30 30 30 30 29 ver-port) 10000)
2060: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 70 63 ))..(define (rpc
2070: 3a 70 69 6e 67 20 72 75 6e 2d 69 64 20 68 6f 73 :ping run-id hos
2080: 74 2d 70 6f 72 74 29 0a 20 20 23 66 29 0a 0a 28 t-port). #f)..(
2090: 64 65 66 69 6e 65 20 28 72 70 63 2d 74 72 61 6e define (rpc-tran
20a0: 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 73 65 74 sport:client-set
20b0: 75 70 29 0a 20 20 28 69 66 20 2a 72 75 6e 72 65 up). (if *runre
20c0: 6d 6f 74 65 2a 0a 20 20 20 20 20 20 28 62 65 67 mote*. (beg
20d0: 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 in..(debug:print
20e0: 20 30 20 22 45 52 52 4f 52 3a 20 41 74 74 65 6d 0 "ERROR: Attem
20f0: 70 74 20 74 6f 20 63 6f 6e 6e 65 63 74 20 74 6f pt to connect to
2100: 20 73 65 72 76 65 72 20 62 75 74 20 61 6c 72 65 server but alre
2110: 61 64 79 20 63 6f 6e 6e 65 63 74 65 64 22 29 0a ady connected").
2120: 09 23 66 29 0a 20 20 20 20 20 20 28 6c 65 74 2a .#f). (let*
2130: 20 28 28 68 6f 73 74 69 6e 66 6f 20 28 6f 70 65 ((hostinfo (ope
2140: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 n-run-close db:g
2150: 65 74 2d 76 61 72 20 23 66 20 22 53 45 52 56 45 et-var #f "SERVE
2160: 52 22 29 29 0a 09 20 20 20 20 20 28 68 6f 73 74 R")).. (host
2170: 64 61 74 20 20 28 69 66 20 68 6f 73 74 69 6e 66 dat (if hostinf
2180: 6f 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 o (string-split
2190: 68 6f 73 74 69 6e 66 6f 20 22 3a 22 29 20 23 66 hostinfo ":") #f
21a0: 29 29 0a 09 20 20 20 20 20 28 68 6f 73 74 20 20 )).. (host
21b0: 20 20 20 28 69 66 20 68 6f 73 74 69 6e 66 6f 20 (if hostinfo
21c0: 28 63 61 72 20 68 6f 73 74 64 61 74 29 20 23 66 (car hostdat) #f
21d0: 29 29 0a 09 20 20 20 20 20 28 70 6f 72 74 20 20 )).. (port
21e0: 20 20 20 28 69 66 20 28 61 6e 64 20 68 6f 73 74 (if (and host
21f0: 69 6e 66 6f 20 28 3e 20 28 6c 65 6e 67 74 68 20 info (> (length
2200: 68 6f 73 74 64 61 74 29 20 31 29 29 28 63 61 64 hostdat) 1))(cad
2210: 72 20 68 6f 73 74 64 61 74 29 20 23 66 29 29 29 r hostdat) #f)))
2220: 0a 09 28 69 66 20 28 61 6e 64 20 70 6f 72 74 0a ..(if (and port.
2230: 09 09 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 .. (string->numb
2240: 65 72 20 70 6f 72 74 29 29 0a 09 20 20 20 20 28 er port)).. (
2250: 6c 65 74 20 28 28 70 6f 72 74 6e 20 28 73 74 72 let ((portn (str
2260: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 6f 72 74 ing->number port
2270: 29 29 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 ))).. (debu
2280: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 g:print-info 2 "
2290: 53 65 74 74 69 6e 67 20 75 70 20 74 6f 20 63 6f Setting up to co
22a0: 6e 6e 65 63 74 20 74 6f 20 68 6f 73 74 20 22 20 nnect to host "
22b0: 68 6f 73 74 20 22 3a 22 20 70 6f 72 74 29 0a 20 host ":" port).
22c0: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
22d0: 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 20 20 ons. exn.
22e0: 20 20 28 62 65 67 69 6e 0a 09 09 20 28 64 65 62 (begin... (deb
22f0: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
2300: 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6f 70 65 R: Failed to ope
2310: 6e 20 61 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 74 n a connection t
2320: 6f 20 74 68 65 20 73 65 72 76 65 72 20 61 74 20 o the server at
2330: 68 6f 73 74 3a 20 22 20 68 6f 73 74 20 22 20 70 host: " host " p
2340: 6f 72 74 3a 20 22 20 70 6f 72 74 29 0a 09 09 20 ort: " port)...
2350: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
2360: 20 20 20 45 58 43 45 50 54 49 4f 4e 3a 20 22 20 EXCEPTION: "
2370: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
2380: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
2390: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
23a0: 29 29 0a 09 09 20 3b 3b 20 28 6f 70 65 6e 2d 72 ))... ;; (open-r
23b0: 75 6e 2d 63 6c 6f 73 65 20 0a 09 09 20 3b 3b 20 un-close ... ;;
23c0: 20 28 6c 61 6d 62 64 61 20 28 64 62 20 2e 20 70 (lambda (db . p
23d0: 61 72 61 6d 29 20 0a 09 09 20 3b 3b 20 20 20 20 aram) ... ;;
23e0: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
23f0: 20 64 62 20 22 44 45 4c 45 54 45 20 46 52 4f 4d db "DELETE FROM
2400: 20 6d 65 74 61 64 61 74 20 57 48 45 52 45 20 76 metadat WHERE v
2410: 61 72 3d 27 53 45 52 56 45 52 27 22 29 29 0a 09 ar='SERVER'"))..
2420: 09 20 3b 3b 20 20 23 66 29 0a 09 09 20 28 73 65 . ;; #f)... (se
2430: 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 23 t! *runremote* #
2440: 66 29 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 f)).. (if
2450: 28 61 6e 64 20 28 6e 6f 74 20 28 61 72 67 73 3a (and (not (args:
2460: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
2470: 22 29 29 20 3b 3b 20 6e 6f 20 70 6f 69 6e 74 20 ")) ;; no point
2480: 69 6e 20 74 68 65 20 73 65 72 76 65 72 20 75 73 in the server us
2490: 69 6e 67 20 74 68 65 20 73 65 72 76 65 72 20 75 ing the server u
24a0: 73 69 6e 67 20 74 68 65 20 73 65 72 76 65 72 0a sing the server.
24b0: 09 09 09 28 28 72 70 63 3a 70 72 6f 63 65 64 75 ...((rpc:procedu
24c0: 72 65 20 27 73 65 72 76 65 72 3a 6c 6f 67 69 6e re 'server:login
24d0: 20 68 6f 73 74 20 70 6f 72 74 6e 29 20 2a 74 6f host portn) *to
24e0: 70 70 61 74 68 2a 29 29 0a 09 09 20 20 20 28 62 ppath*))... (b
24f0: 65 67 69 6e 0a 09 09 20 20 20 20 20 28 64 65 62 egin... (deb
2500: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 ug:print-info 2
2510: 22 4c 6f 67 67 65 64 20 69 6e 20 61 6e 64 20 63 "Logged in and c
2520: 6f 6e 6e 65 63 74 65 64 20 74 6f 20 22 20 68 6f onnected to " ho
2530: 73 74 20 22 3a 22 20 70 6f 72 74 29 0a 09 09 20 st ":" port)...
2540: 20 20 20 20 28 73 65 74 21 20 2a 72 75 6e 72 65 (set! *runre
2550: 6d 6f 74 65 2a 20 28 76 65 63 74 6f 72 20 68 6f mote* (vector ho
2560: 73 74 20 70 6f 72 74 6e 29 29 29 0a 09 09 20 20 st portn)))...
2570: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 (begin... (
2580: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
2590: 20 32 20 22 46 61 69 6c 65 64 20 74 6f 20 6c 6f 2 "Failed to lo
25a0: 67 69 6e 20 6f 72 20 63 6f 6e 6e 65 63 74 20 74 gin or connect t
25b0: 6f 20 22 20 68 6f 73 74 20 22 3a 22 20 70 6f 72 o " host ":" por
25c0: 74 29 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 t)... (set!
25d0: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 23 66 29 29 *runremote* #f))
25e0: 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a ))).. (debug:
25f0: 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 6e 6f print-info 2 "no
2600: 20 73 65 72 76 65 72 20 61 76 61 69 6c 61 62 6c server availabl
2610: 65 22 29 29 29 29 29 0a 0a e")))))..