Megatest

Check-in [194a7192cf]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Server side coded up and compiles. Not actually tested.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.80-reshape
Files: files | file ages | folders
SHA1: 194a7192cff1e38c7e54654af44a72b9d5a1b26d
User & Date: matt on 2023-01-29 19:13:56
Other Links: branch diff | manifest | tags
Context
2023-01-29
20:04
wip check-in: ce20e5667d user: matt tags: v1.80-reshape
19:13
Server side coded up and compiles. Not actually tested. check-in: 194a7192cf user: matt tags: v1.80-reshape
2023-01-27
18:32
Merged from v1.80 check-in: 3d8270b891 user: matt tags: v1.80-reshape
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified Makefile from [2713f77f5a] to [0820a667ed].

︙︙
34
35
36
37
38
39
40
41
42
43

44
45
46
47
48
49
50

MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
            configfmod.scm servermod.scm clientmod.scm rmtmod.scm        \
            artifacts.scm 

all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut

# dbmod.import.o is just a hack here
mofiles/dbfile.o     : mofiles/debugprint.o mofiles/commonmod.o dbmod.import.o
db.o : dbmod.import.o
mofiles/debugprint.o : mofiles/mtargs.o


# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm	\
#             mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm	\
#             rmtmod.scm apimod.scm

GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\








|


>








34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51

MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
            configfmod.scm servermod.scm clientmod.scm rmtmod.scm        \
            artifacts.scm 

all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut

# dbmod.import.o is just a hack here
mofiles/dbfile.o     : mofiles/debugprint.o mofiles/commonmod.o # dbmod.import.o
db.o : dbmod.import.o
mofiles/debugprint.o : mofiles/mtargs.o
mofiles/servermod.o  : mofiles/artifacts.o

# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm	\
#             mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm	\
#             rmtmod.scm apimod.scm

GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\
︙︙
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398

