Megatest

Check-in [9607b06dff]
Login
Overview
Comment:WIP - doesn't compile
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v2.001
Files: files | file ages | folders
SHA1: 9607b06dff6d054e10f654b3663ae26d79a9bc9d
User & Date: matt on 2021-12-18 05:45:07
Other Links: branch diff | manifest | tags
Context
2021-12-18
14:33
wip check-in: c74886dad6 user: matt tags: v2.001
05:45
WIP - doesn't compile check-in: 9607b06dff user: matt tags: v2.001
2021-12-14
20:05
Mostly got unit tests working again. check-in: c7197c92dd user: matt tags: v2.001
Changes

Modified apimod.scm from [90c616c280] to [0baabe14dd].

342
343
344
345
346
347
348

349
350
351
352
353
354
355
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356







+







    ((get-runs-cnt-by-patt)         (apply db:get-runs-cnt-by-patt dbstruct params))
    ((get-all-run-ids)              (db:get-all-run-ids dbstruct))
    ((get-prev-run-ids)             (apply db:get-prev-run-ids dbstruct params))
    ((get-run-ids-matching-target)  (apply db:get-run-ids-matching-target dbstruct params))
    ((get-runs-by-patt)             (apply db:get-runs-by-patt dbstruct params))
    ((get-run-name-from-id)         (apply db:get-run-name-from-id dbstruct params))
    ((get-main-run-stats)           (apply db:get-main-run-stats dbstruct params))
    ((log-to-main)                  (apply debug:print params))
    ((get-var)                      (apply db:get-var dbstruct params))
    ((get-run-stats)                (apply db:get-run-stats dbstruct params))
    ((get-run-times)                (apply db:get-run-times dbstruct params)) 

    ;; STEPS
    ((get-steps-data)               (apply db:get-steps-data dbstruct params))
    ((get-steps-for-test)           (apply db:get-steps-for-test dbstruct params))

Modified debugprint.scm from [4552843dbc] to [b587b5fa22].

1
2
3
4
5
6
7
8
9
10
11
12


13
14

15
16
17
18
19
20
21
22

23
24
25
26
27
28
29
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33












+
+


+








+







(declare (unit debugprint))
(declare (uses mtargs))

(module debugprint
	*
	
;;(import scheme chicken data-structures extras files ports)
(import scheme
	chicken.base
	chicken.string
	chicken.port
	chicken.process-context
	chicken.process-context.posix
	
	(prefix mtargs args:)
	srfi-1
	system-information
	)

;;======================================================================
;; debug stuff
;;======================================================================

(define verbosity (make-parameter '()))
(define *default-log-port*  (current-error-port))
(define debug:print-logger (make-parameter #f)) ;; se to a proc to call on every logging print
	 
(define (debug:setup)
  (let ((debugstr (or (args:get-arg "-debug")
      		      (args:get-arg "-debug-noprop")
      		      (get-environment-variable "MT_DEBUG_MODE"))))
    (verbosity (debug:calc-verbosity debugstr 'q))
    (debug:check-verbosity (verbosity) debugstr)
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
129
130
131

132
133







134
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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152







+
+
+
+







+








+













+


+
+
+
+
+
+
+

	   (list? n))
      (not (null? (lset-intersection! eq? vb n))))
     ((and (number? vb)
	   (list? n))
      (member vb n))
     (else #f))))

(define (debug:handle-remote-logging params)
  (if (debug:print-logger)
      (apply (debug:print-logger) "REMOTE ("(get-host-name)", pid="(current-process-id)") " params)))

(define (debug:print n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  ;; (if *logging*
	      ;; (db:log-event (apply conc params))
	  (apply print params)
	  (debug:handle-remote-logging params)
	  )))) ;; )

(define (debug:print-error n e . params)
  ;; normal print
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "ERROR: " params)
	  (debug:handle-remote-logging (cons "ERROR: " params))
	  )))
  ;; pass important messages to stderr
  (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
      (with-output-to-port (current-error-port)
	(lambda ()
	  (apply print "ERROR: " params)
	  ))))

(define (debug:print-info n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "INFO: (" n ") " params) ;; res)
	  (debug:handle-remote-logging (cons "INFO: " params))
	  ))))

(define (debug:print-warn n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "WARN: (" n ") " params) ;; res)
	  (debug:handle-remote-logging (cons "WARN: " params))
	  ))))
)

Modified rmtmod.scm from [ae314078d9] to [208d4b493b].

131
132
133
134
135
136
137
138
139
140
141
142
143
144


145
146
147

148
149
150
151
152
153

154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174

175
176
177
178
179


180
181
182
183
184
185
186
187
188
189
190
191
192

193
194

195
196

197
198
199
200
201
202
203
204
205
206
207



208
209
210
211
212
213
214
215










216
217
218
219
220
221
222
223
224
225
226











227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248


















249
250


251
252








253
254
255
256
257
258
259





260
261
262
263
264
265

266
267
268
269
270
271
272
273
274
275
276
277
278
279
280

281
282

283
284
285
286
287
288
289
131
132
133
134
135
136
137

138
139
140
141


142
143
144
145

146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173

174
175
176
177


178
179
180
181
182
183
184
185
186
187
188
189
190
191

192
193

194
195

196
197
198
199
200
201
202
203
204
205
206

207
208
209
210
211
212
213




214
215
216
217
218
219
220
221
222
223











