Artifact
9fd201bbc19a46cd5c7b28d167b86ae7cb10b50c:
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 37 2c 20 4d 61 74 74 68 65 77 06-2017, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 54 68 69 73 20 66 69 6c 65 20 69 73 20 70 61 This file is pa
0040: 72 74 20 6f 66 20 4d 65 67 61 74 65 73 74 2e 0a rt of Megatest..
0050: 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 ;; .;; Megat
0060: 65 73 74 20 69 73 20 66 72 65 65 20 73 6f 66 74 est is free soft
0070: 77 61 72 65 3a 20 79 6f 75 20 63 61 6e 20 72 65 ware: you can re
0080: 64 69 73 74 72 69 62 75 74 65 20 69 74 20 61 6e distribute it an
0090: 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b 3b 20 20 d/or modify.;;
00a0: 20 20 20 69 74 20 75 6e 64 65 72 20 74 68 65 20 it under the
00b0: 74 65 72 6d 73 20 6f 66 20 74 68 65 20 47 4e 55 terms of the GNU
00c0: 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 General Public
00d0: 4c 69 63 65 6e 73 65 20 61 73 20 70 75 62 6c 69 License as publi
00e0: 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 20 20 74 shed by.;; t
00f0: 68 65 20 46 72 65 65 20 53 6f 66 74 77 61 72 65 he Free Software
0100: 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 65 69 74 Foundation, eit
0110: 68 65 72 20 76 65 72 73 69 6f 6e 20 33 20 6f 66 her version 3 of
0120: 20 74 68 65 20 4c 69 63 65 6e 73 65 2c 20 6f 72 the License, or
0130: 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 6f 75 72 .;; (at your
0140: 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 6c 61 74 option) any lat
0150: 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b 3b 20 0a er version..;; .
0160: 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 73 74 20 ;; Megatest
0170: 69 73 20 64 69 73 74 72 69 62 75 74 65 64 20 69 is distributed i
0180: 6e 20 74 68 65 20 68 6f 70 65 20 74 68 61 74 20 n the hope that
0190: 69 74 20 77 69 6c 6c 20 62 65 20 75 73 65 66 75 it will be usefu
01a0: 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 20 57 49 l,.;; but WI
01b0: 54 48 4f 55 54 20 41 4e 59 20 57 41 52 52 41 4e THOUT ANY WARRAN
01c0: 54 59 3b 20 77 69 74 68 6f 75 74 20 65 76 65 6e TY; without even
01d0: 20 74 68 65 20 69 6d 70 6c 69 65 64 20 77 61 72 the implied war
01e0: 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 20 20 20 ranty of.;;
01f0: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0200: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0210: 20 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 PARTICULAR PURP
0220: 4f 53 45 2e 20 20 53 65 65 20 74 68 65 0a 3b 3b OSE. See the.;;
0230: 20 20 20 20 20 47 4e 55 20 47 65 6e 65 72 61 6c GNU General
0240: 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 Public License
0250: 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 69 6c 73 for more details
0260: 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 59 6f 75 ..;; .;; You
0270: 20 73 68 6f 75 6c 64 20 68 61 76 65 20 72 65 63 should have rec
0280: 65 69 76 65 64 20 61 20 63 6f 70 79 20 6f 66 20 eived a copy of
0290: 74 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 the GNU General
02a0: 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 0a 3b Public License.;
02b0: 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 69 74 68 ; along with
02c0: 20 4d 65 67 61 74 65 73 74 2e 20 20 49 66 20 6e Megatest. If n
02d0: 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 3a 2f 2f ot, see <http://
02e0: 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c 69 63 65 www.gnu.org/lice
02f0: 6e 73 65 73 2f 3e 2e 0a 3b 3b 0a 0a 3b 3b 3d 3d nses/>..;;..;;==
0300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0340: 3d 3d 3d 3d 0a 3b 3b 0a 3b 3b 20 54 68 69 73 20 ====.;;.;; This
0350: 69 73 20 74 68 65 20 4d 65 67 61 74 65 73 74 20 is the Megatest
0360: 73 70 65 63 69 66 69 63 20 73 74 75 66 66 20 66 specific stuff f
0370: 6f 72 20 73 74 61 72 74 69 6e 67 20 61 6e 64 20 or starting and
0380: 6d 61 69 6e 74 61 69 6e 69 6e 67 20 61 0a 3b 3b maintaining a.;;
0390: 20 73 65 72 76 65 72 2e 20 41 6e 79 74 68 69 6e server. Anythin
03a0: 67 20 74 68 61 74 20 74 61 6c 6b 73 20 74 6f 20 g that talks to
03b0: 74 68 65 20 73 65 72 76 65 72 20 73 68 6f 75 6c the server shoul
03c0: 64 20 67 6f 20 69 6e 20 63 6c 69 65 6e 74 2e 73 d go in client.s
03d0: 63 6d 20 28 6d 61 79 62 65 20 2d 20 6d 69 67 68 cm (maybe - migh
03e0: 74 20 67 65 74 20 72 69 64 20 6f 66 20 63 6c 69 t get rid of cli
03f0: 65 6e 74 2e 73 63 6d 29 0a 3b 3b 20 47 65 6e 65 ent.scm).;; Gene
0400: 72 61 6c 20 6e 61 6e 6f 6d 73 67 20 73 74 75 66 ral nanomsg stuf
0410: 66 20 28 6e 6f 74 20 4d 65 67 61 74 65 73 74 20 f (not Megatest
0420: 73 70 65 63 69 66 69 63 29 20 73 68 6f 75 6c 64 specific) should
0430: 20 67 6f 20 69 6e 20 74 68 65 0a 3b 3b 20 6e 6d go in the.;; nm
0440: 73 67 2d 74 72 61 6e 73 70 6f 72 74 2e 73 63 6d sg-transport.scm
0450: 20 66 69 6c 65 2e 0a 3b 3b 0a 3b 3b 3d 3d 3d 3d file..;;.;;====
0460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04a0: 3d 3d 0a 0a 28 72 65 71 75 69 72 65 2d 65 78 74 ==..(require-ext
04b0: 65 6e 73 69 6f 6e 20 28 73 72 66 69 20 31 38 29 ension (srfi 18)
04c0: 20 65 78 74 72 61 73 20 74 63 70 20 73 31 31 6e extras tcp s11n
04d0: 29 0a 0a 28 75 73 65 20 73 72 66 69 2d 31 20 70 )..(use srfi-1 p
04e0: 6f 73 69 78 20 72 65 67 65 78 20 72 65 67 65 78 osix regex regex
04f0: 2d 63 61 73 65 20 73 72 66 69 2d 36 39 20 68 6f -case srfi-69 ho
0500: 73 74 69 6e 66 6f 20 6d 64 35 20 6d 65 73 73 61 stinfo md5 messa
0510: 67 65 2d 64 69 67 65 73 74 0a 20 20 20 20 20 64 ge-digest. d
0520: 69 72 65 63 74 6f 72 79 2d 75 74 69 6c 73 20 70 irectory-utils p
0530: 6f 73 69 78 2d 65 78 74 72 61 73 20 6d 61 74 63 osix-extras matc
0540: 68 61 62 6c 65 20 74 79 70 65 64 2d 72 65 63 6f hable typed-reco
0550: 72 64 73 0a 20 20 20 20 20 70 6b 74 73 29 0a 0a rds. pkts)..
0560: 28 75 73 65 20 73 70 69 66 66 79 20 75 72 69 2d (use spiffy uri-
0570: 63 6f 6d 6d 6f 6e 20 69 6e 74 61 72 77 65 62 20 common intarweb
0580: 68 74 74 70 2d 63 6c 69 65 6e 74 20 73 70 69 66 http-client spif
0590: 66 79 2d 72 65 71 75 65 73 74 2d 76 61 72 73 29 fy-request-vars)
05a0: 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 ..(declare (unit
05b0: 20 73 65 72 76 65 72 29 29 0a 0a 28 64 65 63 6c server))..(decl
05c0: 61 72 65 20 28 75 73 65 73 20 63 6f 6d 6d 6f 6e are (uses common
05d0: 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 73 ))..(declare (us
05e0: 65 73 20 64 62 29 29 0a 28 69 6d 70 6f 72 74 20 es db)).(import
05f0: 64 62 29 0a 0a 3b 3b 20 42 61 73 69 63 20 73 74 db)..;; Basic st
0600: 75 66 66 20 66 6f 72 20 73 61 66 65 6c 79 20 6b uff for safely k
0610: 69 63 6b 69 6e 67 20 6f 66 66 20 61 20 73 65 72 icking off a ser
0620: 76 65 72 0a 28 64 65 63 6c 61 72 65 20 28 75 73 ver.(declare (us
0630: 65 73 20 70 6f 72 74 6c 6f 67 67 65 72 29 29 0a es portlogger)).
0640: 28 69 6d 70 6f 72 74 20 70 6f 72 74 6c 6f 67 67 (import portlogg
0650: 65 72 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 er)..(declare (u
0660: 73 65 73 20 6e 6d 73 67 2d 74 72 61 6e 73 70 6f ses nmsg-transpo
0670: 72 74 29 29 0a 28 69 6d 70 6f 72 74 20 6e 6d 73 rt)).(import nms
0680: 67 2d 74 72 61 6e 73 70 6f 72 74 29 0a 0a 0a 3b g-transport)...;
0690: 3b 20 4d 69 67 68 74 20 77 61 6e 74 20 74 6f 20 ; Might want to
06a0: 62 72 69 6e 67 20 74 68 65 20 64 61 65 6d 6f 6e bring the daemon
06b0: 69 7a 69 6e 67 20 62 61 63 6b 0a 3b 3b 20 28 64 izing back.;; (d
06c0: 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 61 65 eclare (uses dae
06d0: 6d 6f 6e 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 mon))..(include
06e0: 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e "common_records.
06f0: 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 scm").(include "
0700: 64 62 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 db_records.scm")
0710: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
0720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 50 20 ==========.;; P
0760: 4b 20 54 20 53 20 20 20 53 20 54 20 55 20 46 20 K T S S T U F
0770: 46 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d F .;;===========
0780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d ===========..;;=
07c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0800: 3d 3d 3d 3d 3d 0a 3b 3b 20 20 4e 20 41 20 4e 20 =====.;; N A N
0810: 4f 20 4d 20 53 20 47 20 20 20 42 20 41 20 53 20 O M S G B A S
0820: 45 20 44 20 20 20 53 20 45 20 52 20 56 20 45 20 E D S E R V E
0830: 52 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d R.;;============
0840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 69 ==========..;; i
0880: 6e 66 6f 72 6d 61 74 69 6f 6e 20 61 62 6f 75 74 nformation about
0890: 20 6d 65 20 61 73 20 61 20 73 65 72 76 65 72 0a me as a server.
08a0: 3b 3b 0a 28 64 65 66 73 74 72 75 63 74 20 61 72 ;;.(defstruct ar
08b0: 65 61 0a 20 20 28 63 6f 6e 6e 20 20 23 66 29 0a ea. (conn #f).
08c0: 20 20 28 70 6f 72 74 20 20 23 66 29 0a 20 20 28 (port #f). (
08d0: 6d 79 61 64 64 72 20 23 66 29 0a 20 20 28 68 6f myaddr #f). (ho
08e0: 73 74 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 sts (make-hash-t
08f0: 61 62 6c 65 29 29 0a 20 20 70 6b 74 69 64 20 20 able)). pktid
0900: 3b 3b 20 67 65 74 20 70 6b 74 20 66 72 6f 6d 20 ;; get pkt from
0910: 68 6f 73 74 73 20 74 61 62 6c 65 20 69 66 20 6e hosts table if n
0920: 65 65 64 65 64 0a 20 20 70 6b 74 66 69 6c 65 0a eeded. pktfile.
0930: 20 20 70 6b 74 73 64 69 72 0a 20 20 6d 74 72 61 pktsdir. mtra
0940: 68 0a 20 20 28 6d 75 74 65 78 20 20 20 20 28 6d h. (mutex (m
0950: 61 6b 65 2d 6d 75 74 65 78 29 29 0a 20 20 29 0a ake-mutex)). ).
0960: 0a 3b 3b 20 6d 61 6b 65 20 69 74 20 61 20 67 6c .;; make it a gl
0970: 6f 62 61 6c 3f 20 57 65 6c 6c 2c 20 69 74 20 69 obal? Well, it i
0980: 73 20 6c 6f 63 61 6c 20 74 6f 20 61 72 65 61 20 s local to area
0990: 6d 6f 64 75 6c 65 0a 0a 28 64 65 66 69 6e 65 20 module..(define
09a0: 2a 61 72 65 61 2d 69 6e 66 6f 2a 20 28 6d 61 6b *area-info* (mak
09b0: 65 2d 61 72 65 61 29 29 0a 28 64 65 66 69 6e 65 e-area)).(define
09c0: 20 2a 70 6b 74 73 70 65 63 2a 0a 20 20 60 28 28 *pktspec*. `((
09d0: 73 65 72 76 65 72 20 28 68 6f 73 74 6e 61 6d 65 server (hostname
09e0: 20 2e 20 68 29 0a 09 20 20 20 20 28 70 6f 72 74 . h).. (port
09f0: 20 20 20 20 20 2e 20 70 29 0a 09 20 20 20 20 28 . p).. (
0a00: 70 69 64 20 20 20 20 20 20 2e 20 69 29 0a 09 20 pid . i)..
0a10: 20 20 20 28 69 70 61 64 64 72 20 20 20 2e 20 61 (ipaddr . a
0a20: 29 0a 09 20 20 20 20 29 0a 20 20 20 20 28 64 61 ).. ). (da
0a30: 74 61 20 20 20 28 68 6f 73 74 6e 61 6d 65 20 2e ta (hostname .
0a40: 20 68 29 20 20 3b 3b 20 73 65 6e 64 65 72 20 68 h) ;; sender h
0a50: 6f 73 74 6e 61 6d 65 0a 09 20 20 20 20 28 70 6f ostname.. (po
0a60: 72 74 20 20 20 20 20 2e 20 70 29 20 20 3b 3b 20 rt . p) ;;
0a70: 73 65 6e 64 65 72 20 70 6f 72 74 0a 09 20 20 20 sender port..
0a80: 20 28 69 70 61 64 64 72 20 20 20 2e 20 61 29 20 (ipaddr . a)
0a90: 20 3b 3b 20 73 65 6e 64 65 72 20 69 70 0a 09 20 ;; sender ip..
0aa0: 20 20 20 28 68 6f 73 74 6b 65 79 20 20 2e 20 6b (hostkey . k
0ab0: 29 20 20 3b 3b 20 73 65 6e 64 69 6e 67 20 68 6f ) ;; sending ho
0ac0: 73 74 20 6b 65 79 20 2d 20 73 74 6f 72 65 20 69 st key - store i
0ad0: 6e 66 6f 20 61 74 20 73 65 72 76 65 72 20 75 6e nfo at server un
0ae0: 64 65 72 20 74 68 69 73 20 6b 65 79 0a 09 20 20 der this key..
0af0: 20 20 28 73 65 72 76 6b 65 79 20 20 2e 20 73 29 (servkey . s)
0b00: 20 20 3b 3b 20 73 65 72 76 65 72 20 6b 65 79 20 ;; server key
0b10: 2d 20 74 68 69 73 20 6e 65 65 64 73 20 74 6f 20 - this needs to
0b20: 6d 61 74 63 68 20 61 74 20 73 65 72 76 65 72 20 match at server
0b30: 65 6e 64 20 6f 72 20 72 65 6a 65 63 74 20 74 68 end or reject th
0b40: 65 20 6d 73 67 0a 09 20 20 20 20 28 66 6f 72 6d e msg.. (form
0b50: 61 74 20 20 20 2e 20 66 29 20 20 3b 3b 20 73 62 at . f) ;; sb
0b60: 3d 73 65 72 69 61 6c 69 7a 65 64 2d 62 61 73 65 =serialized-base
0b70: 36 34 2c 20 74 3d 74 65 78 74 2c 20 73 78 3d 73 64, t=text, sx=s
0b80: 65 78 70 72 2c 20 6a 3d 6a 73 6f 6e 0a 09 20 20 expr, j=json..
0b90: 20 20 28 64 61 74 61 20 20 20 20 20 2e 20 64 29 (data . d)
0ba0: 20 20 3b 3b 20 62 61 73 65 36 34 20 65 6e 63 6f ;; base64 enco
0bb0: 64 65 64 20 73 6c 6c 6e 20 64 61 74 61 0a 09 20 ded slln data..
0bc0: 20 20 20 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 )))..(define
0bd0: 28 73 65 72 76 65 72 3a 67 65 74 2d 6d 74 72 61 (server:get-mtra
0be0: 68 29 0a 20 20 28 6f 72 20 28 67 65 74 2d 65 6e h). (or (get-en
0bf0: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
0c00: 6c 65 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f le "MT_RUN_AREA_
0c10: 48 4f 4d 45 22 29 0a 20 20 20 20 20 20 28 69 66 HOME"). (if
0c20: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 22 (file-exists? "
0c30: 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 megatest.config"
0c40: 29 0a 09 20 20 28 63 75 72 72 65 6e 74 2d 64 69 ).. (current-di
0c50: 72 65 63 74 6f 72 79 29 0a 09 20 20 23 66 29 29 rectory).. #f))
0c60: 29 0a 0a 3b 3b 20 67 65 74 20 61 20 70 6f 72 74 )..;; get a port
0c70: 0a 3b 3b 20 73 74 61 72 74 20 74 68 65 20 6e 6d .;; start the nm
0c80: 73 67 20 73 65 72 76 65 72 0a 3b 3b 20 6c 6f 6f sg server.;; loo
0c90: 6b 20 66 6f 72 20 6f 74 68 65 72 20 73 65 72 76 k for other serv
0ca0: 65 72 73 0a 3b 3b 20 63 6f 6e 74 61 63 74 20 6f ers.;; contact o
0cb0: 74 68 65 72 20 73 65 72 76 65 72 73 20 61 6e 64 ther servers and
0cc0: 20 63 6f 6d 70 69 6c 65 20 6c 69 73 74 20 6f 66 compile list of
0cd0: 20 73 65 72 76 65 72 73 0a 3b 3b 20 74 68 65 72 servers.;; ther
0ce0: 65 20 61 72 65 20 74 77 6f 20 74 79 70 65 73 20 e are two types
0cf0: 6f 66 20 73 65 72 76 65 72 0a 3b 3b 20 20 20 20 of server.;;
0d00: 20 6d 61 69 6e 20 73 65 72 76 65 72 73 20 2d 20 main servers -
0d10: 64 61 73 68 62 6f 61 72 64 73 2c 20 72 75 6e 6e dashboards, runn
0d20: 65 72 73 20 61 6e 64 20 64 65 64 69 63 61 74 65 ers and dedicate
0d30: 64 20 73 65 72 76 65 72 73 20 2d 20 6e 65 65 64 d servers - need
0d40: 20 70 6b 74 0a 3b 3b 20 20 20 20 20 70 61 73 73 pkt.;; pass
0d50: 69 76 65 20 73 65 72 76 65 72 73 20 2d 20 74 65 ive servers - te
0d60: 73 74 20 65 78 65 63 75 74 65 72 73 2c 20 73 74 st executers, st
0d70: 65 70 20 63 61 6c 6c 73 2c 20 6c 69 73 74 2d 72 ep calls, list-r
0d80: 75 6e 73 20 2d 20 6e 6f 20 70 6b 74 0a 3b 3b 0a uns - no pkt.;;.
0d90: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
0da0: 73 74 61 72 74 2d 6e 6d 73 67 20 23 21 6f 70 74 start-nmsg #!opt
0db0: 69 6f 6e 61 6c 20 28 66 6f 72 63 65 2d 73 65 72 ional (force-ser
0dc0: 76 65 72 2d 74 79 70 65 20 23 66 29 29 0a 20 20 ver-type #f)).
0dd0: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 28 61 72 (mutex-lock! (ar
0de0: 65 61 2d 6d 75 74 65 78 20 2a 61 72 65 61 2d 69 ea-mutex *area-i
0df0: 6e 66 6f 2a 29 29 0a 20 20 28 6c 65 74 2a 20 28 nfo*)). (let* (
0e00: 28 73 65 72 76 65 72 2d 74 79 70 65 20 20 28 6f (server-type (o
0e10: 72 20 66 6f 72 63 65 2d 73 65 72 76 65 72 2d 74 r force-server-t
0e20: 79 70 65 0a 09 09 09 20 20 20 28 69 66 20 28 61 ype.... (if (a
0e30: 72 67 73 3a 61 6e 79 3f 20 22 2d 72 75 6e 22 20 rgs:any? "-run"
0e40: 22 2d 73 65 72 76 65 72 22 29 0a 09 09 09 20 20 "-server")....
0e50: 20 20 20 20 20 27 6d 61 69 6e 0a 09 09 09 20 20 'main....
0e60: 20 20 20 20 20 27 70 61 73 73 69 76 65 29 29 29 'passive)))
0e70: 0a 09 20 28 70 6f 72 74 2d 6e 75 6d 20 20 20 20 .. (port-num
0e80: 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f 70 65 (portlogger:ope
0e90: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f 72 74 n-run-close port
0ea0: 6c 6f 67 67 65 72 3a 66 69 6e 64 2d 70 6f 72 74 logger:find-port
0eb0: 29 29 0a 09 20 28 62 65 73 74 2d 69 70 20 20 20 )).. (best-ip
0ec0: 20 20 20 28 73 65 72 76 65 72 3a 67 65 74 2d 6d (server:get-m
0ed0: 79 2d 62 65 73 74 2d 61 64 64 72 65 73 73 29 29 y-best-address))
0ee0: 0a 09 20 28 61 72 65 61 2d 63 6f 6e 6e 20 20 20 .. (area-conn
0ef0: 20 28 6e 6d 73 67 3a 73 74 61 72 74 2d 73 65 72 (nmsg:start-ser
0f00: 76 65 72 20 70 6f 72 74 2d 6e 75 6d 29 29 0a 09 ver port-num))..
0f10: 20 3b 3b 20 28 70 6b 74 73 70 65 63 20 20 20 20 ;; (pktspec
0f20: 20 20 28 61 72 65 61 2d 70 6b 74 73 70 65 63 20 (area-pktspec
0f30: 2a 61 72 65 61 2d 69 6e 66 6f 2a 29 29 0a 09 20 *area-info*))..
0f40: 28 6d 74 64 69 72 20 20 20 20 20 20 20 20 28 6f (mtdir (o
0f50: 72 20 28 73 65 72 76 65 72 3a 67 65 74 2d 6d 74 r (server:get-mt
0f60: 72 61 68 29 0a 09 09 09 20 20 20 28 62 65 67 69 rah).... (begi
0f70: 6e 0a 09 09 09 20 20 20 20 20 28 70 72 69 6e 74 n.... (print
0f80: 20 22 45 52 52 4f 52 3a 20 6d 65 67 61 74 65 73 "ERROR: megates
0f90: 74 2e 63 6f 6e 66 69 67 20 6e 6f 74 20 66 6f 75 t.config not fou
0fa0: 6e 64 20 61 6e 64 20 4d 54 5f 52 55 4e 5f 41 52 nd and MT_RUN_AR
0fb0: 45 41 5f 48 4f 4d 45 20 69 73 20 6e 6f 74 20 73 EA_HOME is not s
0fc0: 65 74 2e 22 29 0a 09 09 09 20 20 20 20 20 23 66 et.").... #f
0fd0: 29 29 29 0a 09 20 28 70 6b 74 64 69 72 20 20 20 ))).. (pktdir
0fe0: 20 20 20 20 28 63 6f 6e 63 20 6d 74 64 69 72 0a (conc mtdir.
0ff0: 09 09 09 20 20 20 20 20 22 2f 2e 73 65 72 76 65 ... "/.serve
1000: 72 2d 70 6b 74 73 22 29 29 29 0a 20 20 20 20 28 r-pkts"))). (
1010: 69 66 20 28 6e 6f 74 20 6d 74 64 69 72 29 0a 09 if (not mtdir)..
1020: 23 66 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 69 #f..(begin.. (i
1030: 66 20 20 28 6e 6f 74 20 28 64 69 72 65 63 74 6f f (not (directo
1040: 72 79 3f 20 70 6b 74 64 69 72 29 29 28 63 72 65 ry? pktdir))(cre
1050: 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 70 6b ate-directory pk
1060: 74 64 69 72 29 29 0a 09 20 20 3b 3b 20 73 65 72 tdir)).. ;; ser
1070: 76 65 72 20 69 73 20 73 74 61 72 74 65 64 2c 20 ver is started,
1080: 6e 6f 77 20 63 72 65 61 74 65 20 70 6b 74 20 69 now create pkt i
1090: 66 20 6e 65 65 64 65 64 0a 09 20 20 28 70 72 69 f needed.. (pri
10a0: 6e 74 20 22 53 74 61 72 74 69 6e 67 20 73 65 72 nt "Starting ser
10b0: 76 65 72 20 69 6e 20 22 20 73 65 72 76 65 72 2d ver in " server-
10c0: 74 79 70 65 20 22 20 6d 6f 64 65 22 29 0a 09 20 type " mode")..
10d0: 20 28 69 66 20 28 65 71 3f 20 73 65 72 76 65 72 (if (eq? server
10e0: 2d 74 79 70 65 20 27 6d 61 69 6e 29 0a 09 20 20 -type 'main)..
10f0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 61 72 (begin...(ar
1100: 65 61 2d 70 6b 74 69 64 2d 73 65 74 21 20 2a 61 ea-pktid-set! *a
1110: 72 65 61 2d 69 6e 66 6f 2a 20 0a 09 09 09 09 20 rea-info* .....
1120: 28 77 72 69 74 65 2d 61 6c 69 73 74 2d 3e 70 6b (write-alist->pk
1130: 74 0a 09 09 09 09 20 20 70 6b 74 64 69 72 20 0a t..... pktdir .
1140: 09 09 09 09 20 20 60 28 28 68 6f 73 74 6e 61 6d .... `((hostnam
1150: 65 20 2e 20 2c 28 67 65 74 2d 68 6f 73 74 2d 6e e . ,(get-host-n
1160: 61 6d 65 29 29 0a 09 09 09 09 20 20 20 20 28 69 ame))..... (i
1170: 70 61 64 64 72 20 20 20 2e 20 2c 62 65 73 74 2d paddr . ,best-
1180: 69 70 29 0a 09 09 09 09 20 20 20 20 28 70 6f 72 ip)..... (por
1190: 74 20 20 20 20 20 2e 20 2c 70 6f 72 74 2d 6e 75 t . ,port-nu
11a0: 6d 29 0a 09 09 09 09 20 20 20 20 28 70 69 64 20 m)..... (pid
11b0: 20 20 20 20 20 2e 20 2c 28 63 75 72 72 65 6e 74 . ,(current
11c0: 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 0a 09 -process-id)))..
11d0: 09 09 09 20 20 70 6b 74 73 70 65 63 3a 20 2a 70 ... pktspec: *p
11e0: 6b 74 73 70 65 63 2a 0a 09 09 09 09 20 20 70 74 ktspec*..... pt
11f0: 79 70 65 3a 20 20 20 27 73 65 72 76 65 72 29 29 ype: 'server))
1200: 0a 09 09 28 61 72 65 61 2d 70 6b 74 66 69 6c 65 ...(area-pktfile
1210: 2d 73 65 74 21 20 2a 61 72 65 61 2d 69 6e 66 6f -set! *area-info
1220: 2a 20 28 63 6f 6e 63 20 70 6b 74 64 69 72 20 22 * (conc pktdir "
1230: 2f 22 20 28 61 72 65 61 2d 70 6b 74 69 64 20 2a /" (area-pktid *
1240: 61 72 65 61 2d 69 6e 66 6f 2a 29 20 22 2e 70 6b area-info*) ".pk
1250: 74 22 29 29 29 29 0a 09 20 20 3b 3b 20 73 65 74 t")))).. ;; set
1260: 20 61 6c 6c 20 74 68 65 20 61 72 65 61 20 69 6e all the area in
1270: 66 6f 20 69 6e 20 74 68 65 20 0a 09 20 20 28 61 fo in the .. (a
1280: 72 65 61 2d 70 6b 74 73 64 69 72 2d 73 65 74 21 rea-pktsdir-set!
1290: 20 2a 61 72 65 61 2d 69 6e 66 6f 2a 20 70 6b 74 *area-info* pkt
12a0: 64 69 72 29 0a 09 20 20 28 61 72 65 61 2d 6d 74 dir).. (area-mt
12b0: 72 61 68 2d 73 65 74 21 20 20 20 2a 61 72 65 61 rah-set! *area
12c0: 2d 69 6e 66 6f 2a 20 6d 74 64 69 72 29 0a 09 20 -info* mtdir)..
12d0: 20 28 61 72 65 61 2d 63 6f 6e 6e 2d 73 65 74 21 (area-conn-set!
12e0: 20 20 20 20 2a 61 72 65 61 2d 69 6e 66 6f 2a 20 *area-info*
12f0: 61 72 65 61 2d 63 6f 6e 6e 29 0a 09 20 20 28 61 area-conn).. (a
1300: 72 65 61 2d 70 6f 72 74 2d 73 65 74 21 20 20 20 rea-port-set!
1310: 20 2a 61 72 65 61 2d 69 6e 66 6f 2a 20 70 6f 72 *area-info* por
1320: 74 2d 6e 75 6d 29 0a 09 20 20 28 6d 75 74 65 78 t-num).. (mutex
1330: 2d 75 6e 6c 6f 63 6b 21 20 28 61 72 65 61 2d 6d -unlock! (area-m
1340: 75 74 65 78 20 2a 61 72 65 61 2d 69 6e 66 6f 2a utex *area-info*
1350: 29 29 0a 09 20 20 61 72 65 61 2d 63 6f 6e 6e 29 )).. area-conn)
1360: 29 29 29 0a 0a 3b 3b 20 61 63 74 69 6f 6e 3a 0a )))..;; action:.
1370: 3b 3b 20 20 20 69 6d 6d 65 64 69 61 74 65 20 2d ;; immediate -
1380: 20 71 75 69 63 6b 20 61 63 74 69 6f 6e 73 2c 20 quick actions,
1390: 6e 6f 20 6e 65 65 64 20 74 6f 20 70 75 74 20 69 no need to put i
13a0: 6e 20 71 75 65 75 65 73 0a 3b 3b 20 20 20 64 62 n queues.;; db
13b0: 77 72 69 74 65 20 20 20 2d 20 70 75 74 20 69 6e write - put in
13c0: 20 64 62 77 72 69 74 65 20 71 75 65 75 65 0a 3b dbwrite queue.;
13d0: 3b 20 20 20 64 62 72 65 61 64 20 20 20 20 2d 20 ; dbread -
13e0: 70 75 74 20 69 6e 20 64 62 72 65 61 64 20 71 75 put in dbread qu
13f0: 65 75 65 0a 3b 3b 20 20 20 6f 73 6c 6f 6e 67 20 eue.;; oslong
1400: 20 20 20 2d 20 6f 73 20 61 63 74 69 6f 6e 73 2c - os actions,
1410: 20 65 2e 67 2e 20 64 75 2c 20 74 68 61 74 20 63 e.g. du, that c
1420: 6f 75 6c 64 20 74 61 6b 65 20 61 20 6c 6f 6e 67 ould take a long
1430: 20 74 69 6d 65 0a 3b 3b 20 20 20 6f 73 73 68 6f time.;; ossho
1440: 72 74 20 20 20 2d 20 6f 73 20 61 63 74 69 6f 6e rt - os action
1450: 73 20 74 68 61 74 20 73 68 6f 75 6c 64 20 62 65 s that should be
1460: 20 71 75 69 63 6b 2c 20 65 2e 67 2e 20 64 66 0a quick, e.g. df.
1470: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 ;;.(define (serv
1480: 65 72 3a 73 74 64 2d 68 61 6e 64 6c 65 72 20 64 er:std-handler d
1490: 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 72 at). (let* ((fr
14a0: 6f 6d 2d 68 6f 73 74 20 28 61 6c 69 73 74 2d 72 om-host (alist-r
14b0: 65 66 20 27 68 6f 73 74 6e 61 6d 65 20 64 61 74 ef 'hostname dat
14c0: 29 29 0a 09 20 28 66 72 6f 6d 2d 70 6f 72 74 20 )).. (from-port
14d0: 28 61 6c 69 73 74 2d 72 65 66 20 27 70 6f 72 74 (alist-ref 'port
14e0: 20 20 20 20 20 64 61 74 29 29 0a 09 20 28 73 65 dat)).. (se
14f0: 72 76 6b 65 79 20 20 20 28 61 6c 69 73 74 2d 72 rvkey (alist-r
1500: 65 66 20 27 73 65 72 76 6b 65 79 20 20 64 61 74 ef 'servkey dat
1510: 29 29 0a 09 20 28 68 6f 73 74 6b 65 79 20 20 20 )).. (hostkey
1520: 28 61 6c 69 73 74 2d 72 65 66 20 27 68 6f 73 74 (alist-ref 'host
1530: 6b 65 79 20 20 64 61 74 29 29 0a 09 20 28 64 61 key dat)).. (da
1540: 74 61 20 20 20 20 20 20 28 61 6c 69 73 74 2d 72 ta (alist-r
1550: 65 66 20 27 64 61 74 61 20 20 20 20 20 64 61 74 ef 'data dat
1560: 29 29 0a 09 20 28 61 63 74 69 6f 6e 20 20 20 20 )).. (action
1570: 28 61 6c 69 73 74 2d 72 65 66 20 27 61 63 74 69 (alist-ref 'acti
1580: 6f 6e 20 20 20 64 61 74 29 29 29 0a 20 20 20 20 on dat))).
1590: 3b 3b 20 66 69 72 73 74 2c 20 69 66 20 79 6f 75 ;; first, if you
15a0: 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 77 68 6f 20 don't know who
15b0: 49 20 61 6d 20 74 68 65 6e 20 49 27 6d 20 69 67 I am then I'm ig
15c0: 6e 6f 72 69 6e 67 20 79 6f 75 0a 20 20 20 20 28 noring you. (
15d0: 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 if (not (equal?
15e0: 73 65 72 76 6b 65 79 20 28 61 72 65 61 2d 70 6b servkey (area-pk
15f0: 74 69 64 20 2a 61 72 65 61 2d 69 6e 66 6f 2a 29 tid *area-info*)
1600: 29 29 0a 09 60 28 23 66 20 2e 20 22 49 20 64 6f ))..`(#f . "I do
1610: 6e 27 74 20 6b 6e 6f 77 20 79 6f 75 22 29 20 3b n't know you") ;
1620: 3b 20 69 6d 6d 65 64 69 61 74 65 6c 79 20 72 65 ; immediately re
1630: 74 75 72 6e 20 74 68 69 73 0a 09 28 63 61 73 65 turn this..(case
1640: 20 61 63 74 69 6f 6e 20 20 20 20 20 20 20 20 20 action
1650: 20 20 20 20 20 20 3b 3b 20 65 6c 73 65 20 63 61 ;; else ca
1660: 72 72 79 20 6f 6e 0a 09 20 20 28 28 69 6d 6d 65 rry on.. ((imme
1670: 64 69 61 74 65 29 0a 09 20 20 20 28 63 61 73 65 diate).. (case
1680: 20 64 61 74 61 0a 09 20 20 20 20 20 28 28 70 69 data.. ((pi
1690: 6e 67 29 09 60 28 23 74 20 20 22 73 75 63 63 65 ng).`(#t "succe
16a0: 73 73 22 29 29 0a 09 20 20 20 20 20 28 65 6c 73 ss")).. (els
16b0: 65 20 20 20 20 20 20 60 28 23 74 20 20 22 49 20 e `(#t "I
16c0: 64 69 64 6e 27 74 20 72 65 63 6f 67 6e 69 73 65 didn't recognise
16d0: 20 22 20 64 61 74 61 29 29 29 29 0a 09 20 20 28 " data)))).. (
16e0: 28 64 62 77 72 69 74 65 29 20 20 20 20 60 28 23 (dbwrite) `(#
16f0: 74 20 20 22 64 62 20 77 72 69 74 65 20 73 75 62 t "db write sub
1700: 6d 69 74 74 65 64 22 29 29 0a 09 20 20 28 28 64 mitted")).. ((d
1710: 62 72 65 61 64 29 20 20 20 20 20 60 28 23 74 20 bread) `(#t
1720: 20 22 64 62 20 72 65 61 64 20 73 75 62 6d 69 74 "db read submit
1730: 74 65 64 22 29 29 0a 09 20 20 28 28 6f 73 6c 6f ted")).. ((oslo
1740: 6e 67 29 20 20 20 20 20 60 28 23 74 20 20 22 6f ng) `(#t "o
1750: 73 20 6c 6f 6e 67 20 73 75 62 6d 69 74 74 65 64 s long submitted
1760: 22 29 29 0a 09 20 20 28 28 64 62 77 72 69 74 65 ")).. ((dbwrite
1770: 29 20 20 20 20 60 28 23 74 20 20 22 6f 73 20 73 ) `(#t "os s
1780: 68 6f 72 74 20 73 75 62 6d 69 74 74 65 64 22 29 hort submitted")
1790: 29 0a 09 20 20 28 65 6c 73 65 20 20 20 20 20 20 ).. (else
17a0: 20 20 20 60 28 23 66 20 20 22 75 6e 72 65 63 6f `(#f "unreco
17b0: 67 6e 69 73 65 64 20 61 63 74 69 6f 6e 22 20 61 gnised action" a
17c0: 63 74 69 6f 6e 29 29 29 29 29 29 0a 0a 3b 3b 20 ction))))))..;;
17d0: 43 61 6c 6c 20 74 68 69 73 20 74 6f 20 73 74 61 Call this to sta
17e0: 72 74 20 74 68 65 20 61 63 74 75 61 6c 20 73 65 rt the actual se
17f0: 72 76 65 72 0a 3b 3b 0a 3b 3b 20 73 74 61 72 74 rver.;;.;; start
1800: 5f 73 65 72 76 65 72 0a 3b 3b 0a 3b 3b 20 20 20 _server.;;.;;
1810: 6d 6f 64 65 3a 20 27 0a 3b 3b 20 20 20 68 61 6e mode: '.;; han
1820: 64 6c 65 72 3a 20 70 72 6f 63 20 77 68 69 63 68 dler: proc which
1830: 20 74 61 6b 65 73 20 70 6b 74 72 65 63 69 65 76 takes pktreciev
1840: 65 64 20 61 73 20 61 72 67 75 6d 65 6e 74 0a 3b ed as argument.;
1850: 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 ;.(define (serve
1860: 72 3a 6c 61 75 6e 63 68 20 6d 6f 64 65 20 23 21 r:launch mode #!
1870: 6f 70 74 69 6f 6e 61 6c 20 28 70 72 6f 63 20 73 optional (proc s
1880: 65 72 76 65 72 3a 73 74 64 2d 68 61 6e 64 6c 65 erver:std-handle
1890: 72 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 r)). (let* ((st
18a0: 61 72 74 2d 74 69 6d 65 20 20 20 20 28 63 75 72 art-time (cur
18b0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 rent-seconds))..
18c0: 20 28 72 65 70 20 20 20 20 20 20 20 20 20 20 20 (rep
18d0: 28 73 65 72 76 65 72 3a 73 74 61 72 74 2d 6e 6d (server:start-nm
18e0: 73 67 20 6d 6f 64 65 29 29 0a 09 20 28 6c 61 73 sg mode)).. (las
18f0: 74 2d 6d 73 67 2d 74 69 6d 65 20 28 63 75 72 72 t-msg-time (curr
1900: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 ent-seconds))..
1910: 28 74 68 31 20 20 20 20 20 20 20 20 20 20 20 28 (th1 (
1920: 6d 61 6b 65 2d 74 68 72 65 61 64 0a 09 09 09 20 make-thread....
1930: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 (lambda ()....
1940: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 09 09 (let loop ()...
1950: 09 20 20 20 20 20 28 6c 65 74 20 28 28 64 61 74 . (let ((dat
1960: 20 28 73 65 72 76 65 72 3a 72 65 63 65 69 76 65 (server:receive
1970: 20 72 65 70 29 29 29 0a 09 09 09 20 20 20 20 20 rep)))....
1980: 20 20 28 73 65 74 21 20 6c 61 73 74 2d 6d 73 67 (set! last-msg
1990: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 -time (current-s
19a0: 65 63 6f 6e 64 73 29 29 0a 09 09 09 20 20 20 20 econds))....
19b0: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 72 65 ;; (print "re
19c0: 63 65 69 76 65 64 3a 20 22 20 70 6b 74 64 61 74 ceived: " pktdat
19d0: 29 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 20 ).... (if
19e0: 28 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 63 74 (not (eof-object
19f0: 3f 20 64 61 74 29 29 0a 09 09 09 09 20 20 20 28 ? dat))..... (
1a00: 6c 65 74 20 28 28 72 65 73 64 61 74 20 28 70 72 let ((resdat (pr
1a10: 6f 63 20 64 61 74 29 29 29 0a 09 09 09 09 20 20 oc dat))).....
1a20: 20 20 20 28 70 72 69 6e 74 20 22 47 6f 74 20 22 (print "Got "
1a30: 20 64 61 74 29 0a 09 09 09 09 20 20 20 20 20 28 dat)..... (
1a40: 70 72 69 6e 74 20 22 52 65 73 70 6f 6e 64 69 6e print "Respondin
1a50: 67 20 77 69 74 68 20 22 20 72 65 73 64 61 74 29 g with " resdat)
1a60: 0a 09 09 09 09 20 20 20 20 20 28 6e 6d 73 67 3a ..... (nmsg:
1a70: 73 65 6e 64 20 72 65 70 20 28 73 65 78 70 72 2d send rep (sexpr-
1a80: 3e 73 74 72 69 6e 67 20 72 65 73 64 61 74 29 29 >string resdat))
1a90: 20 3b 3b 20 28 77 69 74 68 2d 6f 75 74 70 75 74 ;; (with-output
1aa0: 2d 74 6f 2d 73 74 72 69 6e 67 20 28 6c 61 6d 62 -to-string (lamb
1ab0: 64 61 20 28 29 28 77 72 69 74 65 20 72 65 73 64 da ()(write resd
1ac0: 61 74 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 at)))).....
1ad0: 28 6c 6f 6f 70 29 29 29 29 29 29 0a 09 09 09 20 (loop))))))....
1ae0: 22 6d 65 73 73 61 67 65 20 68 61 6e 64 6c 65 72 "message handler
1af0: 22 29 29 0a 09 20 28 74 68 32 20 20 20 20 20 20 ")).. (th2
1b00: 20 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 (make-threa
1b10: 64 0a 09 09 09 20 28 6c 61 6d 62 64 61 20 28 29 d.... (lambda ()
1b20: 0a 09 09 09 20 20 20 28 6c 65 74 20 6c 6f 6f 70 .... (let loop
1b30: 20 28 29 0a 09 09 09 20 20 20 20 20 28 74 68 72 ().... (thr
1b40: 65 61 64 2d 73 6c 65 65 70 21 20 31 30 29 0a 09 ead-sleep! 10)..
1b50: 09 09 20 20 20 20 20 28 69 66 20 28 3e 20 28 2d .. (if (> (-
1b60: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
1b70: 73 29 20 6c 61 73 74 2d 6d 73 67 2d 74 69 6d 65 s) last-msg-time
1b80: 29 20 36 30 29 20 3b 3b 20 74 69 6d 65 6f 75 74 ) 60) ;; timeout
1b90: 20 61 66 74 65 72 20 36 30 20 73 65 63 6f 6e 64 after 60 second
1ba0: 73 0a 09 09 09 09 20 28 62 65 67 69 6e 0a 09 09 s..... (begin...
1bb0: 09 09 20 20 20 28 70 72 69 6e 74 20 22 57 61 69 .. (print "Wai
1bc0: 74 65 64 20 66 6f 72 20 36 30 20 73 65 63 6f 6e ted for 60 secon
1bd0: 64 73 20 61 6e 64 20 6e 6f 20 6d 65 73 73 61 67 ds and no messag
1be0: 65 73 2c 20 65 78 69 74 69 6e 67 20 6e 6f 77 2e es, exiting now.
1bf0: 22 29 0a 09 09 09 09 20 20 20 28 65 78 69 74 29 ")..... (exit)
1c00: 29 0a 09 09 09 09 20 28 6c 6f 6f 70 29 29 29 29 )..... (loop))))
1c10: 29 29 29 0a 20 20 20 20 28 74 68 72 65 61 64 2d ))). (thread-
1c20: 73 74 61 72 74 21 20 74 68 31 29 0a 20 20 20 20 start! th1).
1c30: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
1c40: 68 32 29 0a 20 20 20 20 28 74 68 72 65 61 64 2d h2). (thread-
1c50: 6a 6f 69 6e 21 20 74 68 31 29 29 29 0a 0a 3b 3b join! th1)))..;;
1c60: 20 67 65 74 20 74 68 65 20 72 65 73 70 6f 6e 73 get the respons
1c70: 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 e.;;.(define (se
1c80: 72 76 65 72 3a 72 65 63 65 69 76 65 20 72 65 70 rver:receive rep
1c90: 29 0a 20 20 28 6c 65 74 20 28 28 69 6e 73 74 72 ). (let ((instr
1ca0: 20 28 6e 6d 73 67 3a 72 65 63 76 20 72 65 70 29 (nmsg:recv rep)
1cb0: 29 29 0a 20 20 20 20 28 69 66 20 28 73 74 72 69 )). (if (stri
1cc0: 6e 67 3f 20 69 6e 73 74 72 29 0a 09 28 73 74 72 ng? instr)..(str
1cd0: 69 6e 67 2d 3e 73 65 78 70 72 20 69 6e 73 74 72 ing->sexpr instr
1ce0: 29 20 3b 3b 20 28 77 69 74 68 2d 69 6e 70 75 74 ) ;; (with-input
1cf0: 2d 66 72 6f 6d 2d 73 74 72 69 6e 67 20 69 6e 73 -from-string ins
1d00: 74 72 20 72 65 61 64 29 0a 09 69 6e 73 74 72 29 tr read)..instr)
1d10: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 72 ))..(define (ser
1d20: 76 65 72 3a 73 68 75 74 64 6f 77 6e 29 0a 20 20 ver:shutdown).
1d30: 28 6c 65 74 20 28 28 63 6f 6e 6e 20 28 61 72 65 (let ((conn (are
1d40: 61 2d 63 6f 6e 6e 20 20 20 20 2a 61 72 65 61 2d a-conn *area-
1d50: 69 6e 66 6f 2a 29 29 0a 09 28 70 6b 74 66 20 28 info*))..(pktf (
1d60: 61 72 65 61 2d 70 6b 74 66 69 6c 65 20 2a 61 72 area-pktfile *ar
1d70: 65 61 2d 69 6e 66 6f 2a 29 29 0a 09 28 70 6f 72 ea-info*))..(por
1d80: 74 20 28 61 72 65 61 2d 70 6f 72 74 20 20 20 20 t (area-port
1d90: 2a 61 72 65 61 2d 69 6e 66 6f 2a 29 29 29 0a 20 *area-info*))).
1da0: 20 20 20 28 69 66 20 63 6f 6e 6e 0a 09 28 62 65 (if conn..(be
1db0: 67 69 6e 0a 09 20 20 28 69 66 20 70 6b 74 66 20 gin.. (if pktf
1dc0: 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 70 6b (delete-file* pk
1dd0: 74 66 29 29 0a 09 20 20 28 73 65 72 76 65 72 3a tf)).. (server:
1de0: 73 65 6e 64 2d 61 6c 6c 20 22 69 6d 73 68 75 74 send-all "imshut
1df0: 74 69 6e 67 64 6f 77 6e 22 29 0a 09 20 20 28 6e tingdown").. (n
1e00: 6d 73 67 3a 63 6c 6f 73 65 20 63 6f 6e 6e 29 0a msg:close conn).
1e10: 09 20 20 28 70 6f 72 74 6c 6f 67 67 65 72 3a 6f . (portlogger:o
1e20: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 70 6f pen-run-close po
1e30: 72 74 6c 6f 67 67 65 72 3a 72 65 6c 65 61 73 65 rtlogger:release
1e40: 2d 70 6f 72 74 20 70 6f 72 74 29 29 29 29 29 0a -port port))))).
1e50: 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 .(define (server
1e60: 3a 73 65 6e 64 2d 61 6c 6c 20 6d 73 67 29 0a 20 :send-all msg).
1e70: 20 23 66 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 #f)..;; given a
1e80: 20 61 72 65 61 20 72 65 63 6f 72 64 20 6c 6f 6f area record loo
1e90: 6b 20 75 70 20 61 6c 6c 20 74 68 65 20 70 61 63 k up all the pac
1ea0: 6b 65 74 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 kets.;;.(define
1eb0: 28 73 65 72 76 65 72 3a 67 65 74 2d 61 6c 6c 2d (server:get-all-
1ec0: 73 65 72 76 65 72 2d 70 6b 74 73 20 72 65 63 29 server-pkts rec)
1ed0: 0a 20 20 28 6c 65 74 20 28 28 61 6c 6c 2d 70 6b . (let ((all-pk
1ee0: 74 2d 66 69 6c 65 73 20 28 67 6c 6f 62 20 28 63 t-files (glob (c
1ef0: 6f 6e 63 20 28 61 72 65 61 2d 70 6b 74 73 64 69 onc (area-pktsdi
1f00: 72 20 72 65 63 29 20 22 2f 2a 2e 70 6b 74 22 29 r rec) "/*.pkt")
1f10: 29 29 29 0a 3b 3b 09 28 70 6b 74 73 70 65 63 20 ))).;;.(pktspec
1f20: 20 20 20 20 20 20 28 61 72 65 61 2d 70 6b 74 73 (area-pkts
1f30: 70 65 63 20 72 65 63 29 29 29 0a 20 20 20 20 28 pec rec))). (
1f40: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 70 6b 74 map (lambda (pkt
1f50: 2d 66 69 6c 65 29 0a 09 20 20 20 28 72 65 61 64 -file).. (read
1f60: 2d 70 6b 74 2d 3e 61 6c 69 73 74 20 70 6b 74 2d -pkt->alist pkt-
1f70: 66 69 6c 65 20 70 6b 74 73 70 65 63 3a 20 2a 70 file pktspec: *p
1f80: 6b 74 73 70 65 63 2a 29 29 0a 09 20 61 6c 6c 2d ktspec*)).. all-
1f90: 70 6b 74 2d 66 69 6c 65 73 29 29 29 0a 0a 23 3b pkt-files)))..#;
1fa0: 28 28 5a 20 2e 20 22 39 61 30 32 31 32 33 30 32 ((Z . "9a0212302
1fb0: 32 39 35 61 31 39 36 31 30 64 35 37 39 36 66 63 295a19610d5796fc
1fc0: 65 30 33 37 30 66 61 31 33 30 37 35 38 65 39 22 e0370fa130758e9"
1fd0: 29 0a 20 20 28 70 6f 72 74 20 2e 20 22 33 34 38 ). (port . "348
1fe0: 32 37 22 29 0a 20 20 28 70 69 64 20 2e 20 22 32 27"). (pid . "2
1ff0: 38 37 34 38 22 29 0a 20 20 28 68 6f 73 74 6e 61 8748"). (hostna
2000: 6d 65 20 2e 20 22 7a 65 75 73 22 29 0a 20 20 28 me . "zeus"). (
2010: 54 20 2e 20 22 73 65 72 76 65 72 22 29 0a 20 20 T . "server").
2020: 28 44 20 2e 20 22 31 35 34 39 34 32 37 30 33 32 (D . "1549427032
2030: 2e 30 22 29 29 0a 0a 3b 3b 20 73 72 76 70 6b 74 .0"))..;; srvpkt
2040: 20 69 73 20 74 68 65 20 69 6e 66 6f 20 66 6f 72 is the info for
2050: 20 74 68 65 20 73 65 72 76 65 72 20 77 65 20 77 the server we w
2060: 69 73 68 20 74 6f 20 73 65 6e 64 20 74 68 65 20 ish to send the
2070: 6d 65 73 73 61 67 65 20 74 6f 0a 3b 3b 0a 28 64 message to.;;.(d
2080: 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 73 65 efine (server:se
2090: 6e 64 20 73 65 72 76 70 6b 74 20 64 61 74 61 20 nd servpkt data
20a0: 61 63 74 69 6f 6e 29 0a 20 20 28 6c 65 74 2a 20 action). (let*
20b0: 28 28 70 6f 72 74 20 20 20 28 61 6c 69 73 74 2d ((port (alist-
20c0: 72 65 66 20 27 70 6f 72 74 20 20 20 20 20 73 65 ref 'port se
20d0: 72 76 70 6b 74 29 29 0a 09 20 28 68 6f 73 74 20 rvpkt)).. (host
20e0: 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 68 6f (alist-ref 'ho
20f0: 73 74 6e 61 6d 65 20 73 65 72 76 70 6b 74 29 29 stname servpkt))
2100: 0a 09 20 28 69 70 20 20 20 20 20 28 61 6c 69 73 .. (ip (alis
2110: 74 2d 72 65 66 20 27 69 70 61 64 64 72 20 20 20 t-ref 'ipaddr
2120: 73 65 72 76 70 6b 74 29 29 0a 09 20 28 68 6b 65 servpkt)).. (hke
2130: 79 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 y (alist-ref '
2140: 5a 20 20 20 20 20 20 20 20 73 65 72 76 70 6b 74 Z servpkt
2150: 29 29 0a 09 20 28 61 64 64 72 20 20 20 28 63 6f )).. (addr (co
2160: 6e 63 20 28 6f 72 20 69 70 20 68 6f 73 74 29 20 nc (or ip host)
2170: 22 3a 22 20 70 6f 72 74 29 29 20 3b 3b 20 66 61 ":" port)) ;; fa
2180: 6c 6c 20 62 61 63 6b 20 74 6f 20 68 6f 73 74 20 ll back to host
2190: 69 66 20 69 70 20 6e 6f 74 20 70 72 6f 76 69 64 if ip not provid
21a0: 65 64 0a 09 20 28 6d 79 70 6f 72 74 20 28 61 72 ed.. (myport (ar
21b0: 65 61 2d 70 6f 72 74 20 2a 61 72 65 61 2d 69 6e ea-port *area-in
21c0: 66 6f 2a 29 29 0a 09 20 28 6d 79 68 6f 73 74 20 fo*)).. (myhost
21d0: 28 61 72 65 61 2d 6d 79 61 64 64 72 20 2a 61 72 (area-myaddr *ar
21e0: 65 61 2d 69 6e 66 6f 2a 29 29 0a 09 20 28 6d 79 ea-info*)).. (my
21f0: 6b 65 79 20 20 28 61 72 65 61 2d 70 6b 74 69 64 key (area-pktid
2200: 20 20 2a 61 72 65 61 2d 69 6e 66 6f 2a 29 29 0a *area-info*)).
2210: 09 20 28 6d 73 67 20 20 20 20 28 77 69 74 68 2d . (msg (with-
2220: 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 output-to-string
2230: 0a 09 09 20 20 20 28 6c 61 6d 62 64 61 20 28 29 ... (lambda ()
2240: 0a 09 09 20 20 20 20 20 28 77 72 69 74 65 20 60 ... (write `
2250: 28 28 68 6f 73 74 6e 61 6d 65 20 2e 20 2c 6d 79 ((hostname . ,my
2260: 68 6f 73 74 29 0a 09 09 09 20 20 20 20 20 20 28 host).... (
2270: 70 6f 72 74 20 20 20 20 20 2e 20 2c 6d 79 70 6f port . ,mypo
2280: 72 74 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 rt).... (se
2290: 72 76 6b 65 79 20 20 2e 20 2c 68 6b 65 79 29 20 rvkey . ,hkey)
22a0: 20 20 20 20 3b 3b 20 73 65 72 76 65 72 20 6c 6f ;; server lo
22b0: 6f 6b 73 20 61 74 20 74 68 69 73 20 74 6f 20 65 oks at this to e
22c0: 6e 73 75 72 65 20 6d 65 73 73 61 67 65 20 69 73 nsure message is
22d0: 20 66 6f 72 20 74 68 65 6d 0a 09 09 09 20 20 20 for them....
22e0: 20 20 20 28 68 6f 73 74 6b 65 79 20 20 2e 20 2c (hostkey . ,
22f0: 6d 79 6b 65 79 29 0a 09 09 09 20 20 20 20 20 20 mykey)....
2300: 28 61 63 74 69 6f 6e 20 20 20 2e 20 2c 61 63 74 (action . ,act
2310: 69 6f 6e 29 20 20 20 20 3b 3b 20 66 6f 72 6d 61 ion) ;; forma
2320: 74 69 6e 67 20 6f 66 20 74 68 65 20 6d 65 73 73 ting of the mess
2330: 61 67 65 0a 09 09 09 20 20 20 20 20 20 28 64 61 age.... (da
2340: 74 61 20 20 20 20 20 2e 20 2c 64 61 74 61 29 29 ta . ,data))
2350: 0a 09 09 09 20 20 20 20 3b 3b 20 2a 70 6b 74 73 .... ;; *pkts
2360: 70 65 63 2a 0a 09 09 09 20 20 20 20 3b 3b 20 70 pec*.... ;; p
2370: 74 79 70 65 3a 20 27 64 61 74 61 29 29 0a 09 09 type: 'data))...
2380: 09 20 20 20 20 29 29 29 29 29 0a 20 20 20 20 3b . ))))). ;
2390: 3b 20 28 70 72 69 6e 74 20 22 6d 73 67 3a 20 22 ; (print "msg: "
23a0: 20 6d 73 67 29 0a 20 20 20 20 28 69 66 20 28 61 msg). (if (a
23b0: 6e 64 20 70 6f 72 74 20 68 6f 73 74 29 0a 09 28 nd port host)..(
23c0: 73 74 72 69 6e 67 2d 3e 73 65 78 70 72 20 3b 3b string->sexpr ;;
23d0: 20 62 65 67 69 6e 0a 09 20 20 3b 3b 20 28 70 72 begin.. ;; (pr
23e0: 69 6e 74 20 22 73 65 6e 64 69 6e 67 20 22 29 28 int "sending ")(
23f0: 70 70 20 6d 73 67 29 28 70 72 69 6e 74 20 22 20 pp msg)(print "
2400: 74 6f 20 22 20 61 64 64 72 29 0a 09 20 20 28 6e to " addr).. (n
2410: 6d 73 67 3a 6f 70 65 6e 2d 73 65 6e 64 2d 72 65 msg:open-send-re
2420: 63 65 69 76 65 20 61 64 64 72 20 6d 73 67 29 29 ceive addr msg))
2430: 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 ..#f)))..(define
2440: 20 28 73 65 72 76 65 72 3a 67 65 74 2d 6d 79 2d (server:get-my-
2450: 62 65 73 74 2d 61 64 64 72 65 73 73 29 0a 20 20 best-address).
2460: 28 69 70 2d 3e 73 74 72 69 6e 67 20 28 63 61 72 (ip->string (car
2470: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
2480: 20 28 78 29 0a 09 09 09 20 20 20 20 20 28 6e 6f (x).... (no
2490: 74 20 28 65 71 3f 20 28 75 38 76 65 63 74 6f 72 t (eq? (u8vector
24a0: 2d 72 65 66 20 78 20 30 29 20 31 32 37 29 29 29 -ref x 0) 127)))
24b0: 0a 09 09 09 20 20 20 28 76 65 63 74 6f 72 2d 3e .... (vector->
24c0: 6c 69 73 74 20 28 68 6f 73 74 69 6e 66 6f 2d 61 list (hostinfo-a
24d0: 64 64 72 65 73 73 65 73 20 28 68 6f 73 74 6e 61 ddresses (hostna
24e0: 6d 65 2d 3e 68 6f 73 74 69 6e 66 6f 20 22 7a 65 me->hostinfo "ze
24f0: 75 73 22 29 29 29 29 29 29 29 0a 0a 3b 3b 20 77 us")))))))..;; w
2500: 68 6f 61 6d 69 3f 20 49 20 61 6d 20 6d 79 20 70 hoami? I am my p
2510: 6b 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 kt.;;.(define (s
2520: 65 72 76 65 72 3a 77 68 6f 61 6d 69 3f 20 61 72 erver:whoami? ar
2530: 65 61 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c ea). (hash-tabl
2540: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 61 e-ref/default (a
2550: 72 65 61 2d 68 6f 73 74 73 20 61 72 65 61 29 28 rea-hosts area)(
2560: 61 72 65 61 2d 70 6b 74 69 64 20 61 72 65 61 29 area-pktid area)
2570: 20 23 66 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d #f))..;;=======
2580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
25c0: 3b 3b 20 22 43 6c 69 65 6e 74 20 73 69 64 65 22 ;; "Client side"
25d0: 20 6f 70 65 72 61 74 69 6f 6e 73 0a 3b 3b 3d 3d operations.;;==
25e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2620: 3d 3d 3d 3d 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 ====..;; convert
2630: 20 74 6f 2f 66 72 6f 6d 20 73 74 72 69 6e 67 20 to/from string
2640: 2f 20 73 65 78 70 72 0a 0a 28 64 65 66 69 6e 65 / sexpr..(define
2650: 20 28 73 74 72 69 6e 67 2d 3e 73 65 78 70 72 20 (string->sexpr
2660: 73 74 72 29 0a 20 20 28 69 66 20 28 73 74 72 69 str). (if (stri
2670: 6e 67 3f 20 73 74 72 29 0a 20 20 20 20 20 20 28 ng? str). (
2680: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
2690: 73 74 72 69 6e 67 20 73 74 72 20 72 65 61 64 29 string str read)
26a0: 0a 20 20 20 20 20 20 73 74 72 29 29 0a 0a 28 64 . str))..(d
26b0: 65 66 69 6e 65 20 28 73 65 78 70 72 2d 3e 73 74 efine (sexpr->st
26c0: 72 69 6e 67 20 73 29 0a 20 20 28 77 69 74 68 2d ring s). (with-
26d0: 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 output-to-string
26e0: 20 28 6c 61 6d 62 64 61 20 28 29 28 77 72 69 74 (lambda ()(writ
26f0: 65 20 73 29 29 29 29 0a 0a 3b 3b 20 69 73 20 74 e s))))..;; is t
2700: 68 65 20 73 65 72 76 65 72 20 61 6c 69 76 65 3f he server alive?
2710: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 73 65 72 .;;.(define (ser
2720: 76 65 72 3a 70 69 6e 67 20 73 65 72 76 70 6b 74 ver:ping servpkt
2730: 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 61 72 ). (let* ((star
2740: 74 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d t-time (current-
2750: 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 09 milliseconds))..
2760: 20 28 72 65 73 20 20 20 20 20 20 20 20 28 73 65 (res (se
2770: 72 76 65 72 3a 73 65 6e 64 20 73 65 72 76 70 6b rver:send servpk
2780: 74 20 27 70 69 6e 67 20 27 69 6d 6d 65 64 69 61 t 'ping 'immedia
2790: 74 65 29 29 29 0a 20 20 20 20 28 63 6f 6e 73 20 te))). (cons
27a0: 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c (- (current-mill
27b0: 69 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d iseconds) start-
27c0: 74 69 6d 65 29 0a 09 20 20 72 65 73 29 29 29 20 time).. res)))
27d0: 3b 3b 20 28 65 71 75 61 6c 3f 20 72 65 73 20 22 ;; (equal? res "
27e0: 67 6f 74 20 70 69 6e 67 22 29 29 29 29 0a 0a 3b got ping"))))..;
27f0: 3b 20 6c 6f 6f 6b 20 75 70 20 61 6c 6c 20 70 6b ; look up all pk
2800: 74 73 20 61 6e 64 20 67 65 74 20 74 68 65 20 73 ts and get the s
2810: 65 72 76 65 72 20 69 64 20 28 74 68 65 20 68 61 erver id (the ha
2820: 73 68 29 2c 20 70 6f 72 74 2c 20 68 6f 73 74 2f sh), port, host/
2830: 69 70 0a 3b 3b 20 73 74 6f 72 65 20 74 68 69 73 ip.;; store this
2840: 20 69 6e 66 6f 20 69 6e 20 74 68 65 20 67 6c 6f info in the glo
2850: 62 61 6c 20 73 74 72 75 63 74 20 2a 61 72 65 61 bal struct *area
2860: 2d 69 6e 66 6f 2a 0a 3b 3b 0a 3b 3b 20 70 61 73 -info*.;;.;; pas
2870: 73 20 69 6e 20 2a 61 72 65 61 2d 69 6e 66 6f 2a s in *area-info*
2880: 20 61 73 20 72 65 63 0a 3b 3b 0a 28 64 65 66 69 as rec.;;.(defi
2890: 6e 65 20 28 73 65 72 76 65 72 3a 75 70 64 61 74 ne (server:updat
28a0: 65 2d 6b 6e 6f 77 6e 2d 73 65 72 76 65 72 73 20 e-known-servers
28b0: 72 65 63 29 0a 20 20 3b 3b 20 72 65 61 64 6c 6c rec). ;; readll
28c0: 20 61 6c 6c 20 70 6b 74 73 0a 20 20 3b 3b 20 66 all pkts. ;; f
28d0: 6f 72 65 61 63 68 20 70 6b 74 3b 20 69 66 20 69 oreach pkt; if i
28e0: 74 20 69 73 6e 27 74 20 6d 65 20 70 69 6e 67 20 t isn't me ping
28f0: 74 68 65 20 73 65 72 76 65 72 3b 20 69 66 20 61 the server; if a
2900: 6c 69 76 65 2c 20 61 64 64 20 74 6f 20 68 6f 73 live, add to hos
2910: 74 73 20 68 61 73 68 2c 20 65 6c 73 65 20 72 6d ts hash, else rm
2920: 20 74 68 65 20 70 6b 74 0a 20 20 28 6c 65 74 20 the pkt. (let
2930: 28 28 61 6c 6c 2d 70 6b 74 73 20 20 28 64 65 6c ((all-pkts (del
2940: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 0a 09 ete-duplicates..
2950: 09 20 20 20 20 28 61 70 70 65 6e 64 20 28 73 65 . (append (se
2960: 72 76 65 72 3a 67 65 74 2d 61 6c 6c 2d 73 65 72 rver:get-all-ser
2970: 76 65 72 2d 70 6b 74 73 20 72 65 63 29 0a 09 09 ver-pkts rec)...
2980: 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
2990: 2d 76 61 6c 75 65 73 20 28 61 72 65 61 2d 68 6f -values (area-ho
29a0: 73 74 73 20 72 65 63 29 29 29 29 29 0a 09 28 68 sts rec)))))..(h
29b0: 6f 73 74 73 68 61 73 68 20 28 61 72 65 61 2d 68 ostshash (area-h
29c0: 6f 73 74 73 20 72 65 63 29 29 0a 09 28 6d 79 2d osts rec))..(my-
29d0: 69 64 20 20 20 20 20 28 61 72 65 61 2d 70 6b 74 id (area-pkt
29e0: 69 64 20 72 65 63 29 29 0a 09 28 70 6b 74 73 64 id rec))..(pktsd
29f0: 69 72 20 20 20 28 61 72 65 61 2d 70 6b 74 73 64 ir (area-pktsd
2a00: 69 72 20 72 65 63 29 29 20 3b 3b 20 6e 65 65 64 ir rec)) ;; need
2a10: 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 70 6b 74 ed to remove pkt
2a20: 73 20 66 72 6f 6d 20 6e 6f 6e 2d 72 65 73 70 6f s from non-respo
2a30: 6e 73 69 76 65 20 73 65 72 76 65 72 73 0a 09 29 nsive servers..)
2a40: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 . (for-each.
2a50: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 65 72 (lambda (ser
2a60: 76 70 6b 74 29 0a 20 20 20 20 20 20 20 28 6c 65 vpkt). (le
2a70: 74 2a 20 28 28 72 65 73 20 28 73 65 72 76 65 72 t* ((res (server
2a80: 3a 70 69 6e 67 20 73 65 72 76 70 6b 74 29 29 0a :ping servpkt)).
2a90: 09 20 20 20 20 20 20 28 73 69 64 20 28 61 6c 69 . (sid (ali
2aa0: 73 74 2d 72 65 66 20 27 5a 20 73 65 72 76 70 6b st-ref 'Z servpk
2ab0: 74 29 29 20 3b 3b 20 5a 20 63 6f 64 65 20 69 73 t)) ;; Z code is
2ac0: 20 6f 75 72 20 6e 61 6d 65 20 66 6f 72 20 74 68 our name for th
2ad0: 65 20 73 65 72 76 65 72 0a 09 20 20 20 20 20 20 e server..
2ae0: 29 0a 09 20 28 6d 61 74 63 68 20 72 65 73 0a 09 ).. (match res..
2af0: 20 20 20 28 28 71 64 75 72 61 74 69 6f 6e 20 2e ((qduration .
2b00: 20 70 61 79 6c 6f 61 64 29 0a 09 20 20 20 20 28 payload).. (
2b10: 70 72 69 6e 74 20 22 53 65 72 76 65 72 20 70 6b print "Server pk
2b20: 74 3a 22 29 28 70 70 20 73 65 72 76 70 6b 74 29 t:")(pp servpkt)
2b30: 0a 09 20 20 20 20 28 70 72 69 6e 74 20 22 72 65 .. (print "re
2b40: 73 3a 20 22 29 28 70 70 20 72 65 73 29 0a 09 20 s: ")(pp res)..
2b50: 20 20 20 28 6d 61 74 63 68 20 70 61 79 6c 6f 61 (match payloa
2b60: 64 0a 09 20 20 20 20 20 20 28 28 63 6f 64 65 20 d.. ((code
2b70: 6d 65 73 73 61 67 65 29 0a 09 20 20 20 20 20 20 message)..
2b80: 20 28 70 72 69 6e 74 20 22 63 6f 64 65 3a 20 22 (print "code: "
2b90: 20 63 6f 64 65 20 22 20 6d 65 73 73 61 67 65 3a code " message:
2ba0: 20 22 20 6d 65 73 73 61 67 65 29 0a 09 20 20 20 " message)..
2bb0: 20 20 20 20 28 69 66 20 63 6f 64 65 0a 09 09 20 (if code...
2bc0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
2bd0: 74 21 20 68 6f 73 74 73 68 61 73 68 20 73 69 64 t! hostshash sid
2be0: 20 73 65 72 76 70 6b 74 29 0a 09 09 20 20 20 28 servpkt)... (
2bf0: 70 72 69 6e 74 20 22 67 6f 74 20 23 66 20 66 72 print "got #f fr
2c00: 6f 6d 20 74 68 65 20 73 65 72 76 65 72 2c 20 6e om the server, n
2c10: 6f 74 20 73 75 72 65 20 77 68 61 74 20 74 68 61 ot sure what tha
2c20: 74 20 6d 65 61 6e 73 21 22 29 29 29 0a 09 20 20 t means!")))..
2c30: 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 20 (else..
2c40: 20 20 28 70 72 69 6e 74 20 22 47 6f 74 20 22 29 (print "Got ")
2c50: 28 70 70 20 72 65 73 29 28 70 72 69 6e 74 20 22 (pp res)(print "
2c60: 20 66 72 6f 6d 20 73 65 72 76 65 72 20 22 29 28 from server ")(
2c70: 70 70 20 73 65 72 76 70 6b 74 29 20 22 20 62 75 pp servpkt) " bu
2c80: 74 20 72 65 73 70 6f 6e 73 65 20 64 69 64 20 6e t response did n
2c90: 6f 74 20 6d 61 74 63 68 20 28 23 66 2f 23 74 20 ot match (#f/#t
2ca0: 2e 20 6d 73 67 29 22 29 29 29 0a 09 20 20 20 28 . msg)"))).. (
2cb0: 65 6c 73 65 0a 09 20 20 20 20 3b 3b 20 68 65 72 else.. ;; her
2cc0: 65 20 77 65 20 64 65 6c 65 74 65 20 74 68 65 20 e we delete the
2cd0: 70 6b 74 20 2d 20 63 61 6e 27 74 20 72 65 61 63 pkt - can't reac
2ce0: 68 20 74 68 65 20 73 65 72 76 65 72 2c 20 72 65 h the server, re
2cf0: 6d 6f 76 65 20 69 74 0a 09 20 20 20 20 3b 3b 20 move it.. ;;
2d00: 68 6f 77 65 76 65 72 20 74 68 69 73 20 6c 6f 67 however this log
2d10: 69 63 20 69 73 20 69 6e 61 64 65 71 75 61 74 65 ic is inadequate
2d20: 2e 20 77 65 20 73 68 6f 75 6c 64 20 6d 61 72 6b . we should mark
2d30: 20 74 68 65 20 73 65 72 76 65 72 20 61 73 20 63 the server as c
2d40: 68 65 63 6b 65 64 0a 09 20 20 20 20 3b 3b 20 61 hecked.. ;; a
2d50: 6e 64 20 6e 6f 74 20 67 6f 6f 64 2c 20 69 66 20 nd not good, if
2d60: 69 74 20 68 61 70 70 65 6e 73 20 61 20 73 65 63 it happens a sec
2d70: 6f 6e 64 20 74 69 6d 65 20 2d 20 74 68 65 6e 20 ond time - then
2d80: 72 65 6d 6f 76 65 20 74 68 65 20 70 6b 74 0a 09 remove the pkt..
2d90: 20 20 20 20 3b 3b 20 6f 72 20 73 6f 6d 65 74 68 ;; or someth
2da0: 69 6e 67 20 73 69 6d 69 6c 61 72 2e 20 49 2e 65 ing similar. I.e
2db0: 2e 20 64 6f 6e 27 74 20 62 65 20 74 6f 6f 20 71 . don't be too q
2dc0: 75 69 63 6b 20 74 6f 20 61 73 73 75 6d 65 20 74 uick to assume t
2dd0: 68 65 20 73 65 72 76 65 72 20 69 73 20 77 65 64 he server is wed
2de0: 67 65 64 20 6f 72 20 64 65 61 64 0a 09 20 20 20 ged or dead..
2df0: 20 3b 3b 20 63 6f 75 6c 64 20 62 65 20 69 74 20 ;; could be it
2e00: 69 73 20 73 69 6d 70 6c 79 20 74 6f 6f 20 62 75 is simply too bu
2e10: 73 79 20 74 6f 20 72 65 70 6c 79 0a 09 20 20 20 sy to reply..
2e20: 20 28 70 72 69 6e 74 20 22 63 6c 65 61 72 69 6e (print "clearin
2e30: 67 20 6f 75 74 20 73 65 72 76 65 72 20 22 20 73 g out server " s
2e40: 69 64 29 0a 09 20 20 20 20 28 64 65 6c 65 74 65 id).. (delete
2e50: 2d 66 69 6c 65 2a 20 28 63 6f 6e 63 20 70 6b 74 -file* (conc pkt
2e60: 73 64 69 72 20 22 2f 22 20 73 69 64 20 22 2e 70 sdir "/" sid ".p
2e70: 6b 74 22 29 29 0a 09 20 20 20 20 28 68 61 73 68 kt")).. (hash
2e80: 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 68 -table-delete! h
2e90: 6f 73 74 73 68 61 73 68 20 73 69 64 65 29 29 29 ostshash side)))
2ea0: 29 29 0a 20 20 20 20 20 61 6c 6c 2d 70 6b 74 73 )). all-pkts
2eb0: 29 29 29 0a 0a 3b 3b 20 73 65 6e 64 20 6f 75 74 )))..;; send out
2ec0: 20 61 6e 20 22 49 27 6d 20 61 62 6f 75 74 20 74 an "I'm about t
2ed0: 6f 20 65 78 69 74 20 6e 6f 74 69 63 65 20 74 6f o exit notice to
2ee0: 20 61 6c 6c 20 6b 6e 6f 77 6e 20 73 65 72 76 65 all known serve
2ef0: 72 73 22 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 rs".;;.(define (
2f00: 73 65 72 76 65 72 3a 69 6d 6d 69 6e 65 6e 74 2d server:imminent-
2f10: 64 65 61 74 68 29 0a 20 20 27 28 29 29 0a 0a 0a death). '())...
2f20: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
2f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2f60: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 45 20 ========.;; S E
2f70: 52 20 56 20 45 20 52 20 20 20 55 20 54 20 49 20 R V E R U T I
2f80: 4c 20 49 20 54 20 49 20 45 20 53 20 0a 3b 3b 3d L I T I E S .;;=
2f90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2fd0: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 67 65 74 20 61 20 =====..;; get a
2fe0: 73 69 67 6e 61 74 75 72 65 20 66 6f 72 20 69 64 signature for id
2ff0: 65 6e 74 69 66 69 6e 67 20 74 68 69 73 20 70 72 entifing this pr
3000: 6f 63 65 73 73 0a 28 64 65 66 69 6e 65 20 28 73 ocess.(define (s
3010: 65 72 76 65 72 3a 67 65 74 2d 70 72 6f 63 65 73 erver:get-proces
3020: 73 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 20 28 s-signature). (
3030: 63 6f 6e 73 20 28 67 65 74 2d 68 6f 73 74 2d 6e cons (get-host-n
3040: 61 6d 65 29 28 63 75 72 72 65 6e 74 2d 70 72 6f ame)(current-pro
3050: 63 65 73 73 2d 69 64 29 29 29 0a 0a cess-id)))..