install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
          $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
          $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \
	  $(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
          $(PREFIX)/bin/mt-old-to-new.sh $(PREFIX)/bin/mt-new-to-old.sh \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \
	  $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \
          $(PREFIX)/share/js/jquery-3.1.0.slim.min.js \
          $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so \
          $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 \
          $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0
#         $(PREFIX)/bin/.$(ARCHSTR)/ndboard

# $(PREFIX)/bin/newdashboard

$(PREFIX)/bin/.$(ARCHSTR) : 
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib

test: tests/tests.scm
	cd tests;csi -I .. -b -n tests.scm








|






|








378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399

install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
          $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
          $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \
	  $(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
          $(PREFIX)/bin/mt-old-to-new.sh $(PREFIX)/bin/mt-new-to-old.sh \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \
	  $(PREFIX)/share/db/mt-pg.sql \
          $(PREFIX)/share/js/jquery-3.1.0.slim.min.js \
          $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so \
          $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 \
          $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0
#         $(PREFIX)/bin/.$(ARCHSTR)/ndboard

# $(PREFIX)/bin/newdashboard $(PREFIX)/bin/tcmt 

$(PREFIX)/bin/.$(ARCHSTR) : 
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib

test: tests/tests.scm
	cd tests;csi -I .. -b -n tests.scm
︙︙

Modified artifacts/artifacts.scm from [c7f5c74202] to [683eda7f6b].

︙︙
94
95
96
97
98
99
100


101
102
103
104
105
106
107

;;    (dartifact->alist
;;         (car (get-dartifacts db #f 0 #f))
;;        '((foods (fruit . f)
;;                 (meat . m)))))
;; => "beef"
;;



(module artifacts
(
;; cards, util and misc
;; sort-cards
;; calc-sha1
;;
;; low-level constructor procs, exposed only for development/testing, will be removed








>
>








94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109

;;    (dartifact->alist
;;         (car (get-dartifacts db #f 0 #f))
;;        '((foods (fruit . f)
;;                 (meat . m)))))
;; => "beef"
;;

;; NOTE: We call artifacts "arfs"

(module artifacts
(
;; cards, util and misc
;; sort-cards
;; calc-sha1
;;
;; low-level constructor procs, exposed only for development/testing, will be removed
︙︙
137
138
139
140
141
142
143

144
145
146
147
148
149
150

dartifacts->alists ;; apply dartifact->alist to a list of alists using a artifact-spec
alist->artifact    ;; returns two values uuid, artifact
get-value     ;; looks up a value given a key in a dartifact
flatten-all   ;; merge the list of values from a query which includes a artifact into a flat alist <== really useful!
check-artifact

;; artifact alists

write-alist->artifact
read-artifact->alist

;; archive database
;; archive-open-db
;; write-archive-artifacts
;; archive-artifacts








>








139
140
141
142
143
144
145
146
147
148
149
150
151
152
153

dartifacts->alists ;; apply dartifact->alist to a list of alists using a artifact-spec
alist->artifact    ;; returns two values uuid, artifact
get-value     ;; looks up a value given a key in a dartifact
flatten-all   ;; merge the list of values from a query which includes a artifact into a flat alist <== really useful!
check-artifact

;; artifact alists
get-artifact-fname
write-alist->artifact
read-artifact->alist

;; archive database
;; archive-open-db
;; write-archive-artifacts
;; archive-artifacts
︙︙
1087
1088
1089
1090
1091
1092
1093



1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105




;;======================================================================
;; Read/write packets to files (convience functions)
;;======================================================================




;; write alist to a artifact file
;;
(define (write-alist->artifact targdir dat #!key (artifactspec '())(ptype #f))
  (let-values (((uuid artifact)(alist->artifact dat artifactspec ptype: ptype)))
    (with-output-to-file (conc targdir "/" uuid ".artifact")
      (lambda ()
	(print artifact)))
    uuid)) ;; return the uuid

;; read artifact into alist
;;
(define (read-artifact->alist artifact-file #!key (artifactspec #f))








>
>
>




|








1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111




;;======================================================================
;; Read/write packets to files (convience functions)
;;======================================================================

(define (get-artifact-fname targdir uuid)
  (conc targdir "/" uuid ".artifact"))

;; write alist to a artifact file
;;
(define (write-alist->artifact targdir dat #!key (artifactspec '())(ptype #f))
  (let-values (((uuid artifact)(alist->artifact dat artifactspec ptype: ptype)))
    (with-output-to-file (get-artifact-fname targdir uuid)
      (lambda ()
	(print artifact)))
    uuid)) ;; return the uuid

;; read artifact into alist
;;
(define (read-artifact->alist artifact-file #!key (artifactspec #f))
︙︙

Modified megatest.scm from [71251d311f] to [d11cee8fe2].

︙︙
56
57
58
59
60
61
62
63

64
65
66
67
68
69
70

;; (declare (uses mtargs.import))

;; (declare (uses ftail))
;; (import ftail)

(import dbmod
	commonmod
	dbfile)


(define *db* #f) ;; this is only for the repl, do not use in general!!!!

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")








|
>








56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71

;; (declare (uses mtargs.import))

;; (declare (uses ftail))
;; (import ftail)

(import dbmod
	commonmod
	dbfile
	servermod)

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
︙︙
920
921
922
923
924
925
926
927















928
929

930
931
932
933
934
935
936

;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;   we start the server if not running else start the client thread
;;======================================================================

;; Server? Start up here.
;;
(if (args:get-arg "-server")
    (let ((tl        (launch:setup)))















      ;; (server:launch 0 'http)
      (http-transport:launch)

      (set! *didsomething* #t)))

;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;; a specific Megatest area. Detail are being hashed out and this may change.
;;
(if (args:get-arg "-adjutant")
    (begin








|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
>








921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953

;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;   we start the server if not running else start the client thread
;;======================================================================

;; Server? Start up here.
;;
(if (args:get-arg "-server")
    (let* ((tl        (launch:setup))
	   (srvdat    (server:setup tl))
	   (handler   (lambda (dbstruct cmd params)
			(api:execute-requests dbstruct (if (string? cmd)
							   (string->symbol cmd)
							   cmd)
					      (db:string->obj params)))))
      (server:set-handler srvdat handler)
      (srv-obj-to-str-set! srvdat db:obj->string)
      (srv-str-to-obj-set! srvdat db:string->obj)
      (srv-dbstruct-set! srvdat (db:setup #t))
      (thread-join!
       (thread-start! (make-thread
		       (lambda ()
			 (server:run srvdat)))))
      
      ;; (server:launch 0 'http)
      ;; (http-transport:launch)  ;; NOTE: Need to replace this call
      
      (set! *didsomething* #t)))

;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;; a specific Megatest area. Detail are being hashed out and this may change.
;;
(if (args:get-arg "-adjutant")
    (begin
︙︙

Modified servermod.scm from [d16f0054ce] to [79dfcb62eb]. 

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

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
129
130
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
302
303
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
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535

;; Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     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 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"/.server/"srvtype"/"(get-host.pid srvdat))))
    (srv-dir-set! srvdat srvdir)

    (create-directory srvdir #t)
    (for-each (lambda (d)
		(create-directory (conc srvdir"/"d)))
	      '("incoming" "responses"))
    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 
;;   (case (server:get-transport)
;;     ((rpc)  (db:obj->string (vector success/fail query-sig result)))
;;     ((http) (db:obj->string (vector success/fail query-sig result)))
;;     ((fs)   result)
;;     (else 
;;      (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
;;      result)))
;; 
;; ;; Given an area path,  start a server process    ### NOTE ### > file 2>&1 
;; ;; if the target-host is set 
;; ;; try running on that host
;; ;;   incidental: rotate logs in logs/ dir.
;; ;;
;; (define  (server:run areapath) ;; areapath is *toppath* for a given testsuite area
;;   (let* ((testsuite   (common:get-testsuite-name))
;; 	 (logfile     (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log"))
;; 	 (profile-mode (or (configf:lookup *configdat* "misc" "profilesw")
;; 			   ""))
;; 	 (cmdln (conc (common:get-megatest-exe)
;; 		      " -server - ";; (or target-host "-")
;; 		      (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
;; 			  " -daemonize "
;; 			  "")
;; 		      ;; " -log " logfile
;; 		      " -m testsuite:" testsuite
;; 		      " " profile-mode
;; 		      )) ;; (conc " >> " logfile " 2>&1 &")))))
;; 	 (log-rotate  (make-thread common:rotate-logs  "server run, rotate logs thread")) ;; why are we rotating logs here? This is a sensitive location with a lot going on!?
;;          (load-limit  (configf:lookup-number *configdat* "jobtools" "max-server-start-load" default: 3.0)))
;;     ;; we want the remote server to start in *toppath* so push there
;;     (push-directory areapath)
;;     (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
;;     (thread-start! log-rotate)
;;     
;;     ;; host.domain.tld match host?
;;     ;; (if (and target-host 
;;     ;; 	     ;; look at target host, is it host.domain.tld or ip address and does it 
;;     ;; 	     ;; match current ip or hostname
;;     ;; 	     (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
;;     ;; 	     (not (equal? curr-ip target-host)))
;;     ;; 	(begin
;;     ;; 	  (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
;;     ;; 	  (setenv "TARGETHOST" target-host)))
;;     ;;   
;;     (setenv "TARGETHOST_LOGF" logfile)
;;     (thread-sleep! (/ (random 3000) 1000)) ;; add a random initial delay. It seems pretty common that many running tests request a server at the same time
;;     (debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time))
;;     (system (conc "nbfake " cmdln))
;;     (unsetenv "TARGETHOST_LOGF")
;;     ;; (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
;;     (thread-join! log-rotate)
;;     (pop-directory)))
;; 
;; ;; given a path to a server log return: host port startseconds server-id
;; ;; any changes to number of elements returned by this fuction will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which use match let 
;; ;; example of what it's looking for in the log file:
;; ;;     SERVER STARTED: 10.38.175.67:50216 AT 1616502350.0 server-id: 4907e90fc55c7a09694e3f658c639cf4 
;; 
;; (define (server:logf-get-start-info logf)
;;   (let ((server-rx    (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+) server-id: (\\S+) pid: (\\d+)")) ;; SERVER STARTED: host:port AT timesecs server id
;;         (dbprep-rx    (regexp "^SERVER: dbprep"))
;;         (dbprep-found 0)
;; 	(bad-dat      (list #f #f #f #f #f)))
;;     (handle-exceptions
;;      exn
;;      (begin
;;        ;; WARNING: this is potentially dangerous to blanket ignore the errors
;;        (if (file-exists? logf)
;; 	   (debug:print-info 2 *default-log-port* "Unable to get server info from "logf", exn=" exn))
;;        bad-dat) ;; no idea what went wrong, call it a bad server
;;      (with-input-from-file
;; 	 logf
;;        (lambda ()
;; 	 (let loop ((inl  (read-line))
;; 		    (lnum 0))
;; 	   (if (not (eof-object? inl))
;; 	       (let ((mlst (string-match server-rx inl))
;; 		     (dbprep (string-match dbprep-rx inl)))
;; 		 (if dbprep (set! dbprep-found 1))
;; 		 (if (not mlst)
;; 		     (if (< lnum 500) ;; give up if more than 500 lines of server log read
;; 			 (loop (read-line)(+ lnum 1))
;; 			 (begin 
;;                            (debug:print-info 0 *default-log-port* "Unable to get server info from first 500 lines of " logf )
;;                            bad-dat))
;; 		     (match mlst
;; 			    ((_ host port start server-id pid)
;; 			     (list host
;; 				   (string->number port)
;; 				   (string->number start)
;; 				   server-id
;; 				   (string->number pid)))
;; 			    (else
;; 			     (debug:print 0 *current-log-port* "ERROR: did not recognise SERVER line info "mlst)
;; 			     bad-dat))))
;; 	       (begin 
;; 		 (if dbprep-found
;; 		     (begin
;; 		       (debug:print-info 2 *default-log-port* "Server is in dbprep at " (common:human-time))
;; 		       (thread-sleep! 0.5)) ;; was 25 sec but that blocked things from starting?
;; 		     (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (seconds->time-string (current-seconds))))
;; 		 bad-dat))))))))
;; 
;; ;; ;; get a list of servers from the log files, with all relevant data
;; ;; ;; ( mod-time host port start-time pid )
;; ;; ;;
;; ;; (define (server:get-list areapath #!key (limit #f))
;; ;;   (let ((fname-rx    (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))
;; ;; 	(day-seconds (* 24 60 60)))
;; ;;     ;; if the directory exists continue to get the list
;; ;;     ;; otherwise attempt to create the logs dir and then
;; ;;     ;; continue
;; ;;     (if (if (directory-exists? (conc areapath "/logs"))
;; ;; 	    '()
;; ;; 	    (if (file-write-access? areapath)
;; ;; 		(begin
;; ;; 		  (condition-case
;; ;; 		   (create-directory (conc areapath "/logs") #t)
;; ;; 		   (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
;; ;; 		   (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn)))
;; ;; 		  (directory-exists? (conc areapath "/logs")))
;; ;; 		'()))
;; ;; 
;; ;;         ;; Get the list of server logs.
;; ;; 	(let* (
;; ;;                ;; For some reason, when I uncomment the below line, ext-tests sometimes starts 1000's of servers.
;; ;;                ;; (exiting-servers (system (conc "bash -c 'rm -f `grep -il exiting " areapath "/logs/server-*-*.log 2> /dev/null`'")))
;; ;;                (server-logs   (glob (conc areapath "/logs/server-*-*.log")))
;; ;; 	       (num-serv-logs (length server-logs)))
;; ;; 	  (if (or (null? server-logs) (= num-serv-logs 0))
;; ;;               (let ()
;; ;;                  (debug:print 2  *default-log-port* "There are no servers running at " (common:human-time))
;; ;; 	         '()
;; ;;               )
;; ;; 	      (let loop ((hed  (string-chomp (car server-logs)))
;; ;; 			 (tal  (cdr server-logs))
;; ;; 			 (res '()))
;; ;; 		(let* ((mod-time  (handle-exceptions
;; ;; 				   exn
;; ;; 				   (begin
;; ;; 				     (debug:print 0 *default-log-port* "server:get-list: failed to get modification time on " hed ", exn=" exn)
;; ;; 				     (current-seconds)) ;; 0
;; ;; 				   (file-modification-time hed))) ;; default to *very* old so log gets ignored if deleted
;; ;; 		       (down-time (- (current-seconds) mod-time))
;; ;; 		       (serv-dat  (if (or (< num-serv-logs 10)
;; ;; 				  	  (< down-time 900)) ;; day-seconds))
;; ;; 				      (server:logf-get-start-info hed)
;; ;; 				      '())) ;; don't waste time processing server files not touched in the 15 minutes if there are more than ten servers to look at
;; ;; 		       (serv-rec (cons mod-time serv-dat))
;; ;; 		       (fmatch   (string-match fname-rx hed))
;; ;; 		       (pid      (if fmatch (string->number (list-ref fmatch 2)) #f))
;; ;; 		       (new-res  (if (null? serv-dat)
;; ;; 				     res
;; ;; 				     (cons (append serv-rec (list pid)) res)))) ;; any changes to number of elements in new-res will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which uses match let 
;; ;; 		  (if (null? tal)
;; ;; 		      (if (and limit
;; ;; 			       (> (length new-res) limit))
;; ;; 			  new-res ;; (take new-res limit)  <= need intelligent sorting before this will work
;; ;; 			  new-res)
;; ;; 		      (loop (string-chomp (car tal)) (cdr tal) new-res)))))))))
;; 
;; #;(define (server:get-num-alive srvlst)
;;   (let ((num-alive 0))
;;     (for-each
;;      (lambda (server)
;;         (handle-exceptions
;;           exn
;;          (begin 

;;           (debug:print-info 0 *default-log-port*  "Unable to get server start-time and/or mod-time from " server ", exn=" exn))
;;        (match-let (((mod-time host port start-time server-id pid)
;; 		    server))
;; 	 (let* ((uptime  (- (current-seconds) mod-time))
;; 		(runtime (if start-time
;; 			     (- mod-time start-time)
;; 			     0)))
;; 	   (if (< uptime 5)(set! num-alive (+ num-alive 1)))))))
;;      srvlst)
;;     num-alive))
;; 
;; ;; ;; given a list of servers get a list of valid servers, i.e. at least
;; ;; ;; 10 seconds old, has started and is less than 1 hour old and is
;; ;; ;; active (i.e. mod-time < 10 seconds
;; ;; ;;
;; ;; ;; mod-time host port start-time pid
;; ;; ;;
;; ;; ;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off
;; ;; ;; and servers should stick around for about two hours or so.
;; ;; ;;
;; ;; (define (server:get-best srvlst)
;; ;;   (let* ((nums (server:get-num-servers))
;; ;; 	 (now  (current-seconds))
;; ;; 	 (slst (sort
;; ;; 		(filter (lambda (rec)
;; ;; 			  (if (and (list? rec)
;; ;; 				   (> (length rec) 2))
;; ;; 			      (let ((start-time (list-ref rec 3))
;; ;; 				    (mod-time   (list-ref rec 0)))
;; ;; 				;; (print "start-time: " start-time " mod-time: " mod-time)
;; ;; 				(and start-time mod-time
;; ;; 				     (> (- now start-time) 0)    ;; been running at least 0 seconds
;; ;; 				     (< (- now mod-time)   16)   ;; still alive - file touched in last 16 seconds
;; ;; 				     (or (not (configf:lookup *configdat* "server" "runtime")) ;; skip if not set
;; ;; 					 (< (- now start-time)       
;; ;; 					    (+ (- (string->number (configf:lookup *configdat* "server" "runtime"))
;; ;; 					       180)
;; ;; 					    (random 360)))) ;; under one hour running time +/- 180
;; ;; 				     ))
;; ;; 			      #f))
;; ;; 			srvlst)
;; ;; 		(lambda (a b)
;; ;; 		  (< (list-ref a 3)
;; ;; 		     (list-ref b 3))))))
;; ;;     (if (> (length slst) nums)
;; ;; 	(take slst nums)
;; ;; 	slst)))
;; 
;; ;; ;; switch from server:get-list to server:get-servers-info
;; ;; ;;
;; ;; (define (server:get-first-best areapath)
;; ;;   (let ((srvrs (server:get-best (server:get-list areapath))))
;; ;;     (if (and srvrs
;; ;; 	     (not (null? srvrs)))
;; ;; 	(car srvrs)
;; ;; 	#f)))
;; ;; 
;; ;; (define (server:get-rand-best areapath)
;; ;;   (let ((srvrs (server:get-best (server:get-list areapath))))
;; ;;     (if (and (list? srvrs)
;; ;; 	     (not (null? srvrs)))
;; ;; 	(let* ((len (length srvrs))
;; ;; 	       (idx (random len)))
;; ;; 	  (list-ref srvrs idx))
;; ;; 	#f)))
;; 
;; (define (server:record->id servr)
;;   (handle-exceptions
;;    exn
;;    (begin 
;;      (debug:print-info 0 *default-log-port*  "Unable to get server id from " servr ", exn=" exn)     
;;    #f)
;;   (match-let (((host port start-time server-id pid)
;; 	       servr))
;;     (if server-id
;; 	server-id
;; 	#f))))
;; 
;; (define (server:record->url servr)
;;   (handle-exceptions
;;    exn
;;    (begin 
;;      (debug:print-info 0 *default-log-port*  "Unable to get server url from " servr ", exn=" exn)     
;;    #f)
;;   (match-let (((host port start-time server-id pid)
;; 	       servr))
;;     (if (and host port)
;; 	(conc host ":" port)
;; 	#f))))
;; 
;; 
;; ;; if server-start-last exists, and wasn't old enough, wait <idle time> + 1, then call this function recursively until it is old enough.
;; ;; if it is old enough, overwrite it and wait 0.25 seconds.
;; ;; if it then has the wrong server key, wait <idle time> + 1 and call this function recursively.
;; ;;
;; #;(define (server:wait-for-server-start-last-flag areapath)
;;   (let* ((start-flag (conc areapath "/logs/server-start-last"))
;; 	 ;;; THIS INTERACTS WITH [server] timeout. Suggest using 0.1 or above for timeout (6 seconds)
;; 	 (idletime    (configf:lookup-number *configdat* "server" "idletime" default: 4))
;; 	 (server-key (conc (get-host-name) "-" (current-process-id))))
;;     (if (file-exists? start-flag)
;; 	(let* ((fmodtime (file-modification-time start-flag))
;; 	       (delta    (- (current-seconds) fmodtime))
;; 	       (old-enough   (> delta idletime))
;;                (new-server-key ""))
;;           ;; write start-flag file, wait 0.25s, then if previously the start-flag file was older than <idletime> seconds, and the new file still has the same server key as you just wrote, return #t.
;; 	  ;; the intention is to make sure nfs can read the file we just wrote, and make sure it was written by us, and not another process.
;;            (if (and old-enough
;; 		    (begin
;;                       (debug:print-info 2 *default-log-port* "Writing " start-flag)
;; 		      (with-output-to-file start-flag (lambda () (print server-key)))
;; 		      (thread-sleep! 0.25)
;; 		      (set! new-server-key (with-input-from-file start-flag (lambda () (read-line))))
;; 		      (equal? server-key new-server-key)))
;; 	       #t
;;                ;; If either of the above conditions is not true, print a "Gating server start" message, wait <idle-time> + 1, then call this function recursively. 
;; 	       (begin
;; 		 (debug:print-info 0 *default-log-port* "Gating server start, last start: "
;; 				   (seconds->time-string fmodtime) ", time since last start: " delta ", required idletime: " idletime ", gating reason:" (if old-enough "another job started a server" "too soon to start another server"))
;; 		 
;; 		 (thread-sleep! ( + 1 idletime))
;; 		 (server:wait-for-server-start-last-flag areapath)))))))
;; 
;; ;; oldest server alive determines host then choose random of youngest
;; ;; five servers on that host
;; ;;
;; (define (server:get-servers-info areapath)
;;   ;; (assert *toppath* "FATAL: server:get-servers-info called before *toppath* has been set.")
;;   (let* ((servinfodir (server:get-servinfo-dir areapath))) ;; (conc *toppath*"/.servinfo")))
;;     (if (not (file-exists? servinfodir))
;; 	(create-directory servinfodir))
;;     (let* ((allfiles    (glob (conc servinfodir"/*")))
;; 	   (res         (make-hash-table)))
;;       (for-each
;;        (lambda (f)
;; 	 (let* ((hostport  (pathname-strip-directory f))
;; 		(serverdat (server:logf-get-start-info f)))
;; 	   (match serverdat
;; 	     ((host port start server-id pid)
;; 	      (if (and host port start server-id pid)
;; 		  (hash-table-set! res hostport serverdat)
;; 		  (debug:print-info 2 *default-log-port* "bad server info for "f": "serverdat)))
;; 	     (else
;; 	      (debug:print-info 2 *default-log-port* "bad server info for "f": "serverdat)))))
;;        allfiles)
;;       res)))
;; 
;; ;; check the .servinfo directory, are there other servers running on this
;; ;; or another host?
;; ;;
;; ;; returns #t => ok to start another server
;; ;;         #f => not ok to start another server
;; ;;
;; (define (server:minimal-check areapath)
;;   (server:clean-up-old areapath)
;;   (let* ((srvdir      (server:get-servinfo-dir areapath)) ;; (conc areapath"/.servinfo"))
;; 	 (servrs      (glob (conc srvdir"/*")))
;; 	 (thishostip  (server:get-best-guess-address (get-host-name)))
;; 	 (thisservrs  (glob (conc srvdir"/"thishostip":*")))
;; 	 (homehostinf (server:choose-server areapath 'homehost))
;; 	 (havehome    (car homehostinf))
;; 	 (wearehome   (cdr homehostinf)))
;;     (debug:print-info 0 *default-log-port* thishostip", have homehost: "havehome", we are homehost: "wearehome
;; 		      ", numservers: "(length thisservrs))
;;     (cond
;;      ((not havehome) #t) ;; no homehost yet, go for it
;;      ((and havehome wearehome (< (length thisservrs) 20)) #t) ;; we are home and less than 20 servers, ok to start another
;;      ((and havehome (not wearehome)) #f)     ;; we are not the home host
;;      ((and havehome wearehome (>= (length thisservrs) 20)) #f) ;; have enough running
;;      (else
;;       (debug:print 0 *default-log-port* "WARNING: Unrecognised scenario, servrs="servrs", thishostip="thishostip", thisservrs="thisservrs)
;;       #t))))
;; 	 
;; 
;; (define server-last-start 0)
;; 
;; 
;; ;; oldest server alive determines host then choose random of youngest
;; ;; five servers on that host
;; ;;
;; ;; mode:
;; ;;   best - get best server (random of newest five)
;; ;;   home - get home host based on oldest server
;; ;;   info - print info
;; (define (server:choose-server areapath #!optional (mode 'best))
;;   ;; age is current-starttime
;;   ;; find oldest alive
;;   ;;   1. sort by age ascending and ping until good
;;   ;; find alive rand from youngest
;;   ;;   1. sort by age descending
;;   ;;   2. take five
;;   ;;   3. check alive, discard if not and repeat
;;   ;; first we clean up old server files
;;   (server:clean-up-old areapath)
;;   (let* ((since-last (- (current-seconds) server-last-start))
;;         (server-start-delay 10))     
;;     (if ( < (- (current-seconds) server-last-start) 10 )
;;       (begin
;;         (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
;;         (debug:print 2 *default-log-port* "server:choose-server: last server start less than " server-start-delay " seconds ago. Sleeping " server-start-delay " seconds")
;;         (thread-sleep! server-start-delay)
;;       )
;;       (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
;;     )
;;   )
;;   (let* ((serversdat  (server:get-servers-info areapath))
;; 	 (servkeys    (hash-table-keys serversdat))
;; 	 (by-time-asc (if (not (null? servkeys)) ;; NOTE: Oldest is last
;; 			  (sort servkeys ;; list of "host:port"
;; 				(lambda (a b)
;; 				  (>= (list-ref (hash-table-ref serversdat a) 2)
;; 				      (list-ref (hash-table-ref serversdat b) 2))))
;; 			  '())))
;;     (debug:print 2 *default-log-port* "server:choose-server: serversdat: " serversdat)
;;     (debug:print 2 *default-log-port* "server:choose-server: servkeys: " servkeys)
;;     (if (not (null? by-time-asc))
;; 	(let* ((oldest     (last by-time-asc))
;; 	       (oldest-dat (hash-table-ref serversdat oldest))
;; 	       (host       (list-ref oldest-dat 0))
;; 	       (all-valid  (filter (lambda (x)
;; 				     (equal? host (list-ref (hash-table-ref serversdat x) 0)))
;; 				   by-time-asc))
;; 	       (best-ten  (lambda ()
;; 			     (if (> (length all-valid) 11)
;; 				 (take (drop-right all-valid 1) 10) ;; remove the oldest from consideration so it can age out
;; 				 (if (> (length all-valid) 8)
;; 				     (drop-right all-valid 1)
;; 				     all-valid))))
;; 	       (names->dats (lambda (names)
;; 			      (map (lambda (x)
;; 				     (hash-table-ref serversdat x))
;; 				   names)))
;; 	       (am-home?    (lambda ()
;; 			      (let* ((currhost (get-host-name))
;; 				     (bestadrs (server:get-best-guess-address currhost)))

|















|


>














>



|
>
|
<







<
<
<
<
|
<
|
<
>
|
<
<
<
<
|
<
<
<
<
<
|
<
<
<
<
<



>



<
<
|
|
|
|
|
|

|

>
|









>
>
>
>
>
>









<

|

>






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








|
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<


















|
|
|
|
|
|
|
|
|
<
|


















|
|
|
|
|








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
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
129
130
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

;; Copyright 2006-2023, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     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))
(declare (uses artifacts))

(use md5 message-digest posix typed-records extras)

(module servermod
*

(import scheme
	chicken

	extras
	md5
	message-digest
	ports
	posix
	srfi-18

	typed-records
	data-structures

	artifacts
	)


(defstruct srv
  (areapath #f)
  (host     #f)
  (pid      #f)
  (type     #f)
  (dir      #f)




  (incoming #f)

  (dbstruct #f)

  (handler  #f)
  (obj-to-str #f)




  (str-to-obj #f)





  )






;; nearly every process in Megatest (if write access) starts a server so it
;; can receive messages to exit on request
;; servers have a type, mtserve, dboard, runner, execute? TOO COMPLICATED.

;; one server per run db file would be ideal.



;; mtrah/.servers/<host>.<pid>/incoming/*.artifact
;;                            |        `attic
;;                            |
;;                            `outgoing/<clienthost>.<clientpid>/*.artifact
;;                            |                                 `attic
;;                            `<tcp|http|nmsg|?>.host:port

;; on exit processes clean up. only mtserv or dboard clean up abandoned records?

;; IDEA: All requests could go into one directory instead of server specific directory - need locking
;;       don't get multiple processing of arfs

;; 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

;; call this with handler that takes dbstruct cmd and params after doing server:setup
;; and before starting server:run
;;
(define (server:set-handler srvdat handler)
  (srv-handler-set! srvdat handler))

;; set up the server area and return a server struct
;; NOTE: This will need to be gated by write-access
;;
(define (server:setup areapath)
  (let* ((srvdat (make-srv
		  areapath: areapath
		  host:     (get-host-name) ;; likely need to replace with ip address
		  pid:      (current-process-id)

		  ))
	 (srvdir (conc areapath"/.server/"(get-host.pid srvdat))))
    (srv-dir-set! srvdat srvdir)
    (srv-incoming-set! srvdat (conc srvdir"/incoming"))
    (create-directory srvdir #t)
    (for-each (lambda (d)
		(create-directory (conc srvdir"/"d)))
	      '("incoming" "responses"))
    srvdat))

(define *server-keep-running* #f)

;; to cleanly shut the server down set *server-keep-running* to #f
;;
(define (server:run srvdat)
  ;; create server arf
  ;; put arf in srvdat-dir
  ;; forever
  ;;    scan incoming dir
  ;;    foreach arf
  ;;       bundle into with-transaction, no-transaction
  ;;    foreach bundle
  ;;       process the request
  ;;       create results arf and write it to clients dir
  ;;       remove in-arf from incoming
  (let* ((areapath  (srv-areapath srvdat))
	 (srvinfod  (server:get-servinfo-dir areapath))
	 (myarf     (srv->alist srvdat))
	 (myuuid    (write-alist->artifact srvinfod myarf ptype: 'S))
	 (arf-fname (get-artifact-fname srvinfod myuuid))
	 (dbstruct  (srv-dbstruct srvdat)))
    (set! *server-keep-running* #t)
    (let loop ()
      (let* ((start (current-milliseconds))
	     (res   (server:process-incoming srvdat))
	     (delta (- (current-milliseconds) start)))
	(thread-sleep! (if (> delta 500)
			   0.1
			   0.9))
	(if (or (> res 0) ;; res is the number of requests that were found and processed
		*server-keep-running*)
	    (loop))))))

;; read arfs from incoming, process them and put result arfs in proper dirs
;; return number requests found and processed
;;
(define	(server:process-incoming srvdat)
  (let* ((srvdir (srv-dir srvdat))
	 (indir  (srv-incoming srvdat))
	 (arfs   (glob (conc indir"/*.artifacts")))
	 (handler (srv-handler srvdat))
	 (obj->string (srv-obj-to-str srvdat))
	 (dbstruct (srv-dbstruct srvdat)))
    (let loop ((rem arfs))
      (if (not (null? arfs))
	  (let* ((arf  (car rem))
		 (dat  (read-artifact->alist arf))
		 (ruuid (alist-ref 'Z dat))
		 (host (alist-ref 'h dat))
		 (pid  (alist-ref 'i dat))
		 (dest (conc srvdir"/"host"."pid"/responses"))
		 (cmd  (alist-ref 'c dat))
		 (params (alist-ref 'p dat))
		 (res  (handler dbstruct cmd params))
		 (narf `((r . ,(obj->string res))
			 (P . ,ruuid))))
	    (delete-file arf) ;; add ability to save in bundles in archive area
	    (write-alist->artifact dest narf ptype: 'Q)
	    (loop (cdr rem)))))
    (length arfs)))
	  
;; start a server process (NOT start server in this process)
;;
;; 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))))
    
;;======================================================================

;; OLD SERVER STUFF BELOW HERE












































































































































































;;======================================================================














;; ;; servers start by setting up fs transport

;; ;; and put a flag file for that ASAP.


;; ;; they then set up tcp and put a flag file for



































;; ;; that 






































;; ;;















































































;; (define *client-server-id* #f)

;; 
;; ;; oldest server alive determines host then choose random of youngest
;; ;; five servers on that host
;; ;;
;; ;; mode:
;; ;;   best - get best server (random of newest five)
;; ;;   home - get home host based on oldest server
;; ;;   info - print info
;; (define (server:choose-server areapath #!optional (mode 'best))
;;   ;; age is current-starttime
;;   ;; find oldest alive
;;   ;;   1. sort by age ascending and ping until good
;;   ;; find alive rand from youngest
;;   ;;   1. sort by age descending
;;   ;;   2. take five
;;   ;;   3. check alive, discard if not and repeat
;;   ;; first we clean up old server files
;;   (server:clean-up-old areapath)
;; ;;  (let* ((since-last (- (current-seconds) server-last-start))
;; ;;         (server-start-delay 10))     
;; ;;    (if ( < (- (current-seconds) server-last-start) 10 )
;; ;;	(begin
;; ;;          (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
;; ;;          (debug:print 2 *default-log-port* "server:choose-server: last server start less than " server-start-delay " seconds ago. Sleeping " server-start-delay " seconds")
;; ;;          (thread-sleep! server-start-delay)
;; ;;	  )
;; ;;	(debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))

;; ;;	)
;;   (let* ((serversdat  (server:get-servers-info areapath))
;; 	 (servkeys    (hash-table-keys serversdat))
;; 	 (by-time-asc (if (not (null? servkeys)) ;; NOTE: Oldest is last
;; 			  (sort servkeys ;; list of "host:port"
;; 				(lambda (a b)
;; 				  (>= (list-ref (hash-table-ref serversdat a) 2)
;; 				      (list-ref (hash-table-ref serversdat b) 2))))
;; 			  '())))
;;     (debug:print 2 *default-log-port* "server:choose-server: serversdat: " serversdat)
;;     (debug:print 2 *default-log-port* "server:choose-server: servkeys: " servkeys)
;;     (if (not (null? by-time-asc))
;; 	(let* ((oldest     (last by-time-asc))
;; 	       (oldest-dat (hash-table-ref serversdat oldest))
;; 	       (host       (list-ref oldest-dat 0))
;; 	       (all-valid  (filter (lambda (x)
;; 				     (equal? host (list-ref (hash-table-ref serversdat x) 0)))
;; 				   by-time-asc))
;; 	       (best-ten  (lambda ()
;; 			    (if (> (length all-valid) 11)
;; 				(take (drop-right all-valid 1) 10) ;; remove the oldest from consideration so it can age out
;; 				(if (> (length all-valid) 8)
;; 				    (drop-right all-valid 1)
;; 				    all-valid))))
;; 	       (names->dats (lambda (names)
;; 			      (map (lambda (x)
;; 				     (hash-table-ref serversdat x))
;; 				   names)))
;; 	       (am-home?    (lambda ()
;; 			      (let* ((currhost (get-host-name))
;; 				     (bestadrs (server:get-best-guess-address currhost)))
︙︙
554
555
556
557
558
559
560
561




562
563
564
565
566









567
568
569
570
571
572
573

;; 	(begin
;; 	  (server:run areapath)
;;           (set! server-last-start (current-seconds))
;; 	  ;; (thread-sleep! 3)
;; 	  (case mode
;; 	    ((homehost) (cons #f #f))
;; 	    (else	#f))))))
;; 




;; (define (server:get-servinfo-dir areapath)
;;   (let* ((spath (conc areapath"/.servinfo")))
;;     (if (not (file-exists? spath))
;; 	(create-directory spath #t))
;;     spath))









;; 
;; (define (server:clean-up-old areapath)
;;   ;; any server file that has not been touched in ten minutes is effectively dead
;;   (let* ((sfiles (glob (conc (server:get-servinfo-dir areapath)"/*"))))
;;     (for-each
;;      (lambda (sfile)
;;        (let* ((modtime (handle-exceptions








|
>
>
>
>
|
|
|
|
|
>
>
>
>
>
>
>
>
>








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

;; 	(begin
;; 	  (server:run areapath)
;;           (set! server-last-start (current-seconds))
;; 	  ;; (thread-sleep! 3)
;; 	  (case mode
;; 	    ((homehost) (cons #f #f))
;; 	    (else	#f))))))
 
;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

(define (server:get-servinfo-dir areapath)
  (let* ((spath (conc areapath"/.servinfo")))
    (if (not (file-exists? spath))
	(create-directory spath #t))
    spath))

;; ;; 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 (server:clean-up-old areapath)
;;   ;; any server file that has not been touched in ten minutes is effectively dead
;;   (let* ((sfiles (glob (conc (server:get-servinfo-dir areapath)"/*"))))
;;     (for-each
;;      (lambda (sfile)
;;        (let* ((modtime (handle-exceptions
︙︙
583
584
585
586
587
588
589





590








591
592



593






594

595


596




597

598








599
600
601


602
603






604

605



606





607
608
609
610
611
612
613














614


615










616
617
618
619

620

621














622



623

624



625
626
627
628
629




630
631
632
633
634
635























636







637





638
639
640
641
642
643
644















645









646
647
648
649
650
651
652
653
654
655
656
657
658

659







660
661



662



663








664











665
666
667

668
669
670
671
672
673
674
675
676
677
678
679
680
681



682
683

















684










685
686
687

688



689








690


691
692






693


694


695
















696

697
698
699

700
701


702
703














704
705





706

707
708

















709





710



711





712

713
714

715






716
717
718

719



720

721
722




723
724
725


726
727
728
729
730
731

732

733

734
735

736
737

738

739


740
741
742
743
744


745






















746

747

748

749











750
751

752
753
754
755
756

757
758


759
760
761
762
763
764
765
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
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893

;; 	       (debug:print 0 *default-log-port* "WARNING: found old server info file "sfile", removing it.")
;; 	       (handle-exceptions
;; 		   exn
;; 		 (debug:print 0 *default-log-port* "WARNING: failed to delete old server info file "sfile)
;; 		 (delete-file sfile))))))
;;      sfiles)))
;; 





;; ;; would like to eventually get rid of this








;; ;;
;; (define (common:on-homehost?)



;;   (server:choose-server *toppath* 'home?))






;; 

;; ;; kind start up of server, wait before allowing another server for a given


;; ;; area to be launched




;; ;;

;; (define (server:kind-run areapath)








;;   ;; look for $MT_RUN_AREA_HOME/logs/server-start-last
;;   ;; and wait for it to be at least <server idletime> seconds old
;;   ;; (server:wait-for-server-start-last-flag areapath)


;;   (let loop ()
;;     (if (> (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)) 2)






;; 	(begin

;; 	  (if (common:low-noise-print 30 "our-host-load")



;; 	      (debug:print 0 *default-log-port* "WARNING: system load is high, waiting to start server."))





;; 	  (loop))))
;;   (if (< (server:choose-server areapath 'count) 20)
;;       (server:run areapath))
;;   #;(if (not (server:check-if-running areapath)) ;; why try if there is already a server running?
;;       (let* ((lock-file    (conc areapath "/logs/server-start.lock")))
;; 	(let* ((start-flag (conc areapath "/logs/server-start-last")))
;; 	  (common:simple-file-lock-and-wait lock-file expire-time: 25)














;; 	  (debug:print-info  2 *default-log-port* "server:kind-run: touching " start-flag)


;; 	  (system (conc "touch " start-flag)) ;; lazy but safe










;; 	  (server:run areapath)
;; 	  (thread-sleep! 20) ;; don't release the lock for at least a few seconds. And allow time for the server startup to get to "SERVER STARTED".
;; 	  (common:simple-file-release-lock lock-file)))
;;       (debug:print-info 0 *default-log-port* "Found server already running. NOT trying to start another.")))

;; 

;; ;; this one seems to be the general entry point














;; ;;



;; (define (server:start-and-wait areapath #!key (timeout 60))

;;   (let ((give-up-time (+ (current-seconds) timeout)))



;;     (let loop ((server-info (server:check-if-running areapath))
;; 	       (try-num    0))
;;       (if (or server-info
;; 	      (> (current-seconds) give-up-time)) ;; server-url will be #f if no server available.
;; 	  (server:record->url server-info)




;; 	  (let* ( (servers (server:choose-server areapath 'all-valid))
;;                 (num-ok (if servers (length (server:choose-server areapath 'all-valid)) 0)))
;; 	    (if (and (> try-num 0)  ;; first time through simply wait a little while then try again
;; 		     (< num-ok 1))  ;; if there are no decent candidates for servers then try starting a new one
;; 		(server:run areapath))
;; 	    (thread-sleep! 5)























;; 	    (loop (server:check-if-running areapath)







;; 		  (+ try-num 1)))))))





;; 
;; (define (server:get-num-servers #!key (numservers 2))
;;   (let ((ns (string->number
;; 	     (or (configf:lookup *configdat* "server" "numservers") "notanumber"))))
;;     (or ns numservers)))
;; 
;; ;; no longer care if multiple servers are started by accident. older servers will drop off in time.















;; ;;









;; (define (server:check-if-running areapath) ;;  #!key (numservers "2"))
;;   (let* ((ns            (server:get-num-servers)) ;; get the setting the for maximum number of servers allowed
;; 	 (servers       (server:choose-server areapath 'best-ten))) ;; (server:get-best (server:get-list areapath))))
;;     (if (or (and servers
;; 		 (null? servers))
;; 	    (not servers))
;; 	    ;; (and (list? servers)
;; 	    ;;	 (< (length servers) (+ 1 (random ns))))) ;; somewhere between 1 and numservers
;;         #f
;;         (let loop ((hed (car servers))
;;                    (tal (cdr servers)))
;;           (let ((res (server:check-server hed)))
;;             (if res

;;                 hed







;;                 (if (null? tal)
;;                     #f



;;                     (loop (car tal)(cdr tal)))))))))



;; 








;; ;; ping the given server











;; ;;
;; (define (server:check-server server-record)
;;   (let* ((server-url (server:record->url server-record))

;;          (server-id  (server:record->id server-record)) 
;;          (res        (server:ping server-url server-id)))
;;     (if res
;;         server-url
;; 	#f)))
;; 
;; (define (server:kill servr)
;;   (handle-exceptions
;;     exn
;;     (begin 
;;       (debug:print-info 0 *default-log-port*  "Unable to get host and/or port from " servr ", exn=" exn)     
;;     #f)
;;   (match-let (((mod-time hostname port start-time server-id pid)
;; 	       servr))



;;     (tasks:kill-server hostname pid))))
;; 

















;; ;; 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.

;; ;;



;; (define (server:ping host:port server-id #!key (do-exit #f))








;;   (let* ((host-port (cond


;; 		     ((string? host:port)
;; 		      (let ((slst (string-split   host:port ":")))






;; 			(if (eq? (length slst) 2)


;; 			    (list (car slst)(string->number (cadr slst)))


;; 			    #f)))
















;; 		     (else

;; 		      #f))))
;;     (cond
;;      ((and (list? host-port)

;; 	   (eq? (length host-port) 2))
;;       (let* ((myrunremote (make-remote))


;; 	     (iface       (car host-port))
;; 	     (port        (cadr host-port))














;; 	     (server-dat  (client:connect iface port server-id myrunremote))
;; 	     (login-res   (rmt:login-no-auto-client-setup myrunremote)))





;; 	(if (and (list? login-res)

;; 		 (car login-res))
;; 	    (begin

















;; 	      ;; (print "LOGIN_OK")





;; 	      (if do-exit (exit 0))



;; 	      #t)





;; 	    (begin

;; 	      ;; (print "LOGIN_FAILED")
;; 	      (if do-exit (exit 1))

;; 	      #f))))






;;      (else 
;;       (if host:port
;; 	  (debug:print 0 *default-log-port*  "ERROR: bad host:port "host:port))

;;       (if do-exit



;; 	  (exit 1)

;; 	  #f)))))
;; 




;; ;; run ping in separate process, safest way in some cases
;; ;;
;; (define (server:ping-server ifaceport)


;;   (with-input-from-pipe 
;;    (conc (common:get-megatest-exe) " -ping " ifaceport)
;;    (lambda ()
;;      (let loop ((inl (read-line))
;; 		(res "NOREPLY"))
;;        (if (eof-object? inl)

;; 	   (case (string->symbol res)

;; 	     ((NOREPLY)  #f)

;; 	     ((LOGIN_OK) #t)
;; 	     (else       #f))

;; 	   (loop (read-line) inl))))))
;; 

;; ;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).

;; ;;


;; (define (server:login toppath)
;;   (lambda (toppath)
;;     (set! *db-last-access* (current-seconds)) ;; might not be needed.
;;     (if (equal? *toppath* toppath)
;; 	#t


;; 	#f)))






















;; 

;; ;; timeout is hms string: 1h 5m 3s, default is 1 minute

;; ;; This is currently broken. Just use the number of hours with no unit.

;; ;; Default is 60 seconds.











;; ;;
;; (define (server:expiration-timeout)

;;   (let ((tmo (configf:lookup *configdat* "server" "timeout")))
;;     (if (and (string? tmo)
;; 	     (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
;;         (* 3600 (string->number tmo))
;; 	600)))

;; 
;; (define (server:get-best-guess-address hostname)


;;   (let ((res #f))
;;     (for-each 
;;      (lambda (adr)
;;        (if (not (eq? (u8vector-ref adr 0) 127))
;; 	   (set! res adr)))
;;      ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
;;      (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
;;     (string-intersperse 
;;      (map number->string
;; 	  (u8vector->list
;; 	   (if res res (hostname->ip hostname)))) ".")))

;; 
;; ;; (define server:sync-lock-token "SERVER_SYNC_LOCK")
;; ;; (define (server:release-sync-lock)

;; ;;   (db:no-sync-del! *no-sync-db* server:sync-lock-token))
;; ;; (define (server:have-sync-lock?)
;; ;;   (let* ((have-lock-pair (db:no-sync-get-lock *no-sync-db* server:sync-lock-token))
;; ;;          (have-lock?     (car have-lock-pair))









;; ;;          (lock-time      (cdr have-lock-pair))




;; ;;          (lock-age       (- (current-seconds) lock-time)))





















;; ;;     (cond
;; ;;      (have-lock? #t)
















;; ;;      ((>lock-age
;; ;;        (* 3 (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 180)))
;; ;;       (server:release-sync-lock)

;; ;;       (server:have-sync-lock?))




;; ;;      (else #f))))












;; 

;; ;; moving this here as it needs access to db and cannot be in common.

















;; ;;












;; 



















;; (define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
;;   (debug:print "WARNING: bruteforce-syncer is called but has been disabled!")
;;   (lambda ()
;;     (debug:print "WARNING: bruteforce-syncer is called but has been disabled!"))
;;   #;(let* ((sqlite-exe   (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
;;          (sync-log     (or (args:get-arg "-sync-log") (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log")))
;; 	 (tmp-area     (common:get-db-tmp-area))
;; 	 (tmp-db       (conc tmp-area "/megatest.db"))
;; 	 (staging-file (conc *toppath* "/.megatest.db"))
;; 	 (mtdbfile     (conc *toppath* "/megatest.db"))
;; 	 (lockfile     (common:get-sync-lock-filepath))
;;          (sync-cmd-core     (conc sqlite-exe" " tmp-db " .dump | "sqlite-exe" " staging-file "&>"sync-log))
;;          (sync-cmd     (if fork-to-background 
;;                            (conc "/usr/bin/env NBFAKE_LOG="*toppath*"/logs/last-server-sync-"(current-process-id)".log nbfake \""sync-cmd-core" && /bin/mv -f " staging-file " " mtdbfile" \"")
;;                            sync-cmd-core))
;;          (default-min-intersync-delay 2)
;; 	 (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: default-min-intersync-delay))
;;          (default-duty-cycle 0.1)
;;          (duty-cycle   (configf:lookup-number *configdat* "server" "sync-duty-cycle" default: default-duty-cycle))
;;          (last-sync-seconds 10) ;; we will adjust this to a measurement and delay last-sync-seconds * (1 - duty-cycle)
;;          (calculate-off-time (lambda (work-duration duty-cycle)
;;                                   (* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds)))
;;          (off-time min-intersync-delay) ;; adjusted in closure below.
;;          (do-a-sync
;;           (lambda ()
;;             (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
;;             (let* ((finalres
;;                     (let retry-loop ((num-tries 0))
;;                          (if (common:simple-file-lock lockfile)
;; 	                     (begin
;;                                (cond
;;                                 ((not (or fork-to-background persist-until-sync))
;;                                  (debug:print 0 *default-log-port* "INFO: syncer thread sleeping for max of (server.minimum-intersync-delay="min-intersync-delay
;;                                               " , off-time="off-time" seconds ]")
;;                                  (thread-sleep! (max off-time min-intersync-delay)))
;;                                 (else
;;                                  (debug:print 0 *default-log-port* "INFO: syncer thread NOT sleeping ; maybe time-to-exit...")))
;; 
;;                                (if (not (configf:lookup *configdat* "server" "disable-db-snapshot"))
;;                                    (common:snapshot-file mtdbfile subdir: ".db-snapshot"))
;; 		               (delete-file* staging-file)
;; 		               (let* ((start-time (current-milliseconds))
;;                                       (res (system sync-cmd))
;;                                       (dbbackupfile (conc mtdbfile ".backup"))
;;                                       (res2 
;;                                        (cond
;;                                         ((eq? 0 res )
;;                                          (handle-exceptions
;;                                             exn
;;                                             #f
;;                                          (if (file-exists? dbbackupfile)
;; 		                           (delete-file* dbbackupfile)
;;                                          )
;;                                          (if (eq? 0 (file-size sync-log))
;;                                              (delete-file* sync-log))
;; 		                         (system (conc "/bin/mv " staging-file " " mtdbfile))
;;                                          
;;                                          (set! last-sync-seconds (/ (- (current-milliseconds) start-time) 1000))
;;                                          (set! off-time (calculate-off-time
;;                                                          last-sync-seconds
;;                                                          (cond
;;                                                           ((and (number? duty-cycle) (> duty-cycle 0) (< duty-cycle 1))
;;                                                            duty-cycle)
;;                                                           (else
;;                                                            (debug:print 0 *default-log-port* "WARNING: ["(common:human-time)"] server.sync-duty-cycle is invalid.  Should be a number between 0 and 1, but "duty-cycle" was specified.  Using default value: "default-duty-cycle)
;;                                                            default-duty-cycle))))
;;                                          
;;                                          (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec")
;;                                          (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec ; with duty-cycle of "duty-cycle" off time is now "off-time)
;;                                          'sync-completed))
;;                                         (else
;;                                          (system (conc "/bin/cp "sync-log" "sync-log".fail"))
;;                                          (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail")
;;                                          (if (file-exists? (conc mtdbfile ".backup"))
;;                                              (system (conc "/bin/cp "mtdbfile ".backup " mtdbfile)))
;;                                          #f))))
;;                                  (common:simple-file-release-lock lockfile)
;;                                  (BB> "released lockfile: " lockfile)
;;                                  (when (common:file-exists? lockfile)
;;                                    (BB> "DID NOT ACTUALLY RELEASE LOCKFILE"))
;;                                  res2) ;; end let
;;                                );; end begin
;;                              ;; else
;;                              (cond
;;                               (persist-until-sync
;;                                (thread-sleep! 1)
;;                                (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; we're in a fork-to-background so we need to succeed.  Let's wait a jiffy and and try again. num-tries="num-tries" (waiting for lockfile="lockfile" to disappear)")
;;                                (retry-loop (add1 num-tries)))
;;                               (else
;;                                (thread-sleep! (max off-time (+ last-sync-seconds min-intersync-delay)))
;;                                (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.")
;;                                'parallel-sync-in-progress))
;;                              ) ;; end if got lockfile
;;                          )
;;                     ))
;;               (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres)
;;               finalres)
;;             ) ;; end lambda
;;           ))
;;     do-a-sync))
;; 
;; 

)








>
>
>
>
>
|
>
>
>
>
>
>
>
>
|
|
>
>
>
|
>
>
>
>
>
>
|
>
|
>
>
|
>
>
>
>
|
>
|
>
>
>
>
>
>
>
>
|
|
|
>
>
|
<
>
>
>
>
>
>
|
>
|
>
>
>
|
>
>
>
>
>
|
|
<
<
<
<
<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
|
>
>
>
>
>
>
>
>
>
>
|
<
<
|
>
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
|
>
|
>
>
>
|
|
|
<
|
>
>
>
>
|
<
<
<
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
|
>
>
>
>
>
|
|
|
<
<
<
<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
|
|
<
|
|
|
|
<
|
<
<
|
|
>
|
>
>
>
>
>
>
>
|
|
>
>
>
|
>
>
>
|
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
|
<
|
>
|
>
>
>
|
>
>
>
>
>
>
>
>
|
>
>
|
|
>
>
>
>
>
>
|
>
>
|
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
|
|
>
|
|
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
>
>
>
>
>
|
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
|
>
>
>
|
>
>
>
>
>
|
>
|
|
>
|
>
>
>
>
>
>
|
<
|
>
|
>
>
>
|
>
|
|
>
>
>
>
|
|
|
>
>
|
<
|
|
|
|
>
|
>
|
>
|
|
>
|
|
>
|
>
|
>
>
|
<
<
|
|
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
>
|
>
|
>
>
>
>
>
>
>
>
>
>
>
|
|
>
|
|
<
<
|
>
|
|
>
>
|
|
<
<
|
<
<
<
<
|
<
>
|
|
|
>
|
|
|
|
>
>
>
>
>
>
>
>
>
|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
|
>
|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|



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

366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385





386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414


415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446

447
448
449
450
451
452



453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494




495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521

522
523
524
525

526


527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619

620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695

696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750

751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
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
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841


842
843
844
845
846
847
848
849


850




851

852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915

916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092

;; 	       (debug:print 0 *default-log-port* "WARNING: found old server info file "sfile", removing it.")
;; 	       (handle-exceptions
;; 		   exn
;; 		 (debug:print 0 *default-log-port* "WARNING: failed to delete old server info file "sfile)
;; 		 (delete-file sfile))))))
;;      sfiles)))
;; 
;; (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))))

;; ;; ;; 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 
;; ;;   (case (server:get-transport)
;; ;;     ((rpc)  (db:obj->string (vector success/fail query-sig result)))
;; ;;     ((http) (db:obj->string (vector success/fail query-sig result)))
;; ;;     ((fs)   result)
;; ;;     (else 
;; ;;      (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
;; ;;      result)))
;; ;; 
;; ;; ;; Given an area path,  start a server process    ### NOTE ### > file 2>&1 
;; ;; ;; if the target-host is set 
;; ;; ;; try running on that host
;; ;; ;;   incidental: rotate logs in logs/ dir.
;; ;; ;;
;; ;; (define  (server:run areapath) ;; areapath is *toppath* for a given testsuite area
;; ;;   (let* ((testsuite   (common:get-testsuite-name))
;; ;; 	 (logfile     (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log"))
;; ;; 	 (profile-mode (or (configf:lookup *configdat* "misc" "profilesw")
;; ;; 			   ""))
;; ;; 	 (cmdln (conc (common:get-megatest-exe)
;; ;; 		      " -server - ";; (or target-host "-")
;; ;; 		      (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
;; ;; 			  " -daemonize "
;; ;; 			  "")
;; ;; 		      ;; " -log " logfile
;; ;; 		      " -m testsuite:" testsuite
;; ;; 		      " " profile-mode
;; ;; 		      )) ;; (conc " >> " logfile " 2>&1 &")))))
;; ;; 	 (log-rotate  (make-thread common:rotate-logs  "server run, rotate logs thread")) ;; why are we rotating logs here? This is a sensitive location with a lot going on!?
;; ;;          (load-limit  (configf:lookup-number *configdat* "jobtools" "max-server-start-load" default: 3.0)))
;; ;;     ;; we want the remote server to start in *toppath* so push there
;; ;;     (push-directory areapath)
;; ;;     (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
;; ;;     (thread-start! log-rotate)
;; ;;     

;; ;;     ;; host.domain.tld match host?
;; ;;     ;; (if (and target-host 
;; ;;     ;; 	     ;; look at target host, is it host.domain.tld or ip address and does it 
;; ;;     ;; 	     ;; match current ip or hostname
;; ;;     ;; 	     (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
;; ;;     ;; 	     (not (equal? curr-ip target-host)))
;; ;;     ;; 	(begin
;; ;;     ;; 	  (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
;; ;;     ;; 	  (setenv "TARGETHOST" target-host)))
;; ;;     ;;   
;; ;;     (setenv "TARGETHOST_LOGF" logfile)
;; ;;     (thread-sleep! (/ (random 3000) 1000)) ;; add a random initial delay. It seems pretty common that many running tests request a server at the same time
;; ;;     (debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time))
;; ;;     (system (conc "nbfake " cmdln))
;; ;;     (unsetenv "TARGETHOST_LOGF")
;; ;;     ;; (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
;; ;;     (thread-join! log-rotate)
;; ;;     (pop-directory)))
;; ;; 
;; ;; ;; given a path to a server log return: host port startseconds server-id





;; ;; ;; any changes to number of elements returned by this fuction will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which use match let 
;; ;; ;; example of what it's looking for in the log file:
;; ;; ;;     SERVER STARTED: 10.38.175.67:50216 AT 1616502350.0 server-id: 4907e90fc55c7a09694e3f658c639cf4 
;; ;; 
;; ;; (define (server:logf-get-start-info logf)
;; ;;   (let ((server-rx    (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+) server-id: (\\S+) pid: (\\d+)")) ;; SERVER STARTED: host:port AT timesecs server id
;; ;;         (dbprep-rx    (regexp "^SERVER: dbprep"))
;; ;;         (dbprep-found 0)
;; ;; 	(bad-dat      (list #f #f #f #f #f)))
;; ;;     (handle-exceptions
;; ;;      exn
;; ;;      (begin
;; ;;        ;; WARNING: this is potentially dangerous to blanket ignore the errors
;; ;;        (if (file-exists? logf)
;; ;; 	   (debug:print-info 2 *default-log-port* "Unable to get server info from "logf", exn=" exn))
;; ;;        bad-dat) ;; no idea what went wrong, call it a bad server
;; ;;      (with-input-from-file
;; ;; 	 logf
;; ;;        (lambda ()
;; ;; 	 (let loop ((inl  (read-line))
;; ;; 		    (lnum 0))
;; ;; 	   (if (not (eof-object? inl))
;; ;; 	       (let ((mlst (string-match server-rx inl))
;; ;; 		     (dbprep (string-match dbprep-rx inl)))
;; ;; 		 (if dbprep (set! dbprep-found 1))
;; ;; 		 (if (not mlst)
;; ;; 		     (if (< lnum 500) ;; give up if more than 500 lines of server log read
;; ;; 			 (loop (read-line)(+ lnum 1))
;; ;; 			 (begin 


;; ;;                            (debug:print-info 0 *default-log-port* "Unable to get server info from first 500 lines of " logf )
;; ;;                            bad-dat))
;; ;; 		     (match mlst
;; ;; 			    ((_ host port start server-id pid)
;; ;; 			     (list host
;; ;; 				   (string->number port)
;; ;; 				   (string->number start)
;; ;; 				   server-id
;; ;; 				   (string->number pid)))
;; ;; 			    (else
;; ;; 			     (debug:print 0 *current-log-port* "ERROR: did not recognise SERVER line info "mlst)
;; ;; 			     bad-dat))))
;; ;; 	       (begin 
;; ;; 		 (if dbprep-found
;; ;; 		     (begin
;; ;; 		       (debug:print-info 2 *default-log-port* "Server is in dbprep at " (common:human-time))
;; ;; 		       (thread-sleep! 0.5)) ;; was 25 sec but that blocked things from starting?
;; ;; 		     (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (seconds->time-string (current-seconds))))
;; ;; 		 bad-dat))))))))
;; ;; 
;; ;; ;; ;; get a list of servers from the log files, with all relevant data
;; ;; ;; ;; ( mod-time host port start-time pid )
;; ;; ;; ;;
;; ;; ;; (define (server:get-list areapath #!key (limit #f))
;; ;; ;;   (let ((fname-rx    (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))
;; ;; ;; 	(day-seconds (* 24 60 60)))
;; ;; ;;     ;; if the directory exists continue to get the list
;; ;; ;;     ;; otherwise attempt to create the logs dir and then
;; ;; ;;     ;; continue
;; ;; ;;     (if (if (directory-exists? (conc areapath "/logs"))
;; ;; ;; 	    '()
;; ;; ;; 	    (if (file-write-access? areapath)

;; ;; ;; 		(begin
;; ;; ;; 		  (condition-case
;; ;; ;; 		   (create-directory (conc areapath "/logs") #t)
;; ;; ;; 		   (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
;; ;; ;; 		   (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn)))
;; ;; ;; 		  (directory-exists? (conc areapath "/logs")))



;; ;; ;; 		'()))
;; ;; ;; 
;; ;; ;;         ;; Get the list of server logs.
;; ;; ;; 	(let* (
;; ;; ;;                ;; For some reason, when I uncomment the below line, ext-tests sometimes starts 1000's of servers.
;; ;; ;;                ;; (exiting-servers (system (conc "bash -c 'rm -f `grep -il exiting " areapath "/logs/server-*-*.log 2> /dev/null`'")))
;; ;; ;;                (server-logs   (glob (conc areapath "/logs/server-*-*.log")))
;; ;; ;; 	       (num-serv-logs (length server-logs)))
;; ;; ;; 	  (if (or (null? server-logs) (= num-serv-logs 0))
;; ;; ;;               (let ()
;; ;; ;;                  (debug:print 2  *default-log-port* "There are no servers running at " (common:human-time))
;; ;; ;; 	         '()
;; ;; ;;               )
;; ;; ;; 	      (let loop ((hed  (string-chomp (car server-logs)))
;; ;; ;; 			 (tal  (cdr server-logs))
;; ;; ;; 			 (res '()))
;; ;; ;; 		(let* ((mod-time  (handle-exceptions
;; ;; ;; 				   exn
;; ;; ;; 				   (begin
;; ;; ;; 				     (debug:print 0 *default-log-port* "server:get-list: failed to get modification time on " hed ", exn=" exn)
;; ;; ;; 				     (current-seconds)) ;; 0
;; ;; ;; 				   (file-modification-time hed))) ;; default to *very* old so log gets ignored if deleted
;; ;; ;; 		       (down-time (- (current-seconds) mod-time))
;; ;; ;; 		       (serv-dat  (if (or (< num-serv-logs 10)
;; ;; ;; 				  	  (< down-time 900)) ;; day-seconds))
;; ;; ;; 				      (server:logf-get-start-info hed)
;; ;; ;; 				      '())) ;; don't waste time processing server files not touched in the 15 minutes if there are more than ten servers to look at
;; ;; ;; 		       (serv-rec (cons mod-time serv-dat))
;; ;; ;; 		       (fmatch   (string-match fname-rx hed))
;; ;; ;; 		       (pid      (if fmatch (string->number (list-ref fmatch 2)) #f))
;; ;; ;; 		       (new-res  (if (null? serv-dat)
;; ;; ;; 				     res
;; ;; ;; 				     (cons (append serv-rec (list pid)) res)))) ;; any changes to number of elements in new-res will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which uses match let 
;; ;; ;; 		  (if (null? tal)
;; ;; ;; 		      (if (and limit
;; ;; ;; 			       (> (length new-res) limit))
;; ;; ;; 			  new-res ;; (take new-res limit)  <= need intelligent sorting before this will work
;; ;; ;; 			  new-res)
;; ;; ;; 		      (loop (string-chomp (car tal)) (cdr tal) new-res)))))))))
;; ;; 
;; ;; #;(define (server:get-num-alive srvlst)
;; ;;   (let ((num-alive 0))




;; ;;     (for-each
;; ;;      (lambda (server)
;; ;;         (handle-exceptions
;; ;;           exn
;; ;;          (begin 
;; ;;           (debug:print-info 0 *default-log-port*  "Unable to get server start-time and/or mod-time from " server ", exn=" exn))
;; ;;        (match-let (((mod-time host port start-time server-id pid)
;; ;; 		    server))
;; ;; 	 (let* ((uptime  (- (current-seconds) mod-time))
;; ;; 		(runtime (if start-time
;; ;; 			     (- mod-time start-time)
;; ;; 			     0)))
;; ;; 	   (if (< uptime 5)(set! num-alive (+ num-alive 1)))))))
;; ;;      srvlst)
;; ;;     num-alive))
;; ;; 
;; ;; ;; ;; given a list of servers get a list of valid servers, i.e. at least
;; ;; ;; ;; 10 seconds old, has started and is less than 1 hour old and is
;; ;; ;; ;; active (i.e. mod-time < 10 seconds
;; ;; ;; ;;
;; ;; ;; ;; mod-time host port start-time pid
;; ;; ;; ;;
;; ;; ;; ;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off
;; ;; ;; ;; and servers should stick around for about two hours or so.
;; ;; ;; ;;
;; ;; ;; (define (server:get-best srvlst)
;; ;; ;;   (let* ((nums (server:get-num-servers))

;; ;; ;; 	 (now  (current-seconds))
;; ;; ;; 	 (slst (sort
;; ;; ;; 		(filter (lambda (rec)
;; ;; ;; 			  (if (and (list? rec)

;; ;; ;; 				   (> (length rec) 2))


;; ;; ;; 			      (let ((start-time (list-ref rec 3))
;; ;; ;; 				    (mod-time   (list-ref rec 0)))
;; ;; ;; 				;; (print "start-time: " start-time " mod-time: " mod-time)
;; ;; ;; 				(and start-time mod-time
;; ;; ;; 				     (> (- now start-time) 0)    ;; been running at least 0 seconds
;; ;; ;; 				     (< (- now mod-time)   16)   ;; still alive - file touched in last 16 seconds
;; ;; ;; 				     (or (not (configf:lookup *configdat* "server" "runtime")) ;; skip if not set
;; ;; ;; 					 (< (- now start-time)       
;; ;; ;; 					    (+ (- (string->number (configf:lookup *configdat* "server" "runtime"))
;; ;; ;; 					       180)
;; ;; ;; 					    (random 360)))) ;; under one hour running time +/- 180
;; ;; ;; 				     ))
;; ;; ;; 			      #f))
;; ;; ;; 			srvlst)
;; ;; ;; 		(lambda (a b)
;; ;; ;; 		  (< (list-ref a 3)
;; ;; ;; 		     (list-ref b 3))))))
;; ;; ;;     (if (> (length slst) nums)
;; ;; ;; 	(take slst nums)
;; ;; ;; 	slst)))
;; ;; 
;; ;; ;; ;; switch from server:get-list to server:get-servers-info
;; ;; ;; ;;
;; ;; ;; (define (server:get-first-best areapath)
;; ;; ;;   (let ((srvrs (server:get-best (server:get-list areapath))))
;; ;; ;;     (if (and srvrs
;; ;; ;; 	     (not (null? srvrs)))
;; ;; ;; 	(car srvrs)
;; ;; ;; 	#f)))
;; ;; ;; 
;; ;; ;; (define (server:get-rand-best areapath)
;; ;; ;;   (let ((srvrs (server:get-best (server:get-list areapath))))
;; ;; ;;     (if (and (list? srvrs)
;; ;; ;; 	     (not (null? srvrs)))
;; ;; ;; 	(let* ((len (length srvrs))
;; ;; ;; 	       (idx (random len)))
;; ;; ;; 	  (list-ref srvrs idx))
;; ;; ;; 	#f)))
;; ;; 
;; ;; (define (server:record->id servr)
;; ;;   (handle-exceptions
;; ;;    exn
;; ;;    (begin 
;; ;;      (debug:print-info 0 *default-log-port*  "Unable to get server id from " servr ", exn=" exn)     
;; ;;    #f)
;; ;;   (match-let (((host port start-time server-id pid)
;; ;; 	       servr))
;; ;;     (if server-id
;; ;; 	server-id
;; ;; 	#f))))
;; ;; 
;; ;; (define (server:record->url servr)
;; ;;   (handle-exceptions
;; ;;    exn
;; ;;    (begin 
;; ;;      (debug:print-info 0 *default-log-port*  "Unable to get server url from " servr ", exn=" exn)     
;; ;;    #f)
;; ;;   (match-let (((host port start-time server-id pid)
;; ;; 	       servr))
;; ;;     (if (and host port)
;; ;; 	(conc host ":" port)
;; ;; 	#f))))
;; ;; 
;; ;; 
;; ;; ;; if server-start-last exists, and wasn't old enough, wait <idle time> + 1, then call this function recursively until it is old enough.
;; ;; ;; if it is old enough, overwrite it and wait 0.25 seconds.
;; ;; ;; if it then has the wrong server key, wait <idle time> + 1 and call this function recursively.
;; ;; ;;
;; ;; #;(define (server:wait-for-server-start-last-flag areapath)
;; ;;   (let* ((start-flag (conc areapath "/logs/server-start-last"))
;; ;; 	 ;;; THIS INTERACTS WITH [server] timeout. Suggest using 0.1 or above for timeout (6 seconds)
;; ;; 	 (idletime    (configf:lookup-number *configdat* "server" "idletime" default: 4))
;; ;; 	 (server-key (conc (get-host-name) "-" (current-process-id))))
;; ;;     (if (file-exists? start-flag)
;; ;; 	(let* ((fmodtime (file-modification-time start-flag))
;; ;; 	       (delta    (- (current-seconds) fmodtime))
;; ;; 	       (old-enough   (> delta idletime))
;; ;;                (new-server-key ""))
;; ;;           ;; write start-flag file, wait 0.25s, then if previously the start-flag file was older than <idletime> seconds, and the new file still has the same server key as you just wrote, return #t.
;; ;; 	  ;; the intention is to make sure nfs can read the file we just wrote, and make sure it was written by us, and not another process.
;; ;;            (if (and old-enough
;; ;; 		    (begin
;; ;;                       (debug:print-info 2 *default-log-port* "Writing " start-flag)
;; ;; 		      (with-output-to-file start-flag (lambda () (print server-key)))
;; ;; 		      (thread-sleep! 0.25)
;; ;; 		      (set! new-server-key (with-input-from-file start-flag (lambda () (read-line))))
;; ;; 		      (equal? server-key new-server-key)))
;; ;; 	       #t
;; ;;                ;; If either of the above conditions is not true, print a "Gating server start" message, wait <idle-time> + 1, then call this function recursively. 
;; ;; 	       (begin
;; ;; 		 (debug:print-info 0 *default-log-port* "Gating server start, last start: "
;; ;; 				   (seconds->time-string fmodtime) ", time since last start: " delta ", required idletime: " idletime ", gating reason:" (if old-enough "another job started a server" "too soon to start another server"))
;; ;; 		 

;; ;; 		 (thread-sleep! ( + 1 idletime))
;; ;; 		 (server:wait-for-server-start-last-flag areapath)))))))
;; ;; 
;; ;; ;; oldest server alive determines host then choose random of youngest
;; ;; ;; five servers on that host
;; ;; ;;
;; ;; (define (server:get-servers-info areapath)
;; ;;   ;; (assert *toppath* "FATAL: server:get-servers-info called before *toppath* has been set.")
;; ;;   (let* ((servinfodir (server:get-servinfo-dir areapath))) ;; (conc *toppath*"/.servinfo")))
;; ;;     (if (not (file-exists? servinfodir))
;; ;; 	(create-directory servinfodir))
;; ;;     (let* ((allfiles    (glob (conc servinfodir"/*")))
;; ;; 	   (res         (make-hash-table)))
;; ;;       (for-each
;; ;;        (lambda (f)
;; ;; 	 (let* ((hostport  (pathname-strip-directory f))
;; ;; 		(serverdat (server:logf-get-start-info f)))
;; ;; 	   (match serverdat
;; ;; 	     ((host port start server-id pid)
;; ;; 	      (if (and host port start server-id pid)
;; ;; 		  (hash-table-set! res hostport serverdat)
;; ;; 		  (debug:print-info 2 *default-log-port* "bad server info for "f": "serverdat)))
;; ;; 	     (else
;; ;; 	      (debug:print-info 2 *default-log-port* "bad server info for "f": "serverdat)))))
;; ;;        allfiles)
;; ;;       res)))
;; ;; 
;; ;; ;; check the .servinfo directory, are there other servers running on this
;; ;; ;; or another host?
;; ;; ;;
;; ;; ;; returns #t => ok to start another server
;; ;; ;;         #f => not ok to start another server
;; ;; ;;
;; ;; (define (server:minimal-check areapath)
;; ;;   (server:clean-up-old areapath)
;; ;;   (let* ((srvdir      (server:get-servinfo-dir areapath)) ;; (conc areapath"/.servinfo"))
;; ;; 	 (servrs      (glob (conc srvdir"/*")))
;; ;; 	 (thishostip  (server:get-best-guess-address (get-host-name)))
;; ;; 	 (thisservrs  (glob (conc srvdir"/"thishostip":*")))
;; ;; 	 (homehostinf (server:choose-server areapath 'homehost))
;; ;; 	 (havehome    (car homehostinf))
;; ;; 	 (wearehome   (cdr homehostinf)))
;; ;;     (debug:print-info 0 *default-log-port* thishostip", have homehost: "havehome", we are homehost: "wearehome
;; ;; 		      ", numservers: "(length thisservrs))
;; ;;     (cond
;; ;;      ((not havehome) #t) ;; no homehost yet, go for it
;; ;;      ((and havehome wearehome (< (length thisservrs) 20)) #t) ;; we are home and less than 20 servers, ok to start another
;; ;;      ((and havehome (not wearehome)) #f)     ;; we are not the home host
;; ;;      ((and havehome wearehome (>= (length thisservrs) 20)) #f) ;; have enough running
;; ;;      (else
;; ;;       (debug:print 0 *default-log-port* "WARNING: Unrecognised scenario, servrs="servrs", thishostip="thishostip", thisservrs="thisservrs)
;; ;;       #t))))
;; ;; 	 
;; ;; 
;; ;; (define server-last-start 0)
;; ;; 
;; ;; 
;; ;; ;; oldest server alive determines host then choose random of youngest
;; ;; ;; five servers on that host
;; ;; ;;
;; ;; ;; mode:
;; ;; ;;   best - get best server (random of newest five)
;; ;; ;;   home - get home host based on oldest server
;; ;; ;;   info - print info
;; ;; (define (server:choose-server areapath #!optional (mode 'best))
;; ;;   ;; age is current-starttime
;; ;;   ;; find oldest alive
;; ;;   ;;   1. sort by age ascending and ping until good
;; ;;   ;; find alive rand from youngest
;; ;;   ;;   1. sort by age descending
;; ;;   ;;   2. take five
;; ;;   ;;   3. check alive, discard if not and repeat
;; ;;   ;; first we clean up old server files
;; ;;   (server:clean-up-old areapath)
;; ;;   (let* ((since-last (- (current-seconds) server-last-start))
;; ;;         (server-start-delay 10))     

;; ;;     (if ( < (- (current-seconds) server-last-start) 10 )
;; ;;       (begin
;; ;;         (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
;; ;;         (debug:print 2 *default-log-port* "server:choose-server: last server start less than " server-start-delay " seconds ago. Sleeping " server-start-delay " seconds")
;; ;;         (thread-sleep! server-start-delay)
;; ;;       )
;; ;;       (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
;; ;;     )
;; ;;   )
;; ;;   (let* ((serversdat  (server:get-servers-info areapath))
;; ;; 	 (servkeys    (hash-table-keys serversdat))
;; ;; 	 (by-time-asc (if (not (null? servkeys)) ;; NOTE: Oldest is last
;; ;; 			  (sort servkeys ;; list of "host:port"
;; ;; 				(lambda (a b)
;; ;; 				  (>= (list-ref (hash-table-ref serversdat a) 2)
;; ;; 				      (list-ref (hash-table-ref serversdat b) 2))))
;; ;; 			  '())))
;; ;;     (debug:print 2 *default-log-port* "server:choose-server: serversdat: " serversdat)
;; ;;     (debug:print 2 *default-log-port* "server:choose-server: servkeys: " servkeys)
;; ;;     (if (not (null? by-time-asc))
;; ;; 	(let* ((oldest     (last by-time-asc))
;; ;; 	       (oldest-dat (hash-table-ref serversdat oldest))
;; ;; 	       (host       (list-ref oldest-dat 0))
;; ;; 	       (all-valid  (filter (lambda (x)
;; ;; 				     (equal? host (list-ref (hash-table-ref serversdat x) 0)))
;; ;; 				   by-time-asc))
;; ;; 	       (best-ten  (lambda ()
;; ;; 			     (if (> (length all-valid) 11)
;; ;; 				 (take (drop-right all-valid 1) 10) ;; remove the oldest from consideration so it can age out
;; ;; 				 (if (> (length all-valid) 8)
;; ;; 				     (drop-right all-valid 1)
;; ;; 				     all-valid))))
;; ;; 	       (names->dats (lambda (names)
;; ;; 			      (map (lambda (x)
;; ;; 				     (hash-table-ref serversdat x))
;; ;; 				   names)))
;; ;; 	       (am-home?    (lambda ()
;; ;; 			      (let* ((currhost (get-host-name))
;; ;; 				     (bestadrs (server:get-best-guess-address currhost)))
;; ;; 				(or (equal? host currhost)
;; ;; 				    (equal? host bestadrs))))))
;; ;; 	  (case mode
;; ;; 	    ((info)
;; ;; 	     (print "oldest: "oldest-dat", selected host: "host", all-valid: "all-valid)
;; ;; 	     (print "youngest: "(hash-table-ref serversdat (car all-valid))))
;; ;; 	    ((home)     host)
;; ;; 	    ((homehost) (cons host (am-home?))) ;; shut up old code
;; ;; 	    ((home?)    (am-home?))
;; ;; 	    ((best-ten)(names->dats (best-ten)))
;; ;; 	    ((all-valid)(names->dats all-valid))
;; ;; 	    ((best)     (let* ((best-ten (best-ten))
;; ;; 			       (len       (length best-ten)))
;; ;; 			  (hash-table-ref serversdat (list-ref best-ten (random len)))))
;; ;; 	    ((count)(length all-valid))
;; ;; 	    (else

;; ;; 	     (debug:print 0 *default-log-port* "ERROR: invalid command "mode)
;; ;; 	     #f)))
;; ;; 	(begin
;; ;; 	  (server:run areapath)
;; ;;           (set! server-last-start (current-seconds))
;; ;; 	  ;; (thread-sleep! 3)
;; ;; 	  (case mode
;; ;; 	    ((homehost) (cons #f #f))
;; ;; 	    (else	#f))))))
;; ;; 
;; ;; (define (server:get-servinfo-dir areapath)
;; ;;   (let* ((spath (conc areapath"/.servinfo")))
;; ;;     (if (not (file-exists? spath))
;; ;; 	(create-directory spath #t))
;; ;;     spath))
;; ;; 
;; ;; (define (server:clean-up-old areapath)
;; ;;   ;; any server file that has not been touched in ten minutes is effectively dead
;; ;;   (let* ((sfiles (glob (conc (server:get-servinfo-dir areapath)"/*"))))
;; ;;     (for-each

;; ;;      (lambda (sfile)
;; ;;        (let* ((modtime (handle-exceptions
;; ;; 			   exn
;; ;; 			 (begin
;; ;; 			   (debug:print 0 *default-log-port* "WARNING: failed to get modification file for "sfile)
;; ;; 			   (current-seconds))
;; ;; 			 (file-modification-time sfile))))
;; ;; 	 (if (and (number? modtime)
;; ;; 		  (> (- (current-seconds) modtime)
;; ;; 		     600))
;; ;; 	     (begin
;; ;; 	       (debug:print 0 *default-log-port* "WARNING: found old server info file "sfile", removing it.")
;; ;; 	       (handle-exceptions
;; ;; 		   exn
;; ;; 		 (debug:print 0 *default-log-port* "WARNING: failed to delete old server info file "sfile)
;; ;; 		 (delete-file sfile))))))
;; ;;      sfiles)))
;; ;; 
;; ;; ;; would like to eventually get rid of this
;; ;; ;;
;; ;; (define (common:on-homehost?)


;; ;;   (server:choose-server *toppath* 'home?))
;; ;; 
;; ;; ;; kind start up of server, wait before allowing another server for a given
;; ;; ;; area to be launched
;; ;; ;;
;; ;; (define (server:kind-run areapath)
;; ;;   ;; look for $MT_RUN_AREA_HOME/logs/server-start-last
;; ;;   ;; and wait for it to be at least <server idletime> seconds old
;; ;;   ;; (server:wait-for-server-start-last-flag areapath)
;; ;;   (let loop ()
;; ;;     (if (> (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)) 2)
;; ;; 	(begin
;; ;; 	  (if (common:low-noise-print 30 "our-host-load")
;; ;; 	      (debug:print 0 *default-log-port* "WARNING: system load is high, waiting to start server."))
;; ;; 	  (loop))))
;; ;;   (if (< (server:choose-server areapath 'count) 20)
;; ;;       (server:run areapath))
;; ;;   #;(if (not (server:check-if-running areapath)) ;; why try if there is already a server running?
;; ;;       (let* ((lock-file    (conc areapath "/logs/server-start.lock")))
;; ;; 	(let* ((start-flag (conc areapath "/logs/server-start-last")))
;; ;; 	  (common:simple-file-lock-and-wait lock-file expire-time: 25)
;; ;; 	  (debug:print-info  2 *default-log-port* "server:kind-run: touching " start-flag)
;; ;; 	  (system (conc "touch " start-flag)) ;; lazy but safe
;; ;; 	  (server:run areapath)
;; ;; 	  (thread-sleep! 20) ;; don't release the lock for at least a few seconds. And allow time for the server startup to get to "SERVER STARTED".
;; ;; 	  (common:simple-file-release-lock lock-file)))
;; ;;       (debug:print-info 0 *default-log-port* "Found server already running. NOT trying to start another.")))
;; ;; 
;; ;; ;; this one seems to be the general entry point
;; ;; ;;
;; ;; (define (server:start-and-wait areapath #!key (timeout 60))
;; ;;   (let ((give-up-time (+ (current-seconds) timeout)))
;; ;;     (let loop ((server-info (server:check-if-running areapath))
;; ;; 	       (try-num    0))
;; ;;       (if (or server-info
;; ;; 	      (> (current-seconds) give-up-time)) ;; server-url will be #f if no server available.
;; ;; 	  (server:record->url server-info)
;; ;; 	  (let* ( (servers (server:choose-server areapath 'all-valid))
;; ;;                 (num-ok (if servers (length (server:choose-server areapath 'all-valid)) 0)))
;; ;; 	    (if (and (> try-num 0)  ;; first time through simply wait a little while then try again
;; ;; 		     (< num-ok 1))  ;; if there are no decent candidates for servers then try starting a new one
;; ;; 		(server:run areapath))
;; ;; 	    (thread-sleep! 5)
;; ;; 	    (loop (server:check-if-running areapath)
;; ;; 		  (+ try-num 1)))))))
;; ;; 
;; ;; (define (server:get-num-servers #!key (numservers 2))
;; ;;   (let ((ns (string->number
;; ;; 	     (or (configf:lookup *configdat* "server" "numservers") "notanumber"))))
;; ;;     (or ns numservers)))


;; ;; 
;; ;; ;; no longer care if multiple servers are started by accident. older servers will drop off in time.
;; ;; ;;
;; ;; (define (server:check-if-running areapath) ;;  #!key (numservers "2"))
;; ;;   (let* ((ns            (server:get-num-servers)) ;; get the setting the for maximum number of servers allowed
;; ;; 	 (servers       (server:choose-server areapath 'best-ten))) ;; (server:get-best (server:get-list areapath))))
;; ;;     (if (or (and servers
;; ;; 		 (null? servers))


;; ;; 	    (not servers))




;; ;; 	    ;; (and (list? servers)

;; ;; 	    ;;	 (< (length servers) (+ 1 (random ns))))) ;; somewhere between 1 and numservers
;; ;;         #f
;; ;;         (let loop ((hed (car servers))
;; ;;                    (tal (cdr servers)))
;; ;;           (let ((res (server:check-server hed)))
;; ;;             (if res
;; ;;                 hed
;; ;;                 (if (null? tal)
;; ;;                     #f
;; ;;                     (loop (car tal)(cdr tal)))))))))
;; ;; 
;; ;; ;; ping the given server
;; ;; ;;
;; ;; (define (server:check-server server-record)
;; ;;   (let* ((server-url (server:record->url server-record))
;; ;;          (server-id  (server:record->id server-record)) 
;; ;;          (res        (server:ping server-url server-id)))
;; ;;     (if res
;; ;;         server-url
;; ;; 	#f)))
;; ;; 
;; ;; (define (server:kill servr)
;; ;;   (handle-exceptions
;; ;;     exn
;; ;;     (begin 
;; ;;       (debug:print-info 0 *default-log-port*  "Unable to get host and/or port from " servr ", exn=" exn)     
;; ;;     #f)
;; ;;   (match-let (((mod-time hostname port start-time server-id pid)
;; ;; 	       servr))
;; ;;     (tasks:kill-server hostname pid))))
;; ;; 
;; ;; ;; 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.
;; ;; ;;
;; ;; (define (server:ping host:port server-id #!key (do-exit #f))
;; ;;   (let* ((host-port (cond
;; ;; 		     ((string? host:port)
;; ;; 		      (let ((slst (string-split   host:port ":")))
;; ;; 			(if (eq? (length slst) 2)
;; ;; 			    (list (car slst)(string->number (cadr slst)))
;; ;; 			    #f)))
;; ;; 		     (else
;; ;; 		      #f))))
;; ;;     (cond
;; ;;      ((and (list? host-port)
;; ;; 	   (eq? (length host-port) 2))
;; ;;       (let* ((myrunremote (make-remote))
;; ;; 	     (iface       (car host-port))
;; ;; 	     (port        (cadr host-port))
;; ;; 	     (server-dat  (client:connect iface port server-id myrunremote))
;; ;; 	     (login-res   (rmt:login-no-auto-client-setup myrunremote)))
;; ;; 	(if (and (list? login-res)
;; ;; 		 (car login-res))
;; ;; 	    (begin
;; ;; 	      ;; (print "LOGIN_OK")
;; ;; 	      (if do-exit (exit 0))
;; ;; 	      #t)
;; ;; 	    (begin
;; ;; 	      ;; (print "LOGIN_FAILED")
;; ;; 	      (if do-exit (exit 1))
;; ;; 	      #f))))
;; ;;      (else 

;; ;;       (if host:port
;; ;; 	  (debug:print 0 *default-log-port*  "ERROR: bad host:port "host:port))
;; ;;       (if do-exit
;; ;; 	  (exit 1)
;; ;; 	  #f)))))
;; ;; 
;; ;; ;; run ping in separate process, safest way in some cases
;; ;; ;;
;; ;; (define (server:ping-server ifaceport)
;; ;;   (with-input-from-pipe 
;; ;;    (conc (common:get-megatest-exe) " -ping " ifaceport)
;; ;;    (lambda ()
;; ;;      (let loop ((inl (read-line))
;; ;; 		(res "NOREPLY"))
;; ;;        (if (eof-object? inl)
;; ;; 	   (case (string->symbol res)
;; ;; 	     ((NOREPLY)  #f)
;; ;; 	     ((LOGIN_OK) #t)
;; ;; 	     (else       #f))
;; ;; 	   (loop (read-line) inl))))))
;; ;; 
;; ;; ;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).
;; ;; ;;
;; ;; (define (server:login toppath)
;; ;;   (lambda (toppath)
;; ;;     (set! *db-last-access* (current-seconds)) ;; might not be needed.
;; ;;     (if (equal? *toppath* toppath)
;; ;; 	#t
;; ;; 	#f)))
;; ;; 
;; ;; ;; timeout is hms string: 1h 5m 3s, default is 1 minute
;; ;; ;; This is currently broken. Just use the number of hours with no unit.
;; ;; ;; Default is 60 seconds.
;; ;; ;;
;; ;; (define (server:expiration-timeout)
;; ;;   (let ((tmo (configf:lookup *configdat* "server" "timeout")))
;; ;;     (if (and (string? tmo)
;; ;; 	     (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
;; ;;         (* 3600 (string->number tmo))
;; ;; 	600)))
;; ;; 
;; ;; (define (server:get-best-guess-address hostname)
;; ;;   (let ((res #f))
;; ;;     (for-each 
;; ;;      (lambda (adr)
;; ;;        (if (not (eq? (u8vector-ref adr 0) 127))
;; ;; 	   (set! res adr)))
;; ;;      ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
;; ;;      (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
;; ;;     (string-intersperse 
;; ;;      (map number->string
;; ;; 	  (u8vector->list
;; ;; 	   (if res res (hostname->ip hostname)))) ".")))
;; ;; 
;; ;; ;; (define server:sync-lock-token "SERVER_SYNC_LOCK")
;; ;; ;; (define (server:release-sync-lock)
;; ;; ;;   (db:no-sync-del! *no-sync-db* server:sync-lock-token))
;; ;; ;; (define (server:have-sync-lock?)
;; ;; ;;   (let* ((have-lock-pair (db:no-sync-get-lock *no-sync-db* server:sync-lock-token))
;; ;; ;;          (have-lock?     (car have-lock-pair))
;; ;; ;;          (lock-time      (cdr have-lock-pair))
;; ;; ;;          (lock-age       (- (current-seconds) lock-time)))
;; ;; ;;     (cond
;; ;; ;;      (have-lock? #t)
;; ;; ;;      ((>lock-age
;; ;; ;;        (* 3 (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 180)))
;; ;; ;;       (server:release-sync-lock)
;; ;; ;;       (server:have-sync-lock?))
;; ;; ;;      (else #f))))
;; ;; 
;; ;; ;; moving this here as it needs access to db and cannot be in common.
;; ;; ;;
;; ;; 
;; ;; (define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
;; ;;   (debug:print "WARNING: bruteforce-syncer is called but has been disabled!")
;; ;;   (lambda ()
;; ;;     (debug:print "WARNING: bruteforce-syncer is called but has been disabled!"))
;; ;;   #;(let* ((sqlite-exe   (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
;; ;;          (sync-log     (or (args:get-arg "-sync-log") (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log")))
;; ;; 	 (tmp-area     (common:get-db-tmp-area))
;; ;; 	 (tmp-db       (conc tmp-area "/megatest.db"))
;; ;; 	 (staging-file (conc *toppath* "/.megatest.db"))
;; ;; 	 (mtdbfile     (conc *toppath* "/megatest.db"))
;; ;; 	 (lockfile     (common:get-sync-lock-filepath))
;; ;;          (sync-cmd-core     (conc sqlite-exe" " tmp-db " .dump | "sqlite-exe" " staging-file "&>"sync-log))
;; ;;          (sync-cmd     (if fork-to-background 
;; ;;                            (conc "/usr/bin/env NBFAKE_LOG="*toppath*"/logs/last-server-sync-"(current-process-id)".log nbfake \""sync-cmd-core" && /bin/mv -f " staging-file " " mtdbfile" \"")
;; ;;                            sync-cmd-core))
;; ;;          (default-min-intersync-delay 2)
;; ;; 	 (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: default-min-intersync-delay))
;; ;;          (default-duty-cycle 0.1)
;; ;;          (duty-cycle   (configf:lookup-number *configdat* "server" "sync-duty-cycle" default: default-duty-cycle))
;; ;;          (last-sync-seconds 10) ;; we will adjust this to a measurement and delay last-sync-seconds * (1 - duty-cycle)
;; ;;          (calculate-off-time (lambda (work-duration duty-cycle)
;; ;;                                   (* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds)))
;; ;;          (off-time min-intersync-delay) ;; adjusted in closure below.
;; ;;          (do-a-sync
;; ;;           (lambda ()
;; ;;             (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
;; ;;             (let* ((finalres
;; ;;                     (let retry-loop ((num-tries 0))
;; ;;                          (if (common:simple-file-lock lockfile)
;; ;; 	                     (begin
;; ;;                                (cond
;; ;;                                 ((not (or fork-to-background persist-until-sync))
;; ;;                                  (debug:print 0 *default-log-port* "INFO: syncer thread sleeping for max of (server.minimum-intersync-delay="min-intersync-delay
;; ;;                                               " , off-time="off-time" seconds ]")
;; ;;                                  (thread-sleep! (max off-time min-intersync-delay)))
;; ;;                                 (else
;; ;;                                  (debug:print 0 *default-log-port* "INFO: syncer thread NOT sleeping ; maybe time-to-exit...")))
;; ;; 
;; ;;                                (if (not (configf:lookup *configdat* "server" "disable-db-snapshot"))
;; ;;                                    (common:snapshot-file mtdbfile subdir: ".db-snapshot"))
;; ;; 		               (delete-file* staging-file)
;; ;; 		               (let* ((start-time (current-milliseconds))
;; ;;                                       (res (system sync-cmd))
;; ;;                                       (dbbackupfile (conc mtdbfile ".backup"))
;; ;;                                       (res2 
;; ;;                                        (cond
;; ;;                                         ((eq? 0 res )
;; ;;                                          (handle-exceptions
;; ;;                                             exn
;; ;;                                             #f
;; ;;                                          (if (file-exists? dbbackupfile)
;; ;; 		                           (delete-file* dbbackupfile)
;; ;;                                          )
;; ;;                                          (if (eq? 0 (file-size sync-log))
;; ;;                                              (delete-file* sync-log))
;; ;; 		                         (system (conc "/bin/mv " staging-file " " mtdbfile))
;; ;;                                          
;; ;;                                          (set! last-sync-seconds (/ (- (current-milliseconds) start-time) 1000))
;; ;;                                          (set! off-time (calculate-off-time
;; ;;                                                          last-sync-seconds
;; ;;                                                          (cond
;; ;;                                                           ((and (number? duty-cycle) (> duty-cycle 0) (< duty-cycle 1))
;; ;;                                                            duty-cycle)
;; ;;                                                           (else
;; ;;                                                            (debug:print 0 *default-log-port* "WARNING: ["(common:human-time)"] server.sync-duty-cycle is invalid.  Should be a number between 0 and 1, but "duty-cycle" was specified.  Using default value: "default-duty-cycle)
;; ;;                                                            default-duty-cycle))))
;; ;;                                          
;; ;;                                          (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec")
;; ;;                                          (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec ; with duty-cycle of "duty-cycle" off time is now "off-time)
;; ;;                                          'sync-completed))
;; ;;                                         (else
;; ;;                                          (system (conc "/bin/cp "sync-log" "sync-log".fail"))
;; ;;                                          (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail")
;; ;;                                          (if (file-exists? (conc mtdbfile ".backup"))
;; ;;                                              (system (conc "/bin/cp "mtdbfile ".backup " mtdbfile)))
;; ;;                                          #f))))
;; ;;                                  (common:simple-file-release-lock lockfile)
;; ;;                                  (BB> "released lockfile: " lockfile)
;; ;;                                  (when (common:file-exists? lockfile)
;; ;;                                    (BB> "DID NOT ACTUALLY RELEASE LOCKFILE"))
;; ;;                                  res2) ;; end let
;; ;;                                );; end begin
;; ;;                              ;; else
;; ;;                              (cond
;; ;;                               (persist-until-sync
;; ;;                                (thread-sleep! 1)
;; ;;                                (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; we're in a fork-to-background so we need to succeed.  Let's wait a jiffy and and try again. num-tries="num-tries" (waiting for lockfile="lockfile" to disappear)")
;; ;;                                (retry-loop (add1 num-tries)))
;; ;;                               (else
;; ;;                                (thread-sleep! (max off-time (+ last-sync-seconds min-intersync-delay)))
;; ;;                                (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.")
;; ;;                                'parallel-sync-in-progress))
;; ;;                              ) ;; end if got lockfile
;; ;;                          )
;; ;;                     ))
;; ;;               (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres)
;; ;;               finalres)
;; ;;             ) ;; end lambda
;; ;;           ))
;; ;;     do-a-sync))
;; ;; 
;; ;; 

)

This page was generated in about 0.132s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00