224
225
226
227
228
229
230
231
232
233
234






















235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253

254
255
256

257
258
259
260
261
262
263
264
265
266





267
268
269
270
271
272
273
274
275
276

277
278
279
280
281
282
283
284
285
286
287
288
289
290
291

292
293

294
295
296
297
298
299
300
301







-




-
-
+
+


-
+






+




















-
+



-
-
+
+












-
+

-
+

-
+










-
+
+
+




-
-
-
-
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

-
+
+

-
+
+
+
+
+
+
+
+


-
-
-
-
-
+
+
+
+
+





-
+














-
+

-
+







  (status 'starting)
  (trynum 0) ;; count the number of ports we've tried
  ) 

(define (servdat->url sdat)
  (conc (servdat-host sdat)":"(servdat-port sdat)))


;; generate entries for ~/.megatestrc with the following
;;
;;  grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u

(defstruct rmt:remote
  (conns (make-hash-table)) ;; apath/dbname => rmt:conn
(defstruct remotedat
  (conns (make-hash-table)) ;; apath/dbname => conndat
  )

(defstruct rmt:conn
(defstruct conndat
  (apath    #f)
  (dbname   #f)
  (fullname #f)
  (hostport #f)
  (ipaddr   #f)
  (port     #f)
  (socket   #f)
  (srvpkt   #f)
  (srvkey   #f)
  (lastmsg  0)
  (expires  0)
  (inport   #f)
  (outport  #f))

(define *srvpktspec*
  `((server (host    . h)
	    (port    . p)
	    (servkey . k)
	    (pid     . i)
	    (ipaddr  . a)
	    (dbpath  . d))))

;;======================================================================
;;  S U P P O R T   F U N C T I O N S
;;======================================================================

;; replaces *runremote*
(define *rmt:remote* (make-rmt:remote))
(define *remotedat* (make-remotedat))

;; -> http://abc.com:900/<entrypoint>
;;
(define (rmt:conn->uri conn entrypoint)
  (conc "http://"(rmt:conn-ipaddr conn)":"(rmt:conn-port conn)"/"entrypoint))
(define (conndat->uri conn entrypoint)
  (conc "http://"(conndat-ipaddr conn)":"(conndat-port conn)"/"entrypoint))

;; set up the api proc, seems like there should be a better place for this?
(define api-proc (make-parameter conc))
(api-proc api:process-request)

;; do we have a connection to apath dbname and
;; is it not expired? then return it
;;
;; else setup a connection
;;
;; if that fails, return '(#f "some reason") ;; NB// convert to raising an exception
;;
(define (rmt:get-conn remote apath dbname)
(define (rmt:get-conn remdat apath dbname)
  (let* ((fullname (db:dbname->path apath dbname)) ;; we'll switch to full name later
	 (conn     (hash-table-ref/default (rmt:remote-conns remote) dbname #f)))
	 (conn     (hash-table-ref/default (remotedat-conns remdat) dbname #f)))
    (if (and conn
	     (< (current-seconds) (rmt:conn-expires conn)))
	     (< (current-seconds) (conndat-expires conn)))
	conn
	#f)))

(define (rmt:find-main-server apath dbname)
  (let* ((pktsdir     (get-pkts-dir apath))
	 (all-srvpkts (get-all-server-pkts pktsdir *srvpktspec*))
	 ;; (dbpath      (conc apath "/" dbname))
	 (viable-srvs (get-viable-servers all-srvpkts dbname)))
    (get-the-server apath viable-srvs)))

;; looks for a connection to main
;; looks for a connection to main, returns if have and not exired
;; creates new otherwise
;; 
;; connections for other servers happens by requesting from main
;;
;; TODO: This is unnecessarily re-creating the record in the hash table
;;
(define (rmt:open-main-connection remote apath)
  (let* ((dbname         (db:run-id->dbname #f))
	 (the-srv        (rmt:find-main-server apath dbname))
	 (start-main-srv (lambda ()
(define (rmt:open-main-connection remdat apath)
  (let* ((fullpath (db:dbname->path apath "/.db/main.db"))
	 (conn     (hash-table-ref/default remdat fullpath))) ;; TODO - create call for this
    (if (and conn                                             ;; conn is NOT a socket, just saying ...
	     (< (current-seconds) (conndat-expires conn)))
	conn ;; we are current and good to go - we'll deal elsewhere with a server that was killed or died 
	;; Below we will find or create and connect to main
	(let* ((dbname         (db:run-id->dbname #f))
	       (the-srv        (rmt:find-main-server apath dbname))
	       (start-main-srv (lambda () ;; call IF there is no the-srv found
			   ;; srv not ready, delay a little and try again
			   (api:run-server-process apath dbname)
			   (thread-sleep! 4)
			   (rmt:open-main-connection remote apath) ;; TODO: Add limit to number of tries
			   )))
    (if the-srv ;; yes, we have a server, now try connecting to it
	(let* ((srv-addr (server-address the-srv))
	       (ipaddr   (alist-ref 'ipaddr  the-srv))
	       (port     (alist-ref 'port    the-srv))
	       (srvkey   (alist-ref 'servkey the-srv))
	       (fullpath (db:dbname->path apath dbname))
				 (api:run-server-process apath dbname)
				 (thread-sleep! 4)
				 (rmt:open-main-connection remdat apath) ;; TODO: Add limit to number of tries
				 )))
	  (if (not the-srv) ;; have server, try connecting to it
	      (start-main-srv)
	      (let* ((srv-addr (server-address the-srv)) ;; need serv
		     (ipaddr   (alist-ref 'ipaddr  the-srv))
		     (port     (alist-ref 'port    the-srv))
		     (srvkey   (alist-ref 'servkey the-srv))
		     (fullpath (db:dbname->path apath dbname))
	       (srvready (server-ready? ipaddr port srvkey)))
	  (if srvready
	      (begin
		(hash-table-set! (rmt:remote-conns remote)
				 dbname ;; fullpath ;; yes, I'd prefer it to be fullpath - FIXME later
				 (make-rmt:conn
				  apath:   apath
				  dbname:  dbname
				  fullname: fullpath
				  hostport: srv-addr
				  ipaddr: ipaddr
				  port: port
				  srvpkt: the-srv
				  srvkey: srvkey ;; generated by rmt:get-signature on the server side
				  lastmsg: (current-seconds)
				  expires: (+ (current-seconds) 60) ;; this needs to be gathered during the ping
				  ))
		#t)
	      (start-main-srv)))
	(start-main-srv))))

;; NB// remote is a rmt:remote struct
		     (new-the-srv (make-conndat
				   apath:   apath
				   dbname:  dbname
				   fullname: fullpath
				   hostport: srv-addr
				   socket: (open-nn-connection srv-addr)
				   ipaddr: ipaddr
				   port: port
				   srvpkt: the-srv
				   srvkey: srvkey ;; generated by rmt:get-signature on the server side
				   lastmsg: (current-seconds)
				   expires: (+ (current-seconds) 60) ;; this needs to be gathered during the ping
				   )))
		(hash-table-set! (remotedat-conns remdat)
				 fullpath ;; dbname ;; fullpath ;; yes, I'd prefer it to be fullpath - FIXME later
				 new-the-srv)))))))
    
;; NB// remdat is a remotedat struct
;;
(define (rmt:general-open-connection remote apath dbname #!key (num-tries 5))
(define (rmt:general-open-connection remdat apath dbname #!key (num-tries 5))
  (assert (not (equal? dbname ".db/main.db")) "ERROR: general-open-connection should never be called with main as the db")
  (let* ((mdbname (db:run-id->dbname #f))
	 (mconn   (rmt:get-conn remote apath mdbname)))
	 (mconn   (rmt:get-conn remdat apath mdbname)))
    (if (and mconn
	     (not (debug:print-logger)))
	(if (equal? dbname ".db/main.db")
	    (debug:print-info 0 *default-log-port* "Not turning on logging to main, I am main!")
	    (begin
	      (debug:print-info 0 *default-log-port* "Turning on logging to main, look in logs dir for main log.")
	      (debug:print-logger rmt:log-to-main))))
    (cond
     ((or (not mconn) ;; no channel open to main?
	  (< (rmt:conn-expires mconn)(+ (current-seconds) 2))) ;; restablish connection if less than 2 seconds on the lease
      (rmt:open-main-connection remote apath)
      (rmt:general-open-connection remote apath mdbname))
     ((not (rmt:get-conn remote apath dbname))                 ;; no channel open to dbname?     
      (let* ((res (rmt:send-receive-real remote apath mdbname 'get-server `(,apath ,dbname))))
	  (< (conndat-expires mconn)(+ (current-seconds) 2))) ;; restablish connection if less than 2 seconds on the lease
      (rmt:open-main-connection remdat apath)
      (rmt:general-open-connection remdat apath mdbname))
     ((not (rmt:get-conn remdat apath dbname))                 ;; no channel open to dbname?     
      (let* ((res (rmt:send-receive-real remdat apath mdbname 'get-server `(,apath ,dbname))))
	(case res
	  ((server-started)
	   (if (> num-tries 0)
	       (begin
		 (thread-sleep! 2)
		 (rmt:general-open-connection remote apath dbname num-tries: (- num-tries 1)))
		 (rmt:general-open-connection remdat apath dbname num-tries: (- num-tries 1)))
	       (begin
		 (debug:print-error 0 *default-log-port* "Failed to start servers needed or open channel to "apath", "dbname)
		 (exit 1))))
	  (else
	   (if (list? res) ;; server has been registered and the info was returned. pass it on.
	       (begin ;;  ("192.168.0.9" 53817
		      ;;  "5e34239f48e8973b3813221e54701a01" "24310"
		      ;;  "192.168.0.9"
		      ;;  "/home/matt/data/megatest/tests/simplerun"
		 ;;  ".db/1.db")
		 (match
		  res
		  ((host port servkey pid ipaddr apath dbname)
		   (debug:print-info 0 *default-log-port* "got "res)
		   (hash-table-set! (rmt:remote-conns remote)
		   (hash-table-set! (remotedat-conns remdat)
				    dbname
				    (make-rmt:conn
				    (make-conndat
				     apath: apath
				     dbname: dbname
				     hostport: (conc host":"port)
				     ipaddr: ipaddr
				     port: port
				     srvkey: servkey
				     lastmsg: (current-seconds)
304
305
306
307
308
309
310
311

312
313

314
315
316
317
318
319
320
321

322


323
324
325
326
327
328
329
330





331
332
333
334
335
336


337
338
339
340


341
342

343
344
345
346
347
348
349
350
351
352
353
354
355


356
357
358

359
360
361
362
363
364
365
316
317
318
319
320
321
322

323
324

325
326
327
328
329
330
331
332
333
334

335
336
337
338
339





340
341
342
343
344
345
346
347
348


349
350
351
352


353
354
355

356
357
358
359
360
361
362
363
364
365
366
367


368
369
370
371

372
373
374
375
376
377
378
379







-
+

-
+








+
-
+
+



-
-
-
-
-
+
+
+
+
+




-
-
+
+


-
-
+
+

-
+











-
-
+
+


-
+







;; (define *localmode* #t)
(define *localmode* #f)
(define *dbstruct* (make-dbr:dbstruct))

;; Defaults to current area
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f))
  (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote)))
  (if (not *remotedat*)(set! *remotedat* (make-remotedat)))
  (let* ((apath      *toppath*)
	 (conns      *rmt:remote*)
	 (conns      *remotedat*)
	 (dbname     (db:run-id->dbname rid)))
    (if *localmode*
	(let* ((dbdat    (dbr:dbstruct-get-dbdat *dbstruct* dbname))
	       (indat    `((cmd . ,cmd)(params . ,params))))
	  (api:process-request *dbstruct* indat)
	  ;; (api:process-request dbdat indat)
	  )
	(begin
	  (if rid
	  (rmt:general-open-connection conns apath dbname)
	      (rmt:general-open-connection conns apath dbname)
	      (rmt:open-main-connection conns apath))
	  (rmt:send-receive-real conns apath dbname cmd params)))))

#;(define (rmt:send-receive-setup conn)
  (if (not (rmt:conn-inport conn))
      (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn)
				       (rmt:conn-port conn))))
	(rmt:conn-inport-set! conn i)
	(rmt:conn-outport-set! conn o))))
  (if (not (conndat-inport conn))
      (let-values (((i o) (tcp-connect (conndat-ipaddr conn)
				       (conndat-port conn))))
	(conndat-inport-set! conn i)
	(conndat-outport-set! conn o))))
  
;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future
;;
(define (rmt:send-receive-real remote apath dbname cmd params)
  (let* ((conn (rmt:get-conn remote apath dbname)))
(define (rmt:send-receive-real remdat apath dbname cmd params)
  (let* ((conn (rmt:get-conn remdat apath dbname)))
    (assert conn "FATAL: rmt:send-receive-real called without the needed channels opened")
    (let* ((key     #f)
	   (host    (rmt:conn-ipaddr conn))
	   (port    (rmt:conn-port   conn))
	   (host    (conndat-ipaddr conn))
	   (port    (conndat-port   conn))
	   (payload `((cmd    . ,cmd)
		      (key    . ,(rmt:conn-srvkey conn))
		      (key    . ,(conndat-srvkey conn))
		      (params . ,params)))
	   (res      (open-send-receive-nn (conc host":"port)
					   (sexpr->string payload))))
      (string->sexpr res))))

;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future.
;;
;; Purpose - call the main.db server and request a server be started
;; for the given area path and dbname
;;
;; (define (rmt:send-receive-server-start remote apath dbname)
;;   (let* ((conn (rmt:get-conn remote apath dbname)))
;; (define (rmt:send-receive-server-start remdat apath dbname)
;;   (let* ((conn (rmt:get-conn remdat apath dbname)))
;;     (assert conn "FATAL: Unable to connect to db "apath"/"dbname)
;;     #;(let* ((res      (with-input-from-request
;; 		      (rmt:conn->uri conn "api") 
;; 		      (conndat->uri conn "api") 
;; 		      `((params . (,apath ,dbname)))
;; 		      read-string)))
;;       (string->sexpr res))))

(define (rmt:print-db-stats)
  (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
    (debug:print 18 *default-log-port* "DB Stats, "(seconds->year-week/day-time (current-seconds))"\n=====================")
411
412
413
414
415
416
417
418

419
420
421
422
423
424
425
425
426
427
428
429
430
431

432
433
434
435
436
437
438
439







-
+







(define (rmt:kill-server run-id)
  (rmt:send-receive 'kill-server run-id (list run-id)))

(define (rmt:start-server run-id)
  (rmt:send-receive 'start-server 0 (list run-id)))

(define (rmt:get-server-info apath dbname)
  (rmt:send-receive 'get-server-info 0 (list 0 apath dbname)))
  (rmt:send-receive 'get-server-info #f (list #f apath dbname)))

;;======================================================================
;;  M I S C
;;======================================================================

(define (rmt:login run-id)
  (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-signature*)))
766
767
768
769
770
771
772



773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796







+
+
+







  ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
  (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))
  ) ;; )

(define (rmt:get-main-run-stats run-id)
  (rmt:send-receive 'get-main-run-stats #f (list run-id)))

(define (rmt:log-to-main . params)
  (rmt:send-receive 'log-to-main #f (cons #f params)))

(define (rmt:get-var run-id varname)
  (rmt:send-receive 'get-var run-id (list run-id varname)))

(define (rmt:del-var run-id varname)
  (rmt:send-receive 'del-var run-id (list run-id varname)))

(define (rmt:set-var run-id varname value)
1512
1513
1514
1515
1516
1517
1518
1519

1520
1521
1522
1523
1524
1525
1526
1529
1530
1531
1532
1533
1534
1535

1536
1537
1538
1539
1540
1541
1542
1543







-
+







				     (lambda (dbh dbfile)
				       (db:release-lock dbh dbfile))))
		  (let* ((sdat *server-info*) ;; we have a run-id server
			 (host (servdat-host sdat))
			 (port (servdat-port sdat))
			 (uuid (servdat-uuid sdat)))
		    (if (not (string-match ".db/main.db" (args:get-arg "-db")))
			(let* ((res (rmt:deregister-server *rmt:remote* ;; TODO/BUG: why is this requiring *rmt:remote*?
			(let* ((res (rmt:deregister-server *remotedat* ;; TODO/BUG: why is this requiring *remotedat*?
							   *toppath*
							   (servdat-host *server-info*)   ;; iface
							   (servdat-port *server-info*)
							   (servdat-uuid *server-info*)
							   (current-process-id)
							   )))
			  (debug:print-info 0 *default-log-port* "deregistered-server, res="res)))
1587
1588
1589
1590
1591
1592
1593


1594
1595





1596
1597
1598
1599
1600
1601
1602
1604
1605
1606
1607
1608
1609
1610
1611
1612


1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624







+
+
-
-
+
+
+
+
+







  (args:get-arg "-server"))

;; called in megatest.scm, host-port is string hostname:port
;;
;; NOTE: This is NOT called directly from clients as not all transports support a client running
;;       in the same process as the server. 
;;
;; conn is a conndat record
;;
(define (server:ping host port server-id #!key (do-exit #f))
  (server-ready? host port server-id))
(define (server:ping conn #!key (do-exit #f))
  (let* ((req (conndat-socket conn))
	 (srvkey (conndat-srvkey conn))
	 (msg (sexpr->string '(ping ,srvkey))))
    (send-receive-nn req msg))) ;; (server-ready? host port server-id))

;;======================================================================
;; http-transportmod.scm contents moved here
;;======================================================================

(define (http-transport:make-server-url hostport)
  (if (not hostport)
1730
1731
1732
1733
1734
1735
1736
1737

1738
1739
1740
1741
1742
1743
1744

1745
1746
1747
1748
1749
1750
1751
1752
1753
1754

1755
1756
1757
1758
1759
1760

1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774

1775
1776
1777
1778
1779
1780
1781


1782
1783
1784
1785
1786
1787
1788
1752
1753
1754
1755
1756
1757
1758

1759
1760
1761
1762
1763
1764
1765

1766
1767
1768
1769
1770
1771
1772
1773
1774
1775

1776
1777
1778
1779
1780
1781

1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795

1796
1797
1798
1799
1800
1801


1802
1803
1804
1805
1806
1807
1808
1809
1810







-
+






-
+









-
+





-
+













-
+





-
-
+
+







;; S E R V E R   U T I L I T I E S 
;;======================================================================

;;======================================================================
;; C L I E N T S
;;======================================================================

(define (http-transport:get-time-to-cleanup)
(define (rmt:get-time-to-cleanup)
  (let ((res #f))
    (mutex-lock! *http-mutex*)
    (set! res (> (current-seconds) *http-connections-next-cleanup*))
    (mutex-unlock! *http-mutex*)
    res))

(define (http-transport:inc-requests-count)
(define (rmt:inc-requests-count)
  (mutex-lock! *http-mutex*)
  (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))
  ;; Use this opportunity to slow things down iff there are too many requests in flight
  (if (> *http-requests-in-progress* 5)
      (begin
	(debug:print-info 0 *default-log-port* "Whoa there buddy, ease up...")
	(thread-sleep! 1)))
  (mutex-unlock! *http-mutex*))

(define (http-transport:dec-requests-count proc) 
(define (rmt:dec-requests-count proc) 
  (mutex-lock! *http-mutex*)
  (proc)
  (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
  (mutex-unlock! *http-mutex*))

(define (http-transport:dec-requests-count-and-close-all-connections)
(define (rmt:dec-requests-count-and-close-all-connections)
  (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
  (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds
    (if (> *http-requests-in-progress* 0)
	(if (> etime (current-seconds))
	    (begin
	      (thread-sleep! 0.052)
	      (loop etime))
	    (debug:print-error 0 *default-log-port*
			       "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections"))
	#;(close-idle-connections!)))
  (set! *http-connections-next-cleanup* (+ (current-seconds) 10))
  (mutex-unlock! *http-mutex*))

(define (http-transport:inc-requests-and-prep-to-close-all-connections)
(define (rmt:inc-requests-and-prep-to-close-all-connections)
  (mutex-lock! *http-mutex*)
  (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)))

;; careful closing of connections stored in *runremote*
;;
(define (http-transport:close-connections #!key (area-dat #f))
  (debug:print-info 0 *default-log-port* "http-transport:close-connections doesn't do anything now!"))
(define (rmt:close-connections #!key (area-dat #f))
  (debug:print-info 0 *default-log-port* "rmt:close-connections doesn't do anything now!"))
;;   (let* ((runremote  (or area-dat *runremote*))
;; 	 (server-dat (if runremote
;;                          (remote-conndat runremote)
;;                          #f))) ;; (hash-table-ref/default *runremote* run-id #f)))
;;     (if (vector? server-dat)
;; 	(let ((api-dat (http-transport:server-dat-get-api-uri server-dat)))
;; 	  (handle-exceptions
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094



2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106



2107
2108
2109
2110
2111
2112
2113



2114
2115
2116
2117
2118
2119
2120
2121
2122
2123

2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134

2135
2136
2137
2138
2139
2140

2141
2142
2143
2144
2145
2146
2147
2107
2108
2109
2110
2111
2112
2113



2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125



2126
2127
2128
2129
2130
2131
2132



2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144

2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155

2156
2157
2158
2159
2160
2161

2162
2163
2164
2165
2166
2167
2168
2169







-
-
-
+
+
+









-
-
-
+
+
+




-
-
-
+
+
+









-
+










-
+





-
+







		  (begin
		    (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")
		    (exit))
		  (loop start-time
			(equal? sdat last-sdat)
			sdat))))))))

(define (rmt:register-server remote apath iface port server-key dbname)
  (rmt:open-main-connection remote apath) ;; we need a channel to main.db
  (rmt:send-receive-real remote apath      ;; params: host port servkey pid ipaddr dbpath
(define (rmt:register-server remdat apath iface port server-key dbname)
  (rmt:open-main-connection remdat apath) ;; we need a channel to main.db
  (rmt:send-receive-real remdat apath      ;; params: host port servkey pid ipaddr dbpath
			 (db:run-id->dbname #f)
			 'register-server `(,iface
					    ,port
					    ,server-key
					    ,(current-process-id)
					    ,iface
					    ,apath
					    ,dbname)))

(define (rmt:get-count-servers remote apath)
  (rmt:open-main-connection remote apath) ;; we need a channel to main.db
  (rmt:send-receive-real remote apath      ;; params: host port servkey pid ipaddr dbpath
(define (rmt:get-count-servers remdat apath)
  (rmt:open-main-connection remdat apath) ;; we need a channel to main.db
  (rmt:send-receive-real remdat apath      ;; params: host port servkey pid ipaddr dbpath
			 (db:run-id->dbname #f)
			 'get-count-servers `(,apath
					      )))

(define (rmt:deregister-server remote apath iface port server-key dbname)
  (rmt:open-main-connection remote apath) ;; we need a channel to main.db
  (rmt:send-receive-real remote apath      ;; params: host port servkey pid ipaddr dbpath
(define (rmt:deregister-server remdat apath iface port server-key dbname)
  (rmt:open-main-connection remdat apath) ;; we need a channel to main.db
  (rmt:send-receive-real remdat apath      ;; params: host port servkey pid ipaddr dbpath
                         (db:run-id->dbname #f)
                         'deregister-server `(,iface
                                              ,port
                                              ,server-key
                                              ,(current-process-id)
                                              ,iface
                                              ,apath
                                              ,dbname)))

(define (http-transport:wait-for-stable-interface #!optional (num-tries-allowed 100))
(define (rmt:wait-for-stable-interface #!optional (num-tries-allowed 100))
  ;; wait until *server-info* stops changing
  (let* ((stime (current-seconds)))
    (let loop ((last-host  #f)
	       (last-port  #f)
	       (tries 0))
      (let* ((curr-host (and *server-info* (servdat-host *server-info*)))
	     (curr-port (and *server-info* (servdat-port *server-info*))))
	;; first we verify port and interface, update *server-info* in need be.
	(cond
	 ((> tries num-tries-allowed)
	  (debug:print 0 *default-log-port* "http-transport:keep-running, giving up after trying for several minutes.")
	  (debug:print 0 *default-log-port* "rmt:keep-running, giving up after trying for several minutes.")
	  (exit 1))
	 ((not *server-info*)
	  (thread-sleep! 0.25)
	  (loop curr-host curr-port (+ tries 1)))
	 ((or (not last-host)(not last-port))
	  (debug:print 0 *default-log-port* "http-transport:keep-running, still no interface, tries="tries)
	  (debug:print 0 *default-log-port* "rmt:keep-running, still no interface, tries="tries)
	  (thread-sleep! 0.25)
	  (loop curr-host curr-port (+ tries 1)))
	 ((or (not (equal? last-host curr-host))
	      (not (equal? last-port curr-port)))
	  (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info")
	  (thread-sleep! 0.25)
	  (loop curr-host curr-port (+ tries 1)))
2155
2156
2157
2158
2159
2160
2161
2162

2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180


2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201

2202
2203
2204
2205
2206
2207
2208
2177
2178
2179
2180
2181
2182
2183

2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200


2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222

2223
2224
2225
2226
2227
2228
2229
2230







-
+
















-
-
+
+




















-
+







		       "SERVER STARTED: " curr-host
		       ":" curr-port
		       " AT " (current-seconds) " server signature: " *my-signature*
		       " with "(servdat-trynum *server-info*)" port changes")
	  (flush-output *default-log-port*)
	  #t))))))

;; run http-transport:keep-running in a parallel thread to monitor that the db is being 
;; run rmt:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (rmt:keep-running dbname) 
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive
  (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server")

  (let* ((server-start-time (current-seconds))
	 (pkts-dir          (get-pkts-dir))
	 (server-key        (rmt:get-signature)) ;; This servers key
	 (is-main           (equal? (args:get-arg "-db") ".db/main.db"))
	 (last-access       0)
	 (server-timeout    (server:expiration-timeout)))
    ;; main and run db servers have both got wait logic (could/should merge it)
    (if is-main
	(http-transport:wait-for-server pkts-dir dbname server-key)
	(http-transport:wait-for-stable-interface))
	(rmt:wait-for-server pkts-dir dbname server-key)
	(rmt:wait-for-stable-interface))
    ;; this is our forever loop
    (let* ((iface             (servdat-host *server-info*))
	   (port              (servdat-port *server-info*)))
      (let loop ((count          0)
		 (bad-sync-count 0)
		 (start-time     (current-milliseconds)))
	
	(if (and (not is-main)
		 (common:low-noise-print 60 "servdat-status"))
	    (debug:print-info 0 *default-log-port* "servdat-status is " (servdat-status *server-info*)))

	;; set up the database handle
	(mutex-lock! *heartbeat-mutex*)
	(if (not *dbstruct-db*) ;; no db opened yet, open the db and register with main if appropriate
	    (let ((watchdog (bdat-watchdog *bdat*)))		 
	      (debug:print 0 *default-log-port* "SERVER: dbprep")
	      (db:setup dbname) ;; sets *dbstruct-db* as side effect
	      (servdat-status-set! *server-info* 'db-opened)
	      ;; IFF I'm not main, call into main and register self
	      (if (not is-main)
		  (let ((res (rmt:register-server *rmt:remote*
		  (let ((res (rmt:register-server *remotedat*
						  *toppath* iface port
						  server-key dbname)))
		    (if res ;; we are the server
			(servdat-status-set! *server-info* 'have-interface-and-db)
			(let* ((serv-info (rmt:get-server-info *toppath* dbname)))
			  (match serv-info
			    ((host port servkey pid ipaddr apath dbpath)
2259
2260
2261
2262
2263
2264
2265
2266

2267
2268
2269
2270
2271
2272
2273
2281
2282
2283
2284
2285
2286
2287

2288
2289
2290
2291
2292
2293
2294
2295







-
+







	      (db:print-current-query-stats)))
	(let* ((hrs-since-start  (/ (- (current-seconds) server-start-time) 3600)))
	  (cond
	   ((and *server-run*
		 (> (+ last-access server-timeout)
		    (current-seconds))
		 (if is-main
		     (> (rmt:get-count-servers *rmt:remote* *toppath*) 1)
		     (> (rmt:get-count-servers *remotedat* *toppath*) 1)
		     #t))
	    (if (common:low-noise-print 120 "server continuing")
		(debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)))
	    (loop 0 bad-sync-count (current-milliseconds)))
	   (else
	    (set! *unclean-shutdown* #f)
	    (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
2353
2354
2355
2356
2357
2358
2359
2360

2361
2362
2363
2364

2365
2366
2367
2368
2369




















2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383














2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401


















2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428



























2429
2430
2431
2432
2433
2434
2435
2375
2376
2377
2378
2379
2380
2381

2382


2383

2384




2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405














2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419


















2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437



























2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471







-
+
-
-

-
+
-
-
-
-

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
       (print "ERROR: Failed to start server \"" emsg "\"")
       (exit 1))
      
     (nng-dial #;nn-bind rep (conc "tcp://*:" portnum)))
    rep))

;; open connection to server, send message, close connection
(define (open-nn-connection host-port)
;;
(define (open-send-close-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds
  (let ((req  (make-req-socket 'req))
        (uri  (conc "tcp://" host-port))
        (uri  (conc "tcp://" host-port)))
        (res  #f)
        ;; (contacts (alist-ref 'contact attrib))
        ;; (mode (alist-ref 'mode attrib))
	)
    (socket-set! req 'nng/recvtimeo 2000)
    (nng-dial req uri)
    req))

(define (send-receive-nn req msg)
  (nng-send req msg)
  (nng-recv req))

(define (close-nn-connection req)
  (nng-close! req))
  
;; ;; open connection to server, send message, close connection
;; ;;
;; (define (open-send-close-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds
;;   (let ((req  (make-req-socket 'req))
;;         (uri  (conc "tcp://" host-port))
;;         (res  #f)
;;         ;; (contacts (alist-ref 'contact attrib))
;;         ;; (mode (alist-ref 'mode attrib))
;; 	)
;;     (socket-set! req 'nng/recvtimeo 2000)
    (handle-exceptions
     exn
     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
       ;; Send notification       
       (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" )
       #f)
     (nng-dial req uri)
     ;; (print "Connected to the server " )
     (nng-send req msg)
     ;; (print "Request Sent")  
     (let* ((th1  (make-thread (lambda ()
                                 (let ((resp (nng-recv req)))
                                   (nng-close! req)
                                   (set! res (if (equal? resp "ok")
;;     (handle-exceptions
;;      exn
;;      (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
;;        ;; Send notification       
;;        (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" )
;;        #f)
;;      (nng-dial req uri)
;;      ;; (print "Connected to the server " )
;;      (nng-send req msg)
;;      ;; (print "Request Sent")  
;;      (let* ((th1  (make-thread (lambda ()
;;                                  (let ((resp (nng-recv req)))
;;                                    (nng-close! req)
;;                                    (set! res (if (equal? resp "ok")
                                                 #t
                                                 #f))))
                               "recv thread"))
            (th2 (make-thread (lambda ()
                                (thread-sleep! timeout)
                                (thread-terminate! th1))
			      "timer thread")))
       (thread-start! th1)
       (thread-start! th2)
       (thread-join! th1)
       res))))

(define (open-send-receive-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds
  (let ((req  (make-req-socket))
        (uri  (conc "tcp://" host-port))
        (res  #f)
	;;        (contacts (alist-ref 'contact attrib))
        ;; (mode (alist-ref 'mode attrib))
;;                                                  #t
;;                                                  #f))))
;;                                "recv thread"))
;;             (th2 (make-thread (lambda ()
;;                                 (thread-sleep! timeout)
;;                                 (thread-terminate! th1))
;; 			      "timer thread")))
;;        (thread-start! th1)
;;        (thread-start! th2)
;;        (thread-join! th1)
;;        res))))
;; 
;; (define (open-send-receive-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds
;;   (let ((req  (make-req-socket))
;;         (uri  (conc "tcp://" host-port))
;;         (res  #f)
;; 	;;        (contacts (alist-ref 'contact attrib))
;;         ;; (mode (alist-ref 'mode attrib))
	) 
    (handle-exceptions
     exn
     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
       ;; Send notification      
       (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\", exn=" exn)
       #f)
     (nng-dial req uri)
     ;; (print "Connected to the server " )
     (nng-send req msg)
     ;; (print "Request Sent")  
     ;; receive code here
     ;;(print (nn-recv req))
     (let* ((th1  (make-thread (lambda ()
                                 (let ((resp (nng-recv req)))
                                   (nng-close! req)
                                   (print resp)
                                   (set! res resp)))
                               "recv thread"))
            (th2 (make-thread (lambda ()
                                (thread-sleep! timeout)
                                (thread-terminate! th1))
                             "timer thread")))
       (thread-start! th1)
       (thread-start! th2)
       (thread-join! th1)
       res))))
;; 	) 
;;     (handle-exceptions
;;      exn
;;      (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
;;        ;; Send notification      
;;        (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\", exn=" exn)
;;        #f)
;;      (nng-dial req uri)
;;      ;; (print "Connected to the server " )
;;      (nng-send req msg)
;;      ;; (print "Request Sent")  
;;      ;; receive code here
;;      ;;(print (nn-recv req))
;;      (let* ((th1  (make-thread (lambda ()
;;                                  (let ((resp (nng-recv req)))
;;                                    (nng-close! req)
;;                                    ;; (print resp)
;;                                    (set! res resp)))
;;                                "recv thread"))
;;             (th2 (make-thread (lambda ()
;;                                 (thread-sleep! timeout)
;;                                 (thread-terminate! th1))
;;                              "timer thread")))
;;        (thread-start! th1)
;;        (thread-start! th2)
;;        (thread-join! th1)
;;        res))))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

;; run ping in separate process, safest way in some cases
;;
2509
2510
2511
2512
2513
2514
2515
2516

2517
2518
2519

2520
2521
2522

2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533

2534
2535
2536
2537

2538
2539
2540
2541

2542
2543
2545
2546
2547
2548
2549
2550
2551

2552
2553
2554

2555
2556
2557

2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568

2569
2570
2571
2572

2573
2574
2575
2576

2577
2578
2579







-
+


-
+


-
+










-
+



-
+



-
+


;; 						  headers: '((content-type text/plain))))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "loop-test"))
;; 				   (send-response body: (alist-ref 'data ($))
;; 						  headers: '((content-type text/plain))))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ ""))
;; 				   (send-response body: ((http-get-function 'http-transport:main-page))))
;; 				   (send-response body: ((http-get-function 'rmt:main-page))))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "json_api"))
;; 				   (send-response body: ((http-get-function 'http-transport:main-page))))
;; 				   (send-response body: ((http-get-function 'rmt:main-page))))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "runs"))
;; 				   (send-response body: ((http-get-function 'http-transport:main-page))))
;; 				   (send-response body: ((http-get-function 'rmt:main-page))))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ any))
;; 				   (send-response body: "hey there!\n"
;; 						  headers: '((content-type text/plain))))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "hey"))
;; 				   (send-response body: "hey there!\n" 
;; 						  headers: '((content-type text/plain))))
;;                               ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "jquery3.1.0.js"))
;; 				   (send-response body: ((http-get-function 'http-transport:show-jquery))
;; 				   (send-response body: ((http-get-function 'rmt:show-jquery))
;; 						  headers: '((content-type application/javascript))))
;;                               ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "test_log"))
;; 				   (send-response body: ((http-get-function 'http-transport:html-test-log) $) 
;; 				   (send-response body: ((http-get-function 'rmt:html-test-log) $) 
;; 						  headers: '((content-type text/HTML))))    
;;                               ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "dashboard"))
;; 				   (send-response body: ((http-get-function 'http-transport:html-dboard) $)
;; 				   (send-response body: ((http-get-function 'rmt:html-dboard) $)
;; 						  headers: '((content-type text/HTML)))) 
;; 				  (else (continue))))))))

Modified tests/unittests/basicserver.scm from [928bc7546a] to [938c89c684].

19
20
21
22
23
24
25
26

27
28
29
30
31
32
33
19
20
21
22
23
24
25

26
27
28
29
30
31
32
33







-
+







;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;; Run like this:
;;
;;  ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)

(import rmtmod trace http-client apimod dbmod
	launchmod)
	launchmod srfi-69)

(trace-call-sites #t)
(trace
 ;; db:get-dbdat
 ;; rmt:find-main-server
;;  rmt:send-receive-real
;;  rmt:send-receive