Artifact 0bbf1bf4b67c22bcee9d75881b2e53a4dfb47628:
- File server.scm — part of check-in [3469edbbf7] at 2011-10-08 20:23:24 on branch trunk — 90% converted to using units (user: matt size: 1885)
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 31 2c 20 4d 61 74 74 68 65 77 06-2011, 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 64 65 63 6c PURPOSE...(decl 0150: 61 72 65 20 28 75 6e 69 74 20 73 65 72 76 65 72 are (unit server 0160: 29 29 0a 0a 3b 3b 20 70 72 6f 63 73 74 72 20 69 ))..;; procstr i 0170: 73 20 74 68 65 20 6e 61 6d 65 20 6f 66 20 74 68 s the name of th 0180: 65 20 70 72 6f 63 65 64 75 72 65 20 74 6f 20 62 e procedure to b 0190: 65 20 63 61 6c 6c 65 64 20 61 73 20 61 20 73 74 e called as a st 01a0: 72 69 6e 67 0a 28 64 65 66 69 6e 65 20 28 73 65 ring.(define (se 01b0: 72 76 65 72 3a 61 75 74 6f 72 65 6d 6f 74 65 20 rver:autoremote 01c0: 70 72 6f 63 73 74 72 20 70 61 72 61 6d 73 29 0a procstr params). 01d0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except 01e0: 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 ions. exn. ( 01f0: 62 65 67 69 6e 0a 20 20 20 20 20 28 64 65 62 75 begin. (debu 0200: 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 74 g:print 1 "Remot 0210: 65 20 66 61 69 6c 65 64 20 66 6f 72 20 22 20 70 e failed for " p 0220: 72 6f 63 20 22 20 22 20 70 61 72 61 6d 73 29 0a roc " " params). 0230: 20 20 20 20 20 28 61 70 70 6c 79 20 28 65 76 61 (apply (eva 0240: 6c 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f l (string->symbo 0250: 6c 20 70 72 6f 63 29 29 20 70 61 72 61 6d 73 29 l proc)) params) 0260: 29 0a 20 20 20 28 69 66 20 2a 72 75 6e 72 65 6d ). (if *runrem 0270: 6f 74 65 2a 0a 20 20 20 20 20 20 20 28 61 70 70 ote*. (app 0280: 6c 79 20 28 65 76 61 6c 20 28 73 74 72 69 6e 67 ly (eval (string 0290: 2d 3e 73 79 6d 62 6f 6c 20 28 63 6f 6e 63 20 22 ->symbol (conc " 02a0: 72 65 6d 6f 74 65 3a 22 20 70 72 6f 63 73 74 72 remote:" procstr 02b0: 29 29 29 20 70 61 72 61 6d 73 29 0a 20 20 20 20 ))) params). 02c0: 20 20 20 28 65 76 61 6c 20 28 73 74 72 69 6e 67 (eval (string 02d0: 2d 3e 73 79 6d 62 6f 6c 20 70 72 6f 63 73 74 72 ->symbol procstr 02e0: 29 20 70 61 72 61 6d 73 29 29 29 29 0a 0a 28 64 ) params))))..(d 02f0: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 73 74 efine (server:st 0300: 61 72 74 20 64 62 29 0a 20 20 28 64 65 62 75 67 art db). (debug 0310: 3a 70 72 69 6e 74 20 30 20 22 41 74 74 65 6d 70 :print 0 "Attemp 0320: 74 69 6e 67 20 74 6f 20 73 74 61 72 74 20 74 68 ting to start th 0330: 65 20 73 65 72 76 65 72 20 2e 2e 2e 22 29 0a 20 e server ..."). 0340: 20 28 6c 65 74 2a 20 28 28 72 70 63 3a 6c 69 73 (let* ((rpc:lis 0350: 74 65 6e 65 72 20 28 73 65 72 76 65 72 3a 66 69 tener (server:fi 0360: 6e 64 2d 66 72 65 65 2d 70 6f 72 74 2d 61 6e 64 nd-free-port-and 0370: 2d 6f 70 65 6e 20 28 72 70 63 3a 64 65 66 61 75 -open (rpc:defau 0380: 6c 74 2d 73 65 72 76 65 72 2d 70 6f 72 74 29 29 lt-server-port)) 0390: 29 0a 09 20 28 74 68 31 20 20 20 20 20 20 20 20 ).. (th1 03a0: 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a 09 (make-thread.. 03b0: 09 09 28 63 75 74 65 20 28 72 70 63 3a 6d 61 6b ..(cute (rpc:mak 03c0: 65 2d 73 65 72 76 65 72 20 72 70 63 3a 6c 69 73 e-server rpc:lis 03d0: 74 65 6e 65 72 29 20 22 72 70 63 3a 73 65 72 76 tener) "rpc:serv 03e0: 65 72 22 29 0a 09 09 09 27 72 70 63 3a 73 65 72 er")....'rpc:ser 03f0: 76 65 72 29 29 29 0a 20 20 20 20 28 64 62 3a 73 ver))). (db:s 0400: 65 74 2d 76 61 72 20 64 62 20 22 53 45 52 56 45 et-var db "SERVE 0410: 52 22 20 28 63 6f 6e 63 20 28 67 65 74 2d 68 6f R" (conc (get-ho 0420: 73 74 2d 6e 61 6d 65 29 20 22 3a 22 20 28 72 70 st-name) ":" (rp 0430: 63 3a 64 65 66 61 75 6c 74 2d 73 65 72 76 65 72 c:default-server 0440: 2d 70 6f 72 74 29 29 29 0a 20 20 20 20 28 72 70 -port))). (rp 0450: 63 3a 70 75 62 6c 69 73 68 2d 70 72 6f 63 65 64 c:publish-proced 0460: 75 72 65 21 20 0a 20 20 20 20 20 27 72 65 6d 6f ure! . 'remo 0470: 74 65 3a 72 75 6e 20 0a 20 20 20 20 20 28 6c 61 te:run . (la 0480: 6d 62 64 61 20 28 70 72 6f 63 73 74 72 20 2e 20 mbda (procstr . 0490: 70 61 72 61 6d 73 29 0a 20 20 20 20 20 20 20 28 params). ( 04a0: 73 65 72 76 65 72 3a 61 75 74 6f 72 65 6d 6f 74 server:autoremot 04b0: 65 20 70 72 6f 63 73 74 72 20 70 61 72 61 6d 73 e procstr params 04c0: 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 2a 72 ))). (set! *r 04d0: 70 63 3a 6c 69 73 74 65 6e 65 72 2a 20 72 70 63 pc:listener* rpc 04e0: 3a 6c 69 73 74 65 6e 65 72 2a 29 0a 20 20 20 20 :listener*). 04f0: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 72 (thread-start! r 0500: 70 63 3a 73 65 72 76 65 72 29 29 29 0a 0a 28 64 pc:server)))..(d 0510: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 66 69 efine (server:fi 0520: 6e 64 2d 66 72 65 65 2d 70 6f 72 74 2d 61 6e 64 nd-free-port-and 0530: 2d 6f 70 65 6e 20 70 6f 72 74 29 0a 20 20 28 68 -open port). (h 0540: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions 0550: 0a 20 20 20 65 78 6e 0a 20 20 20 28 62 65 67 69 . exn. (begi 0560: 6e 0a 20 20 20 20 20 28 70 72 69 6e 74 20 22 46 n. (print "F 0570: 61 69 6c 65 64 20 74 6f 20 62 69 6e 64 20 74 6f ailed to bind to 0580: 20 70 6f 72 74 20 22 20 28 72 70 63 3a 64 65 66 port " (rpc:def 0590: 61 75 6c 74 2d 73 65 72 76 65 72 2d 70 6f 72 74 ault-server-port 05a0: 29 20 22 2c 20 74 72 79 69 6e 67 20 6e 65 78 74 ) ", trying next 05b0: 20 70 6f 72 74 22 29 0a 20 20 20 20 20 28 73 65 port"). (se 05c0: 72 76 65 72 3a 66 69 6e 64 2d 66 72 65 65 2d 70 rver:find-free-p 05d0: 6f 72 74 2d 61 6e 64 2d 6f 70 65 6e 20 28 2b 20 ort-and-open (+ 05e0: 70 6f 72 74 20 31 29 29 29 0a 20 20 20 28 72 70 port 1))). (rp 05f0: 63 3a 64 65 66 61 75 6c 74 2d 73 65 72 76 65 72 c:default-server 0600: 2d 70 6f 72 74 20 70 6f 72 74 29 0a 20 20 20 28 -port port). ( 0610: 74 63 70 2d 6c 69 73 74 65 6e 20 28 72 70 63 3a tcp-listen (rpc: 0620: 64 65 66 61 75 6c 74 2d 73 65 72 76 65 72 2d 70 default-server-p 0630: 6f 72 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ort))))..(define 0640: 20 28 73 65 72 76 65 72 3a 63 6c 69 65 6e 74 2d (server:client- 0650: 73 65 74 75 70 20 64 62 29 0a 20 20 28 6c 65 74 setup db). (let 0660: 2a 20 28 28 68 6f 73 74 69 6e 66 6f 20 28 64 62 * ((hostinfo (db 0670: 3a 67 65 74 2d 76 61 72 20 64 62 20 22 53 45 52 :get-var db "SER 0680: 56 45 52 22 29 29 0a 09 20 28 68 6f 73 74 64 61 VER")).. (hostda 0690: 74 20 20 28 69 66 20 68 6f 73 74 69 6e 66 6f 20 t (if hostinfo 06a0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 68 6f (string-split ho 06b0: 73 74 69 6e 66 6f 20 22 3a 22 29 29 29 0a 09 20 stinfo ":"))).. 06c0: 28 68 6f 73 74 20 20 20 20 20 28 69 66 20 68 6f (host (if ho 06d0: 73 74 69 6e 66 6f 20 28 63 61 72 20 68 6f 73 74 stinfo (car host 06e0: 64 61 74 29 29 29 0a 09 20 28 70 6f 72 74 20 20 dat))).. (port 06f0: 20 20 20 28 69 66 20 28 61 6e 64 20 68 6f 73 74 (if (and host 0700: 69 6e 66 6f 20 28 3e 20 28 6c 65 6e 67 74 68 20 info (> (length 0710: 68 6f 73 74 64 61 74 29 20 31 29 29 28 63 61 64 hostdat) 1))(cad 0720: 72 20 68 6f 73 74 64 61 74 29 20 23 66 29 29 29 r hostdat) #f))) 0730: 0a 20 20 20 20 28 73 65 74 21 20 2a 72 75 6e 72 . (set! *runr 0740: 65 6d 6f 74 65 2a 20 28 76 65 63 74 6f 72 20 68 emote* (vector h 0750: 6f 73 74 20 70 6f 72 74 29 29 29 29 0a ost port)))).