14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
|
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
(declare (unit servermod))
(module servermod
*
(import scheme
chicken
md5
message-digest
ports
posix
)
(define *client-server-id* #f)
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
;; Generate a unique signature for this server
(define (mk-signature)
(message-digest-string (md5-primitive)
(with-output-to-string
(lambda ()
(write (list (current-directory)
(current-process-id)
(argv)))))))
(define (get-client-server-id)
(if *client-server-id* *client-server-id*
(let ((sig (mk-signature))) ;; clients re-use the server:mk-signature logic
(set! *client-server-id* sig)
*client-server-id*)))
;; ;; When using zmq this would send the message back (two step process)
;; ;; with spiffy or rpc this simply returns the return data to be returned
;; ;;
;; (define (server:reply return-addr query-sig success/fail result)
;; (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
;; ;; (send-message pubsock target send-more: #t)
;; ;; (send-message pubsock
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
(declare (unit servermod))
(use md5 message-digest posix typed-records extras)
(module servermod
*
(import scheme
chicken
extras
md5
message-digest
ports
posix
typed-records
data-structures
)
(define *client-server-id* #f)
(defstruct srv
(areapath #f)
(host #f)
(pid #f)
(type #f)
(dir #f)
)
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
;; Generate a unique signature for this server
(define (mk-signature)
(message-digest-string (md5-primitive)
(with-output-to-string
(lambda ()
(write (list (current-directory)
(current-process-id)
(argv)))))))
(define (get-client-server-id)
(if *client-server-id* *client-server-id*
(let ((sig (mk-signature))) ;; clients re-use the server:mk-signature logic
(set! *client-server-id* sig)
*client-server-id*)))
;; if srvdat is #f calculate host.pid
(define (get-host.pid srvdat)
(if srvdat
(conc (srv-host srvdat)"."(srv-pid srvdat))
(conc (get-host-name)"."(current-process-id))))
;; nearly every process in Megatest (if write access) starts a server so it
;; can receive messages to exit on request
;; one server per run db file would be ideal.
;; servers have a type, mtserve, dboard, runner, execute
;; mtrah/.servers/<type>/<host>.<pid>/incoming/*.artifact
;; | `attic
;; |
;; (note: not needed? (i)) `outgoing/<clienthost>.<clientpid>/*.artifact
;; | `attic
;; `<tcp|http|nmsg|?>.host:port
;; (i) Not needed if it is expected that all processes run a server
;; on exit processes clean up. only mtserv or dboard clean up abandoned records?
;; server:setup - setup the directory
;; server:launch - start a new mtserve process, possibly
;; using a launcher
;; server:run - run the long running thread that monitors
;; the .server area
;; server:exit - shutdown the server and exit
;; server:handle-request - take incoming request, process it, send response
;; back via best or fastest available transport
;; set up the server area and return a server struct
;; NOTE: This will need to be gated by write-access
;;
(define (server:setup srvtype areapath)
(let* ((srvdat (make-srv
areapath: areapath
host: (get-host-name) ;; likely need to replace with ip address
pid: (current-process-id)
type: srvtype))
(srvdir (conc areapath"/"srvtype"/"(get-host.pid srvdat))))
(srv-dir-set! srvdat srvdir)
(create-directory srvdir #t)
srvdat))
;; maybe check load before calling this?
(define (server:launch areapath)
(let* ((logd (conc areapath"/logs"))
(logf (conc logd"/from-"(get-host.pid #f)".log")))
(if (not (file-exists? logd))(create-directory logd #t))
(setenv "NBFAKE_LOG" logf)
(system (conc "nbfake mtserve -start-dir "areapath))))
;; ;; When using zmq this would send the message back (two step process)
;; ;; with spiffy or rpc this simply returns the return data to be returned
;; ;;
;; (define (server:reply return-addr query-sig success/fail result)
;; (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
;; ;; (send-message pubsock target send-more: #t)
;; ;; (send-message pubsock
|