Megatest

Check-in [e035c43096]
Login
Overview
Comment:Merged v1.65 to trunk
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: e035c430960d006cf80d8a1fec597f3b032f665f
User & Date: matt on 2018-02-06 06:00:48
Other Links: manifest | tags
Context
2018-03-06
14:16
Merged v1.65 changes to trunk check-in: 4ac2e6a164 user: mrwellan tags: trunk
2018-02-06
06:00
Merged v1.65 to trunk check-in: e035c43096 user: matt tags: trunk
05:59
Rebuilt manual check-in: c57a166878 user: matt tags: v1.65
2018-01-30
15:58
Merged v1.65 into trunk check-in: 2a7aecb431 user: mrwellan tags: trunk
Changes

Modified Makefile from [79b5605b19] to [6f749a00c0].

1
2
3
4
5
6
7
8
9
10
# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
# rm <files>.o ; make install CSCOPTS='-profile' ; ... ;  chicken-profile | less

PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
   ods.scm runconfig.scm server.scm configf.scm \
   db.scm keys.scm margs.scm megatest-version.scm \
   process.scm runs.scm tasks.scm tests.scm genexample.scm \


|







1
2
3
4
5
6
7
8
9
10
# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
# rm <files>.o ; make install CSCOPTS='-profile' ; ... ;  chicken-profile | less
SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
   ods.scm runconfig.scm server.scm configf.scm \
   db.scm keys.scm margs.scm megatest-version.scm \
   process.scm runs.scm tasks.scm tests.scm genexample.scm \

Deleted batchsim/Makefile version [23dda389e9].

1
2
3
4
5
6
7
8
RUN=default.scm

all : batchsim
	./batchsim $(RUN)

batchsim : batchsim.scm
	csc batchsim.scm

<
<
<
<
<
<
<
<
















Deleted batchsim/batchsim.scm version [d5cdd008ec].

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
(use ezxdisp srfi-18)

(define *ezx* (ezx-init 650 650 "Batch simulator"))
(require-library ezxgui)
(define *green*  (make-ezx-color 0 1 0)) 
(define *black*  (make-ezx-color 0 0 0))
(define *grey*   (make-ezx-color 0.1 0.1 0.1))
(define *blue*   (make-ezx-color 0 0 1)) 
(define *cyan*   (make-ezx-color 0 1 1))
(define *green*  (make-ezx-color 0 1 0))
(define *purple* (make-ezx-color 1 0 1))
(define *red*    (make-ezx-color 1 0 0))
(define *white*  (make-ezx-color 1 1 1))
(define *yellow* (make-ezx-color 1 1 0))

(define *user-colors-palette*
  (list 
   *green*
   *blue*
   *cyan*
   *purple*
   *red*
   *yellow*
   *black*))

(define *dark-green* (get-color "dark-green"))
(define *brown*      (get-color "brown"))

(ezx-select-layer *ezx* 1)
(ezx-wipe-layer *ezx* 1)

;; (ezx-str-2d *ezx* 30 30 "Hello" *white*)
;; (ezx-fillrect-2d *ezx* 100 100 120 120 *brown*)
(ezx-redraw *ezx*)

(define *last-draw* (current-milliseconds))
(define *draw-delta* 40) ;; milliseconds between drawing

(define (wait-for-next-draw-time)
  (let* ((cm    (current-milliseconds))
	 (delta (- *draw-delta* (- cm *last-draw*))))
    (if (> delta 0)
	(thread-sleep! (/ delta 1000)))
    (set! *last-draw* (current-milliseconds))))

(include "events.scm")

;; System spec (to be moved into loaded file)
;;
;;                           x  y  w gap  x-min x-max
(define *cpu-grid* (vector  500 50 15  2  500   600))
(define (make-cpu:grid)(make-vector 6))
(define *queues* (make-hash-table)) ;; name -> (list (list user duration num-cpus num-gigs) ... )
(define *cpus* (make-hash-table)) ;; cpu-name => (vector user job-len num-cpu mem x-loc y-loc)
(define *obj-locations* (make-hash-table)) ;; name -> (x y layer)
(define *queue-spec*
  (vector
   80  ;; start-x
   300 ;; start-y
   300 ;; delta-y how far to next queue
   15  ;; height
   400 ;; length
   ))
(define *use-log* #f)
(define *job-log-scale* 10)

;;======================================================================
;; CPU
;;======================================================================

(define-record cpu name num-cores mem job x y)

;;======================================================================
;; CPU Pool
;;======================================================================

(define-record pool name x y w h gap boxw cpus delta nrows ncols cpunum)

(define (new-pool name x y nrows ncols gap boxw)
  (let* ((delta (+ gap boxw))
	 ;; (nrows (quotient h (+ gap delta)))
	 ;; (ncols (quotient w (+ gap delta)))
	 (w     (+ gap (* nrows delta)))
	 (h     (+ gap (* ncols delta)))
	 (cpus  (make-vector (* nrows ncols) #f))
	 (npool (make-pool name x y w h gap boxw cpus delta nrows ncols 0)))
    npool))

(define (pool:add-cpu pool name num-cores mem)
  (let* ((cpu (make-cpu name num-cores mem #f #f #f)))
    (vector-set! (pool-cpus pool)(pool-cpunum pool) cpu)
    (pool-cpunum-set! pool (+ 1 (pool-cpunum pool)))
    cpu))

(define (pool:draw ezx pool)
  (let ((nrows (pool-nrows pool))
	(ncols (pool-ncols pool))
	(x     (pool-x     pool))
	(y     (pool-y     pool))
	(w     (pool-w     pool))
	(h     (pool-h     pool))
	(gap   (pool-gap   pool))
	(boxw  (pool-boxw  pool))
	(delta (pool-delta pool))
	(cpus  (pool-cpus  pool)))
    (ezx-select-layer ezx 1)
    ;(ezx-wipe-layer   ezx 1)
    ;; draw time at upper right
    (ezx-str-2d ezx x y (pool-name pool) *black*)
    (ezx-rect-2d ezx x y (+ x w)(+ y h) *black* 1)
    (let loop ((row    0)
	       (col    0)
	       (cpunum 0))
      (let* ((cpu  (vector-ref cpus cpunum))
	     (xval (+ x gap (* row delta)))
	     (yval (+ y gap (* col delta))))
	(if cpu
	    (begin
	      (cpu-x-set! cpu xval)
	      (cpu-y-set! cpu yval))
	    (vector-set! cpus cpunum (make-cpu (conc cpunum) 1 1 #f xval yval)))
	;; (print "box at " xval ", " yval)
	(ezx-rect-2d ezx xval yval (+ xval boxw) (+ yval boxw) *grey* 1)
	(if (< col (- ncols 1))
	    (loop row (+ col 1)(+ cpunum 1))
	    (if (< row (- nrows 1))
		(loop (+ row 1) 0 (+ cpunum 1))))))
    (ezx-redraw ezx)))
	       

;;======================================================================
;; Users
;;======================================================================

(define *user-colors* (make-hash-table))

(define (get-user-color user)
  (let ((color (hash-table-ref/default *user-colors* user #f)))
    (if color
	color
	(let* ((color-num (+ (length (hash-table-keys *user-colors*)) 1))
	       (color     (list-ref *user-colors-palette* color-num)))
	  (hash-table-set! *user-colors* user color)
	  color))))

;;======================================================================
;; Job Queues
;;======================================================================

;; jobs

(define (make-queue:job)(make-vector 4))
(define-inline (queue:job-get-user       vec)    (vector-ref  vec 0))
(define-inline (queue:job-get-duration   vec)    (vector-ref  vec 1))
(define-inline (queue:job-get-num-cpu    vec)    (vector-ref  vec 2))
(define-inline (queue:job-get-num-gigs   vec)    (vector-ref  vec 3))
(define-inline (queue:job-set-user!      vec val)(vector-set! vec 0 val))
(define-inline (queue:job-set-duration!  vec val)(vector-set! vec 1 val))
(define-inline (queue:job-set-num-cpu!   vec val)(vector-set! vec 2 val))
(define-inline (queue:job-set-num-gigs!  vec val)(vector-set! vec 3 val))

;; add a job to the queue
;;
(define (add-job queue-name user duration num-cpu num-gigs)
  (let* ((queue-dat (hash-table-ref/default *queues* queue-name '()))
	 (new-queue (append 
		     queue-dat
		     (list (vector user duration num-cpu num-gigs)))))
  (hash-table-set! *queues* queue-name new-queue)
  (draw-queue-jobs queue-name)))

;; peek for jobs to do in queue
;;
(define (peek-job queue-name)
  (let ((queue (hash-table-ref/default *queues* queue-name '())))
    (if (null? queue)
	#f
	(car queue))))

;; take job from queue
;;
(define (take-job queue-name)
  (let ((queue (hash-table-ref/default *queues* queue-name '())))
    (if (null? queue)
	#f
	(begin
	  (hash-table-set! *queues* queue-name (cdr queue))
	  (draw-queue-jobs queue-name)
	  (car queue)))))

;;======================================================================
;; CPUs
;;======================================================================

(define (make-cpu:dat)(make-vector 6 #f))
(define-inline (cpu:dat-get-user      vec)    (vector-ref  vec 0))
(define-inline (cpu:dat-get-job-len   vec)    (vector-ref  vec 1))
(define-inline (cpu:dat-get-num-cpu   vec)    (vector-ref  vec 2))
(define-inline (cpu:dat-get-mem       vec)    (vector-ref  vec 3))
(define-inline (cpu:dat-get-x         vec)    (vector-ref  vec 4))
(define-inline (cpu:dat-get-y         vec)    (vector-ref  vec 5))
(define-inline (cpu:dat-set-user!     vec val)(vector-set! vec 0 val))
(define-inline (cpu:dat-set-job-len!  vec val)(vector-set! vec 1 val))
(define-inline (cpu:dat-set-num-cpu!  vec val)(vector-set! vec 2 val))
(define-inline (cpu:dat-set-mem!      vec val)(vector-set! vec 3 val))
(define-inline (cpu:dat-set-x!        vec val)(vector-set! vec 4 val))
(define-inline (cpu:dat-set-y!        vec val)(vector-set! vec 5 val))

(define-inline (cpu:grid-get-x        vec)    (vector-ref  vec 0))
(define-inline (cpu:grid-get-y        vec)    (vector-ref  vec 1))
(define-inline (cpu:grid-get-w        vec)    (vector-ref  vec 2))
(define-inline (cpu:grid-get-gap      vec)    (vector-ref  vec 3))
(define-inline (cpu:grid-get-x-min    vec)    (vector-ref  vec 4))
(define-inline (cpu:grid-get-x-max    vec)    (vector-ref  vec 5))
(define-inline (cpu:grid-set-x!       vec val)(vector-set! vec 0 val))
(define-inline (cpu:grid-set-y!       vec val)(vector-set! vec 1 val))
(define-inline (cpu:grid-set-w!       vec val)(vector-set! vec 2 val))
(define-inline (cpu:grid-set-gap!     vec val)(vector-set! vec 3 val))
(define-inline (cpu:grid-set-x-min!   vec val)(vector-set! vec 4 val))
(define-inline (cpu:grid-set-x-max!   vec val)(vector-set! vec 5 val))

(define (add-cpu name num-cores mem)
  (let ((x     (cpu:grid-get-x     *cpu-grid*))
	(y     (cpu:grid-get-y     *cpu-grid*))
	(delta (+ (cpu:grid-get-w  *cpu-grid*)(cpu:grid-get-gap *cpu-grid*)))
	(x-max (cpu:grid-get-x-max *cpu-grid*)))
    (hash-table-set! *cpus* name (vector #f #f num-cores mem x y))
    (if (> x x-max)
	(begin
	  (cpu:grid-set-x! *cpu-grid* (cpu:grid-get-x-min *cpu-grid*))
	  (cpu:grid-set-y! *cpu-grid* (+ y delta)))
	(cpu:grid-set-x! *cpu-grid* (+ x delta)))))

;; draw grey box for each cpu on layer 2
;; jobs are drawn on layer 1
;;
(define (draw-cpus) ;; call once after init'ing all cpus
  (ezx-select-layer *ezx* 1)
  (ezx-wipe-layer   *ezx* 1)
  ;; draw time at upper right
  (ezx-str-2d *ezx* 20 20 (seconds->h:m:s *now*) *black*)
  (for-each
   (lambda (cpu)
     (let ((x (cpu:dat-get-x cpu))
	   (y (cpu:dat-get-y cpu))
	   (w (cpu:grid-get-w *cpu-grid*)))
       (ezx-rect-2d *ezx* x y (+ x w) (+ y w) *grey* 1)))
   (hash-table-values *cpus*))
  (ezx-redraw *ezx*))

(define (draw-jobs)
  ;; (draw-cpus)
  (ezx-select-layer *ezx* 2)
  (ezx-wipe-layer   *ezx* 2)
  (for-each
   (lambda (cpu)
     (let* ((x (cpu:dat-get-x cpu))
	    (y (cpu:dat-get-y cpu))
	    (w (cpu:grid-get-w *cpu-grid*))
	    (u (cpu:dat-get-user cpu)))
       (if u ;; job running if not #f
	   (let ((color (get-user-color u)))
	     (ezx-fillrect-2d *ezx* (+ x 2)(+ 2 y)(+ x 9) (+ y 9) color)))))
   (hash-table-values *cpus*))
  (ezx-redraw *ezx*))

(define (end-job cpu-name user)
  (let ((cpu (hash-table-ref/default *cpus* cpu-name #f)))
    (if cpu
	(let ((curr-user (cpu:dat-get-user cpu))) ;; if it is a user name then job is not done - error
	  (if (or (not curr-user)
		  (not (equal? curr-user user)))
	      (print "ERROR: cpu " cpu-name " not running job for " user "!")
	      (begin
		(cpu:dat-set-user!    cpu #f)
		(cpu:dat-set-job-len! cpu #f)
		(draw-jobs)))) ;; hash-table-set! *cpus* cpu-name (make-cpu:dat))))
	(print "ERROR: no cpu " cpu-name " found. Ensure it is registered before addressing it."))))

(define (run-job cpu-name job)
  (let* ((user    (queue:job-get-user     job))
	 (job-len (queue:job-get-duration job))
	 (cpu     (hash-table-ref/default *cpus* cpu-name #f)))
    (if cpu
	(let ((curr-user (cpu:dat-get-user cpu))) ;; if it is a user name then job is not done - error
	  (if curr-user
	      (begin
		(print "ERROR: cpu already busy! Adding more jobs not supported yet. " cpu-name)
		#f)
	      (begin
		(cpu:dat-set-user!    cpu user)
		(cpu:dat-set-job-len! cpu job-len)
		(draw-jobs)
		(hash-table-set! *cpus* cpu-name cpu)
		(event (+ *now* job-len) (lambda ()(end-job cpu-name user)))
		#t)))
	#f)))
    
(define (get-cpu)
  (let ((all-cpus (hash-table-keys *cpus*)))
    (if (null? all-cpus) 
	#f
	(let loop ((hed (car all-cpus))
		   (tal (cdr all-cpus)))
	  (if (cpu:dat-get-user (hash-table-ref/default *cpus* hed '(#f #f))) ;; if user is #f then cpu is available
	      (if (null? tal)
		  #f
		  (loop (car tal)(cdr tal)))
	      hed)))))
  
;;======================================================================
;; Animation
;;======================================================================

;; make-vector-record  queue spec x y delta-y height length
(define (make-queue:spec)(make-vector 5))
(define-inline (queue:spec-get-x         vec)    (vector-ref  vec 0))
(define-inline (queue:spec-get-y         vec)    (vector-ref  vec 1))
(define-inline (queue:spec-get-delta-y   vec)    (vector-ref  vec 2))
(define-inline (queue:spec-get-height    vec)    (vector-ref  vec 3))
(define-inline (queue:spec-get-length    vec)    (vector-ref  vec 4))
(define-inline (queue:spec-set-x!        vec val)(vector-set! vec 0 val))
(define-inline (queue:spec-set-y!        vec val)(vector-set! vec 1 val))
(define-inline (queue:spec-set-delta-y!  vec val)(vector-set! vec 2 val))
(define-inline (queue:spec-set-height!   vec val)(vector-set! vec 3 val))
(define-inline (queue:spec-set-length!   vec val)(vector-set! vec 4 val))

;; queues are drawn on layer 3 but boxes (jobs) are drawn on the numbered layer
;;
(define (draw-queues)
  (let* ((text-offset 3)
	 (queue-names (sort (hash-table-keys *queues*) string>=?))
	 (start-x (vector-ref *queue-spec* 0))
	 (text-x  (+ start-x text-offset))
	 (delta-y (vector-ref *queue-spec* 1))
	 (delta-x (vector-ref *queue-spec* 2))
	 (height  (vector-ref *queue-spec* 3))
	 (length  (vector-ref *queue-spec* 4))
	 (end-x   (+ start-x length)))
    (ezx-select-layer *ezx* 3)
    (ezx-wipe-layer   *ezx* 3)
    (let loop ((y       (vector-ref *queue-spec* 1))
	       (qname   (car queue-names))
	       (tail    (cdr queue-names))
	       (layer   4))
      (print "Drawing queue at x=" start-x ", y=" y)
      (ezx-fillrect-2d  *ezx* start-x y end-x (+ y height) *brown*)
      (ezx-str-2d       *ezx* text-x (- (+ y height) text-offset) qname *white*)
      (hash-table-set! *obj-locations* qname (list start-x y layer))
      (if (not (null? tail))
	  (loop (+ y height delta-y)
		(car tail)
		(cdr tail)
		(+  layer 1))))
    (ezx-redraw *ezx*)))

;; compress queue data to (vector user count) list
;;
(define (draw-queue-compress-queue-data queue-dat)
  (let loop ((hed  (car queue-dat))
	     (tal  (cdr queue-dat))
	     (curr #f) ;; (vector name count)
	     (res  '()))
    (let ((user (queue:job-get-user hed)))
      (cond
       ((not curr) ;; first time through only?
	(if (null? tal)
	    (append res (list (vector user 1)))
	    (loop (car tal)(cdr tal)(vector user 1) res)))
       ((equal? (vector-ref curr 0) user) 
	(vector-set! curr 1 (+ (vector-ref curr 1) 1))
	(if (null? tal)
	    (append res (list curr))
	    (loop (car tal)(cdr tal) curr res)))
       (else ;; names are different, add curr to queue and create new curr
	(let ((newcurr (vector user 1)))
	  (if (null? tal)
	      (append res (list newcurr))
	      (loop (car tal)(cdr tal) newcurr (append res (list curr))))))))))

;; draw jobs for a given queue
;;
(define (draw-queue-jobs queue-name)
  (let* ((queue-dat (hash-table-ref/default *queues*        queue-name #f))  ;; list of jobs in the queue
	 (obj-spec  (hash-table-ref/default *obj-locations* queue-name #f)))  ;; x, y etc. of the drawn queue
    (if obj-spec
	(let ((origin-x  (list-ref obj-spec 0))
	      (origin-y  (list-ref obj-spec 1))
	      (bar-width 10)
	      (queue-len (queue:spec-get-length *queue-spec*))
	      (layer     (list-ref obj-spec 2)))
	  (ezx-select-layer *ezx* layer)
	  (ezx-wipe-layer   *ezx* layer)
	  (if (not (null? queue-dat))
	      (let ((res (draw-queue-compress-queue-data queue-dat)))
		(if (not (null? res))
		    (let loop ((hed (car res))
			       (tal (cdr res))
			       (x2   (+ origin-x queue-len)))
		      (let* ((user (vector-ref hed 0))
			     (h    (let ((numjobs (vector-ref hed 1)))
				     (if *use-log*
					 (inexact->exact (round (log (+ 1 (* *job-log-scale* numjobs)))))
					 numjobs)))
			     (x1   (- x2  bar-width))
			     (y2   (- origin-y h)))
			;; (print "x1 " x1 ", origin-y " origin-y ", x2 " x2 ", y2 " y2)
			(ezx-fillrect-2d *ezx* x1 y2 x2 origin-y (get-user-color user))
			(if (not (null? tal))
			    (loop (car tal)(cdr tal) x1)))))
		(ezx-redraw *ezx*)))))))
	  
(let* ((args  (argv))
       (fname (if (> (length args) 1)
		  (cadr args)
 		  "default.scm")))
  (load (if (file-exists? fname) fname "default.scm")))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted batchsim/default.scm version [6d3b9494d2].

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
;; run sim for four hours
;;
(define *end-time* (* 60 50))

;; create the cpus
;;
(let loop ((count 200))
  (add-cpu (conc "cpu_" count) 1 1)
  (if (>= count 0)(loop (- count 1))))

(draw-cpus)

(define *pool1* (new-pool "generic" 100 100 100 100 2 10))
(let loop ((count 10))
  (pool:add-cpu *pool1* (conc count) 1 1)
  (if (> count 0)
      (loop (- count 1))))

(pool:draw *ezx* *pool1*)

;; init the queues
;;
(hash-table-set! *queues* "normal" '())
(hash-table-set! *queues* "quick"  '())
(draw-queues)

;; user k adds 200 jobs at time zero
;;
(event *start-time*
       (lambda ()
	 (let loop ((count 300)) ;; add 500 jobs
	   (add-job "normal" "k" 600 1 1)
	   (if (>= count 0)(loop (- count 1))))))

;; one minute in user m runs ten jobs
;;
(event (+ 600 *start-time*)
       (lambda ()
	 (let loop ((count 300)) ;; add 100 jobs
	   (add-job "normal" "m" 600 1 1)
	   (if (> count 0)(loop (- count 1))))))

;; every minute user j runs ten jobs
;;
(define *user-j-jobs* 300)
(event (+ 600 *start-time*)
       (lambda ()
	 (let f ()
	   (schedule 60)
	   (if (> *user-j-jobs* 0)
	       (begin
		 (let loop ((count 5)) ;; add 100 jobs
		   (add-job "quick" "j" 600 1 1)
		   (if (> count 0)(loop (- count 1))))
		 (set! *user-j-jobs* (- *user-j-jobs* 5))))
	   (if (and (not *done*)
		    (> *user-j-jobs* 0))
	       (f))))) ;; Megatest user running 200 jobs

;; every minute user j runs ten jobs
;;
(define *user-j-jobs* 300)
(event (+ 630 *start-time*)
       (lambda ()
	 (let f ()
	   (schedule 60)
	   (if (> *user-j-jobs* 0)
	       (begin
		 (let loop ((count 5)) ;; add 100 jobs
		   (add-job "quick" "n" 600 1 1)
		   (if (> count 0)(loop (- count 1))))
		 (set! *user-j-jobs* (- *user-j-jobs* 5))))
	   (if (and (not *done*)
		    (> *user-j-jobs* 0))
	       (f))))) ;; Megatest user running 200 jobs

;; ;;
;; (event *start-time*
;;        (lambda ()
;; 	 (let f ((count 200))
;; 	   (schedule 10)
;; 	   (add-job "normal" "t" 60 1 1)
;; 	   (if (and (not *done*)
;; 		    (>= count 0))
;; 	       (f (- count 1))))))

;; every 3 seconds check for available machines and launch a job
;;
(event *start-time*
       (lambda ()
	 (let f ()
	   (schedule 3)
	   (let ((queue-names (random-sort (hash-table-keys *queues*))))
	     (let loop ((cpu   (get-cpu))
			(count (+ (length queue-names) 4))
			(qname (car queue-names))
			(remq  (cdr queue-names)))
	       (if (and cpu
			(> count 0))
		   (begin
		     (if (peek-job qname) ;; any jobs to do in normal queue
			 (let ((job (take-job qname)))
			   (run-job cpu job)))
		     (loop (get-cpu)
			   (- count 1)
			   (if (null? remq)
			       (car queue-names)
			       (car remq))
			   (if (null? remq)
			       (cdr queue-names)
			       (cdr remq)))))))
	   (if (not *done*)(f)))))

;; screen updates
;;
(event *start-time* (lambda ()
		      (let f ()
			(schedule 60) ;; update the screen every 60 seconds of sim time
			(draw-cpus) ;; (print "Now: " *now* " queue: " (hash-table->alist *queues*))
			(wait-for-next-draw-time)
			(if (not *done*) (f)))))


;; end the simulation
;;
(event *end-time*
       (lambda () 
	 (set! *event-list* '())
	 (set! *done* #t)))

(start)
;; (exit 0)

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































Deleted batchsim/events.scm version [65f06322e9].

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

;;======================================================================
;; Event Processing and Simulator
;;======================================================================

;; The global event list
(define *event-list* '())
(define *start-time* 0)
(define *end-time*   (* 60 60 4)) ;; four hours
(define *now*        *start-time*)
(define *done*       #f)

(define (random-sort l)
  (sort l
        (lambda (x y)
          (equal? 0 (random 2))))) 
				    
;; Each item in the event list is a list of a scheduled time and the thunk
;; (time thunk). Sort the list so that the next event is the earliest.
;;
(define event-sort
  (lambda (@a @b)
    (< (car @a)(car @b))))

(define event
  (lambda ($time $thunk)  ;; add a sort based on scheduled time here -- improve later
                          ;; to use an insert algorythm.
    (set! *event-list* (sort (cons (list $time $thunk) *event-list*) event-sort))))

(define start
  (lambda ()
    (let ((next (car *event-list*)))
      (set! *event-list* (cdr *event-list*))
      (set! *now* (car next))      
      (if (not *done*) ;; note that the second item in the list is the thunk
	  ((car (cdr next)))))))

(define pause
  (lambda ()
    (call/cc 
     (lambda (k)
       (event (lambda () (k #f)))
       (start)))))

(define schedule
  (lambda ($time)
    (call/cc 
     (lambda (k)
       (event (+ *now* $time) (lambda () (k #f)))
       (start)))))

;; (event (lambda () (let f () (pause) (display "h") (f))))

(define years->seconds
  (lambda ($yrs)
    (* $yrs 365 24 3600)))

(define weeks->seconds
  (lambda ($wks)
    (* $wks 7 24 3600)))

(define days->seconds
  (lambda ($days)
    (* $days 24 3600)))

(define months->seconds
  (lambda ($months)
    (* $months (/ 365 12) 24 3600)))

(define seconds->date
  (lambda ($seconds)
    (posix-strftime "%D" (posix-localtime (inexact->exact $seconds)))))

(define (seconds->h:m:s seconds)
  (let* ((hours   (quotient seconds 3600))
	 (rem1    (- seconds (* hours 3600)))
	 (minutes (quotient rem1 60))
	 (rem-sec (- rem1 (* minutes 60))))
    (conc hours "h " minutes "m " rem-sec "s")))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































Deleted batchsim/testing.scm version [c6005591aa].

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
;; run sim for four hours
;;
(define *end-time* (* 60 50))

;; create the cpus
;;
(let loop ((count 200))
  (add-cpu (conc "cpu_" count) 1 1)
  (if (>= count 0)(loop (- count 1))))

;; (draw-cpus)

(define *pool1* (new-pool "generic" 20 20 12 80 2 4))
(let loop ((count 10))
  (pool:add-cpu *pool1* (conc count) 1 1)
  (if (> count 0)
      (loop (- count 1))))

(pool:draw *ezx* *pool1*)

;; ;; init the queues
;; ;;
;; (hash-table-set! *queues* "normal" '())
;; (hash-table-set! *queues* "quick"  '())
;; (draw-queues)
;; 
;; ;; user k adds 200 jobs at time zero
;; ;;
;; (event *start-time*
;;        (lambda ()
;; 	 (let loop ((count 300)) ;; add 500 jobs
;; 	   (add-job "normal" "k" 600 1 1)
;; 	   (if (>= count 0)(loop (- count 1))))))
;; 
;; ;; one minute in user m runs ten jobs
;; ;;
;; (event (+ 600 *start-time*)
;;        (lambda ()
;; 	 (let loop ((count 300)) ;; add 100 jobs
;; 	   (add-job "normal" "m" 600 1 1)
;; 	   (if (> count 0)(loop (- count 1))))))
;; 
;; ;; every minute user j runs ten jobs
;; ;;
;; (define *user-j-jobs* 300)
;; (event (+ 600 *start-time*)
;;        (lambda ()
;; 	 (let f ()
;; 	   (schedule 60)
;; 	   (if (> *user-j-jobs* 0)
;; 	       (begin
;; 		 (let loop ((count 5)) ;; add 100 jobs
;; 		   (add-job "quick" "j" 600 1 1)
;; 		   (if (> count 0)(loop (- count 1))))
;; 		 (set! *user-j-jobs* (- *user-j-jobs* 5))))
;; 	   (if (and (not *done*)
;; 		    (> *user-j-jobs* 0))
;; 	       (f))))) ;; Megatest user running 200 jobs
;; 
;; ;; every minute user j runs ten jobs
;; ;;
;; (define *user-j-jobs* 300)
;; (event (+ 630 *start-time*)
;;        (lambda ()
;; 	 (let f ()
;; 	   (schedule 60)
;; 	   (if (> *user-j-jobs* 0)
;; 	       (begin
;; 		 (let loop ((count 5)) ;; add 100 jobs
;; 		   (add-job "quick" "n" 600 1 1)
;; 		   (if (> count 0)(loop (- count 1))))
;; 		 (set! *user-j-jobs* (- *user-j-jobs* 5))))
;; 	   (if (and (not *done*)
;; 		    (> *user-j-jobs* 0))
;; 	       (f))))) ;; Megatest user running 200 jobs
;; 
;; ;; ;;
;; ;; (event *start-time*
;; ;;        (lambda ()
;; ;; 	 (let f ((count 200))
;; ;; 	   (schedule 10)
;; ;; 	   (add-job "normal" "t" 60 1 1)
;; ;; 	   (if (and (not *done*)
;; ;; 		    (>= count 0))
;; ;; 	       (f (- count 1))))))
;; 
;; ;; every 3 seconds check for available machines and launch a job
;; ;;
;; (event *start-time*
;;        (lambda ()
;; 	 (let f ()
;; 	   (schedule 3)
;; 	   (let ((queue-names (random-sort (hash-table-keys *queues*))))
;; 	     (let loop ((cpu   (get-cpu))
;; 			(count (+ (length queue-names) 4))
;; 			(qname (car queue-names))
;; 			(remq  (cdr queue-names)))
;; 	       (if (and cpu
;; 			(> count 0))
;; 		   (begin
;; 		     (if (peek-job qname) ;; any jobs to do in normal queue
;; 			 (let ((job (take-job qname)))
;; 			   (run-job cpu job)))
;; 		     (loop (get-cpu)
;; 			   (- count 1)
;; 			   (if (null? remq)
;; 			       (car queue-names)
;; 			       (car remq))
;; 			   (if (null? remq)
;; 			       (cdr queue-names)
;; 			       (cdr remq)))))))
;; 	   (if (not *done*)(f)))))
;; 
;; ;; screen updates
;; ;;
(event *start-time* (lambda ()
		      (let f ()
			(schedule 60) ;; update the screen every 60 seconds of sim time
			;; (draw-cpus) ;; (print "Now: " *now* " queue: " (hash-table->alist *queues*))
			(pool:draw *ezx* *pool1*)

			(wait-for-next-draw-time)
			(if (not *done*) (f)))))
;; 
;; 
;; ;; end the simulation
;; ;;
(event *end-time*
       (lambda () 
	 (set! *event-list* '())
	 (set! *done* #t)))
;; 
(start)
;; ;; (exit 0)
;; 
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































Modified common.scm from [16edb8a716] to [9660178c65].

459
460
461
462
463
464
465



466
467
468
469
470
471
472
	  (common:to-alist (cdr dat))))
   ((hash-table? dat)
    (map common:to-alist (hash-table->alist dat)))
   (else
    (if dat
	dat
	""))))




(define (common:low-noise-print waitval . keys)
  (let* ((key      (string-intersperse (map conc keys) "-" ))
	 (lasttime (hash-table-ref/default *common:denoise* key 0))
	 (currtime (current-seconds)))
    (if (> (- currtime lasttime) waitval)
	(begin







>
>
>







459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
	  (common:to-alist (cdr dat))))
   ((hash-table? dat)
    (map common:to-alist (hash-table->alist dat)))
   (else
    (if dat
	dat
	""))))

(define (common:alist-ref/default key alist default)
  (or (alist-ref key alist) default))

(define (common:low-noise-print waitval . keys)
  (let* ((key      (string-intersperse (map conc keys) "-" ))
	 (lasttime (hash-table-ref/default *common:denoise* key 0))
	 (currtime (current-seconds)))
    (if (> (- currtime lasttime) waitval)
	(begin
1361
1362
1363
1364
1365
1366
1367























1368
1369
1370
1371
1372
1373
1374
	      (loop (car tal)
		    (cdr tal)
		    new-rownames
		    new-colnames
		    (if (> curr-rownum rownum) curr-rownum rownum)
		    (if (> curr-colnum colnum) curr-colnum colnum)
		    ))))))
























;;======================================================================
;; S Y S T E M   S T U F F
;;======================================================================

;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
;;







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







1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
	      (loop (car tal)
		    (cdr tal)
		    new-rownames
		    new-colnames
		    (if (> curr-rownum rownum) curr-rownum rownum)
		    (if (> curr-colnum colnum) curr-colnum colnum)
		    ))))))

;; if it looks like a number -> convert it to a number, else return it
;;
(define (common:lazy-convert inval)
  (let* ((as-num (if (string? inval)(string->number inval) #f)))
    (or as-num inval)))

;; convert string a=1; b=2; c=a silly thing; d=
;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
;;
(define (common:val->alist val #!key (convert #f))
  (let ((val-list (string-split-fields ";\\s*" val #:infix)))
    (if val-list
	(map (lambda (x)
	       (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
		 (case (length f)
		   ((0) `(,#f))  ;; null string case
		   ((1) `(,(string->symbol (car f))))
		   ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f)))
							 (if convert (common:lazy-convert inval) inval))))
		   (else f))))
	     val-list)
	'())))

;;======================================================================
;; S Y S T E M   S T U F F
;;======================================================================

;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
;;
1424
1425
1426
1427
1428
1429
1430
1431




























1432
1433
1434


1435
1436
1437
1438
1439
1440
1441
1442


1443
1444
1445
1446
1447
1448


1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479

1480
1481
1482
1483
1484
1485
1486
1487


1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531

1532



1533
1534
1535
1536
1537
1538
1539
;; 		(let ((match (string-search load-rx l)))
;; 		  (if match
;; 		      (let ((newval (string->number (cadr match))))
;; 			(if (number? newval)
;; 			    (set! cpu-load newval))))))
;; 	      (car load-res))
;;     cpu-load))





























;; get cpu load by reading from /proc/loadavg, return all three values
;;
(define (common:get-cpu-load remote-host)


  (if remote-host
      (map (lambda (res)
	     (if (eof-object? res) 9e99 res))
	   (with-input-from-pipe 
	    (conc "ssh " remote-host " cat /proc/loadavg")
	    (lambda ()(list (read)(read)(read)))))
      (with-input-from-file "/proc/loadavg" 
	(lambda ()(list (read)(read)(read))))))



;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads
;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc.
;;  keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load
;;
(define (common:get-normalized-cpu-load remote-host)


  (let ((data (if remote-host
                  (with-input-from-pipe 
                   (conc "ssh " remote-host " cat /proc/loadavg;cat /proc/cpuinfo;echo end")
                   read-lines)
                  (append 
                   (with-input-from-file "/proc/loadavg" 
                     read-lines)
                   (with-input-from-file "/proc/cpuinfo"
                     read-lines)
                   (list "end"))))
        (load-rx  (regexp "^([\\d\\.]+)\\s+([\\d\\.]+)\\s+([\\d\\.]+)\\s+.*$"))
        (proc-rx  (regexp "^processor\\s+:\\s+(\\d+)\\s*$"))
        (core-rx  (regexp "^core id\\s+:\\s+(\\d+)\\s*$"))
        (phys-rx  (regexp "^physical id\\s+:\\s+(\\d+)\\s*$"))
        (max-num  (lambda (p n)(max (string->number p) n))))
    ;; (print "data=" data)
    (if (null? data) ;; something went wrong
        #f
        (let loop ((hed      (car data))
                   (tal      (cdr data))
                   (loads    #f)
                   (proc-num 0)  ;; processor includes threads
                   (phys-num 0)  ;; physical chip on motherboard
                   (core-num 0)) ;; core
          ;; (print hed ", " loads ", " proc-num ", " phys-num ", " core-num)
          (if (null? tal) ;; have all our data, calculate normalized load and return result
              (let* ((act-proc (+ proc-num 1))
                     (act-phys (+ phys-num 1))
                     (act-core (+ core-num 1))
                     (adj-proc-load (/ (car loads) act-proc))
                     (adj-core-load (/ (car loads) act-core)))

                (append (list (cons 'adj-proc-load adj-proc-load)
                              (cons 'adj-core-load adj-core-load))
                        (list (cons '1m-load (car loads))
                              (cons '5m-load (cadr loads))
                              (cons '15m-load (caddr loads)))
                        (list (cons 'proc act-proc)
                              (cons 'core act-core)
                              (cons 'phys act-phys))))


              (regex-case
               hed
               (load-rx  ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num))
               (proc-rx  ( x p         ) (loop (car tal)(cdr tal) loads           (max-num p proc-num) phys-num core-num))
               (phys-rx  ( x p         ) (loop (car tal)(cdr tal) loads           proc-num (max-num p phys-num) core-num))
               (core-rx  ( x c         ) (loop (car tal)(cdr tal) loads           proc-num phys-num (max-num c core-num)))
               (else 
                (begin
                  ;; (print "NO MATCH: " hed)
                  (loop (car tal)(cdr tal) loads proc-num phys-num core-num)))))))))

(define (common:unix-ping hostname)
  (let ((res (system (conc "ping -c 1 " hostname " > /dev/null"))))
    (eq? res 0)))

;; ideally put all this info into the db, no need to preserve it across moving homehost
;;
;; return list of
;;  ( reachable? cpuload update-time )
(define (common:get-host-info hostname)
  (let* ((loadinfo (rmt:get-latest-host-load hostname))
         (load (car loadinfo))
         (load-sample-time (cdr loadinfo))
         (load-sample-age (- (current-seconds) load-sample-time))
         (loadinfo-timeout-seconds 20)
         (host-last-update-timeout-seconds 10)
         (host-rec (hash-table-ref/default *host-loads* hostname #f))
         )
    (cond
     ((< load-sample-age loadinfo-timeout-seconds)
      (list #t
            load-sample-time
            load))
     ((and host-rec
           (< (current-seconds) (+ (host-last-update host-rec) host-last-update-timeout-seconds)))
      (list #t
            (host-last-update host-rec)
            (host-last-cpuload host-rec )))
     ((common:unix-ping hostname)
      (list #t
            (current-seconds)
            (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname))))
     (else
      (list #f 0 -1)))))

    



(define (common:update-host-loads-table hosts-raw)
  (let* ((hosts (filter (lambda (x)
                          (string-match (regexp "^\\S+$") x))
                        hosts-raw)))
    (for-each
     (lambda (hostname)
       (let* ((rec       (let ((h (hash-table-ref/default *host-loads* hostname #f)))








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



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






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










|
|
|
|
|
|















|

|
>
|
>
>
>







1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
;; 		(let ((match (string-search load-rx l)))
;; 		  (if match
;; 		      (let ((newval (string->number (cadr match))))
;; 			(if (number? newval)
;; 			    (set! cpu-load newval))))))
;; 	      (car load-res))
;;     cpu-load))

;; get values from cached info from dropping file in logs dir
;;  e.g. key is host and dtype is normalized-load
;;
(define (common:get-cached-info key dtype #!key (age 5))
  (let* ((fullpath (conc *toppath* "/logs/" key "-" dtype ".log")))
    (if (and (file-exists? fullpath)
	     (file-read-access? fullpath))
	(handle-exceptions
	 exn
	 #f
	 (debug:print 2 *default-log-port* "reading file " fullpath)
	 (let ((real-age (- (current-seconds)(file-change-time fullpath)))) 
	   (if (< real-age age)
	       (with-input-from-file fullpath read)
	       (begin
		 (debug:print 2 *default-log-port* "file " fullpath " is too old (" real-age" seconds)to trust, skipping reading it")
		 #f))))
	(begin
	  (debug:print 2 *default-log-port* "not reading file " fullpath)
	  #f))))
 
(define (common:write-cached-info key dtype dat)
  (let* ((fullpath (conc *toppath* "/logs/" key "-" dtype ".log")))
    (handle-exceptions
     exn
     #f
     (with-output-to-file fullpath (lambda ()(pp dat))))))

;; get cpu load by reading from /proc/loadavg, return all three values
;;
(define (common:get-cpu-load remote-host)
  (let* ((actual-hostname (or remote-host (get-host-name))))
    (or (common:get-cached-info actual-hostname "cpu-load")
	(let ((result (if remote-host
			  (map (lambda (res)
				 (if (eof-object? res) 9e99 res))
			       (with-input-from-pipe 
				   (conc "ssh " remote-host " cat /proc/loadavg")
				 (lambda ()(list (read)(read)(read)))))
			  (with-input-from-file "/proc/loadavg" 
			    (lambda ()(list (read)(read)(read)))))))
	  (common:write-cached-info actual-hostname "cpu-load" result)
	  result))))

;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads
;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc.
;;  keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load
;;
(define (common:get-normalized-cpu-load remote-host)
  (let ((actual-host (or remote-host (get-host-name)))) ;; #f is localhost
    (or (common:get-cached-info actual-host "normalized-load")
	(let ((data (if remote-host
			(with-input-from-pipe 
			    (conc "ssh " remote-host " cat /proc/loadavg;cat /proc/cpuinfo;echo end")
			  read-lines)
			(append 
			 (with-input-from-file "/proc/loadavg" 
			   read-lines)
			 (with-input-from-file "/proc/cpuinfo"
			   read-lines)
			 (list "end"))))
	      (load-rx  (regexp "^([\\d\\.]+)\\s+([\\d\\.]+)\\s+([\\d\\.]+)\\s+.*$"))
	      (proc-rx  (regexp "^processor\\s+:\\s+(\\d+)\\s*$"))
	      (core-rx  (regexp "^core id\\s+:\\s+(\\d+)\\s*$"))
	      (phys-rx  (regexp "^physical id\\s+:\\s+(\\d+)\\s*$"))
	      (max-num  (lambda (p n)(max (string->number p) n))))
	  ;; (print "data=" data)
	  (if (null? data) ;; something went wrong
	      #f
	      (let loop ((hed      (car data))
			 (tal      (cdr data))
			 (loads    #f)
			 (proc-num 0)  ;; processor includes threads
			 (phys-num 0)  ;; physical chip on motherboard
			 (core-num 0)) ;; core
		;; (print hed ", " loads ", " proc-num ", " phys-num ", " core-num)
		(if (null? tal) ;; have all our data, calculate normalized load and return result
		    (let* ((act-proc (+ proc-num 1))
			   (act-phys (+ phys-num 1))
			   (act-core (+ core-num 1))
			   (adj-proc-load (/ (car loads) act-proc))
			   (adj-core-load (/ (car loads) act-core))
			   (result
			    (append (list (cons 'adj-proc-load adj-proc-load)
					  (cons 'adj-core-load adj-core-load))
				    (list (cons '1m-load (car loads))
					  (cons '5m-load (cadr loads))
					  (cons '15m-load (caddr loads)))
				    (list (cons 'proc act-proc)
					  (cons 'core act-core)
					  (cons 'phys act-phys)))))
		      (common:write-cached-info actual-host "normalized-load" result)
		      result)
		  (regex-case
		   hed
		   (load-rx  ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num))
		   (proc-rx  ( x p         ) (loop (car tal)(cdr tal) loads           (max-num p proc-num) phys-num core-num))
		   (phys-rx  ( x p         ) (loop (car tal)(cdr tal) loads           proc-num (max-num p phys-num) core-num))
		   (core-rx  ( x c         ) (loop (car tal)(cdr tal) loads           proc-num phys-num (max-num c core-num)))
		   (else 
		    (begin
		      ;; (print "NO MATCH: " hed)
		      (loop (car tal)(cdr tal) loads proc-num phys-num core-num)))))))))))

(define (common:unix-ping hostname)
  (let ((res (system (conc "ping -c 1 " hostname " > /dev/null"))))
    (eq? res 0)))

;; ideally put all this info into the db, no need to preserve it across moving homehost
;;
;; return list of
;;  ( reachable? cpuload update-time )
(define (common:get-host-info hostname)
  (let* ((loadinfo                         (rmt:get-latest-host-load hostname)) ;; if this host happens to have been recently used by a test reuse the load data
         (load                             (car loadinfo))
         (load-sample-time                 (cdr loadinfo))
         (load-sample-age                  (- (current-seconds) load-sample-time))
         (loadinfo-timeout-seconds         6) ;; this was 20 seconds, seems way too lax. Switch to 6 seconds
         (host-last-update-timeout-seconds 4)
         (host-rec (hash-table-ref/default *host-loads* hostname #f))
         )
    (cond
     ((< load-sample-age loadinfo-timeout-seconds)
      (list #t
            load-sample-time
            load))
     ((and host-rec
           (< (current-seconds) (+ (host-last-update host-rec) host-last-update-timeout-seconds)))
      (list #t
            (host-last-update host-rec)
            (host-last-cpuload host-rec )))
     ((common:unix-ping hostname)
      (list #t
            (current-seconds)
            (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) ;; this is cheaper than you might think. get-normalized-cpu-load is cached for up to 5 seconds
     (else
      (list #f 0 -1) ;; bad host, don't use!
      ))))

;; see defstruct host at top of file.
;;    host: reachable last-update last-used last-cpuload
;;
(define (common:update-host-loads-table hosts-raw)
  (let* ((hosts (filter (lambda (x)
                          (string-match (regexp "^\\S+$") x))
                        hosts-raw)))
    (for-each
     (lambda (hostname)
       (let* ((rec       (let ((h (hash-table-ref/default *host-loads* hostname #f)))
1547
1548
1549
1550
1551
1552
1553



1554





1555
1556
1557
1558








1559
1560












1561

1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572






1573
1574
1575

1576


1577
1578
1579
1580







1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591

1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612


1613
1614
1615
1616


1617
1618
1619
1620
1621
1622
1623
1624
1625
1626


1627
1628
1629
1630
1631
1632
1633
              (last-reached-time (cadr host-info))
              (load              (caddr host-info)))
         (host-reachable-set!    rec is-reachable)
         (host-last-update-set!  rec last-reached-time)
         (host-last-cpuload-set! rec load)))
     hosts)))




(define (common:get-least-loaded-host hosts-raw)





  (let* ((hosts (filter (lambda (x)
                          (string-match (regexp "^\\S+$") x))
                        hosts-raw))
         (best-host #f)








         (best-load 99999)
         (curr-time (current-seconds)))












    (common:update-host-loads-table hosts)

    (for-each
     (lambda (hostname)
       (let* ((rec
               (let ((h (hash-table-ref/default *host-loads* hostname #f)))
                 (if h
                     h
                     (let ((h (make-host)))
                       (hash-table-set! *host-loads* hostname h)
                       h))))
              (reachable (host-reachable rec))
              (load      (host-last-cpuload   rec)))






         (cond
          ((not reachable) #f)
          ((< (+ load (/ (random 250) 1000))         ;; add a random factor to keep from getting in a rut

              (+ best-load (/ (random 250) 1000))  )


           (set! best-load load)
           (set! best-host hostname)))))
     hosts)
    best-host))








(define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f))
  (let* ((loadavg (common:get-cpu-load remote-host))
	 (numcpus (if (< 1 numcpus-in) ;; not possible
		      (common:get-num-cpus remote-host)
		      numcpus-in))
	 (maxload (max maxload-in 0.5)) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
	 (first   (car loadavg))
	 (next    (cadr loadavg))
	 (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1
	 (loadjmp (- first next)))

    (cond
     ((and (> first adjload)
	   (> count 0))
      (debug:print-info 0 *default-log-port* "server start delayed " waitdelay " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg ""))
      (thread-sleep! waitdelay)
      (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
     ((and (> loadjmp numcpus)
	   (> count 0))
      (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg ""))
      (thread-sleep! waitdelay)
      (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host)))))

(define (common:wait-for-homehost-load maxload msg)
  (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local.
                     #f
                     (common:get-homehost)))
         (hh     (if hh-dat (car hh-dat) #f))
         (numcpus (common:get-num-cpus hh)))
    (common:wait-for-normalized-load maxload msg hh)))

(define (common:get-num-cpus remote-host)


  (let ((proc (lambda ()
		(let loop ((numcpu 0)
			   (inl    (read-line)))
		  (if (eof-object? inl)


		      numcpu
		      (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl)
				(+ numcpu 1)
				numcpu)
			    (read-line)))))))
    (if remote-host
	(with-input-from-pipe 
	 (conc "ssh " remote-host " cat /proc/cpuinfo")
	 proc)
	(with-input-from-file "/proc/cpuinfo" proc))))



;; wait for normalized cpu load to drop below maxload
;;
(define (common:wait-for-normalized-load maxload msg remote-host)
  (let ((num-cpus (common:get-num-cpus remote-host)))
    (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host)))








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

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










|
>



|
|



|
|











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







1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660






1661
1662
1663
1664
1665
1666
1667
1668
1669
1670

1671
1672
1673
1674
1675

1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
              (last-reached-time (cadr host-info))
              (load              (caddr host-info)))
         (host-reachable-set!    rec is-reachable)
         (host-last-update-set!  rec last-reached-time)
         (host-last-cpuload-set! rec load)))
     hosts)))

;; go through the hosts from least recently used to most recently used, pick the first that meets the load criteral from the
;; [host-rules] section.
;;
(define (common:get-least-loaded-host hosts-raw host-type configdat)
  (let* ((rdat       (configf:lookup configdat "host-rules" host-type))
	 (rules      (common:val->alist (or rdat "") convert: #t))   ;; maxnload, maxnjobs, maxjobrate
	 (maxnload   (common:alist-ref/default 'maxnload rules 1.5)) ;; max normalized load
	 (maxnjobs   (common:alist-ref/default 'maxnjobs rules 1.5)) ;; max normalized number of jobs
	 (maxjobrate (common:alist-ref/default 'maxjobrate rules (/ 1 6))) ;; max rate of submitting jobs to a given host in jobs/second
	 (hosts      (filter (lambda (x)
			       (string-match (regexp "^\\S+$") x))
			     hosts-raw))
         ;; (best-host #f)
	 (get-rec    (lambda (hostname)
		       ;; (print "get-rec hostname=" hostname)
		       (let ((h (hash-table-ref/default *host-loads* hostname #f)))
			 (if h
			     h
			     (let ((h (make-host)))
			       (hash-table-set! *host-loads* hostname h)
			       h)))))
         (best-load 99999)
         (curr-time (current-seconds))
	 (get-hosts-sorted (lambda (hosts)
			     (sort hosts (lambda (a b)
					   (let ((a-rec (get-rec a))
						 (b-rec (get-rec b)))
					     ;; (print "a=" a " a-rec=" a-rec " host-last-used=" (host-last-used a-rec))
					     ;; (print "b=" b " b-rec=" b-rec " host-last-used=" (host-last-used b-rec))
					     (< (host-last-used a-rec)
						(host-last-used b-rec))))))))
    (debug:print 0 *default-log-port* "INFO: hosts-sorted=" (get-hosts-sorted hosts))
    (if (null? hosts)
	#f ;; no hosts to select from. All done and giving up now.
	(let ((hosts-sorted (get-hosts-sorted hosts)))
	  (common:update-host-loads-table hosts)
	  (let loop ((hostname  (car hosts-sorted))
		     (tal       (cdr hosts-sorted))
		     (best-host #f))
	    (let* ((rec       (get-rec hostname))






		   (reachable (host-reachable     rec))
		   (load      (host-last-cpuload  rec))
		   (last-used (host-last-used     rec))
		   (delta     (- curr-time last-used))
		   (job-rate  (if (> delta 0)
				  (/ 1 delta)
				  999)) ;; jobs per second
		   (new-best  
		    (cond
		     ((not reachable)

		      (debug:print 0 *default-log-port* "Skipping host " hostname " as it cannot be reached.")
		      best-host)
		     ((and (< load maxnload)        ;; load is acceptable
			   (< job-rate maxjobrate)) ;; job rate is acceptable
		      (set! best-load load)

		      hostname)
		     (else best-host))))
	      (debug:print 0 *default-log-port* "INFO: Trying host " hostname " with load " load ", last used " delta " seconds ago, with job-rate " job-rate " for running a test." )
	      (if new-best
		  (begin ;; found a host, return it
		    (debug:print 0 *default-log-port* "INFO: Found host: " new-best " load: " load " last-used: " delta " seconds ago, with job-rate: " job-rate)
		    (host-last-used-set! rec curr-time)
		    new-best)
		  (if (null? tal) #f (loop (car tal)(cdr tal) best-host)))))))))

(define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f))
  (let* ((loadavg (common:get-cpu-load remote-host))
	 (numcpus (if (< 1 numcpus-in) ;; not possible
		      (common:get-num-cpus remote-host)
		      numcpus-in))
	 (maxload (max maxload-in 0.5)) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
	 (first   (car loadavg))
	 (next    (cadr loadavg))
	 (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1
	 (loadjmp (- first next))
         (adjwait (+ (random 10)(/ (- 1000 count) 10) waitdelay))) ;; add some randomness to the time to break any alignment where netbatch dumps many jobs to machines simultaneously
    (cond
     ((and (> first adjload)
	   (> count 0))
      (debug:print-info 0 *default-log-port* "server start delayed " adjwait " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg ""))
      (thread-sleep! adjwait)
      (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
     ((and (> loadjmp numcpus)
	   (> count 0))
      (debug:print-info 0 *default-log-port* "waiting " adjwait " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg ""))
      (thread-sleep! adjwait)
      (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host)))))

(define (common:wait-for-homehost-load maxload msg)
  (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local.
                     #f
                     (common:get-homehost)))
         (hh     (if hh-dat (car hh-dat) #f))
         (numcpus (common:get-num-cpus hh)))
    (common:wait-for-normalized-load maxload msg hh)))

(define (common:get-num-cpus remote-host)
  (let* ((actual-host (or remote-host (get-host-name))))
    (or (common:get-cached-info actual-host "num-cpus" age: 86400) ;; hosts had better not be changing the number of cpus too often!
	(let* ((proc   (lambda ()
			 (let loop ((numcpu 0)
				    (inl    (read-line)))
			   (if (eof-object? inl)
			       (begin
				 (common:write-cached-info remote-host "num-cpus" numcpu)
				 numcpu)
			       (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl)
					 (+ numcpu 1)
					 numcpu)
				     (read-line))))))
	       (result (if remote-host
			   (with-input-from-pipe 
			       (conc "ssh " remote-host " cat /proc/cpuinfo")
			     proc)
			   (with-input-from-file "/proc/cpuinfo" proc))))
	  (common:write-cached-info actual-host "num-cpus" result)
	  result))))

;; wait for normalized cpu load to drop below maxload
;;
(define (common:wait-for-normalized-load maxload msg remote-host)
  (let ((num-cpus (common:get-num-cpus remote-host)))
    (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host)))

2330
2331
2332
2333
2334
2335
2336






2337
2338
2339
2340
2341
2342
2343
;; x86_64 zeus xena myth01
;; allhosts #{g hosts arm} #{g hosts x86_64}
;; 
;; [host-types]
;; general #MTLOWESTLOAD #{g hosts allhosts}
;; arm     #MTLOWESTLOAD #{g hosts arm}
;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo






;; 
;; [launchers]
;; envsetup general
;; xor/%/n 4C16G
;; % nbgeneral
;; 
;; [jobtools]







>
>
>
>
>
>







2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
;; x86_64 zeus xena myth01
;; allhosts #{g hosts arm} #{g hosts x86_64}
;; 
;; [host-types]
;; general #MTLOWESTLOAD #{g hosts allhosts}
;; arm     #MTLOWESTLOAD #{g hosts arm}
;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo
;;
;; [host-rules]
;; # maxnload   => max normalized load
;; # maxnjobs   => max jobs per cpu
;; # maxjobrate => max jobs per second
;; general maxnload=1.1; maxnjobs=1.2; maxjobrate=0.1 
;; 
;; [launchers]
;; envsetup general
;; xor/%/n 4C16G
;; % nbgeneral
;; 
;; [jobtools]
2360
2361
2362
2363
2364
2365
2366
2367


2368









2369
2370
2371
2372
2373
2374
2375
		      (begin
			(debug:print-info 2 *default-log-port* "Have flexi-launcher match for " testname "/" itempath " = " host-type)
			(let ((launcher (configf:lookup configdat "host-types" host-type)))
			  (if launcher
			      (let* ((launcher-parts (string-split launcher))
				     (launcher-exe   (car launcher-parts)))
				(if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline
				    (let ((targ-host (common:get-least-loaded-host (cdr launcher-parts))))


				      (conc "remrun " targ-host))









				    launcher))
			      (begin
				(debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type)
				(if (null? tal)
				    fallback-launcher
				    (loop (car tal)(cdr tal)))))))
		      ;; no match, try again







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







2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
		      (begin
			(debug:print-info 2 *default-log-port* "Have flexi-launcher match for " testname "/" itempath " = " host-type)
			(let ((launcher (configf:lookup configdat "host-types" host-type)))
			  (if launcher
			      (let* ((launcher-parts (string-split launcher))
				     (launcher-exe   (car launcher-parts)))
				(if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline
				    (let host-loop ((targ-host (common:get-least-loaded-host (cdr launcher-parts) host-type configdat))
						    (count     100))
				      (if targ-host
					  (conc "remrun " targ-host)
					  (if (> count 0)
					      (begin
						(debug:print 0 *default-log-port* "INFO: Waiting for a host for host-type " host-type)
						(thread-sleep! (- 101 count))
						(host-loop (common:get-least-loaded-host (cdr launcher-parts) host-type configdat)
							   (- count 1)))
					      (begin
						(debug:print 0 *default-log-port* "FATAL: Failed to find a host from #MTLOWESTLOAD for host-type " host-type)
						(exit)))))
				    launcher))
			      (begin
				(debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type)
				(if (null? tal)
				    fallback-launcher
				    (loop (car tal)(cdr tal)))))))
		      ;; no match, try again

Modified dashboard.scm from [414a79db6e] to [fca0a7ecf2].

2085
2086
2087
2088
2089
2090
2091
2092

2093
2094
2095
2096
2097
2098
2099

;; This is the Run Summary tab
;; 
(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f))
  (let* ((update-mutex (dboard:commondat-update-mutex commondat))
	 (tb      (iup:treebox
		   #:value 0
		   #:name "Runs"

		   #:expand "YES"
		   #:addexpanded "YES"
		   #:selection-cb
		   (lambda (obj id state)
		     (debug:catch-and-dump
		      (lambda ()
			;; (print "obj: " obj ", id: " id ", state: " state)







|
>







2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100

;; This is the Run Summary tab
;; 
(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f))
  (let* ((update-mutex (dboard:commondat-update-mutex commondat))
	 (tb      (iup:treebox
		   #:value 0
		   ;;#:name "Runs"
                   #:title "Runs" ;;  was #:name -- iup 3.19 changed this... "Changed: [DEPRECATED REMOVED] removed the old attribute NAMEid from IupTree to avoid conflict with the common attribute NAME. Use the TITLEid attribute."
		   #:expand "YES"
		   #:addexpanded "YES"
		   #:selection-cb
		   (lambda (obj id state)
		     (debug:catch-and-dump
		      (lambda ()
			;; (print "obj: " obj ", id: " id ", state: " state)

Deleted dbwars/NOTES version [8f8ee6c6d0].

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
Before using prepare:

matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert
Adding 1047 test3 item/39 host0-0.3-200000-240-this one sucks eh? (added 51886 records so far)
Adding 1122 test5 item/52 host2-0.2-200000-120-this is a good one eh? (added 78889 records so far)
Adding 1050 test7 item/31 host1-0.1-100000-120-this is a good one eh? (added 110641 records so far)
create-tests ran register-test 144000 times in 41.0 seconds

After using prepare:

matt@xena:/tmp/megatest/dbwars$ csc sqlite3-test.scm && ./sqlite3-test insert
Adding 1082 test4 item/74 host1-0.3-100000-120-this is a good one eh? (added 61281 records so far)
Adding 1138 test7 item/43 host2-0.3-200000-120-this is a good one eh? (added 109001 records so far)
Adding 1023 test9 item/00 host0-0.2-100000-240-this one sucks eh? (added 143878 records so far)
create-tests ran register-test 144000 times in 38.0 seconds

After moving the prepare outside the call (so it isn't done each time):

matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert
Adding 1042 test4 item/59 host0-0.3-200000-120-this is a good one eh? (added 63401 records so far)
Adding 1011 test6 item/40 host0-0.1-200000-120-this one sucks eh? (added 94906 records so far)
Adding 1076 test9 item/34 host1-0.2-200000-120-just eh, eh? (added 139035 records so far)
create-tests ran register-test 144000 times in 33.0 seconds

Using sql-de-lite with very similar code:

matt@xena:/tmp/megatest/dbwars$ ./sql-de-lite-test insert
Adding 1029 test4 item/53 host0-0.2-200000-240- (added 64252 records so far)
Adding 1134 test7 item/64 host2-0.3-100000-240-this is a good one eh? (added 105973 records so far)
create-tests ran register-test 144000 times in 31.0 seconds

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































Deleted dbwars/sql-de-lite-test.scm version [004f7cb8d7].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

(use sql-de-lite)
(include "test-common.scm")

(define db (open-database "test.db"))

(exec (sql db test-table-defn))
(exec (sql db syncsetup))

(define (register-test stmth  run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)
    (exec 
     stmth ;; (sql db test-insert)
     run-id
     testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time))

(let ((stmth (sql db test-insert)))
  (create-tests stmth))

(close-database db)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































Deleted dbwars/sqlite3-test.scm version [338a298923].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

(use sqlite3)
(include "test-common.scm")

(define db (open-database "test.db"))

(execute db test-table-defn)
(execute db syncsetup)


(define (register-test stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)
  (execute stmth
	   run-id
	   testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time))

(let ((stmth (prepare db test-insert)))
  (create-tests stmth)
  (finalize! stmth))

(finalize! db)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































Deleted dbwars/test-common.scm version [02dcd9f2da].

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
(use srfi-18 srfi-69 apropos)

(define args (argv))

(if (not (eq? (length args) 2))
    (begin
      (print "Usage: sqlitecompare [insert|update]")
      (exit 0)))

(define action (string->symbol (cadr args)))

(system "rm -f test.db")

(define test-table-defn
		 "CREATE TABLE IF NOT EXISTS tests 
                    (id INTEGER PRIMARY KEY,
                     run_id     INTEGER,
                     testname   TEXT,
                     host       TEXT DEFAULT 'n/a',
                     cpuload    REAL DEFAULT -1,
                     diskfree   INTEGER DEFAULT -1,
                     uname      TEXT DEFAULT 'n/a', 
                     rundir     TEXT DEFAULT 'n/a',
                     shortdir   TEXT DEFAULT '',
                     item_path  TEXT DEFAULT '',
                     state      TEXT DEFAULT 'NOT_STARTED',
                     status     TEXT DEFAULT 'FAIL',
                     attemptnum INTEGER DEFAULT 0,
                     final_logf TEXT DEFAULT 'logs/final.log',
                     logdat     BLOB, 
                     run_duration INTEGER DEFAULT 0,
                     comment    TEXT DEFAULT '',
                     event_time TIMESTAMP,
                     fail_count INTEGER DEFAULT 0,
                     pass_count INTEGER DEFAULT 0,
                     archived   INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes
                     CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path)
          );")

(define test-insert "INSERT INTO tests  (run_id,testname,host,cpuload,diskfree,uname,rundir,shortdir,item_path,state,status,final_logf,run_duration,comment,event_time)
                                values (?,     ?,       ?,   ?,      ?,       ?,    ?,     ?,       ?,        ?,    ?,     ?,         ?,           ?,      ?        );")
(define syncsetup "PRAGMA synchronous = OFF;")

(define tests '("test0" "test1" "test2" "test3" "test4" "test5" "test6" "test7" "test8" "test9"))
(define items '())
(for-each 
 (lambda (n)
   (for-each 
    (lambda (m)
      (set! items (cons (conc "item/" n m) items)))
    '(0 1 2 3 4 5 6 7 8 9)))
 '(0 1 2 3 4 5 6 7 8 9))
(define hosts '("host0" "host1" "host2")) ;;  "host3" "host4" "host5" "host6" "host7" "host8" "host9"))
(define cpuloads '(0.1 0.2 0.3))    ;; 0.4 0.5 0.6 0.7 0.8 0.9))
(define diskfrees '(100000 200000)) ;; 300000 400000 500000 600000 700000 800000 900000))
(define uname "Linux xena 3.5.0-40-generic #62~precise1-Ubuntu SMP Fri Aug 23 17:59:10 UTC 2013 i686 i686 i386 GNU/Linux")
(define basedir "/mfs/matt/data/megatest/runs/testing")
(define final-logf "finallog.html")
(define run-durations (list 120 240)) ;;  260))
(define comments '("" "this is a good one eh?" "this one sucks eh?" "just eh, eh?"))

(define run-ids (make-hash-table))
(define max-run-id 1000)

(define (test-factors->run-id host cpuload diskfree run-duration comment)
  (let* ((factor (conc host "-" cpuload "-" diskfree "-" run-duration "-" comment))
	 (run-id (hash-table-ref/default run-ids factor #f)))
    (if run-id 
	(list run-id factor)
	(let ((new-id (+ max-run-id 1)))
	  (set! max-run-id new-id)
	  (hash-table-set! run-ids factor new-id)
	  (list new-id factor)))))
	  

(define (create-tests stmth)
  (let ((num-created 0)
	(last-print  (current-seconds))
	(start-time  (current-seconds)))
    (for-each 
     (lambda (test)
       (for-each 
	(lambda (item)
	  (for-each 
	   (lambda (host)
	     (for-each 
	      (lambda (cpuload)
		(for-each
		 (lambda (diskfree)
		   (for-each 
		    (lambda (run-duration)
		      (for-each 
		       (lambda (comment)
			 (let* ((run-id-dat (test-factors->run-id host cpuload diskfree run-duration comment))
				(run-id (car run-id-dat))
				(factor (cadr run-id-dat))
				(curr-time (current-seconds)))
			   (if (> (- curr-time last-print) 10)
			       (begin
				 (print "Adding " run-id " " test " " item " " factor " (added " num-created " records so far)")
				 (set! last-print curr-time)))
			   (set! num-created (+ num-created 1))
			   (register-test stmth ;; db  
					  run-id
					  test  ;; testname
					  host
					  cpuload
					  diskfree
					  uname
					  (conc basedir "/" test "/" item) ;; rundir
					  (conc test "/" item) ;; shortdir
					  item   ;; item-path
					  "NOT_STARTED" ;; state
					  "NA"          ;; status
					  final-logf
					  run-duration
					  comment
					  (current-seconds))))
		       comments))
		    run-durations))
		 diskfrees))
	      cpuloads))
	   hosts))
	items))
     tests)
    (print "create-tests ran register-test " num-created " times in " (- (current-seconds) start-time) " seconds")))

				   
			 
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































Deleted defunct/multi-dboard.scm version [de11d53f46].

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
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
;;======================================================================
;; Copyright 2006-2013, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

(use format numbers sql-de-lite srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)

(declare (uses margs))
(declare (uses megatest-version))
(declare (uses gutils))
(declare (uses tree))
(declare (uses configf))
(declare (uses portlogger))
(declare (uses keys))
(declare (uses common))

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

(define help (conc 
	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2011

Usage: dashboard [options]
  -h                : this help
  -group groupname  : display this group of areas
  -test testid      : control test identified by testid
  -guimonitor       : control panel for runs

Misc
  -rows N         : set number of rows
"))

;; process args
(define remargs (args:get-args 
		 (argv)
		 (list  "-group" ;; display this group of areas
			"-debug"
			) 
		 (list  "-h"
			"-v"
			"-q"
			)
		 args:arg-hash
		 0))

(if (args:get-arg "-h")
    (begin
      (print help)
      (exit)))

;; (if (args:get-arg "-host")
;;     (begin
;;       (set! (common:get-remote remote) (string-split (args:get-arg "-host" ":")))
;;       (client:launch))
;;     (client:launch))

(define *runremote* #f)
(define *windows* (make-hash-table))
(define *changed-main* (make-hash-table)) ;; set path/... => #t
(define *changed-mutex* (make-mutex))     ;; use for all incoming change requests
(define *searchpatts*   (make-hash-table))

(debug:setup)

(define *tim* (iup:timer))
(define *ord* #f)

(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")

(define (message-window msg)
  (iup:show
   (iup:dialog
    (iup:vbox 
     (iup:label msg #:margin "40x40")))))

(define (iuplistbox-fill-list lb items . default)
  (let ((i 1)
	(selected-item (if (null? default) #f (car default))))
    (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
    (for-each (lambda (item)
		(iup:attribute-set! lb (number->string i) item)
		(if selected-item
		    (if (equal? selected-item item)
			(iup:attribute-set! lb "VALUE" item))) ;; (number->string i))))
		(set! i (+ i 1)))
	      items)
    i))

(define (pad-list l n)(append l (make-list (- n (length l)))))


(define (mkstr . x)
  (string-intersperse (map conc x) ","))

(define (update-search x val)
  (hash-table-set! *searchpatts* x val))


;;======================================================================
;; R E C O R D S
;;======================================================================

;; NOTE: Consider switching to defstruct.

;; data for an area (regression or testsuite)
;;
(define-record areadat
  name               ;; area name
  path               ;; mt run area home
  configdat          ;; megatest config
  denoise            ;; focal point for not putting out same messages over and over
  client-signature   ;; key for client-server conversation
  remote             ;; hash of all the client side connnections
  run-keys           ;; target keys for this area
  runs               ;; used in dashboard, hash of run-ids -> rundat
  read-only          ;; can I write to this area?
  monitordb          ;; db handle for monitor.db
  maindb             ;; db handle for main.db
  )

;; rundat, basic run data
;;
(define-record rundat
  id                 ;; the run-id
  target             ;; val1/val2 ... corrosponding to run-keys in areadat
  runname
  state              ;; state of the run, symbol 
  status             ;; status of the run, symbol
  event-time         ;; when the run was initiated
  tests              ;; hash of test-id -> testdat, QUESTION: separate by run-id?
  db                 ;; db handle
  )

;; testdat, basic test data
(define-record testdat
  run-id             ;; what run is this from
  id                 ;; test id
  testname           ;; test name
  itempath           ;; item path
  state              ;; test state, symbol
  status             ;; test status, symbol
  event-time         ;; when the test started
  duration           ;; how long the test took
  )

;; general data for the dboard application
;;
(define-record data
  cfgdat             ;; data from ~/.megatest/<group>.dat
  areas              ;; hash of areaname -> area-rec
  current-window-id  ;; 
  current-tab-id     ;; 
  update-needed      ;; flag to indicate that the tab pointed to by current tab id needs refreshing immediately
  tabs               ;; hash of tab-id -> areaname (??) should be of type "tab"
  )

;; all the components of an area display, all fits into a tab but
;; parts may be swapped in/out as needed
;;
(define-record tab
  tree
  matrix    ;; the spreadsheet 
  areadat   ;; the one-structure (one day dbstruct will be put in here)
  view-path ;; <target/path>/<runname>/...
  view-type ;; standard, etc.
  controls  ;; the controls
  data      ;; all the data kept in sync with db
  filters   ;; user filters, alist name -> filter record, eventually store these in ~/.megatest/<group>.dat?
  run-id    ;; the current run-id
  test-ids  ;; the current test id hash, run-id => test-id
  command   ;; the command from the entry field
  headers   ;; hash of header  -> colnum
  rows      ;; hash of rowname -> rownum
  )

(define-record filter
  target    ;; hash of widgets for the target
  runname   ;; the runname widget
  testpatt  ;; the testpatt widget
  )

;;======================================================================
;; D B
;;======================================================================

;; These are all using sql-de-lite and independent of area so cannot use stuff 
;; from db.scm

;; NB// run-id=#f => return dbdir only
;;
(define (areadb:dbfile-path areadat run-id)
  (let* ((cfgdat  (areadat-configdat areadat))
	 (dbdir   (or (configf:lookup cfgdat "setup" "dbdir")
		      (conc (configf:lookup cfgdat "setup" "linktree") "/.db")))
	 (fname   (if run-id
		      (case run-id
			((-1) "monitor.db")
			((0) "main.db")
			(else (conc run-id ".db")))
		      #f)))
    (handle-exceptions
     exn
     (begin
       (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
       (exit 1))
     (if (not (directory? dbdir))(create-directory dbdir #t)))
    (if fname
	(conc dbdir "/" fname)
	dbdir)))

;; -1 => monitor.db
;;  0 => main.db
;; >1 => <run-id>.db
;;
(define (areadb:open areadat run-id)
  (let* ((runs   (areadat-runs areadat))
	 (rundat (if (> run-id 0) ;; it is a run
		     (hash-table-ref/default runs run-id #f)
		     #f))
	 (db     (case run-id ;; if already opened, get the db and return it
		   ((-1) (areadat-monitordb areadat))
		   ((0)  (areadat-maindb    areadat))
		   (else (if rundat
			     (rundat-db rundat)
			     #f)))))
    (if db
	db ;; merely return the already opened db
	(let* ((dbfile (areadb:dbfile-path areadat run-id)) ;; not already opened, so open it
	       (db     (if (file-exists? dbfile)
			   (open-database dbfile)
			   (begin
			     (debug:print-error 0 *default-log-port* "I was asked to open " dbfile ", but file does not exist or is not readable.")
			     #f))))
	  (case run-id
	    ((-1)(areadat-monitordb-set! areadat db))
	    ((0) (areadat-maindb-set!    areadat db))
	    (else (rundat-db-set!        rundat  db)))
	  db))))

;; populate the areadat tests info, does NOT fill the tests data itself unless asked
;;
(define (areadb:populate-run-info areadat)
  (let* ((runs   (or (areadat-runs areadat) (make-hash-table)))
	 (keys   (areadat-run-keys areadat))
	 (maindb (areadb:open areadat 0)))
    (if maindb
	(query (for-each-row (lambda (row)
			       (let ((id  (list-ref row 0))
				     (dat (apply make-rundat (append row (list #f #f))))) ;; add placeholders for tests and db
				 (print row)
				 (hash-table-set! runs id dat))))
	       (sql maindb (conc "SELECT id,"
				 (string-intersperse keys "||'/'||")
				 ",runname,state,status,event_time FROM runs WHERE state != 'deleted';")))
	(debug:print-error 0 *default-log-port* "no main.db found at "  (areadb:dbfile-path areadat 0)))
    areadat))

;; given an areadat and target/runname patt fill up runs data
;;
;; ?????/

;; given a list of run-ids refresh/retrieve runs data into areadat
;;
(define (areadb:fill-tests areadat #!key (run-ids #f))
  (let* ((runs   (or (areadat-runs areadat) (make-hash-table))))
    (for-each
     (lambda (run-id)
       (let* ((rundat (hash-table-ref/default runs run-id #f))
	      (tests  (if (and rundat
			       (rundat-tests rundat)) ;; re-use existing hash table?
			  (rundat-tests rundat)
			  (let ((ht (make-hash-table)))
			    (rundat-tests-set! rundat ht)
			    ht)))
	      (rundb  (areadb:open areadat run-id)))
	 (query (for-each-row (lambda (row)
				(let* ((id         (list-ref row 0))
				       (testname   (list-ref row 1))
				       (itempath   (list-ref row 2))
				       (state      (list-ref row 3))
				       (status     (list-ref row 4))
				       (eventtim   (list-ref row 5))
				       (duration   (list-ref row 6)))
				  (hash-table-set! tests id
						   (make-testdat run-id id testname itempath state status eventtim duration)))))
		(sql rundb "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE state != 'DELETED';"))))
     (or run-ids (hash-table-keys runs)))
    areadat))
    

;; initialize and refresh data
;;		
(define (dboard:general-updater con port)
  (for-each
   (lambda (window-id)
     ;; (print "Processing for window-id " window-id)
     (let* ((window-dat     (hash-table-ref *windows* window-id))
	    (areas          (data-areas     window-dat))
	    ;; (keys           (areadat-run-keys area-dat))
	    (tabs           (data-tabs      window-dat))
	    (tab-ids        (hash-table-keys tabs))
	    (current-tab    (if (null? tab-ids)
				#f
				(hash-table-ref tabs (car tab-ids))))
	    (current-tree   (if (null? tab-ids) #f (tab-tree   current-tab)))
	    (current-node   (if (null? tab-ids) 0  (string->number (iup:attribute current-tree "VALUE"))))
	    (current-path   (if (eq? current-node 0)
				"Areas"
				(string-intersperse (tree:node->path current-tree current-node) "/")))
	    (current-matrix (if (null? tab-ids) #f (tab-matrix current-tab)))
	    (seen-nodes     (make-hash-table))
	    (path-changed   (if current-tab
				(equal? current-path (tab-view-path current-tab))
				#t)))
       ;; (debug:print-info 0 *default-log-port* "Current path: " current-path)
       ;; now for each area in the window gather the data
       (if path-changed
	   (begin
	     (debug:print-info 0 *default-log-port* "clearing matrix - path changed")
	     (dboard:clear-matrix current-tab)))
       (for-each
	(lambda (area-name)
	  ;; (print "Processing for area-name " area-name)
	  (let* ((area-dat  (hash-table-ref areas area-name))
		 (area-path (areadat-path   area-dat))
		 (runs      (areadat-runs   area-dat)))
	    (if (hash-table-ref/default *changed-main* area-path 'processed)
		(begin
		  (print "Processing " area-dat " for area-name " area-name)
		  (hash-table-set! *changed-main* area-path #f)
		  (areadb:populate-run-info area-dat)
		  (for-each 
		   (lambda (run-id)
		     (let* ((run     (hash-table-ref runs run-id))
			    (target  (rundat-target run))
			    (runname (rundat-runname run)))
		       (if current-tree
			   (let* ((partial-path (append (string-split target "/")(list runname)))
				  (full-path    (cons area-name partial-path)))
			     (if (not (hash-table-exists? seen-nodes full-path))
				 (begin
				   (print "INFO: Adding node " partial-path " to section " area-name)
				   (tree:add-node current-tree "Areas" full-path)
				   (areadb:fill-tests area-dat run-ids: (list run-id))))
				   (hash-table-set! seen-nodes full-path #t)))))
		   (hash-table-keys runs))))
	    (if (or (equal? "Areas" current-path)
		    (string-match (conc "^Areas/" area-name "(|\\/.*)$") current-path))
		(dboard:redraw-area area-name area-dat current-tab current-matrix current-path))))
	(hash-table-keys areas))))
   (hash-table-keys *windows*)))

;;======================================================================
;; D A S H B O A R D   D B 
;;======================================================================

;; All moved to common.scm		

;;======================================================================
;; T R E E 
;;======================================================================

;; <area> - <target - ... > - <runname> - <test> - <itempath - ...>

(define (dashboard:tree-browser data adat window-id)
  ;; (iup:split
  (let* ((tb      (iup:treebox
		   #:value 0
		   #:title "Areas"
		   #:expand "YES"
		   #:addexpanded "NO"
		   #:selection-cb
		   (lambda (obj id state)
		     ;; (print "obj: " obj ", id: " id ", state: " state)
		     (let* ((tree-path (tree:node->path obj id))
			    (area      (car tree-path))
			    (areadat-path (cdr tree-path)))
		       #f
		       ;; (test-id  (tree-path->test-id (cdr run-path))))
		       ;; (if test-id
		       ;;    (hash-table-set! (dboard:data-curr-test-ids *data*)
		       ;;		     window-id test-id))
		       ;; (print "path: " (tree:node->path obj id) " test-id: " test-id))))))
		       )))))
    ;; (iup:attribute-set! tb "VALUE" "0")
    ;; (iup:attribute-set! tb "NAME" "Runs")
    ;; (iup:attribute-set! tb "ADDEXPANDED" "NO")
    ;; (dboard:data-tests-tree-set! *data* tb)
    tb))

;;======================================================================
;; M A I N   M A T R I X
;;======================================================================

;; General displayer
;;
(define (dashboard:main-matrix data adat window-id)
  (let* (;; (tab-dat         (areadat-
	 (view-matrix     (iup:matrix
			   ;; (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f))
			   #:expand "YES"
			   ;; #:fittosize "YES"
			   #:resizematrix "YES"
			   #:scrollbar "YES"
			   #:numcol 100
			   #:numlin 100
			   #:numcol-visible 3
			   #:numlin-visible 20
			   #:click-cb (lambda (obj lin col status)
					(print "obj: " obj " lin: " lin " col: " col " status: " status " value: " (iup:attribute obj "VALUE"))))))
    
    ;; (iup:attribute-set! view-matrix "RESIZEMATRIX" "YES")
    (iup:attribute-set! view-matrix "WIDTH0" "100")
    ;; (dboard:data-runs-matrix-set! *data* runs-matrix)
    ;; (iup:hbox
    ;;  (iup:frame 
    ;;   #:title "Runs browser"
    ;;   (iup:vbox
    view-matrix))

;;======================================================================
;; A R E A S
;;======================================================================

(define (dashboard:init-area data area-name apath)
  (let* ((mtconf      (dboard:read-mtconf apath))
	 (area-dat    (let ((ad (make-areadat
				 area-name ;; area name
				 apath     ;; path to area
				 ;; 'http     ;; transport
				 mtconf    ;; megatest.config
				 (make-hash-table) ;; denoise hash
				 #f        ;; client-signature
				 #f        ;; remote connections
				 (keys:config-get-fields mtconf) ;; run keys
				 (make-hash-table) ;; run-id -> (hash of test-ids => dat)
				 (and (file-exists? apath)(file-write-access? apath)) ;; read-only
				 #f
				 #f
				 )))
			(hash-table-set! (data-areas data) area-name ad)
			ad)))
    area-dat))

;; given the keys for an area and a path from the tree browser
;; return the level: areas area runs run tests test
;;
(define (dboard:get-view-type keys current-path)
  (let* ((path-parts (string-split current-path "/"))
	 (path-len   (length path-parts)))
    (cond
     ((equal? current-path "Areas")     'areas)
     ((eq? path-len 2)                  'area)
     ((<= (+ (length keys) 2) path-len) 'runs)
     (else                              'run))))

(define (dboard:clear-matrix tab)
  (if tab
      (begin
	(iup:attribute-set! (tab-matrix tab) "CLEARVALUE" "ALL")
	(tab-headers-set! tab (make-hash-table))
	(tab-rows-set!    tab (make-hash-table)))))

;; full redraw of a given area
;;
(define (dboard:redraw-area area-name area-dat tab-dat current-matrix current-path)
  (let* ((keys      (areadat-run-keys area-dat))
	 (runs      (areadat-runs     area-dat))
	 (headers   (tab-headers   tab-dat))
	 (rows      (tab-rows      tab-dat))
	 (used-cols (hash-table-values headers))
	 (used-rows (hash-table-values rows))
	 (touched   (make-hash-table)) ;; (vector row col) ==> true, touched cell
	 (view-type (dboard:get-view-type keys current-path))
	 (changed   #f)
	 (state-statuses  (list "PASS" "FAIL" "WARN" "CHECK" "SKIP" "RUNNING" "LAUNCHED")))
    ;; (debug:print 0 *default-log-port* "current-matrix=" current-matrix)
    (case view-type
      ((areas) ;; find row for this area, if not found, create new entry
       (let* ((curr-rownum (hash-table-ref/default rows area-name #f))
	      (next-rownum (+ (apply max (cons 0 used-rows)) 1))
	      (rownum      (or curr-rownum next-rownum))
	      (coord       (conc rownum ":0")))
	 (if (not curr-rownum)(hash-table-set! rows area-name rownum))
	 (if (not (equal? (iup:attribute current-matrix coord) area-name))
	     (begin
	       (let loop ((hed  (car state-statuses))
			  (tal  (cdr state-statuses))
			  (count 1))
		 (if (not (equal? (iup:attribute current-matrix (conc "0:" count)) hed))
		     (iup:attribute-set! current-matrix (conc "0:" count) hed))
		 (iup:attribute-set! current-matrix (conc rownum ":" count) "0")
		 (if (not (null? tal))
		     (loop (car tal)(cdr tal)(+ count 1))))
	       (debug:print-info 0 *default-log-port* "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name)
	       (iup:attribute-set! current-matrix coord area-name)
	       (set! changed #t))))))
    (if changed (iup:attribute-set! current-matrix "REDRAW" "ALL"))))
	     

       
   ;; (dboard:clear-matrix current-matrix used-cols used-rows touched) ;; clear all
    
	
  
;;======================================================================
;; D A S H B O A R D
;;======================================================================

(define (dashboard:area-panel aname data window-id)
  (let* ((apath      (configf:lookup (data-cfgdat data) aname "path")) ;;  (hash-table-ref (dboard:data-cfgdat data) area-name))
	 ;;          (hash-table-ref (dboard:data-cfgdat data) aname))
	 (area-dat   (dashboard:init-area data aname apath))
	 (tb         (dashboard:tree-browser data area-dat window-id)) ;; (dboard:areas-tree-browser data)
	 (ad         (dashboard:main-matrix  data area-dat window-id))
	 (areas      (data-areas data))
	 (dboard-dat (make-tab
		      #f           ;; tree
		      #f           ;; matrix
		      area-dat     ;;
		      #f           ;; view path
		      'default     ;; view type
		      #f           ;; controls
		      (make-hash-table) ;; cached data? not sure how to use this yet :)
		      #f           ;; filters
		      #f           ;; the run-id
		      (make-hash-table) ;; run-id -> test-id, for current test id
		      ""
		      (make-hash-table) ;; headername -> colnum
		      (make-hash-table) ;; rowname    -> rownum
		      )))
    (hash-table-set! (data-areas data) aname area-dat) ;; dboard-dat)
    (hash-table-set! (data-tabs data) window-id dboard-dat)
    (tab-tree-set!   dboard-dat tb)
    (tab-matrix-set! dboard-dat ad)
    (iup:split
     #:value 200
     tb ad)))


;; Main Panel
;;
(define (dashboard:main-panel data window-id)
  (iup:dialog
   #:title "Megatest Control Panel"
;;   #:menu (dcommon:main-menu data)
   #:shrink "YES"
   (iup:vbox
    (let* ((area-names  (hash-table-keys (data-cfgdat data)))
	   (area-panels (map (lambda (aname)
			       (dashboard:area-panel aname data window-id))
			     area-names))
	   (tabtop      (apply iup:tabs  
			       #:tabchangepos-cb (lambda (obj curr prev)
						   (data-current-tab-id-set! data curr)
						   (data-update-needed-set!  data #t)
						   (print "Tab is: " curr ", prev was " prev))
			       area-panels))
	   (tabs     (data-tabs data)))
      (if (not (null? area-names))
	  (let loop ((index 0)
		     (hed   (car area-names))
		     (tal   (cdr area-names)))
	    ;; (hash-table-set! tabs index hed)
	    (debug:print 0 *default-log-port* "Adding area " hed " with index " index " to dashboard")
	    (iup:attribute-set! tabtop (conc "TABTITLE" index) hed)
	    (if (not (null? tal))
		(loop (+ index 1)(car tal)(cdr tal)))))
      tabtop))))


;;======================================================================
;; N A N O M S G   S E R V E R
;;======================================================================

(define (dboard:server-service soc port)
  (print "server starting")
  (let loop ((msg-in (nn-recv soc))
	     (count  0))
    (if (eq? 0 (modulo count 1000))
	(print "server received: " msg-in ", count=" count))
    (cond
     ;;
     ;; quit
     ;;
     ((equal? msg-in "quit")
      (nn-send soc "Ok, quitting"))
     ;;
     ;; ping
     ;;
     ((and (>= (string-length msg-in) 4)
	   (equal? (substring msg-in 0 4) "ping"))
      (nn-send soc (conc (current-process-id)))
      (loop (nn-recv soc)(+ count 1)))
     ;;
     ;; main changed
     ;;
     ((and (>= (string-length msg-in) 4)
	   (equal? (substring msg-in 0 4) "main"))
      (let ((parts (string-split msg-in " ")))
	(hash-table-set! *changed-main* (cadr parts) #t)
	(nn-send soc "got it!")))
     ;;
     ;; ??
     ;;
     (else
      (nn-send soc "hello " msg-in " you got to the else clause!")))
    (loop (nn-recv soc)(if (> count 20000000)
			   0
			   (+ count 1)))))

(define (dboard:one-time-ping-receive soc port)
  (let ((msg-in (nn-recv soc)))
    (if (and (>= (string-length msg-in) 4)
	     (equal? (substring msg-in 0 4) "ping"))
	(nn-send soc (conc (current-process-id))))))

(define (dboard:server-start given-port #!key (num-tries 200))
  (let* ((rep (nn-socket 'rep))
	 (port (or given-port  (portlogger:main "find")))
	 (con (conc "tcp://*:" port)))
    ;; register this connect here ....
    (nn-bind rep con)
    (thread-start! 
     (make-thread (lambda ()
		    (dboard:one-time-ping-receive rep port))
		  "one time receive thread"))
    (if (dboard:ping-self "localhost" port)
	(begin
	  (print "INFO: dashboard nanomsg server started on " port)
	  (values rep port))
	(begin
	  (print "WARNING: couldn't create server on port " port)
	  (portlogger:main "set" "failed")
	  (if (> num-tries 0)
	      (dboard:server-start #f (- num-tries 1))
	      (begin
		(print "ERROR: failed to start nanomsg server")
		(values #f #f)))))))

(define (dboard:server-close con port)
  (nn-close con)
  (portlogger:main "set" port "released"))

(define (dboard:ping-self host port #!key (return-socket #t))
  ;; send a random number along with pid and check that we get it back
  (let* ((req     (nn-socket 'req))
	 (key     "ping")
	 (success #f)
	 (keepwaiting #t)
	 (ping    (make-thread
		   (lambda ()
		     (print "ping: sending string \"" key "\", expecting " (current-process-id))
		     (nn-send req key)
		     (let ((result  (nn-recv req)))
		       (if (equal? (conc (current-process-id)) result)
			   (begin
			     (print "ping, success: received \"" result "\"")
			     (set! success #t))
			   (begin
			     (print "ping, failed: received key \"" result "\"")
			     (set! keepwaiting #f)
			     (set! success #f)))))
		   "ping"))
	 (timeout (make-thread (lambda ()
				 (let loop ((count 0))
				   (thread-sleep! 1)
				   (print "still waiting after " count " seconds...")
				   (if (and keepwaiting (< count 10))
				       (loop (+ count 1))))
				 (if keepwaiting
				     (begin
				       (print "timeout waiting for ping")
				       (thread-terminate! ping))))
			       "timeout")))
    (nn-connect req (conc "tcp://" host ":" port))
    (handle-exceptions
     exn
     (begin
       (print-call-chain)
       (print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
       (print "exn=" (condition->list exn))
       (print "ping failed to connect to " host ":" port))
     (thread-start! timeout)
     (thread-start! ping)
     (thread-join! ping)
     (if success (thread-terminate! timeout)))
    (if return-socket
	(if success req #f)
	(begin
	  (nn-close req)
	  success))))

;;======================================================================
;; C O N F I G U R A T I O N 
;;======================================================================

;; Get the configuration file for a group name, if the group name is "default" and it doesn't 
;; exist, create it and add the current path if it contains megatest.config
;;
(define (dboard:get-config group-name)
  (let* ((fname (conc (getenv "HOME") "/.megatest/" group-name ".dat")))
    (if (file-exists? fname)
	(read-config fname (make-hash-table) #t)
	(if (dboard:create-config fname)
	    (dboard:get-config group-name)
	    (make-hash-table)))))

(define (dboard:create-config fname)
  ;; (handle-exceptions
  ;;  exn
  ;;  
  ;;  #f ;; failed to create - just give up
   (let* ((dirname       (pathname-directory fname))
	  (file-name     (pathname-strip-directory fname))
	  (curr-mtcfgdat (find-config "megatest.config"
				      toppath: (or (get-environment-variable "MT_RUN_AREA_HOME")(current-directory))))
	  (curr-mtcfg    (if (and curr-mtcfgdat (not (null? curr-mtcfgdat)))(cadr curr-mtcfgdat) #f))
	  (curr-mtpath   (if curr-mtcfg (car curr-mtcfgdat) #f)))
     (if curr-mtpath
	 (begin
	   (debug:print-info 0 *default-log-port* "Creating config file " fname)
	   (if (not (file-exists? dirname))
	       (create-directory dirname #t))
	   (with-output-to-file fname
	     (lambda ()
	       (let ((aname (pathname-strip-directory curr-mtpath)))
		 (print "[" aname "]")
		 (print  "path " curr-mtpath))))
	   #t)
	 (begin
	   (debug:print-info 0 *default-log-port* "Need to create a config but no megatest.config found: " curr-mtcfgdat)
	   #f))))
;; )

(define (dboard:read-mtconf apath)
  (let* ((mtconffile  (conc apath "/megatest.config")))
    (call-with-environment-variables
     (list (cons "MT_RUN_AREA_HOME" apath))
     (lambda ()
       (read-config mtconffile (make-hash-table) #f)) ;; megatest.config
     )))
	 

;;======================================================================
;; G U I   S T U F F 
;;======================================================================

;;; main. Theoretically could have multiple windows (each with a group of tags, thus window-id
;;;
(define (dboard:make-window window-id)
  (let* (;; (window-id 0)
	 (groupn    (or (args:get-arg "-group") "default"))
	 (cfgdat    (dboard:get-config groupn))
	 ;; (cfgdat    (if (file-exists? cfname)(read-config cfname (make-hash-table) #t)(make-hash-table)))
	 (data      (make-data
		     cfgdat ;; this is the data from ~/.megatest for the selected group
		     (make-hash-table) ;; areaname -> area-rec
		     0                 ;; current window id
		     0                 ;; current tab id
		     #f                ;; redraw needed for current tab id
		     (make-hash-table) ;; tab-id -> areaname
		     )))
    (hash-table-set! *windows* window-id data)
    (iup:show (dashboard:main-panel data window-id))
    (iup:main-loop)))

;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))

(define (main)
  (let-values 
      (((con port)(dboard:server-start #f)))
    (let ((portnum   (if (string? port)(string->number port) port)))
      ;; got here, monitor/dashboard was started
      (mddb:register-dashboard portnum)
      (thread-start! (make-thread (lambda ()(dboard:server-service con portnum)) "server service"))
      (thread-start! (make-thread (lambda ()
				    (let loop ()
				      (dboard:general-updater con portnum)
				      (thread-sleep! 1)
				      (loop))) "general updater"))
      (dboard:make-window 0)
      (mddb:unregister-dashboard (get-host-name) portnum)
      (dboard:server-close con port))))

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted defunct/nmsg-transport.scm version [b30844cb1a].

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

;; Copyright 2006-2012, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

(require-extension (srfi 18) extras tcp s11n)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
(import (prefix sqlite3 sqlite3:))

;; (use nanomsg)

(declare (unit nmsg-transport))

(declare (uses common))
(declare (uses db))
(declare (uses tests))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(declare (uses server))

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

;; Transition to pub --> sub with pull <-- push
;;
;;   1. client sends request to server via push to the pull port
;;   2. server puts request in queue or processes immediately as appropriate
;;   3. server puts responses from completed requests into pub port 
;;
;; TODO
;;
;; Done Tested
;; [x]  [ ]    1. Add columns pullport pubport to servers table
;; [x]  [ ]    2. Add rm of monitor.db if older than 11/12/2012 
;; [x]  [ ]    3. Add create of pullport and pubport with finding of available ports
;; [x]  [ ]    4. Add client compose of request
;; [x]  [ ]        - name of client: testname/itempath-test_id-hostname 
;; [x]  [ ]        - name of request: callname, params
;; [x]  [ ]        - request key: f(clientname, callname, params)
;; [x]  [ ]    5. Add processing of subscription hits
;; [x]  [ ]        - done when get key 
;; [x]  [ ]        - return results
;; [x]  [ ]    6. Add timeout processing
;; [x]  [ ]        - after 60 seconds
;; [ ]  [ ]            i. check server alive, connect to new if necessary
;; [ ]  [ ]           ii. resend request
;; [ ]  [ ]    7. Turn self ping back on

(define (nmsg-transport:make-server-url hostport #!key (bindall #f))
  (if (not hostport)
      #f
      (conc "tcp://" (if bindall "*" (car hostport)) ":" (cadr hostport))))

(define *server-loop-heart-beat* (current-seconds))
(define *heartbeat-mutex* (make-mutex))

;;======================================================================
;; S E R V E R
;;======================================================================

(define (nmsg-transport:run dbstruct hostn run-id server-id #!key (retrynum 1000))
  (debug:print 2 *default-log-port* "Attempting to start the server ...")
  (let* ((start-port      (portlogger:open-run-close portlogger:find-port))
	 (server-thread   (make-thread (lambda ()
					 (nmsg-transport:try-start-server dbstruct run-id start-port server-id))
				       "server thread"))
	 (tdbdat          (tasks:open-db)))
    (thread-start! server-thread)
    (thread-sleep! 0.1)
    (if (nmsg-transport:ping hostn start-port timeout: 2 expected-key: (current-process-id))
	(let ((interface (if (equal? hostn "-")(get-host-name) hostn)))
	  (tasks:server-set-interface-port (db:delay-if-busy tdbdat) server-id interface start-port)
	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
	  (set! *server-info* (list hostn start-port)) ;; probably not needed anymore? currently used by keep-running
	  (thread-sleep! 3) ;; give some margin for queries to complete before switching from file based access to server based access
	  ;; (set! *inmemdb*  dbstruct)
	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
	  (thread-start! (make-thread
			  (lambda ()(nmsg-transport:keep-running server-id run-id))
			  "keep running"))
	  (thread-join! server-thread))
	(if (> retrynum 0)
	    (begin
	      (debug:print 0 *default-log-port* "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.")
	      (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature")
	      (portlogger:open-run-close portlogger:set-failed start-port)
	      (nmsg-transport:run dbstruct hostn run-id server-id))
	    (begin
	      (debug:print-error 0 *default-log-port* "could not find an open port to start server on. Giving up")
	      (exit 1))))))

(define (nmsg-transport:try-start-server dbstruct run-id portnum server-id)
  (let ((repsoc (nn-socket 'rep)))
    (nn-bind repsoc (conc "tcp://*:" portnum))
    (let loop ((msg-in (nn-recv repsoc)))
      (let* ((dat    (db:string->obj msg-in transport: 'nmsg)))
	(debug:print 0 *default-log-port* "server, received: " dat)
	(let ((result (api:execute-requests dbstruct dat)))
	  (debug:print 0 *default-log-port* "server, sending: " result)
	  (nn-send repsoc (db:obj->string result  transport: 'nmsg)))
	(loop (nn-recv repsoc))))))

;; all routes though here end in exit ...
;;
(define (nmsg-transport:launch run-id)
  (let* ((tdbdat   (tasks:open-db))
	 (dbstruct (db:setup run-id))
	 (hostn    (or (args:get-arg "-server") "-")))
    (set! *run-id*   run-id)
    (set! *inmemdb* dbstruct)
    ;; with nbfake daemonize isn't really needed
    ;;
    ;; (if (args:get-arg "-daemonize")
    ;;     (begin
    ;;       (daemon:ize)
    ;;       (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
    ;;           (begin
    ;;     	(current-error-port *alt-log-file*)
    ;;     	(current-output-port *alt-log-file*)))))
    (if (server:check-if-running run-id)
	(begin
	  (debug:print-info 0 *default-log-port* "Server for run-id " run-id " already running")
	  (exit 0)))
    (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
	       (remtries  4))
      (if (not server-id)
	  (if (> remtries 0)
	      (begin
		(thread-sleep! 2)
		(if (not (server:check-if-running run-id))
		    (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
			  (- remtries 1))
		    (begin
		      (debug:print-info 0 *default-log-port* "Another server took the slot, exiting")
		      (exit 0))))
	      (begin
		;; since we didn't get the server lock we are going to clean up and bail out
		(debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
		(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
		))
	  ;; locked in a server id, try to start up
	  (nmsg-transport:run dbstruct hostn run-id server-id))
      (set! *didsomething* #t)
      (exit))))

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

(define (nmsg-transport:mk-signature)
  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list (current-directory)
					  (argv)))))))

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

;; ping the server at host:port
;;   return the open socket if successful (return-socket == #t)
;;   expect the key expected-key returned in payload
;;   send our-key or #f as payload
;;
(define (nmsg-transport:ping hostn port #!key (timeout 3)(return-socket #t)(expected-key #f)(our-key #f)(socket #f))
  ;; send a random number along with pid and check that we get it back
  (let* ((host    (if (or (not hostn)
			  (equal? hostn "-")) ;; use localhost
		      (get-host-name)
		      hostn))
	 (req     (or socket
		      (let ((soc (nn-socket 'req)))
			(nn-connect soc (conc "tcp://" host ":" port))
			soc)))
	 (success #t)
	 (dat     (vector "ping" our-key))
	 (result  (condition-case 
		   (nmsg-transport:client-api-send-receive-raw req dat timeout: timeout)
		   ((timeout)(set! success #f) #f)))
	 (key     (if success 
		      (vector-ref result 1)
		      #f)))
    (debug:print 0 *default-log-port* "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key))
    (if (and success
	     (or (not expected-key) ;; just getting a reply is good enough then
		 (equal? key expected-key)))
	(if return-socket
	    req
	    (begin
	      (if (not socket)(nn-close req)) ;; don't want a side effect of closing socket if handed it
	      #t))
	(begin
	  (if (not socket)(nn-close req)) ;; failed to ping, close socket as side effect
	  #f))))

;; send data to server, wait max of timeout seconds for a response.
;; return #( success/fail result )
;;
;; for effiency it is easier to do the obj->string and string->obj here.
;;
(define (nmsg-transport:client-api-send-receive-raw socreq indat #!key (enable-send #t)(timeout 25))
  (let* ((success     #f)
	 (result      #f)
	 (keepwaiting #t)
	 (dat         (db:obj->string indat transport: 'nmsg))
	 (send-recv   (make-thread
		       (lambda ()
			 (nn-send socreq dat)
			 (let* ((res (nn-recv socreq)))
			   (set! success #t)
			   (set! result (db:string->obj res transport: 'nmsg))))
		       "send-recv"))
	 (timeout     (make-thread
		       (lambda ()
			 (let loop ((count 0))
			   (thread-sleep! 1)
			   (debug:print-info 1 *default-log-port* "send-receive-raw, still waiting after " count " seconds...")
			   (if (and keepwaiting (< count timeout)) ;; yes, this is very aproximate
			       (loop (+ count 1))))
			 (if keepwaiting
			     (begin
			       (print "timeout waiting for ping")
			       (thread-terminate! send-recv))))
		       "timeout")))
    ;; replace with condition-case?
    (handle-exceptions
     exn
     (set! result "timeout")
     (thread-start! timeout)
     (thread-start! send-recv)
     (thread-join! send-recv)
     (if success (thread-terminate! timeout)))
    ;; raise timeout error if timed out
    (if success
	(if (and (vector? result)
		 (vector-ref result 0)) ;; did it fail at the server?
	    result                ;; nope, all good
	    (begin
	      (debug:print-error 0 *default-log-port* "error occured at server, info=" (vector-ref result 2))
	      (debug:print 0 *default-log-port* " client call chain:")
	      (print-call-chain (current-error-port))
	      (debug:print 0 *default-log-port* " server call chain:")
	      (pp (vector-ref result 1) (current-error-port))
	      (signal (vector-ref result 0))))
	(signal (make-composite-condition
		 (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))

;; run nmsg-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (nmsg-transport:keep-running server-id run-id)
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive
  (let* ((server-info (let loop ()
                        (let ((sdat #f))
                          (mutex-lock! *heartbeat-mutex*)
                          (set! sdat *server-info*)
                          (mutex-unlock! *heartbeat-mutex*)
                          (if sdat 
			      (begin
				(debug:print-info 0 *default-log-port* "keep-running got sdat=" sdat)
				sdat)
                              (begin
                                (thread-sleep! 0.5)
                                (loop))))))
         (iface       (car server-info))
         (port        (cadr server-info))
         (last-access 0)
	 (tdbdat      (tasks:open-db))
	 (server-timeout (let ((tmo (configf:lookup  *configdat* "server" "timeout")))
			   (if (and (string? tmo)
				    (string->number tmo))
			       (* 60 60 (string->number tmo))
			       ;; (* 3 24 60 60) ;; default to three days
			       (* 60 1)         ;; default to one minute
			       ;; (* 60 60 25)      ;; default to 25 hours
			       ))))
    (print "Keep-running got server pid " server-id ", using iface " iface " and port " port)
    (let loop ((count 0))
      (thread-sleep! 4) ;; no need to do this very often
      ;; NB// sync currently does NOT return queue-length
      (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1)))
      ;; (print "Server running, count is " count)
        (if (< count 1) ;; 3x3 = 9 secs aprox
            (loop (+ count 1)))
        
        (mutex-lock! *heartbeat-mutex*)
        (set! last-access *last-db-access*)
        (mutex-unlock! *heartbeat-mutex*)
	(db:sync-touched *inmemdb* run-id force-sync: #t)
        (if (and *server-run*
	       (> (+ last-access server-timeout)
		  (current-seconds)))
            (begin
              (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
              (loop 0))
            (begin
              (debug:print-info 0 *default-log-port* "Starting to shutdown the server.")
              (set! *time-to-exit* #t)
	      (db:sync-touched *inmemdb* run-id force-sync: #t)
              (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running")
              (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
              (exit)
	      ))))))

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

(define (nmsg-transport:client-connect iface portnum)
  (let* ((reqsoc      (nmsg-transport:ping iface portnum return-socket: #t)))
    (vector iface portnum #f #f #f (current-seconds) reqsoc)))

;; returns result, there is no sucess/fail flag - handled via excpections
;;
(define (nmsg-transport:client-api-send-receive run-id connection-info cmd param #!key (remtries 5))
  ;; NB// In the html version of this routine there is a call to 
  ;;      tasks:kill-server-run-id when there is an exception
  (mutex-lock! *http-mutex*)
  (let* ((packet  (vector cmd param))
	 (reqsoc  (http-transport:server-dat-get-socket connection-info))
	 (res     (nmsg-transport:client-api-send-receive-raw reqsoc packet)))
;;	 (status  (vector-ref rawres 0))
;;	 (result  (vector-ref rawres 1)))
    (mutex-unlock! *http-mutex*)
    res)) ;; (vector status (if status (db:string->obj result transport: 'nmsg) result))))
	
;;======================================================================
;; J U N K 
;;======================================================================

;; DO NOT USE
;;
(define (nmsg-transport:client-signal-handler signum)
  (handle-exceptions
   exn
   (debug:print 0 *default-log-port* " ... exiting ...")
   (let ((th1 (make-thread (lambda ()
			     (if (not *received-response*)
				 (receive-message* *runremote*))) ;; flush out last call if applicable
			   "eat response"))
	 (th2 (make-thread (lambda ()
			     (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
			     (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
			     (debug:print 0 *default-log-port* "       Done.")
			     (exit 4))
			   "exit on ^C timer")))
     (thread-start! th2)
     (thread-start! th1)
     (thread-join! th2))))

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































































































































Modified docs/manual/megatest_manual.html from [c3063909ab] to [a4e30dbe30].

1
2
3
4
5
6
7
8
9
10
11
12
<!DOCTYPE html>
<html lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
<meta name="generator" content="AsciiDoc 8.6.7">
<title>The Megatest Users Manual</title>
<style type="text/css">
/* Shared CSS for AsciiDoc xhtml11 and html5 backends */

/* Default font. */
body {
  font-family: Georgia,serif;




|







1
2
3
4
5
6
7
8
9
10
11
12
<!DOCTYPE html>
<html lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
<meta name="generator" content="AsciiDoc 8.6.9">
<title>The Megatest Users Manual</title>
<style type="text/css">
/* Shared CSS for AsciiDoc xhtml11 and html5 backends */

/* Default font. */
body {
  font-family: Georgia,serif;
82
83
84
85
86
87
88
89



90
91
92



93
94
95
96
97
98
99

ul, ol, li > p {
  margin-top: 0;
}
ul > li     { color: #aaa; }
ul > li > * { color: black; }

pre {



  padding: 0;
  margin: 0;
}




#author {
  color: #527bbd;
  font-weight: bold;
  font-size: 1.1em;
}
#email {







|
>
>
>



>
>
>







82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105

ul, ol, li > p {
  margin-top: 0;
}
ul > li     { color: #aaa; }
ul > li > * { color: black; }

.monospaced, code, pre {
  font-family: "Courier New", Courier, monospace;
  font-size: inherit;
  color: navy;
  padding: 0;
  margin: 0;
}
pre {
  white-space: pre-wrap;
}

#author {
  color: #527bbd;
  font-weight: bold;
  font-size: 1.1em;
}
#email {
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228

div.exampleblock > div.content {
  border-left: 3px solid #dddddd;
  padding-left: 0.5em;
}

div.imageblock div.content { padding-left: 0; }
span.image img { border-style: none; }
a.image:visited { color: white; }

dl {
  margin-top: 0.8em;
  margin-bottom: 0.8em;
}
dt {







|







220
221
222
223
224
225
226
227
228
229
230
231
232
233
234

div.exampleblock > div.content {
  border-left: 3px solid #dddddd;
  padding-left: 0.5em;
}

div.imageblock div.content { padding-left: 0; }
span.image img { border-style: none; vertical-align: text-bottom; }
a.image:visited { color: white; }

dl {
  margin-top: 0.8em;
  margin-bottom: 0.8em;
}
dt {
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429


/*
 * xhtml11 specific
 *
 * */

tt {
  font-family: "Courier New", Courier, monospace;
  font-size: inherit;
  color: navy;
}

div.tableblock {
  margin-top: 1.0em;
  margin-bottom: 1.5em;
}
div.tableblock > table {
  border: 3px solid #527bbd;
}







<
<
<
<
<
<







416
417
418
419
420
421
422






423
424
425
426
427
428
429


/*
 * xhtml11 specific
 *
 * */







div.tableblock {
  margin-top: 1.0em;
  margin-bottom: 1.5em;
}
div.tableblock > table {
  border: 3px solid #527bbd;
}
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468


/*
 * html5 specific
 *
 * */

.monospaced {
  font-family: "Courier New", Courier, monospace;
  font-size: inherit;
  color: navy;
}

table.tableblock {
  margin-top: 1.0em;
  margin-bottom: 1.5em;
}
thead, p.tableblock.header {
  font-weight: bold;
  color: #527bbd;







<
<
<
<
<
<







449
450
451
452
453
454
455






456
457
458
459
460
461
462


/*
 * html5 specific
 *
 * */







table.tableblock {
  margin-top: 1.0em;
  margin-bottom: 1.5em;
}
thead, p.tableblock.header {
  font-weight: bold;
  color: #527bbd;
534
535
536
537
538
539
540


541
542
543
544
545
546
547
body.manpage div.sectionbody {
  margin-left: 3em;
}

@media print {
  body.manpage div#toc { display: none; }
}


@media screen {
  body {
    max-width: 50em; /* approximately 80 characters wide */
    margin-left: 16em;
  }

  #toc {







>
>







528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
body.manpage div.sectionbody {
  margin-left: 3em;
}

@media print {
  body.manpage div#toc { display: none; }
}


@media screen {
  body {
    max-width: 50em; /* approximately 80 characters wide */
    margin-left: 16em;
  }

  #toc {
866
867
868
869
870
871
872































































873
874
875
876
877
878
879
880
</div>
</div>
<div class="sect1">
<h2 id="_road_map">Road Map</h2>
<div class="sectionbody">
<div class="paragraph"><p>Note 1: This road-map is still evolving and subject to change without notice.</p></div>
<div class="sect2">































































<h3 id="_rfc_move_data_into_completed_runs_db">RFC: Move data into completed-runs.db</h3>
<div class="paragraph"><p><strong>Purpose</strong>: shrink megatest.db data to enable lower load and higher performance.</p></div>
<div class="paragraph"><p><strong>Method</strong>: add a completed-runs.db and automatically move runs data from megatest.db to that db</p></div>
<div class="paragraph"><p><strong>Design</strong>:</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
completed-runs.db is a full megatest database with complete schema







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







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
</div>
</div>
<div class="sect1">
<h2 id="_road_map">Road Map</h2>
<div class="sectionbody">
<div class="paragraph"><p>Note 1: This road-map is still evolving and subject to change without notice.</p></div>
<div class="sect2">
<h3 id="_rfc_m01_add_ability_to_move_runs_to_other_areas">RFC M01: Add ability to move runs to other Areas</h3>
<div class="paragraph"><p><strong>Purpose</strong>: allow shrinking megatest.db data by moving runs to an alternate
 Megatest area with same keys.</p></div>
<div class="paragraph"><p><strong>Method</strong>: extend db sync to take a different megatest area as a destination.</p></div>
<div class="paragraph"><p><strong>Design</strong>:</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
add param -destination [area|path]. when specified runs are copied to new
  area and removed from local db.
</p>
</li>
<li>
<p>
the data move would involve these steps
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
copy the run data to destination area megatest.db
</p>
</li>
<li>
<p>
mark the run records as MOVED, do not remove the run data on disk
</p>
</li>
</ol></div>
</li>
<li>
<p>
accessing the data would be by running dashboard in the satellite area
</p>
</li>
<li>
<p>
future versions of Megatest dashboard should support displaying areas in a
  merged way by adding the area as the topmost variable (i.e. effectively
  extending the target.
</p>
</li>
<li>
<p>
some new controls would be supported in the config
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
[setup] &#8658; allow-runs [no|yes]  &#8656;= used to disallow runs
</p>
</li>
<li>
<p>
[automigrate] &#8658; areaname target=%/%/%; runname=%; age=30d &#8656;= automigrate
   by these criteria for the given area.
</p>
</li>
</ol></div>
</li>
</ol></div>
<div class="paragraph"><p><strong>Branch</strong>: This work is taking place on branch v1.65-reduce-records</p></div>
</div>
<div class="sect2">
<h3 id="_rfc_m02_move_data_into_completed_runs_db">RFC M02: Move data into completed-runs.db</h3>
<div class="paragraph"><p><strong>Purpose</strong>: shrink megatest.db data to enable lower load and higher performance.</p></div>
<div class="paragraph"><p><strong>Method</strong>: add a completed-runs.db and automatically move runs data from megatest.db to that db</p></div>
<div class="paragraph"><p><strong>Design</strong>:</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
completed-runs.db is a full megatest database with complete schema
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
</li>
</ol></div>
</li>
</ol></div>
<div class="paragraph"><p><strong>Branch</strong>: This work is taking place on branch v1.65-reduce-records</p></div>
</div>
<div class="sect2">
<h3 id="_rfc_automatic_homehost_migrations">RFC: Automatic homehost migrations</h3>
<div class="paragraph"><p><strong>Purpose</strong>: Automatically migrate homehost.</p></div>
<div class="paragraph"><p><strong>Method</strong>: Check that there are no tests running, launched or remotehoststart in past ½ hour then if not on homehost migrate the db to current host</p></div>
<div class="paragraph"><p><strong>Design</strong>:</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Check that the system is quiescent, i.e. that there are no runs in flight or recently run







|







983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
</li>
</ol></div>
</li>
</ol></div>
<div class="paragraph"><p><strong>Branch</strong>: This work is taking place on branch v1.65-reduce-records</p></div>
</div>
<div class="sect2">
<h3 id="_rfc_m03_automatic_homehost_migrations">RFC M03: Automatic homehost migrations</h3>
<div class="paragraph"><p><strong>Purpose</strong>: Automatically migrate homehost.</p></div>
<div class="paragraph"><p><strong>Method</strong>: Check that there are no tests running, launched or remotehoststart in past ½ hour then if not on homehost migrate the db to current host</p></div>
<div class="paragraph"><p><strong>Design</strong>:</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Check that the system is quiescent, i.e. that there are no runs in flight or recently run
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
<div class="content monospaced">
<pre>[triggers]
COMPLETED/ xterm -e bash -s --</pre>
</div></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
</td>
<td class="content">There is a trailing space after the --</td>
</tr></table>
</div>
<div class="paragraph"><p>There are a number of environment variables available to the trigger script
but since triggers can be called in various contexts not all variables are
available at all times. The trigger script should check for the variable and







|







2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
<div class="content monospaced">
<pre>[triggers]
COMPLETED/ xterm -e bash -s --</pre>
</div></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/usr/images/icons/note.png" alt="Note">
</td>
<td class="content">There is a trailing space after the --</td>
</tr></table>
</div>
<div class="paragraph"><p>There are a number of environment variables available to the trigger script
but since triggers can be called in various contexts not all variables are
available at all times. The trigger script should check for the variable and
2401
2402
2403
2404
2405
2406
2407
2408

2409
2410
2411
2412
</div>
</div>
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br>
Last updated 2018-01-30 13:24:43 PST

</div>
</div>
</body>
</html>







|
>




2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
</div>
</div>
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br>
Last updated
 2018-02-03 21:10:39 MST
</div>
</div>
</body>
</html>

Modified docs/manual/server.png from [ae7d7ee58e] to [267af6c507].

cannot compute difference between binary files

Deleted ducttape/Makefile version [7c53ca1a83].

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
help:
	@echo ""
	@echo "make targets:"
	@echo "============="
	@echo "install      - build and install general_lib egg as icfadm"
	@echo "test         - run unit tests on ducttape-lib.scm (tests code, not egg)"
	@echo "eggs-info     - show chicken-install commands to get eggs upon which ducttape-lib depends"
	@echo "test_example - compile an example scm against installed general_lib egg"
	@echo "clean        - remove binaries and other build artifacts"
	@echo ""

clean:
	rm -f *.so *.import.scm test_ducttape test_example foo *.c *.o

install:
	chicken-install

test:
	chicken-install -no-install
	csc test_ducttape.scm

	./test_ducttape
	rm -f foo

test_example:
	@csc test_example.scm
	@./test_example
	@rm test_example

eggs-info:
	@echo chicken-install ansi-escape-sequences
	@echo chicken-install slice
	@echo chicken-install rfc3339
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































Deleted ducttape/README version [bc9be285fc].

1
2
3
4
5
6
7
8
This directory holds the "ducttape" chicken scheme egg used by megatest.

Run "make test" to ensure this egg works on your system.

Run "make install" as your admin user with chicken on your $PATH to install this egg.



<
<
<
<
<
<
<
<
















Deleted ducttape/ducttape-lib.meta version [a22283c9d8].

1
2
3
4
5
6
7
8
9
10
11
12
13
;;; ducttape-lib.meta -*- Hen -*-

((egg "ducttape-lib.egg")
 (synopsis "Miscellaneous tool and standard print routines.")
 (category env)
 (author "Brandon Barclay")
 (doc-from-wiki)
 (license "GPL-2")
 ;; srfi-69, posix, srfi-18
 (depends regex)
 (test-depends test)
 ; suspicious - (files "ducttape-lib")
 )
<
<
<
<
<
<
<
<
<
<
<
<
<


























Deleted ducttape/ducttape-lib.scm version [8e1a0ecd55].

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
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
(module ducttape-lib
    (
     runs-ok
     ducttape-debug-level
     ducttape-debug-regex-filter
     ducttape-silent-mode
     ducttape-quiet-mode
     ducttape-log-file
     ducttape-color-mode
     iputs-preamble
     script-name
     idbg
     ierr
     iwarn
     inote
     iputs
     re-match?
                                        ;     launch-repl
     keyword-skim
     skim-cmdline-opts-noarg-by-regex
     skim-cmdline-opts-withargs-by-regex
     get-cli-arg
     get-cli-switch
     concat-lists
     ducttape-process-command-line
     ducttape-append-logfile
     ducttape-activate-logfile
     isys
     do-or-die
     counter-maker
     dir-is-writable?
     mktemp
     get-tmpdir
     sendmail
     find-exe

     zeropad
     string-leftpad
     string-rightpad
     seconds->isodate
     seconds->wwdate
     seconds->wwdate-values
     isodate->seconds
     isodate->wwdate
     wwdate->seconds
     wwdate->isodate
     current-wwdate
     current-isodate
     *this-exe-dir*
     *this-exe-name*
     *this-exe-fullpath*
     )

  (import scheme chicken extras ports data-structures )
  (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339)
  ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process*
  (use directory-utils uuid-lib filepath srfi-19 ) ; linenoise

    ;; plugs a hole in posix-extras in latter chicken versions
  (use posix-extras pathname-expand files)
  (define ##sys#expand-home-path pathname-expand)
  (define (realpath x) (resolve-pathname  (pathname-expand (or x "/dev/null")) ))

  (include "mimetypes.scm") ; provides ext->mimetype
  (include "workweekdate.scm")
  (define ducttape-lib-version 1.00)
  (define (toplevel-command sym proc) (lambda () #f))

;;;; define some handy globals
  ;; resolve fullpath to this script or binary.
  (define (__get-this-script-fullpath #!key (argv (argv)))
    (let* ((this-script
            (cond
             ((and (> (length argv) 2)
                   (string-match "^(.*/csi|csi)$" (car argv))
                   (string-match "^-(s|ss|sx|script)$" (cadr argv)))
              (caddr argv))
             (else (car argv))))
           (fullpath (realpath this-script)))
      fullpath))
  
  (define *this-exe-fullpath* (__get-this-script-fullpath))
  (define *this-exe-dir*      (pathname-directory *this-exe-fullpath*))
  (define *this-exe-name*     (pathname-strip-directory *this-exe-fullpath*))
  

;;;; utility procedures


  
  ;; begin credit: megatest's process.scm
  (define (port->list fh )
    (if (eof-object? fh) #f
        (let loop ((curr (read-line fh))
                   (result '()))
          (if (not (eof-object? curr))
              (loop (read-line fh)
                    (append result (list curr)))
              result))))

  (define (conservative-read port)
    (let loop ((res ""))
      (if (not (eof-object? (peek-char port)))
          (loop (conc res (read-char port)))
          res)))
  ;; end credit: megatest's process.scm

  (define (counter-maker)
    (let ((acc 0))
      (lambda ( #!optional (increment 1) )
        (set! acc (+ increment acc))
        acc)))

  (define (port->string port #!optional ) ; todo - add newline 
    (let ((linelist (port->list port)))
      (if linelist
          (string-join linelist "\n")
          "")))


  (define (outport->foreach outport foreach-thunk)
    (let loop ((line (foreach-thunk)))
      (if line
          (begin
            (write-line line outport)
            (loop (foreach-thunk))
            )
          (begin
            ;;http://bugs.call-cc.org/ticket/766
            ;;close-[input|output]-port implicitly calling process-wait on process pipe ports. This leads to errors like
            ;;Error: (process-wait) waiting for child process failed - No child processes: 10872
            (close-output-port outport)
            #f))))
  
  ;; weird - alist-ref arg order changes signature csc vs. csi... explitly defining.
  (define (my-alist-ref key alist)
    (let ((res (assoc key alist)))
      (if res (cdr res) #f)))

  (define (keyword-skim-alist args alist)
    (let loop ((result-alist '()) (result-args args) (rest-alist alist))
      (cond
       ((null? rest-alist) (values result-alist result-args))
       (else
        (let ((keyword (caar rest-alist))
              (defval (cdar rest-alist)))
          (let-values (((kwval result-args2)
                        (keyword-skim
                         keyword
                         defval
                         result-args)))
            (loop
             (cons (cons keyword kwval) result-alist)
             result-args2
             (cdr rest-alist))))))))
  
  (define (isys command . rest-args)
    (let-values
        (((opt-alist args)
          (keyword-skim-alist
           rest-args
           '( ( foreach-stdout-thunk: . #f )
              ( foreach-stdin-thunk: . #f )
              ( stdin-proc: . #f ) ) )))
      (let* ((foreach-stdout-thunk
              (my-alist-ref foreach-stdout-thunk: opt-alist))
             (foreach-stdin-thunk
              (my-alist-ref foreach-stdin-thunk: opt-alist))
             (stdin-proc
              (if foreach-stdin-thunk
                  (lambda (port)
                    (outport->foreach port foreach-stdin-thunk))
                  (my-alist-ref stdin-proc: opt-alist))))

        ;; TODO: support command is list.
        
        (let-values (((stdout stdin pid stderr)
                      (if (null? args)
                          (process* command)
                          (process* command args))))
          
                                        ;(if foreach-stdin-thunk
                                        ;    (set! stdin-proc
                                        ;          (lambda (port)
                                        ;            (outport->foreach port foreach-stdin-thunk))))
          
          (if stdin-proc
              (stdin-proc stdin))
          
          (let ((stdout-res 
                 (if foreach-stdout-thunk  ;; don't accumulate stdout if we have a thunk; probably doing this because stdout is BIG so lets not waste memory
                     (begin
                       (port-for-each foreach-stdout-thunk (lambda () (read-line stdout)))
                       "foreach-stdout-thunk ate stdout"
                       )
                     (if stdin-proc
                         "foreach-stdin-thunk/stdin-proc blocks stdout"
                         (port->string stdout))))
                (stderr-res
                 (if stdin-proc
                     "foreach-stdin-thunk/stdin-proc blocks stdout"
                     (port->string stderr))))

            ;; if we've used a stdin-proc, we've closed stdin port, which unfortunately causes a wait-pid internally, causing stdout and stderr ports to auto-close.  don't close them again.  (so sad - we lost stdout and stderr contents when we write to stdin)
            ;; see - http://bugs.call-cc.org/ticket/766
            (if (not stdin-proc)
                (close-input-port stdout)
                (close-input-port stderr))
            
            (let-values (((anotherpid normalexit? exitstatus)  (process-wait pid)))
              (values exitstatus stdout-res stderr-res)))))))
  
  (define (do-or-die command   #!key nodie (foreach-stdout #f) (stdin-proc #f))
    (let-values (((exit-code stdout-str stderr-str) (isys command foreach-stdout-thunk: foreach-stdout stdin-proc: stdin-proc )))
      (if (equal? 0 exit-code)
          stdout-str
          (begin
            (ierr (conc "Command  > " command " "  "< failed with " exit-code " because: \n" stderr-str) )
            (if nodie #f (exit exit-code))))))


  ;; runs-ok: evaluate expression while suppressing exceptions.
                                        ;    on caught exception, returns #f
                                        ;    otherwise, returns expression value
  (define (runs-ok thunk)
    (handle-exceptions exn #f (begin (thunk) #t)))

  ;; concat-lists: result list = lista + listb
  (define (concat-lists lista listb) ;; ok, I just reimplemented append...
    (foldr cons listb lista))
  

;;; setup general_lib env var parameters

  ;; show warning/note/error/debug prefixes using ansi colors
  (define ducttape-color-mode
    (make-parameter (get-environment-variable "DUCTTAPE_COLORIZE")))

  ;; if defined, has number value.  if number value > 0, show debug messages
  ;; value should be decremented in subshells -- idea is raising debug level will show debug messages deeper and deeper in process call stack
  (define ducttape-debug-level
    (make-parameter
     (let ( (raw-debug-level (get-environment-variable "DUCTTAPE_DEBUG_LEVEL")) )
       (if raw-debug-level
           (let ((num-debug-level (runs-ok (string->number raw-debug-level))))
             (if (integer? num-debug-level)
                 (begin
                   (let ((new-num-debug-level (- num-debug-level 1)))
                     (if (> new-num-debug-level 0) ;; decrement
                         (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level))
                         (unsetenv "DUCTTAPE_DEBUG_LEVEL")))
                   num-debug-level) ; it was set and > 0, mode is value
                 (begin
                   (unsetenv "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it
                   #f))) ; value was invalid, mode is f
           #f)))) ; var not set, mode is f


  (define ducttape-debug-mode (if (ducttape-debug-level)  #t  #f))

  ;; ducttape-debug-regex-filter suppresses non-matching debug messages
  (define ducttape-debug-regex-filter
    (make-parameter
     (let ((raw-debug-pattern (get-environment-variable "DUCTTAPE_DEBUG_PATTERN")))
       (if raw-debug-pattern
           raw-debug-pattern
           "."))))

  ;; silent mode suppresses Note and Warning type messages
  (define ducttape-silent-mode
    (make-parameter (get-environment-variable "DUCTTAPE_SILENT_MODE")))

  ;; quiet mode suppresses Note type messages
  (define ducttape-quiet-mode
    (make-parameter (get-environment-variable "DUCTTAPE_QUIET_MODE")))

  ;; if log file is defined, warning/note/error/debug messages are appended
  ;; to named logfile.
  (define ducttape-log-file
    (make-parameter (get-environment-variable "DUCTTAPE_LOG_FILE")))




  
  
;;; standard messages printing implementation

                                        ; get the name of the current script/binary being run
  (define (script-name)
    (car (reverse (string-split (car (argv)) "/"))))

  (define (ducttape-timestamp)
    (rfc3339->string (time->rfc3339 (seconds->local-time))))


  (define (iputs-preamble msg-type #!optional (suppress-color #f))
    (let ((do-color (and
                     (not suppress-color)
                     (ducttape-color-mode)
                     (terminal-port? (current-error-port)))))
      (case msg-type
        ((note)
         (if do-color
             (set-text (list 'fg-green 'bg-black 'bold) "Note:")
             "Note:"
             ))
        ((warn)
         (if do-color
             (set-text (list 'fg-yellow 'bg-black 'bold) "Warning:")
             "Warning:"
             ))
        ((err)
         (if do-color
             (set-text (list 'fg-red 'bg-black 'bold) "Error:")
             "Error:"
             ))
        ((dbg)
         (if do-color
             (set-text (list 'fg-blue 'bg-magenta) "Debug:")
             "Debug:"
             )))))

  (define (ducttape-append-logfile msg-type message #!optional (suppress-preamble #f))
    (let
        ((txt 
          (string-join 
           (list 
            (ducttape-timestamp) 
            (script-name)
            (if suppress-preamble
                message
                (string-join  (list (iputs-preamble msg-type #t) message) " ")))
           " | ")))

      (if (ducttape-log-file)
          (runs-ok
           (call-with-output-file (ducttape-log-file)
             (lambda (output-port)
               (format output-port "~A ~%" txt)
               )
             #:append))
          #t)))

  (define (ducttape-activate-logfile #!optional (logfile #f))
    ;; from python ducttape-lib.py
                                        ; message = "START - pid=%d ppid=%d argv=(%s) pwd=%s user=%s host=%s"%(pid,ppid," ".join("'"+x+"'" for x in sys.argv),os.environ['PWD'],os.getenv('USER','nouser'),os.getenv('HOST','nohost') )
    (let ((pid (number->string (current-process-id)))
          (ppid (number->string (parent-process-id)))
          (argv 
           (string-join 
            (map 
             (lambda (x) 
               (string-join (list "\"" x "\"")  "" ))
             (argv))
            " "))
          (pwd (or (get-environment-variable "PWD") "nopwd"))
          (user (or (get-environment-variable "USER") "nouser"))
          (host (or (get-environment-variable "HOST") "nohost")))
      (if logfile
          (begin
            (ducttape-log-file logfile)
            (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file))))
      (ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t)))         


  ;; log exit code
  (define (set-ducttape-log-exit-handler)
    (let ((orig-exit-handler (exit-handler)))
      (exit-handler 
       (lambda (exitcode) 
         (ducttape-append-logfile 'note (format #f "Exit ~A by sys.exit" exitcode) #t)
         (orig-exit-handler exitcode)))))


  (define (idbg first-message  . rest-args)
    (let* ((debug-level-threshold
            (if (> (length rest-args) 0) (car rest-args) 1))
           (message-list
            (if (> (length rest-args) 1)
                (cons first-message (cdr rest-args))
                (list first-message)) )
           (message (apply conc
                  (map ->string message-list))))

      (ducttape-append-logfile 'dbg message)
      (if (ducttape-debug-level)
          (if (<= debug-level-threshold (ducttape-debug-level))
              (if (string-search (ducttape-debug-regex-filter) message)
                  (begin 
                    (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'dbg) message (script-name))))))))

  (define (ierr message-first  . message-rest)
    (let* ((message
            (apply conc
             (map ->string (cons message-first message-rest)))))
      (ducttape-append-logfile 'err message)
      (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'err) message (script-name))))

  (define (iwarn message-first  . message-rest)
    (let* ((message
            (apply conc
             (map ->string (cons message-first message-rest)))))
      (ducttape-append-logfile 'warn message)
      (if (not (ducttape-silent-mode))
          (begin
            (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'warn) message (script-name))))))

  (define (inote message-first  . message-rest)
    (let* ((message
            (apply conc
             (map ->string (cons message-first message-rest)))))
      (ducttape-append-logfile 'note message)
      (if (not (or (ducttape-silent-mode) (ducttape-quiet-mode)))
          (begin 
            (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'note) message (script-name))))))

  
  (define (iputs kind message #!optional (debug-level-threshold 1))
    (cond
     ((member kind (string-split "NOTE/Note/note/n/N" "/")) (inote message))
     ((member kind (string-split "Error/ERROR/error/Err/ERR/err/E/e" "/")) (ierr message))
     ((member kind
              (string-split "Warning/WARNING/warning/Warn/WARN/warn/W/w" "/"))
      (iwarn message))
     ((member kind (string-split "Debug/DEBUG/debug/Dbg/DBG/dbg/D/d" "/"))
      (idbg message debug-level-threshold))))

  (define (mkdir-recursive path-so-far hier-list-to-create)
    (if (null? hier-list-to-create)
        path-so-far
        (let* ((next-hier-item (car hier-list-to-create))
               (rest-hier-items (cdr hier-list-to-create))
               (path-to-mkdir (string-concatenate (list path-so-far "/" next-hier-item))))
          (if (runs-ok (lambda () (create-directory path-to-mkdir)))
              (mkdir-recursive path-to-mkdir rest-hier-items)
              #f))))

                                        ; ::mkdir-if-not-exists::
                                        ; make a dir recursively if it does not 
                                        ; already exist.
                                        ; on success - returns path
                                        ; on fail - returns #f
  (define (mkdirp-if-not-exists the-dir)
    (let ( (path-list (string-split the-dir "/")))
      (mkdir-recursive "/" path-list)))

                                        ; ::mkdir-if-not-exists::
                                        ; make a dir recursively if it does not 
                                        ; already exist.
                                        ; on success - returns path
                                        ; on fail - returns #f


  (define (mkdirp-if-not-exists the-dir)
    (let ( (path-list (string-split the-dir "/")))
      (mkdir-recursive "/" path-list)))

  (define (dir-is-writable? the-dir)
    (let ((dummy-file (string-concatenate (list the-dir "/.dummyfile"))))
      (and
       (file-exists? the-dir)
       (cond 
        ((runs-ok (lambda ()(with-output-to-file dummy-file (lambda () (print "foo")))))
         (begin
           (runs-ok (lambda () (delete-file dummy-file) ))
           the-dir))
        (else #f)))))


  (define (get-tmpdir )
    (let* ((tmproot
            (dir-is-writable?
             (or 
              (get-environment-variable "TMPDIR") 
              "/tmp")))

           (user
            (or
             (get-environment-variable "USER")
             "USER_Envvar_not_set"))
           (tmppath
            (string-concatenate 
             (list tmproot "/env21-general-" user ))))

      (dir-is-writable?
       (mkdirp-if-not-exists
        tmppath))))

  (define (mktemp
           #!optional
           (prefix "general_lib_tmpfile")
           (dir #f))
    (let-values
        (((fd path) 
          (file-mkstemp 
           (conc 
            (if dir  dir  (get-tmpdir))
            "/" prefix ".XXXXXX"))))
      (close-output-port (open-output-file* fd))
      path))



  ;;http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment
  ;; write send-email using:
  ;;   - isys-foreach-stdin-line
  ;;   - formatting in http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment
  (define (sendmail to_addr subject body
                    #!key
                    (from_addr "admin")
                    cc_addr
                    bcc_addr
                    more-headers
                    use_html
                    (attach-files-list '())
                    (images-with-content-id-alist '())
                    )

    (define (sendmail-proc sendmail-port)
      (define (wl line-str)
        (write-line line-str sendmail-port))

      (define (get-uuid)
        (string-upcase (uuid->string (uuid-generate))))

      (let ((mailpart-uuid (get-uuid))
            (mailpart-body-uuid (get-uuid)))
        
        (define (boundary)
          (wl (conc "--" mailpart-uuid)))

        (define (body-boundary)
          (wl (conc "--" mailpart-body-uuid)))


        (define (email-mime-header)
          (wl (conc "From: " from_addr))
          (wl (conc "To: " to_addr))
          (if cc_addr
              (wl (conc "Cc: " cc_addr)))
          (if bcc_addr
              (wl (conc "Bcc: " bcc_addr)))
          (if more-headers
              (wl more-headers))
          (wl (conc "Subject: " subject))
          (wl "MIME-Version: 1.0")
          (wl (conc "Content-Type: multipart/mixed; boundary=\"" mailpart-uuid "\""))
          (wl "")
          (boundary)
          (wl (conc "Content-Type: multipart/alternative; boundary=\"" mailpart-body-uuid "\""))
          (wl "")
          )

        
        (define (email-text-body)
          (body-boundary)
          (wl "Content-Type: text/plain; charset=ISO-8859-1")
          (wl "Content-Disposition: inline")
          (wl "")
          (wl body)
          (body-boundary))
        
        (define (email-html-body)
          (body-boundary)
          (wl "Content-Type: text/plain; charset=ISO-8859-1")
          (wl "")
          (wl "You need to enable HTML option for email")
          (body-boundary)
          (wl "Content-Type: text/html; charset=ISO-8859-1")
          (wl "Content-Disposition: inline")
          (wl "")
          (wl body)
          (body-boundary))

        (define (attach-file file #!key (content-id #f))
          (let* ((filename
                  (filepath:take-file-name file))
                 (ext-with-dot
                  (filepath:take-extension file))
                 (ext (string-take-right
                       ext-with-dot
                       (- (string-length ext-with-dot) 1)))
                 (mimetype (ext->mimetype ext))
                 (uuencode-command (conc "uuencode " file " " filename)))
            (boundary)
            (wl (conc "Content-Type: " mimetype "; name=\"" filename "\""))
            (wl "Content-Transfer-Encoding: uuencode")
            (if content-id
                (wl (conc "Content-Id: " content-id)))
            (wl (conc "Content-Disposition: attachment; filename=\"" filename "\""))
            (wl "")
            (do-or-die
             uuencode-command
             foreach-stdout:
             (lambda (line)
               (wl line)))))

        (define (embed-image file+content-id)
          (let ((file (car file+content-id))
                (content-id (cdr file+content-id)))
            (attach-file file content-id: content-id)))
        
        ;; send the email
        (email-mime-header)
        (if use_html
            (email-html-body)
            (email-text-body))
        (for-each attach-file attach-files-list)
        (for-each embed-image images-with-content-id-alist)
        (boundary)
        (close-output-port sendmail-port)))
    
    (do-or-die "/usr/sbin/sendmail -t"
               stdin-proc: sendmail-proc))

  ;; like shell "which" command
  (define (find-exe exe)
    (let* ((path-items
            (string-split
             (or
              (get-environment-variable "PATH") "")
             ":")))

      (let loop ((rest-path-items path-items))
        (if (null? rest-path-items)
            #f
            (let* ((this-dir (car rest-path-items))
                   (next-rest (cdr rest-path-items))
                   (candidate (conc this-dir "/" exe)))
              (if (file-execute-access? candidate)
                  candidate
                  (loop next-rest)))))))


;;;; process command line options

  ;; get command line switches (have no subsequent arg; eg. [-foo])
  ;;  assumes these are switches without arguments
  ;;  will return list of matches
  ;;  removes matches from command-line-arguments parameter
  (define (skim-cmdline-opts-noarg-by-regex switch-pattern)
    (let* (
           (irr (irregex switch-pattern))
           (matches (filter
                     (lambda (x)
                       (irregex-match irr x))
                     (command-line-arguments)))
           (non-matches (filter
                         (lambda (x)
                           (not (member x matches)))
                         (command-line-arguments))))

      (command-line-arguments non-matches)
      matches))

  (define (keyword-skim keyword default args #!optional (eqpred equal?))
    (let loop ( (kwval default) (args-remaining args) (args-to-return '()) )
      (cond 
       ((null? args-remaining)
        (values
         (if (list? kwval) (reverse kwval) kwval)
         (reverse args-to-return)))
       ((and (> (length args-remaining) 1) (eqpred keyword (car args-remaining)))
        (if (list? default)
            (if (equal? default kwval)
                (loop (list (cadr args-remaining)) (cddr args-remaining) args-to-return)
                (loop (cons (cadr args-remaining) kwval) (cddr args-remaining) args-to-return))
            (loop (cadr args-remaining) (cddr args-remaining) args-to-return)))
       (else (loop kwval (cdr args-remaining) (cons (car args-remaining) args-to-return))))))


  (define (get-cli-arg arg #!key (default #f) (is-list #f))
    (let* ((temp    (skim-cmdline-opts-withargs-by-regex arg)))
      (if (> (length temp) 0)
          (if is-list
              temp
              (car temp))
          default)))

  (define (get-cli-switch arg)
    (let ((temp (skim-cmdline-opts-noarg-by-regex arg)))
      (if (> (length temp) 0)
          (car temp)
          #f)))
  



  ;; get command line switches (have a subsequent arg; eg. [-foo bar])
  ;;  assumes these are switches without arguments
  ;;  will return list of arguments to matches
  ;;  removes matches from command-line-arguments parameter

  (define (re-match? re str)
    (irregex-match re str))

  (define (skim-cmdline-opts-withargs-by-regex switch-pattern)
    (let-values
        (((result new-cmdline-args)
          (keyword-skim switch-pattern
                        '()
                        (command-line-arguments)
                        re-match?
                        )))
      (command-line-arguments new-cmdline-args)
      result))
  
  

  ;; recognize ducttape-lib command line switches (--quiet, --silent, --color, -d.., -dp.., -logfile)
  ;;    - reset parameters; reset DUCTTAPE_* env vars to match user specified intent
  ;;    - mutate (command-line-arguments) parameter to subtract these recognized and handled switches
  ;;       * beware -- now (argv) and (command-line-arguments) are inconsistent... cannot mutate (argv) alas.  Use (command-line-arguments)
  ;; WARNING: this defines command line arguments that may clash with your program.  Only call this if you
  ;; are sure they can coexist.
  (define (ducttape-process-command-line)

    ;; --quiet
    (let ((quiet-opts (skim-cmdline-opts-noarg-by-regex "--?quiet")))
      (if (not (null? quiet-opts))
          (begin
            (setenv "DUCTTAPE_QUIET_MODE" "1")
            (ducttape-quiet-mode "1"))))

    ;; --silent
    (let ((silent-opts (skim-cmdline-opts-noarg-by-regex "--?silent")))
      (if (not (null? silent-opts))
          (begin
            (setenv "DUCTTAPE_SILENT_MODE" "1")
            (ducttape-silent-mode "1"))))

    ;; -color
    (let ((color-opts (skim-cmdline-opts-noarg-by-regex "--?colou?r(ize)?")))
      (if (not (null? color-opts))
          (begin
            (setenv "DUCTTAPE_COLORIZE" "1")
            (ducttape-color-mode "1"))))

    ;; -nocolor
    (let ((nocolor-opts (skim-cmdline-opts-noarg-by-regex "--?nocolou?r(ize)?")))
      (if (not (null? nocolor-opts))
          (begin
            (unsetenv "DUCTTAPE_COLORIZE" )
            (ducttape-color-mode #f))))

    ;; -logfile
    (let ((logfile-opts (skim-cmdline-opts-withargs-by-regex "--?log(-?file)?")))
      (if (not (null? logfile-opts))
          (begin
            (ducttape-log-file (car (reverse logfile-opts)))
            (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file)))))

    ;; -d -dd -d#
    (let ((debug-opts (skim-cmdline-opts-noarg-by-regex "-d(d*|\\d+)"))
          (initial-debuglevel (if (ducttape-debug-level) (ducttape-debug-level) 0) ))
      (if (not (null? debug-opts))
          (begin
            (ducttape-debug-level
             (let loop ((opts debug-opts) (debuglevel initial-debuglevel))
               (if (null? opts)
                   debuglevel
                   (let*
                       ( (curopt (car opts))
                         (restopts (cdr opts))
                         (ds (string-match "-(d+)" curopt))
                         (dnum (string-match "-d(\\d+)" curopt)))
                     (cond
                      (ds (loop restopts (+ debuglevel (string-length (cadr ds)))))
                      (dnum  (loop restopts (string->number (cadr dnum)))))))))
            (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level))))))


    ;; -dp <pat> / --debug-pattern <pat>
    (let ((debugpat-opts (skim-cmdline-opts-withargs-by-regex "--?(debug-pattern|dp)")))
      (if (not (null? debugpat-opts))
          (begin
            (ducttape-debug-regex-filter (string-join debugpat-opts "|"))
            (setenv "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter)))))) 


  ;;; following code commented out; side effects not wanted on startup
  ;; immediately activate logfile (will be noop if logfile disabled)
  ;;(ducttape-activate-logfile)
  ;;(set-ducttape-log-exit-handler)
  
  ;; TODO: hook exception handler so we can log exception before we sign off.

  ;; handle command line immediately; 
  ;;(process-command-line)                    


  ) ; end module
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted ducttape/ducttape-lib.setup version [f078cc60c2].

1
(standard-extension 'ducttape-lib '1.0.0)
<


Deleted ducttape/mimetypes.scm version [391fe0b393].

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
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
;; gathered from macosx:
;;   cat /etc/apache2/mime.types | grep -v '^#' | perl -ne 'print "(\"$2\" . \"$1\")\n" if /(\S+)\s+(\S+)/' > mimetypes.scm
;; + manual manipulation

(define ducttape_ext2mimetype '(("ez" . "application/andrew-inset")
("aw" . "application/applixware")
("atom" . "application/atom+xml")
("atomcat" . "application/atomcat+xml")
("atomsvc" . "application/atomsvc+xml")
("ccxml" . "application/ccxml+xml")
("cdmia" . "application/cdmi-capability")
("cdmic" . "application/cdmi-container")
("cdmid" . "application/cdmi-domain")
("cdmio" . "application/cdmi-object")
("cdmiq" . "application/cdmi-queue")
("cu" . "application/cu-seeme")
("davmount" . "application/davmount+xml")
("dbk" . "application/docbook+xml")
("dssc" . "application/dssc+der")
("xdssc" . "application/dssc+xml")
("ecma" . "application/ecmascript")
("emma" . "application/emma+xml")
("epub" . "application/epub+zip")
("exi" . "application/exi")
("pfr" . "application/font-tdpfr")
("gml" . "application/gml+xml")
("gpx" . "application/gpx+xml")
("gxf" . "application/gxf")
("stk" . "application/hyperstudio")
("ink" . "application/inkml+xml")
("ipfix" . "application/ipfix")
("jar" . "application/java-archive")
("ser" . "application/java-serialized-object")
("class" . "application/java-vm")
("js" . "application/javascript")
("json" . "application/json")
("jsonml" . "application/jsonml+json")
("lostxml" . "application/lost+xml")
("hqx" . "application/mac-binhex40")
("cpt" . "application/mac-compactpro")
("mads" . "application/mads+xml")
("mrc" . "application/marc")
("mrcx" . "application/marcxml+xml")
("ma" . "application/mathematica")
("mathml" . "application/mathml+xml")
("mbox" . "application/mbox")
("mscml" . "application/mediaservercontrol+xml")
("metalink" . "application/metalink+xml")
("meta4" . "application/metalink4+xml")
("mets" . "application/mets+xml")
("mods" . "application/mods+xml")
("m21" . "application/mp21")
("mp4s" . "application/mp4")
("doc" . "application/msword")
("mxf" . "application/mxf")
("bin" . "application/octet-stream")
("oda" . "application/oda")
("opf" . "application/oebps-package+xml")
("ogx" . "application/ogg")
("omdoc" . "application/omdoc+xml")
("onetoc" . "application/onenote")
("oxps" . "application/oxps")
("xer" . "application/patch-ops-error+xml")
("pdf" . "application/pdf")
("pgp" . "application/pgp-encrypted")
("asc" . "application/pgp-signature")
("prf" . "application/pics-rules")
("p10" . "application/pkcs10")
("p7m" . "application/pkcs7-mime")
("p7s" . "application/pkcs7-signature")
("p8" . "application/pkcs8")
("ac" . "application/pkix-attr-cert")
("cer" . "application/pkix-cert")
("crl" . "application/pkix-crl")
("pkipath" . "application/pkix-pkipath")
("pki" . "application/pkixcmp")
("pls" . "application/pls+xml")
("ai" . "application/postscript")
("cww" . "application/prs.cww")
("pskcxml" . "application/pskc+xml")
("rdf" . "application/rdf+xml")
("rif" . "application/reginfo+xml")
("rnc" . "application/relax-ng-compact-syntax")
("rl" . "application/resource-lists+xml")
("rld" . "application/resource-lists-diff+xml")
("rs" . "application/rls-services+xml")
("gbr" . "application/rpki-ghostbusters")
("mft" . "application/rpki-manifest")
("roa" . "application/rpki-roa")
("rsd" . "application/rsd+xml")
("rss" . "application/rss+xml")
("rtf" . "application/rtf")
("sbml" . "application/sbml+xml")
("scq" . "application/scvp-cv-request")
("scs" . "application/scvp-cv-response")
("spq" . "application/scvp-vp-request")
("spp" . "application/scvp-vp-response")
("sdp" . "application/sdp")
("setpay" . "application/set-payment-initiation")
("setreg" . "application/set-registration-initiation")
("shf" . "application/shf+xml")
("smi" . "application/smil+xml")
("rq" . "application/sparql-query")
("srx" . "application/sparql-results+xml")
("gram" . "application/srgs")
("grxml" . "application/srgs+xml")
("sru" . "application/sru+xml")
("ssdl" . "application/ssdl+xml")
("ssml" . "application/ssml+xml")
("tei" . "application/tei+xml")
("tfi" . "application/thraud+xml")
("tsd" . "application/timestamped-data")
("plb" . "application/vnd.3gpp.pic-bw-large")
("psb" . "application/vnd.3gpp.pic-bw-small")
("pvb" . "application/vnd.3gpp.pic-bw-var")
("tcap" . "application/vnd.3gpp2.tcap")
("pwn" . "application/vnd.3m.post-it-notes")
("aso" . "application/vnd.accpac.simply.aso")
("imp" . "application/vnd.accpac.simply.imp")
("acu" . "application/vnd.acucobol")
("atc" . "application/vnd.acucorp")
("air" . "application/vnd.adobe.air-application-installer-package+zip")
("fcdt" . "application/vnd.adobe.formscentral.fcdt")
("fxp" . "application/vnd.adobe.fxp")
("xdp" . "application/vnd.adobe.xdp+xml")
("xfdf" . "application/vnd.adobe.xfdf")
("ahead" . "application/vnd.ahead.space")
("azf" . "application/vnd.airzip.filesecure.azf")
("azs" . "application/vnd.airzip.filesecure.azs")
("azw" . "application/vnd.amazon.ebook")
("acc" . "application/vnd.americandynamics.acc")
("ami" . "application/vnd.amiga.ami")
("apk" . "application/vnd.android.package-archive")
("cii" . "application/vnd.anser-web-certificate-issue-initiation")
("fti" . "application/vnd.anser-web-funds-transfer-initiation")
("atx" . "application/vnd.antix.game-component")
("mpkg" . "application/vnd.apple.installer+xml")
("m3u8" . "application/vnd.apple.mpegurl")
("swi" . "application/vnd.aristanetworks.swi")
("iota" . "application/vnd.astraea-software.iota")
("aep" . "application/vnd.audiograph")
("mpm" . "application/vnd.blueice.multipass")
("bmi" . "application/vnd.bmi")
("rep" . "application/vnd.businessobjects")
("cdxml" . "application/vnd.chemdraw+xml")
("mmd" . "application/vnd.chipnuts.karaoke-mmd")
("cdy" . "application/vnd.cinderella")
("cla" . "application/vnd.claymore")
("rp9" . "application/vnd.cloanto.rp9")
("c4g" . "application/vnd.clonk.c4group")
("c11amc" . "application/vnd.cluetrust.cartomobile-config")
("c11amz" . "application/vnd.cluetrust.cartomobile-config-pkg")
("csp" . "application/vnd.commonspace")
("cdbcmsg" . "application/vnd.contact.cmsg")
("cmc" . "application/vnd.cosmocaller")
("clkx" . "application/vnd.crick.clicker")
("clkk" . "application/vnd.crick.clicker.keyboard")
("clkp" . "application/vnd.crick.clicker.palette")
("clkt" . "application/vnd.crick.clicker.template")
("clkw" . "application/vnd.crick.clicker.wordbank")
("wbs" . "application/vnd.criticaltools.wbs+xml")
("pml" . "application/vnd.ctc-posml")
("ppd" . "application/vnd.cups-ppd")
("car" . "application/vnd.curl.car")
("pcurl" . "application/vnd.curl.pcurl")
("dart" . "application/vnd.dart")
("rdz" . "application/vnd.data-vision.rdz")
("uvf" . "application/vnd.dece.data")
("uvt" . "application/vnd.dece.ttml+xml")
("uvx" . "application/vnd.dece.unspecified")
("uvz" . "application/vnd.dece.zip")
("fe_launch" . "application/vnd.denovo.fcselayout-link")
("dna" . "application/vnd.dna")
("mlp" . "application/vnd.dolby.mlp")
("dpg" . "application/vnd.dpgraph")
("dfac" . "application/vnd.dreamfactory")
("kpxx" . "application/vnd.ds-keypoint")
("ait" . "application/vnd.dvb.ait")
("svc" . "application/vnd.dvb.service")
("geo" . "application/vnd.dynageo")
("mag" . "application/vnd.ecowin.chart")
("nml" . "application/vnd.enliven")
("esf" . "application/vnd.epson.esf")
("msf" . "application/vnd.epson.msf")
("qam" . "application/vnd.epson.quickanime")
("slt" . "application/vnd.epson.salt")
("ssf" . "application/vnd.epson.ssf")
("es3" . "application/vnd.eszigno3+xml")
("ez2" . "application/vnd.ezpix-album")
("ez3" . "application/vnd.ezpix-package")
("fdf" . "application/vnd.fdf")
("mseed" . "application/vnd.fdsn.mseed")
("seed" . "application/vnd.fdsn.seed")
("gph" . "application/vnd.flographit")
("ftc" . "application/vnd.fluxtime.clip")
("fm" . "application/vnd.framemaker")
("fnc" . "application/vnd.frogans.fnc")
("ltf" . "application/vnd.frogans.ltf")
("fsc" . "application/vnd.fsc.weblaunch")
("oas" . "application/vnd.fujitsu.oasys")
("oa2" . "application/vnd.fujitsu.oasys2")
("oa3" . "application/vnd.fujitsu.oasys3")
("fg5" . "application/vnd.fujitsu.oasysgp")
("bh2" . "application/vnd.fujitsu.oasysprs")
("ddd" . "application/vnd.fujixerox.ddd")
("xdw" . "application/vnd.fujixerox.docuworks")
("xbd" . "application/vnd.fujixerox.docuworks.binder")
("fzs" . "application/vnd.fuzzysheet")
("txd" . "application/vnd.genomatix.tuxedo")
("ggb" . "application/vnd.geogebra.file")
("ggt" . "application/vnd.geogebra.tool")
("gex" . "application/vnd.geometry-explorer")
("gxt" . "application/vnd.geonext")
("g2w" . "application/vnd.geoplan")
("g3w" . "application/vnd.geospace")
("gmx" . "application/vnd.gmx")
("kml" . "application/vnd.google-earth.kml+xml")
("kmz" . "application/vnd.google-earth.kmz")
("gqf" . "application/vnd.grafeq")
("gac" . "application/vnd.groove-account")
("ghf" . "application/vnd.groove-help")
("gim" . "application/vnd.groove-identity-message")
("grv" . "application/vnd.groove-injector")
("gtm" . "application/vnd.groove-tool-message")
("tpl" . "application/vnd.groove-tool-template")
("vcg" . "application/vnd.groove-vcard")
("hal" . "application/vnd.hal+xml")
("zmm" . "application/vnd.handheld-entertainment+xml")
("hbci" . "application/vnd.hbci")
("les" . "application/vnd.hhe.lesson-player")
("hpgl" . "application/vnd.hp-hpgl")
("hpid" . "application/vnd.hp-hpid")
("hps" . "application/vnd.hp-hps")
("jlt" . "application/vnd.hp-jlyt")
("pcl" . "application/vnd.hp-pcl")
("pclxl" . "application/vnd.hp-pclxl")
("sfd-hdstx" . "application/vnd.hydrostatix.sof-data")
("mpy" . "application/vnd.ibm.minipay")
("afp" . "application/vnd.ibm.modcap")
("irm" . "application/vnd.ibm.rights-management")
("sc" . "application/vnd.ibm.secure-container")
("icc" . "application/vnd.iccprofile")
("igl" . "application/vnd.igloader")
("ivp" . "application/vnd.immervision-ivp")
("ivu" . "application/vnd.immervision-ivu")
("igm" . "application/vnd.insors.igm")
("xpw" . "application/vnd.intercon.formnet")
("i2g" . "application/vnd.intergeo")
("qbo" . "application/vnd.intu.qbo")
("qfx" . "application/vnd.intu.qfx")
("rcprofile" . "application/vnd.ipunplugged.rcprofile")
("irp" . "application/vnd.irepository.package+xml")
("xpr" . "application/vnd.is-xpr")
("fcs" . "application/vnd.isac.fcs")
("jam" . "application/vnd.jam")
("rms" . "application/vnd.jcp.javame.midlet-rms")
("jisp" . "application/vnd.jisp")
("joda" . "application/vnd.joost.joda-archive")
("ktz" . "application/vnd.kahootz")
("karbon" . "application/vnd.kde.karbon")
("chrt" . "application/vnd.kde.kchart")
("kfo" . "application/vnd.kde.kformula")
("flw" . "application/vnd.kde.kivio")
("kon" . "application/vnd.kde.kontour")
("kpr" . "application/vnd.kde.kpresenter")
("ksp" . "application/vnd.kde.kspread")
("kwd" . "application/vnd.kde.kword")
("htke" . "application/vnd.kenameaapp")
("kia" . "application/vnd.kidspiration")
("kne" . "application/vnd.kinar")
("skp" . "application/vnd.koan")
("sse" . "application/vnd.kodak-descriptor")
("lasxml" . "application/vnd.las.las+xml")
("lbd" . "application/vnd.llamagraphics.life-balance.desktop")
("lbe" . "application/vnd.llamagraphics.life-balance.exchange+xml")
("123" . "application/vnd.lotus-1-2-3")
("apr" . "application/vnd.lotus-approach")
("pre" . "application/vnd.lotus-freelance")
("nsf" . "application/vnd.lotus-notes")
("org" . "application/vnd.lotus-organizer")
("scm" . "application/vnd.lotus-screencam")
("lwp" . "application/vnd.lotus-wordpro")
("portpkg" . "application/vnd.macports.portpkg")
("mcd" . "application/vnd.mcd")
("mc1" . "application/vnd.medcalcdata")
("cdkey" . "application/vnd.mediastation.cdkey")
("mwf" . "application/vnd.mfer")
("mfm" . "application/vnd.mfmp")
("flo" . "application/vnd.micrografx.flo")
("igx" . "application/vnd.micrografx.igx")
("mif" . "application/vnd.mif")
("daf" . "application/vnd.mobius.daf")
("dis" . "application/vnd.mobius.dis")
("mbk" . "application/vnd.mobius.mbk")
("mqy" . "application/vnd.mobius.mqy")
("msl" . "application/vnd.mobius.msl")
("plc" . "application/vnd.mobius.plc")
("txf" . "application/vnd.mobius.txf")
("mpn" . "application/vnd.mophun.application")
("mpc" . "application/vnd.mophun.certificate")
("xul" . "application/vnd.mozilla.xul+xml")
("cil" . "application/vnd.ms-artgalry")
("cab" . "application/vnd.ms-cab-compressed")
("xls" . "application/vnd.ms-excel")
("xlam" . "application/vnd.ms-excel.addin.macroenabled.12")
("xlsb" . "application/vnd.ms-excel.sheet.binary.macroenabled.12")
("xlsm" . "application/vnd.ms-excel.sheet.macroenabled.12")
("xltm" . "application/vnd.ms-excel.template.macroenabled.12")
("eot" . "application/vnd.ms-fontobject")
("chm" . "application/vnd.ms-htmlhelp")
("ims" . "application/vnd.ms-ims")
("lrm" . "application/vnd.ms-lrm")
("thmx" . "application/vnd.ms-officetheme")
("cat" . "application/vnd.ms-pki.seccat")
("stl" . "application/vnd.ms-pki.stl")
("ppt" . "application/vnd.ms-powerpoint")
("ppam" . "application/vnd.ms-powerpoint.addin.macroenabled.12")
("pptm" . "application/vnd.ms-powerpoint.presentation.macroenabled.12")
("sldm" . "application/vnd.ms-powerpoint.slide.macroenabled.12")
("ppsm" . "application/vnd.ms-powerpoint.slideshow.macroenabled.12")
("potm" . "application/vnd.ms-powerpoint.template.macroenabled.12")
("mpp" . "application/vnd.ms-project")
("docm" . "application/vnd.ms-word.document.macroenabled.12")
("dotm" . "application/vnd.ms-word.template.macroenabled.12")
("wps" . "application/vnd.ms-works")
("wpl" . "application/vnd.ms-wpl")
("xps" . "application/vnd.ms-xpsdocument")
("mseq" . "application/vnd.mseq")
("mus" . "application/vnd.musician")
("msty" . "application/vnd.muvee.style")
("taglet" . "application/vnd.mynfc")
("nlu" . "application/vnd.neurolanguage.nlu")
("ntf" . "application/vnd.nitf")
("nnd" . "application/vnd.noblenet-directory")
("nns" . "application/vnd.noblenet-sealer")
("nnw" . "application/vnd.noblenet-web")
("ngdat" . "application/vnd.nokia.n-gage.data")
("n-gage" . "application/vnd.nokia.n-gage.symbian.install")
("rpst" . "application/vnd.nokia.radio-preset")
("rpss" . "application/vnd.nokia.radio-presets")
("edm" . "application/vnd.novadigm.edm")
("edx" . "application/vnd.novadigm.edx")
("ext" . "application/vnd.novadigm.ext")
("odc" . "application/vnd.oasis.opendocument.chart")
("otc" . "application/vnd.oasis.opendocument.chart-template")
("odb" . "application/vnd.oasis.opendocument.database")
("odf" . "application/vnd.oasis.opendocument.formula")
("odft" . "application/vnd.oasis.opendocument.formula-template")
("odg" . "application/vnd.oasis.opendocument.graphics")
("otg" . "application/vnd.oasis.opendocument.graphics-template")
("odi" . "application/vnd.oasis.opendocument.image")
("oti" . "application/vnd.oasis.opendocument.image-template")
("odp" . "application/vnd.oasis.opendocument.presentation")
("otp" . "application/vnd.oasis.opendocument.presentation-template")
("ods" . "application/vnd.oasis.opendocument.spreadsheet")
("ots" . "application/vnd.oasis.opendocument.spreadsheet-template")
("odt" . "application/vnd.oasis.opendocument.text")
("odm" . "application/vnd.oasis.opendocument.text-master")
("ott" . "application/vnd.oasis.opendocument.text-template")
("oth" . "application/vnd.oasis.opendocument.text-web")
("xo" . "application/vnd.olpc-sugar")
("dd2" . "application/vnd.oma.dd2+xml")
("oxt" . "application/vnd.openofficeorg.extension")
("pptx" . "application/vnd.openxmlformats-officedocument.presentationml.presentation")
("sldx" . "application/vnd.openxmlformats-officedocument.presentationml.slide")
("ppsx" . "application/vnd.openxmlformats-officedocument.presentationml.slideshow")
("potx" . "application/vnd.openxmlformats-officedocument.presentationml.template")
("xlsx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet")
("xltx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.template")
("docx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.document")
("dotx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.template")
("mgp" . "application/vnd.osgeo.mapguide.package")
("dp" . "application/vnd.osgi.dp")
("esa" . "application/vnd.osgi.subsystem")
("pdb" . "application/vnd.palm")
("paw" . "application/vnd.pawaafile")
("str" . "application/vnd.pg.format")
("ei6" . "application/vnd.pg.osasli")
("efif" . "application/vnd.picsel")
("wg" . "application/vnd.pmi.widget")
("plf" . "application/vnd.pocketlearn")
("pbd" . "application/vnd.powerbuilder6")
("box" . "application/vnd.previewsystems.box")
("mgz" . "application/vnd.proteus.magazine")
("qps" . "application/vnd.publishare-delta-tree")
("ptid" . "application/vnd.pvi.ptid1")
("qxd" . "application/vnd.quark.quarkxpress")
("bed" . "application/vnd.realvnc.bed")
("mxl" . "application/vnd.recordare.musicxml")
("musicxml" . "application/vnd.recordare.musicxml+xml")
("cryptonote" . "application/vnd.rig.cryptonote")
("cod" . "application/vnd.rim.cod")
("rm" . "application/vnd.rn-realmedia")
("rmvb" . "application/vnd.rn-realmedia-vbr")
("link66" . "application/vnd.route66.link66+xml")
("st" . "application/vnd.sailingtracker.track")
("see" . "application/vnd.seemail")
("sema" . "application/vnd.sema")
("semd" . "application/vnd.semd")
("semf" . "application/vnd.semf")
("ifm" . "application/vnd.shana.informed.formdata")
("itp" . "application/vnd.shana.informed.formtemplate")
("iif" . "application/vnd.shana.informed.interchange")
("ipk" . "application/vnd.shana.informed.package")
("twd" . "application/vnd.simtech-mindmapper")
("mmf" . "application/vnd.smaf")
("teacher" . "application/vnd.smart.teacher")
("sdkm" . "application/vnd.solent.sdkm+xml")
("dxp" . "application/vnd.spotfire.dxp")
("sfs" . "application/vnd.spotfire.sfs")
("sdc" . "application/vnd.stardivision.calc")
("sda" . "application/vnd.stardivision.draw")
("sdd" . "application/vnd.stardivision.impress")
("smf" . "application/vnd.stardivision.math")
("sdw" . "application/vnd.stardivision.writer")
("sgl" . "application/vnd.stardivision.writer-global")
("smzip" . "application/vnd.stepmania.package")
("sm" . "application/vnd.stepmania.stepchart")
("sxc" . "application/vnd.sun.xml.calc")
("stc" . "application/vnd.sun.xml.calc.template")
("sxd" . "application/vnd.sun.xml.draw")
("std" . "application/vnd.sun.xml.draw.template")
("sxi" . "application/vnd.sun.xml.impress")
("sti" . "application/vnd.sun.xml.impress.template")
("sxm" . "application/vnd.sun.xml.math")
("sxw" . "application/vnd.sun.xml.writer")
("sxg" . "application/vnd.sun.xml.writer.global")
("stw" . "application/vnd.sun.xml.writer.template")
("sus" . "application/vnd.sus-calendar")
("svd" . "application/vnd.svd")
("sis" . "application/vnd.symbian.install")
("xsm" . "application/vnd.syncml+xml")
("bdm" . "application/vnd.syncml.dm+wbxml")
("xdm" . "application/vnd.syncml.dm+xml")
("tao" . "application/vnd.tao.intent-module-archive")
("pcap" . "application/vnd.tcpdump.pcap")
("tmo" . "application/vnd.tmobile-livetv")
("tpt" . "application/vnd.trid.tpt")
("mxs" . "application/vnd.triscape.mxs")
("tra" . "application/vnd.trueapp")
("ufd" . "application/vnd.ufdl")
("utz" . "application/vnd.uiq.theme")
("umj" . "application/vnd.umajin")
("unityweb" . "application/vnd.unity")
("uoml" . "application/vnd.uoml+xml")
("vcx" . "application/vnd.vcx")
("vsd" . "application/vnd.visio")
("vis" . "application/vnd.visionary")
("vsf" . "application/vnd.vsf")
("wbxml" . "application/vnd.wap.wbxml")
("wmlc" . "application/vnd.wap.wmlc")
("wmlsc" . "application/vnd.wap.wmlscriptc")
("wtb" . "application/vnd.webturbo")
("nbp" . "application/vnd.wolfram.player")
("wpd" . "application/vnd.wordperfect")
("wqd" . "application/vnd.wqd")
("stf" . "application/vnd.wt.stf")
("xar" . "application/vnd.xara")
("xfdl" . "application/vnd.xfdl")
("hvd" . "application/vnd.yamaha.hv-dic")
("hvs" . "application/vnd.yamaha.hv-script")
("hvp" . "application/vnd.yamaha.hv-voice")
("osf" . "application/vnd.yamaha.openscoreformat")
("osfpvg" . "application/vnd.yamaha.openscoreformat.osfpvg+xml")
("saf" . "application/vnd.yamaha.smaf-audio")
("spf" . "application/vnd.yamaha.smaf-phrase")
("cmp" . "application/vnd.yellowriver-custom-menu")
("zir" . "application/vnd.zul")
("zaz" . "application/vnd.zzazz.deck+xml")
("vxml" . "application/voicexml+xml")
("wgt" . "application/widget")
("hlp" . "application/winhlp")
("wsdl" . "application/wsdl+xml")
("wspolicy" . "application/wspolicy+xml")
("7z" . "application/x-7z-compressed")
("abw" . "application/x-abiword")
("ace" . "application/x-ace-compressed")
("dmg" . "application/x-apple-diskimage")
("aab" . "application/x-authorware-bin")
("aam" . "application/x-authorware-map")
("aas" . "application/x-authorware-seg")
("bcpio" . "application/x-bcpio")
("torrent" . "application/x-bittorrent")
("blb" . "application/x-blorb")
("bz" . "application/x-bzip")
("bz2" . "application/x-bzip2")
("cbr" . "application/x-cbr")
("vcd" . "application/x-cdlink")
("cfs" . "application/x-cfs-compressed")
("chat" . "application/x-chat")
("pgn" . "application/x-chess-pgn")
("nsc" . "application/x-conference")
("cpio" . "application/x-cpio")
("csh" . "application/x-csh")
("deb" . "application/x-debian-package")
("dgc" . "application/x-dgc-compressed")
("dir" . "application/x-director")
("wad" . "application/x-doom")
("ncx" . "application/x-dtbncx+xml")
("dtb" . "application/x-dtbook+xml")
("res" . "application/x-dtbresource+xml")
("dvi" . "application/x-dvi")
("evy" . "application/x-envoy")
("eva" . "application/x-eva")
("bdf" . "application/x-font-bdf")
("gsf" . "application/x-font-ghostscript")
("psf" . "application/x-font-linux-psf")
("otf" . "application/x-font-otf")
("pcf" . "application/x-font-pcf")
("snf" . "application/x-font-snf")
("ttf" . "application/x-font-ttf")
("pfa" . "application/x-font-type1")
("woff" . "application/x-font-woff")
("arc" . "application/x-freearc")
("spl" . "application/x-futuresplash")
("gca" . "application/x-gca-compressed")
("ulx" . "application/x-glulx")
("gnumeric" . "application/x-gnumeric")
("gramps" . "application/x-gramps-xml")
("gtar" . "application/x-gtar")
("hdf" . "application/x-hdf")
("install" . "application/x-install-instructions")
("iso" . "application/x-iso9660-image")
("jnlp" . "application/x-java-jnlp-file")
("latex" . "application/x-latex")
("lzh" . "application/x-lzh-compressed")
("mie" . "application/x-mie")
("prc" . "application/x-mobipocket-ebook")
("m3u8" . "application/x-mpegurl")
("application" . "application/x-ms-application")
("lnk" . "application/x-ms-shortcut")
("wmd" . "application/x-ms-wmd")
("wmz" . "application/x-ms-wmz")
("xbap" . "application/x-ms-xbap")
("mdb" . "application/x-msaccess")
("obd" . "application/x-msbinder")
("crd" . "application/x-mscardfile")
("clp" . "application/x-msclip")
("exe" . "application/x-msdownload")
("mvb" . "application/x-msmediaview")
("wmf" . "application/x-msmetafile")
("mny" . "application/x-msmoney")
("pub" . "application/x-mspublisher")
("scd" . "application/x-msschedule")
("trm" . "application/x-msterminal")
("wri" . "application/x-mswrite")
("nc" . "application/x-netcdf")
("nzb" . "application/x-nzb")
("p12" . "application/x-pkcs12")
("p7b" . "application/x-pkcs7-certificates")
("p7r" . "application/x-pkcs7-certreqresp")
("rar" . "application/x-rar-compressed")
("ris" . "application/x-research-info-systems")
("sh" . "application/x-sh")
("shar" . "application/x-shar")
("swf" . "application/x-shockwave-flash")
("xap" . "application/x-silverlight-app")
("sql" . "application/x-sql")
("sit" . "application/x-stuffit")
("sitx" . "application/x-stuffitx")
("srt" . "application/x-subrip")
("sv4cpio" . "application/x-sv4cpio")
("sv4crc" . "application/x-sv4crc")
("t3" . "application/x-t3vm-image")
("gam" . "application/x-tads")
("tar" . "application/x-tar")
("tcl" . "application/x-tcl")
("tex" . "application/x-tex")
("tfm" . "application/x-tex-tfm")
("texinfo" . "application/x-texinfo")
("obj" . "application/x-tgif")
("ustar" . "application/x-ustar")
("src" . "application/x-wais-source")
("der" . "application/x-x509-ca-cert")
("fig" . "application/x-xfig")
("xlf" . "application/x-xliff+xml")
("xpi" . "application/x-xpinstall")
("xz" . "application/x-xz")
("z1" . "application/x-zmachine")
("xaml" . "application/xaml+xml")
("xdf" . "application/xcap-diff+xml")
("xenc" . "application/xenc+xml")
("xhtml" . "application/xhtml+xml")
("xml" . "application/xml")
("dtd" . "application/xml-dtd")
("xop" . "application/xop+xml")
("xpl" . "application/xproc+xml")
("xslt" . "application/xslt+xml")
("xspf" . "application/xspf+xml")
("mxml" . "application/xv+xml")
("yang" . "application/yang")
("yin" . "application/yin+xml")
("zip" . "application/zip")
("adp" . "audio/adpcm")
("au" . "audio/basic")
("mid" . "audio/midi")
("mp4a" . "audio/mp4")
("m4a" . "audio/mp4a-latm")
("mpga" . "audio/mpeg")
("oga" . "audio/ogg")
("s3m" . "audio/s3m")
("sil" . "audio/silk")
("uva" . "audio/vnd.dece.audio")
("eol" . "audio/vnd.digital-winds")
("dra" . "audio/vnd.dra")
("dts" . "audio/vnd.dts")
("dtshd" . "audio/vnd.dts.hd")
("lvp" . "audio/vnd.lucent.voice")
("pya" . "audio/vnd.ms-playready.media.pya")
("ecelp4800" . "audio/vnd.nuera.ecelp4800")
("ecelp7470" . "audio/vnd.nuera.ecelp7470")
("ecelp9600" . "audio/vnd.nuera.ecelp9600")
("rip" . "audio/vnd.rip")
("weba" . "audio/webm")
("aac" . "audio/x-aac")
("aif" . "audio/x-aiff")
("caf" . "audio/x-caf")
("flac" . "audio/x-flac")
("mka" . "audio/x-matroska")
("m3u" . "audio/x-mpegurl")
("wax" . "audio/x-ms-wax")
("wma" . "audio/x-ms-wma")
("ram" . "audio/x-pn-realaudio")
("rmp" . "audio/x-pn-realaudio-plugin")
("wav" . "audio/x-wav")
("xm" . "audio/xm")
("cdx" . "chemical/x-cdx")
("cif" . "chemical/x-cif")
("cmdf" . "chemical/x-cmdf")
("cml" . "chemical/x-cml")
("csml" . "chemical/x-csml")
("xyz" . "chemical/x-xyz")
("bmp" . "image/bmp")
("cgm" . "image/cgm")
("g3" . "image/g3fax")
("gif" . "image/gif")
("ief" . "image/ief")
("jp2" . "image/jp2")
("jpeg" . "image/jpeg")
("ktx" . "image/ktx")
("pict" . "image/pict")
("png" . "image/png")
("btif" . "image/prs.btif")
("sgi" . "image/sgi")
("svg" . "image/svg+xml")
("tiff" . "image/tiff")
("psd" . "image/vnd.adobe.photoshop")
("uvi" . "image/vnd.dece.graphic")
("sub" . "image/vnd.dvb.subtitle")
("djvu" . "image/vnd.djvu")
("dwg" . "image/vnd.dwg")
("dxf" . "image/vnd.dxf")
("fbs" . "image/vnd.fastbidsheet")
("fpx" . "image/vnd.fpx")
("fst" . "image/vnd.fst")
("mmr" . "image/vnd.fujixerox.edmics-mmr")
("rlc" . "image/vnd.fujixerox.edmics-rlc")
("mdi" . "image/vnd.ms-modi")
("wdp" . "image/vnd.ms-photo")
("npx" . "image/vnd.net-fpx")
("wbmp" . "image/vnd.wap.wbmp")
("xif" . "image/vnd.xiff")
("webp" . "image/webp")
("3ds" . "image/x-3ds")
("ras" . "image/x-cmu-raster")
("cmx" . "image/x-cmx")
("fh" . "image/x-freehand")
("ico" . "image/x-icon")
("pntg" . "image/x-macpaint")
("sid" . "image/x-mrsid-image")
("pcx" . "image/x-pcx")
("pic" . "image/x-pict")
("pnm" . "image/x-portable-anymap")
("pbm" . "image/x-portable-bitmap")
("pgm" . "image/x-portable-graymap")
("ppm" . "image/x-portable-pixmap")
("qtif" . "image/x-quicktime")
("rgb" . "image/x-rgb")
("tga" . "image/x-tga")
("xbm" . "image/x-xbitmap")
("xpm" . "image/x-xpixmap")
("xwd" . "image/x-xwindowdump")
("eml" . "message/rfc822")
("igs" . "model/iges")
("msh" . "model/mesh")
("dae" . "model/vnd.collada+xml")
("dwf" . "model/vnd.dwf")
("gdl" . "model/vnd.gdl")
("gtw" . "model/vnd.gtw")
("mts" . "model/vnd.mts")
("vtu" . "model/vnd.vtu")
("wrl" . "model/vrml")
("x3db" . "model/x3d+binary")
("x3dv" . "model/x3d+vrml")
("x3d" . "model/x3d+xml")
("manifest" . "text/cache-manifest")
("appcache" . "text/cache-manifest")
("ics" . "text/calendar")
("css" . "text/css")
("csv" . "text/csv")
("html" . "text/html")
("n3" . "text/n3")
("txt" . "text/plain")
("dsc" . "text/prs.lines.tag")
("rtx" . "text/richtext")
("sgml" . "text/sgml")
("tsv" . "text/tab-separated-values")
("t" . "text/troff")
("ttl" . "text/turtle")
("uri" . "text/uri-list")
("vcard" . "text/vcard")
("curl" . "text/vnd.curl")
("dcurl" . "text/vnd.curl.dcurl")
("scurl" . "text/vnd.curl.scurl")
("mcurl" . "text/vnd.curl.mcurl")
("sub" . "text/vnd.dvb.subtitle")
("fly" . "text/vnd.fly")
("flx" . "text/vnd.fmi.flexstor")
("gv" . "text/vnd.graphviz")
("3dml" . "text/vnd.in3d.3dml")
("spot" . "text/vnd.in3d.spot")
("jad" . "text/vnd.sun.j2me.app-descriptor")
("wml" . "text/vnd.wap.wml")
("wmls" . "text/vnd.wap.wmlscript")
("s" . "text/x-asm")
("c" . "text/x-c")
("f" . "text/x-fortran")
("java" . "text/x-java-source")
("opml" . "text/x-opml")
("p" . "text/x-pascal")
("nfo" . "text/x-nfo")
("etx" . "text/x-setext")
("sfv" . "text/x-sfv")
("uu" . "text/x-uuencode")
("vcs" . "text/x-vcalendar")
("vcf" . "text/x-vcard")
("3gp" . "video/3gpp")
("3g2" . "video/3gpp2")
("h261" . "video/h261")
("h263" . "video/h263")
("h264" . "video/h264")
("jpgv" . "video/jpeg")
("jpm" . "video/jpm")
("mj2" . "video/mj2")
("ts" . "video/mp2t")
("mp4" . "video/mp4")
("mpeg" . "video/mpeg")
("ogv" . "video/ogg")
("qt" . "video/quicktime")
("uvh" . "video/vnd.dece.hd")
("uvm" . "video/vnd.dece.mobile")
("uvp" . "video/vnd.dece.pd")
("uvs" . "video/vnd.dece.sd")
("uvv" . "video/vnd.dece.video")
("dvb" . "video/vnd.dvb.file")
("fvt" . "video/vnd.fvt")
("mxu" . "video/vnd.mpegurl")
("pyv" . "video/vnd.ms-playready.media.pyv")
("uvu" . "video/vnd.uvvu.mp4")
("viv" . "video/vnd.vivo")
("dv" . "video/x-dv")
("webm" . "video/webm")
("f4v" . "video/x-f4v")
("fli" . "video/x-fli")
("flv" . "video/x-flv")
("m4v" . "video/x-m4v")
("mkv" . "video/x-matroska")
("mng" . "video/x-mng")
("asf" . "video/x-ms-asf")
("vob" . "video/x-ms-vob")
("wm" . "video/x-ms-wm")
("wmv" . "video/x-ms-wmv")
("wmx" . "video/x-ms-wmx")
("wvx" . "video/x-ms-wvx")
("avi" . "video/x-msvideo")
("movie" . "video/x-sgi-movie")
("smv" . "video/x-smv")
("ice" . "x-conference/x-cooltalk")))

(define (ext->mimetype ext)
  (let ((x (assoc ext ducttape_ext2mimetype)))
   (if x (cdr x) "text/plain")))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted ducttape/sample_ducttape.scm version [d6ebb1f644].

1
2
3
4
(include "ducttape-lib.scm")
(import ducttape-lib)
(inote "hello world")
(exit 0)
<
<
<
<








Deleted ducttape/test_ducttape.scm version [f1892fd163].

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
#!/usr/bin/env csi -script
(use test)
(include "ducttape-lib.scm")
(import ducttape-lib)
(import ansi-escape-sequences)
(use trace)
(set! systype (do-or-die (if (file-exists? "/bin/uname") "/bin/uname" "/usr/bin/uname")))
;(trace skim-cmdline-opts-withargs-by-regex)
;(trace keyword-skim)
;(trace re-match?)
(define (reset-ducttape)
  (unsetenv "DUCTTAPE_DEBUG_LEVEL")
  (ducttape-debug-level #f)

  (unsetenv "DUCTTAPE_DEBUG_PATTERN")
  (ducttape-debug-regex-filter ".")

  (unsetenv "DUCTTAPE_LOG_FILE")
  (ducttape-log-file #f)

  (unsetenv "DUCTTAPE_SILENT_MODE")
  (ducttape-silent-mode #f)

  (unsetenv "DUCTTAPE_QUIET_MODE")
  (ducttape-quiet-mode #f)

  (unsetenv "DUCTTAPE_COLOR_MODE")
  (ducttape-color-mode #f)
)

(define (reset-ducttape-with-cmdline-list cmdline-list)
  (reset-ducttape)

  (command-line-arguments cmdline-list)
  (ducttape-process-command-line)
)


(define (direct-iputs-test)
  (ducttape-color-mode #f)
  (ierr "I'm an error")
  (iwarn "I'm a warning")
  (inote "I'm a note")

  (ducttape-debug-level 1)
  (idbg "I'm a debug statement")
  (ducttape-debug-level #f)
  (idbg "I'm a hidden debug statement")

  (ducttape-silent-mode #t)
  (iwarn "I shouldn't show up")
  (inote "I shouldn't show up either")
  (ierr "I should show up 1")
  (ducttape-silent-mode #f)

  (ducttape-quiet-mode #t)
  (iwarn "I should show up 2")
  (inote "I shouldn't show up though")
  (ierr "I should show up 3")
  (ducttape-quiet-mode #f)

  (ducttape-debug-level 1)
  (idbg "foo")
  (iputs "dbg" "debug message")
  (iputs "e" "error message")
  (iputs "w" "warning message")
  (iputs "n" "note message")

  (ducttape-color-mode #t)
  (ierr "I'm an error COLOR")
  (iwarn "I'm a warning COLOR")
  (inote "I'm a note COLOR")
  (idbg "I'm a debug COLOR")


  )

(define (test-argprocessor-funcs)
  
  (test-group
   "Command line processor utility functions"

   (set! testargs1 '( "-d" "-d" "-d3" "-ddd" "-foo" "fooarg" "-foo" "fooarg2" "-lastArgIsDecoy" "-foo"))
   (command-line-arguments testargs1)
   (set! expected_result '("-d" "-d" "-d3" "-ddd"))
   (set! expected_sideeffect '("-foo" "fooarg" "-foo" "fooarg2" "-lastArgIsDecoy" "-foo"))

   (test "skim-cmdline-opts-noarg-by-regex result" expected_result (skim-cmdline-opts-noarg-by-regex "-d(d+|\\d+)?"))
   (test "skim-cmdline-opts-noarg-by-regex sideeffect" expected_sideeffect (command-line-arguments))


  
   (command-line-arguments testargs1)
   (set! expected_result '("fooarg" "fooarg2" ))
   (set! expected_sideeffect '( "-d" "-d" "-d3" "-ddd" "-lastArgIsDecoy" "-foo"))
   (test
    "skim-cmdline-opts-withargs-by-regex result"
    expected_result
    (skim-cmdline-opts-withargs-by-regex "--?foo"))
   
   (test
    "skim-cmdline-opts-withargs-by-regex sideeffect"
    expected_sideeffect
    (command-line-arguments))

   ))

(define (test-misc)
  (test-group
   "misc"
   (let ((tmpfile (mktemp)))
     (test-assert "mktemp: temp file created" (file-exists? tmpfile))
     (if (file-exists? tmpfile)
         (delete-file tmpfile))

     )))



(define (test-systemstuff)
  (test-group
   "system commands"

   (let-values (((ec o e) (isys (find-exe "true"))))
     (test-assert "isys: /bin/true should have exit code 0" (equal? ec 0)))
   (let-values (((ec o e) (isys (find-exe "false"))))
     (test-assert "isys: /bin/false should have exit code 1" (equal? ec 1)))

   (let-values (((ec o e) (isys "/bin/echo" "foo" "bar" "baz")))
     (test-assert "isys: /bin/echo should have exit code 0" (equal? ec 0))
     (test-assert "isys: /bin/echo should have stdout 'foo bar baz'" (equal? o "foo bar baz")))
   
   (let-values (((ec o e) (isys "/bin/ls /zzzzz")))
     (let ((expected-code
            (if (equal? systype "Darwin") 1 2))
           (expected-err
            (if (equal? systype "Darwin")
                "ls: /zzzzz: No such file or directory"
                "/bin/ls: cannot access /zzzzz: No such file or directory"))

           )
       (test "isys: /bin/ls /zzzzz should have exit code 2" expected-code ec)
       (test "isys: /bin/ls /zzzzz should have empty stdout" "" o)
       (test
        "isys: /bin/ls /zzzzz should have stderr"
        expected-err
        e))
     )

   (let-values (((ec o e) (isys "/bin/ls /etc/passwd")))
     (test "isys: /bin/ls /etc/passwd should have exit code 0" 0 ec)
     (test "isys: /bin/ls /etc/passwd should have stdout" "/etc/passwd" o)
     (test
      "isys: /bin/ls /etc/passwd should have empty stderr"
      ""
      e))

      (let ((res (do-or-die "/bin/ls /etc/passwd")))
        (test
         "do-or-die: ls /etc/passwd should work"
         "/etc/passwd" res ))

      (let ((res (do-or-die "/bin/ls /zzzzz" nodie: #t)))
        (test
         "do-or-die: ls /zzzzz should die"
         #f res ))

      ; test reading from process stdout line at a time
      (let* (
             (lineno (counter-maker))

             ; print each line with an index
             (eachline-fn (lambda (line)
                         (print "GOTLINE " (lineno) "> " line)))

             (res
              (do-or-die "/bin/ls -l /etc | head; true"
                         foreach-stdout: eachline-fn )))
        
        (test-assert "ls -l /etc should not be empty"
                     (not (equal? res ""))))
      ;; test writing to process stdout line at a time

      (let* ((tmpfile (mktemp))
             (cmd (conc "cat > " tmpfile)))
        (let-values (((c o e)
                      (isys cmd stdin-proc:
                       (lambda (myport)
                         (write-line "hello" myport)
                         (write-line "hello2" myport)
                         (close-output-port myport)))))
          (test "isys-sp: cat should exit 0" 0 c)
          (let ((mycmd (conc "cat " tmpfile)))
            (test "isys-sp: cat output should match input" "hello\nhello2" (do-or-die mycmd)))

          (delete-file tmpfile)
        ))

      (let* ((tmpfile (mktemp))
             (cmd (conc "cat > " tmpfile)))
        (do-or-die cmd stdin-proc:
                   (lambda (myport)
                     (write-line "hello" myport)
                     (write-line "hello2" myport)
                     (close-output-port myport))
                   cmd)
        (test "dod-sp: cat output should match input" "hello\nhello2" (do-or-die (conc "cat " tmpfile)))
        (delete-file tmpfile))



      

      (let*
          ((thefile (conc "/tmp/" (get-environment-variable "USER")  "9-lines"))
           (counter (counter-maker))
           (stdin-writer
            (lambda ()
              (if (< (counter) 10)
                  (number->string (counter 0))
                  #f)))
            (cmd (conc "cat > " thefile)))
        (let-values
            (((c o e)
              (isys cmd foreach-stdin-thunk: stdin-writer)))

          (test-assert "isys-fsl: cat should return 0" (equal? c 0))

          (test-assert
           "isys-fsl: cat should have written a file"
           (file-exists? thefile))
          
          (if
           (file-exists? thefile)
           (begin
             (test "isys-fsl: cat file should have right contents" "1\n2\n3\n4\n5\n6\n7\n8\n9" (do-or-die (conc "cat " thefile)))
             (delete-file thefile)))))
      
   ) ; end test-group
  ) ; end define

   
(define (test-argprocessor )
  (test-group
   "Command line processor parameter settings"

   (reset-ducttape-with-cmdline-list '())
   (test-assert "(nil) debug mode should be off" (not (ducttape-debug-level)))
   (test-assert "(nil): debug pattern should be '.'" (equal? "." (ducttape-debug-regex-filter)))
   (test-assert "(nil): colors should be off" (not (ducttape-color-mode)))
   (test-assert "(nil): silent mode should be off" (not (ducttape-silent-mode)))
   (test-assert "(nil): quiet mode should be off" (not (ducttape-quiet-mode)))
   (test-assert "(nil): logfile should be off" (not (ducttape-log-file)))

   (reset-ducttape-with-cmdline-list '("-d"))
   (test-assert "-d: debug mode should be on at level 1" (eq? 1 (ducttape-debug-level)))

   (reset-ducttape-with-cmdline-list '("-dd"))
   (test "-dd: debug level should be 2" 2 (ducttape-debug-level))

   (reset-ducttape-with-cmdline-list '("-ddd"))
   (test "-ddd: debug level should be 3" 3 (ducttape-debug-level))

   (reset-ducttape-with-cmdline-list '("-d2"))
   (test "-d2: debug level should be 2" 2 (ducttape-debug-level))

   (reset-ducttape-with-cmdline-list '("-d3"))
   (test "-d3: debug level should be 3" 3 (ducttape-debug-level))

   (reset-ducttape-with-cmdline-list '("-dp" "foo"))
   (test "-dp foo: debug pattern should be 'foo'" "foo" (ducttape-debug-regex-filter))

   (reset-ducttape-with-cmdline-list '("--debug-pattern" "foo"))
   (test "--debug-pattern foo: debug pattern should be 'foo'" "foo" (ducttape-debug-regex-filter))

   (reset-ducttape-with-cmdline-list '("-dp" "foo" "-dp" "bar"))
   (test "-dp foo -dp bar: debug pattern should be 'foo|bar'"  "foo|bar" (ducttape-debug-regex-filter))

   (reset-ducttape-with-cmdline-list '("--quiet"))
   (test-assert "-quiet: quiet mode should be active" (ducttape-quiet-mode))

   (reset-ducttape-with-cmdline-list '("--silent"))
   (test-assert "-silent: silent mode should be active" (ducttape-silent-mode))

   (reset-ducttape-with-cmdline-list '("--color"))
   (test-assert "-color: color mode should be active" (ducttape-color-mode))

   (reset-ducttape-with-cmdline-list '("--log" "foo"))
   (test "--log foo: logfile should be 'foo'" "foo" (ducttape-log-file))

))

(define (test-wwdate)
  (test-group
   "wwdate conversion tests"
   (let ((test-table
          '(("16ww01.5" . "2016-01-01")
            ("16ww18.5" . "2016-04-29")
            ("1999ww33.5" . "1999-08-13")
            ("16ww18.4" . "2016-04-28")
            ("16ww18.3" . "2016-04-27")
            ("13ww01.0" . "2012-12-30")
            ("13ww52.6" . "2013-12-28")
            ("16ww53.3" . "2016-12-28"))))
     (for-each
      (lambda (test-pair)
        (let ((wwdate (car test-pair))
              (isodate (cdr test-pair)))
          (test
           (conc "(isodate->wwdate "isodate ") => "wwdate)
           wwdate
           (isodate->wwdate isodate))
          
          (test
           (conc "(wwdate->isodate "wwdate ")   => "isodate)
           isodate
           (wwdate->isodate wwdate))))
      test-table))))

(define (main)
  ;; (test <description; #f uses func prototype> <expected result> <thunk>)
  
;  (test-group "silly settext group"
;              (test #f "\x1b[1mfoo\x1b[0m" (set-text (list 'bold) "foo"))
;              (test "settext bold" "\x1b[1mfoo\x1b[0m" (set-text (list 'bold) "foo"))
;              )

  ; visually inspect this
  (direct-iputs-test)

  ; following use unit test test-egg
  (reset-ducttape)
  (test-argprocessor-funcs)
  (reset-ducttape)
  (test-argprocessor)
  (test-systemstuff)
  (test-misc)
  (test-wwdate)
  ) ; end main()

(main)
(sendmail "brandon.j.barclay@intel.com" "6hello subject"  "test body" )

;(let* ((image-file "/nfs/site/home/bjbarcla/megatest-logo.png")
;       (cid "mtlogo")
;       (image-alist (list (cons image-file cid)))
;       (body  (conc "Hello world<br /><img cid:"cid" alt=\"test image\"><br>bye!")))

;  (sendmail "brandon.j.barclay@intel.com" "7hello subject"  body use_html: #t images-with-content-id-alist: image-alist)
;  (print "sent image mail"))
;(sendmail "bjbarcla" "2hello subject html"  "test body<h1>hello</h1><i>italics</i>" use_html: #t)
;(sendmail "bb" "4hello attach subject html"  "<h2>hmm</h2>" use_html: #t attach-files-list: '( "/Users/bb/Downloads/wdmycloud-manual-4779-705103.pdf" ) )

;(launch-repl)
(test-exit)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































































































































































































































































































Deleted ducttape/test_example.scm version [74b706bd1d].

1
2
3
(use ducttape-lib)

(inote "Hello world")
<
<
<






Deleted ducttape/useargs-example.scm version [c73af521bf].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
(use ducttape-lib)

(let (
      (customers (skim-cmdline-opts-withargs-by-regex "--cust(omer)?"))
      (magicmode (skim-cmdline-opts-noarg-by-regex "--magic"))
      )
  (print "your customers are " customers)
  (if (null? magicmode)
      (print "no unicorns for you")
      (print "magic!")
  )
  )

(idbg "hello")
(idbg "hello2" 2)
(idbg "hello2" 3)
(inote "note")
(iwarn "warn")
(ierr "err")
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































Deleted ducttape/workweekdate.scm version [075bec1c4d].

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
(use srfi-19)
(use test)
;;(use format)
(use regex)
;(declare (unit wwdate))
;; utility procedures to convert among
;; different ways to express date (wwdate, seconds since epoch, isodate)
;;
;; samples:
;; isodate   -> "2016-01-01"
;; wwdate -> "16ww01.5"
;; seconds   -> 1451631600

;; procedures provided:
;; ====================
;; seconds->isodate
;; seconds->wwdate
;;
;; isodate->seconds
;; isodate->wwdate
;;
;; wwdate->seconds
;; wwdate->isodate

;; srfi-19 used extensively; this doc is better tha the eggref:
;; http://srfi.schemers.org/srfi-19/srfi-19.html

;; Author: brandon.j.barclay@intel.com 16ww18.6

(define (date->seconds date)
  (inexact->exact
   (string->number
    (date->string date "~s"))))

(define (seconds->isodate seconds)
  (let* ((date (seconds->date seconds))
         (result (date->string date "~Y-~m-~d")))
    result))

(define (isodate->seconds isodate)
  "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K"
  (let* ((numlist (map string->number (string-split isodate "-")))
        (raw-year (car numlist))
        (year (if (< raw-year 100) (+ raw-year 2000) raw-year))
        (month (list-ref numlist 1))
        (day (list-ref numlist 2))
        (date (make-date 0 0 0 0 day month year))
        (seconds (date->seconds date)))

    seconds))

;; adapted from perl Intel::WorkWeek perl module
;; workweek year consists of numbered weeks starting from week 1
;;   days of week are numbered starting from 0 on sunday
;;   weeks begin on sunday- day number 0 and end saturday- day 6
;;   week 1 is defined as the week containing jan 1 of the year
;;   workweek year does not match calendar year in workweek 1
;;     since workweek 1 contains jan1 and workweek begins sunday,
;;     days prior to jan1 in workweek 1 belong to the next workweek year
(define (seconds->wwdate-values seconds)
  (define (date-difference->seconds d1 d2)
    (- (date->seconds d1) (date->seconds d2)))

  (let* ((thisdate (seconds->date seconds))
         (thisdow (string->number (date->string thisdate "~w")))

         (year (date-year thisdate))
         ;; intel workweek 1 begins on sunday of week containing jan1
         (jan1 (make-date 0 0 0 0 1 1 year))
         (jan1dow (date-week-day jan1))
         (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow))))

         (ww01_delta_seconds (date-difference->seconds thisdate ww01))
         (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) ))))
         
         ;; we could be in ww1 of next year
         (this-saturday (seconds->date
                         (+ seconds
                            (* 60 60 24 (- 6 thisdow)))))
         (this-week-ends-next-year?
          (> (date-year this-saturday) year))
         (intelyear
          (if this-week-ends-next-year?
              (add1 year)
              year))
         (intelweek
          (if this-week-ends-next-year?
              1
              wwnum_initial)))
   (values intelyear intelweek thisdow)))

(define (string-leftpad in width pad-char)
  (let* ((unpadded-str (->string in))
         (padlen_temp (- width (string-length unpadded-str)))
         (padlen (if (< padlen_temp 0) 0 padlen_temp))
         (padding (make-string padlen pad-char)))
    (conc padding unpadded-str)))

(define (string-rightpad in width pad-char)
  (let* ((unpadded-str (->string in))
         (padlen_temp (- width (string-length unpadded-str)))
         (padlen (if (< padlen_temp 0) 0 padlen_temp))
         (padding (make-string padlen pad-char)))
    (conc unpadded-str padding)))

(define (zeropad num width)
  (string-leftpad num width #\0))

(define (seconds->wwdate seconds)

  (let-values (((intelyear intelweek day-of-week-num)
                (seconds->wwdate-values seconds)))
    (let ((intelyear-str
           (zeropad
            (->string
             (if (> intelyear 1999)
                 (- intelyear 2000) intelyear))
            2))
          (intelweek-str
           (zeropad (->string intelweek) 2))
          (dow-str (->string day-of-week-num)))
      (conc intelyear-str "ww" intelweek-str "." dow-str))))

(define (isodate->wwdate isodate)
  (seconds->wwdate
   (isodate->seconds isodate)))

(define (wwdate->seconds wwdate)
  (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" wwdate)))
    (if
     (not match)
     #f
     (let* (
            (intelyear-raw (string->number (list-ref match 1)))
            (intelyear (if (< intelyear-raw 100)
                           (+ intelyear-raw 2000)
                           intelyear-raw))
            (intelww (string->number (list-ref match 2)))
            (dayofweek (string->number (list-ref match 3)))

            (day-of-seconds (* 60 60 24 ))
            (week-of-seconds (* day-of-seconds 7))
            

            ;; get seconds at ww1.0
            (new-years-date (make-date 0 0 0 0 1 1 intelyear))
            (new-years-seconds
             (date->seconds new-years-date))
            (new-years-dayofweek (date-week-day new-years-date))
            (ww1.0_seconds (- new-years-seconds
                              (* day-of-seconds
                                 new-years-dayofweek)))
            (workweek-adjustment (* week-of-seconds (sub1 intelww)))
            (weekday-adjustment (* dayofweek day-of-seconds))

            (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment)))
       result))))

(define (wwdate->isodate wwdate)
  (seconds->isodate (wwdate->seconds wwdate)))

(define (current-wwdate)
  (seconds->wwdate (current-seconds)))

(define (current-isodate)
  (seconds->isodate (current-seconds)))

(define (wwdate-tests)
  (test-group
   "date conversion tests"
   (let ((test-table
          '(("16ww01.5" . "2016-01-01")
            ("16ww18.5" . "2016-04-29")
            ("1999ww33.5" . "1999-08-13")
            ("16ww18.4" . "2016-04-28")
            ("16ww18.3" . "2016-04-27")
            ("13ww01.0" . "2012-12-30")
            ("13ww52.6" . "2013-12-28")
            ("16ww53.3" . "2016-12-28"))))
     (for-each
      (lambda (test-pair)
        (let ((wwdate (car test-pair))
              (isodate (cdr test-pair)))
          (test
           (conc "(isodate->wwdate "isodate ") => "wwdate)
           wwdate
           (isodate->wwdate isodate))
          
          (test
           (conc "(wwdate->isodate "wwdate ")   => "isodate)
           isodate
           (wwdate->isodate wwdate))))
      test-table))))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































Deleted emergency-patches/emergency-patch-1.scm version [078bae8dfb].

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


;; These are called by the server on recipt of /api calls
;;    - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;;    - returns #( flag result )
;;
(define (api:execute-requests dbstruct dat)
  (handle-exceptions
   exn
   (let ((call-chain (get-call-chain)))
     (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat)
     (print-call-chain (current-error-port))
     (debug:print 0 *default-log-port* " message: "  ((condition-property-accessor 'exn 'message) exn))       
     (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
   (cond
    ((not (vector? dat))                    ;; it is an error to not receive a vector
     (vector #f (vector #f "remote must be called with a vector")))
    ((> *api-process-request-count* 20) ;; 20)
     (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.")
     (set! *server-overloaded* #t)
     (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor!
    (else  
     (let* ((cmd-in            (vector-ref dat 0))
            (cmd               (if (symbol? cmd-in)
				   cmd-in
				   (string->symbol cmd-in)))
            (params            (vector-ref dat 1))
            (start-t           (current-milliseconds))
            (readonly-mode     (dbr:dbstruct-read-only dbstruct))
            (readonly-command  (member cmd api:read-only-queries))
            (writecmd-in-readonly-mode (and readonly-mode (not readonly-command)))
            (res    
             (if writecmd-in-readonly-mode
                 (conc "attempt to run write command "cmd" on a read-only database")
                 (case cmd
                   ;;===============================================
                   ;; READ/WRITE QUERIES
                   ;;===============================================

                   ((get-keys-write)                        (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl
                   
                   ;; SERVERS
                   ((start-server)                    (apply server:kind-run params))
                   ((kill-server)                     (set! *server-run* #f))

                   ;; TESTS

                   ;;((test-set-state-status-by-id)     (apply mt:test-set-state-status-by-id dbstruct params))
                   ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items.
                   ((test-set-state-status-by-id)

                    ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
                    (db:set-state-status-and-roll-up-items
                     dbstruct
                     (list-ref params 0) ; run-id
                     (list-ref params 1) ; test-name
                     #f                  ; item-path
                     (list-ref params 2) ; state
                     (list-ref params 3) ; status
                     (list-ref params 4) ; comment
                     ))
                   
                   ((delete-test-records)             (apply db:delete-test-records dbstruct params))
                   ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params))
                   ((test-set-state-status)           (apply db:test-set-state-status dbstruct params))
                   ((test-set-top-process-pid)        (apply db:test-set-top-process-pid dbstruct params))
                   ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params))
                   ((top-test-set-per-pf-counts)      (apply db:top-test-set-per-pf-counts dbstruct params))
                   ((test-set-archive-block-id)       (apply db:test-set-archive-block-id dbstruct params))

                   ;; RUNS
                   ((register-run)                 (apply db:register-run dbstruct params))
                   ((set-tests-state-status)       (apply db:set-tests-state-status dbstruct params))
                   ((delete-run)                   (apply db:delete-run dbstruct params))
                   ((lock/unlock-run)              (apply db:lock/unlock-run dbstruct params))
                   ((update-run-event_time)        (apply db:update-run-event_time dbstruct params))
                   ((update-run-stats)             (apply db:update-run-stats dbstruct params))
                   ((set-var)                      (apply db:set-var dbstruct params))
                   ((del-var)                      (apply db:del-var dbstruct params))

                   ;; STEPS
                   ((teststep-set-status!)         (apply db:teststep-set-status! dbstruct params))

                   ;; TEST DATA
                   ((test-data-rollup)             (apply db:test-data-rollup dbstruct params))
                   ((csv->test-data)               (apply db:csv->test-data dbstruct params))

                   ;; MISC
                   ((sync-inmem->db)               (let ((run-id (car params)))
                                                     (db:sync-touched dbstruct run-id force-sync: #t)))
                   ((mark-incomplete)              (apply db:find-and-mark-incomplete dbstruct params))

                   ;; TESTMETA
                   ((testmeta-add-record)       (apply db:testmeta-add-record dbstruct params))
                   ((testmeta-update-field)     (apply db:testmeta-update-field dbstruct params))
                   ((get-tests-tags)            (db:get-tests-tags dbstruct))

                   ;; TASKS
                   ((tasks-add)                 (apply tasks:add dbstruct params))   
                   ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params))
                   ((tasks-get-last)            (apply tasks:get-last dbstruct params))

		   ;; NO SYNC DB
		   ((no-sync-set)               (apply db:no-sync-set         *no-sync-db* params))
		   ((no-sync-get/default)       (apply db:no-sync-get/default *no-sync-db* params))
		   ((no-sync-del!)              (apply db:no-sync-del!        *no-sync-db* params))
		 
                   ;; ARCHIVES
                   ;; ((archive-get-allocations)   
                   ((archive-register-disk)     (apply db:archive-register-disk dbstruct params))
                   ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
                   ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))

                   ;;======================================================================
                   ;; READ ONLY QUERIES
                   ;;======================================================================

                   ;; KEYS
                   ((get-key-val-pairs)               (apply db:get-key-val-pairs dbstruct params))
                   ((get-keys)                        (db:get-keys dbstruct))
                   ((get-key-vals)                    (apply db:get-key-vals dbstruct params))
                   ((get-target)                      (apply db:get-target dbstruct params))
                   ((get-targets)                     (db:get-targets dbstruct))

                   ;; ARCHIVES
                   ((test-get-archive-block-info)     (apply db:test-get-archive-block-info dbstruct params))
                   
                   ;; TESTS
                   ((test-toplevel-num-items)         (apply db:test-toplevel-num-items dbstruct params))
                   ((get-test-info-by-id)	       (apply db:get-test-info-by-id dbstruct params))
                   ((test-get-rundir-from-test-id)    (apply db:test-get-rundir-from-test-id dbstruct params))
                   ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params))
                   ((get-count-tests-running)         (apply db:get-count-tests-running dbstruct params))
                   ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
                   ;; ((delete-test-step-records)        (apply db:delete-test-step-records dbstruct params))
                   ((get-previous-test-run-record)    (apply db:get-previous-test-run-record dbstruct params))
                   ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
                   ((test-get-logfile-info)           (apply db:test-get-logfile-info dbstruct params))
                   ((test-get-records-for-index-file)  (apply db:test-get-records-for-index-file dbstruct params))
                   ((get-testinfo-state-status)       (apply db:get-testinfo-state-status dbstruct params))
                   ((test-get-top-process-pid)        (apply db:test-get-top-process-pid dbstruct params))
                   ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
                   ((get-prereqs-not-met)             (apply db:get-prereqs-not-met dbstruct params))
                   ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
                   ((synchash-get)                    (apply synchash:server-get dbstruct params))
                   ((get-raw-run-stats)               (apply db:get-raw-run-stats dbstruct params))

                   ;; RUNS
                   ((get-run-info)                 (apply db:get-run-info dbstruct params))
                   ((get-run-status)               (apply db:get-run-status dbstruct params))
                   ((set-run-status)               (apply db:set-run-status dbstruct params))
                   ((get-tests-for-run)            (apply db:get-tests-for-run dbstruct params))
                   ((get-test-id)                  (apply db:get-test-id dbstruct params))
                   ((get-tests-for-run-mindata)    (apply db:get-tests-for-run-mindata dbstruct params))
                   ((get-runs)                     (apply db:get-runs dbstruct params))
                   ((get-num-runs)                 (apply db:get-num-runs dbstruct params))
                   ((get-all-run-ids)              (db:get-all-run-ids dbstruct))
                   ((get-prev-run-ids)             (apply db:get-prev-run-ids dbstruct params))
                   ((get-run-ids-matching-target)  (apply db:get-run-ids-matching-target dbstruct params))
                   ((get-runs-by-patt)             (apply db:get-runs-by-patt dbstruct params))
                   ((get-run-name-from-id)         (apply db:get-run-name-from-id dbstruct params))
                   ((get-main-run-stats)           (apply db:get-main-run-stats dbstruct params))
                   ((get-var)                      (apply db:get-var dbstruct params))
                   ((get-run-stats)                (apply db:get-run-stats dbstruct params))

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

                   ;; TEST DATA
                   ((read-test-data)               (apply db:read-test-data dbstruct params))
                   ((read-test-data*)              (apply db:read-test-data* dbstruct params))

                   ;; MISC
                   ((get-latest-host-load)         (apply db:get-latest-host-load dbstruct params))
                   ((have-incompletes?)            (apply db:have-incompletes? dbstruct params))
                   ((login)                        (apply db:login dbstruct params))
                   ((general-call)                 (let ((stmtname   (car params))
                                                         (run-id     (cadr params))
                                                         (realparams (cddr params)))
                                                     (db:general-call dbstruct stmtname realparams)))
                   ((sdb-qry)                      (apply sdb:qry params))
                   ((ping)                         (current-process-id))
		   ((get-changed-record-ids)       (apply db:get-changed-record-ids dbstruct params))
		   
                   ;; TESTMETA
                   ((testmeta-get-record)       (apply db:testmeta-get-record dbstruct params))

                   ;; TASKS 
                   ((find-task-queue-records)   (apply tasks:find-task-queue-records dbstruct params))
		   (else
		    (debug:print 0 *default-log-port* "ERROR: bad api call " cmd)
		    (conc "ERROR: BAD api call " cmd))))))
       
       ;; save all stats
       (let ((delta-t (- (current-milliseconds)
			 start-t)))
	 (hash-table-set! *db-api-call-time* cmd
			  (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '()))))
       (if writecmd-in-readonly-mode
	   (vector #f res)
           (vector #t res)))))))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































Deleted emergency-patches/emergency-patch-2.scm version [2347b68fd3].

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
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")

(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f))
  (let* ((loadavg (common:get-cpu-load remote-host))
	 (first   (car loadavg))
	 (next    (cadr loadavg))
	 (adjload (* maxload numcpus))
	 (loadjmp (- first next)))
    (cond
     ((and (> first adjload)
	   (> count 0))
      (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload " " (if msg msg ""))
      (thread-sleep! waitdelay)
      (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))
     ((and (> loadjmp numcpus)
	   (> count 0))
      (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg ""))
      (thread-sleep! waitdelay)
      (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))))))

(define (common:wait-for-homehost-load maxload msg)
  (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local.
                     #f
                     (common:get-homehost)))
         (hh     (if hh-dat (car hh-dat) #f))
         (numcpus (common:get-num-cpus hh)))
    (common:wait-for-normalized-load maxload msg: msg remote-host: hh)))

;; wait for normalized cpu load to drop below maxload
;;
(define (common:wait-for-normalized-load maxload #!key (msg #f)(remote-host #f))
  (let ((num-cpus (common:get-num-cpus remote-host)))
    (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host)))

;;  hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps)
(define (runs:process-expanded-tests runsdat testdat)
  ;; unroll the contents of runsdat and testdat (due to ongoing refactoring).
  (let* ((hed                    (runs:testdat-hed testdat))
	 (tal                    (runs:testdat-tal testdat))
	 (reg                    (runs:testdat-reg testdat))
	 (reruns                 (runs:testdat-reruns testdat))
	 (test-name              (runs:testdat-test-name testdat))
	 (item-path              (runs:testdat-item-path testdat))
	 (jobgroup               (runs:testdat-jobgroup testdat))
	 (waitons                (runs:testdat-waitons testdat))
	 (item-path              (runs:testdat-item-path testdat))
	 (testmode               (runs:testdat-testmode testdat))
	 (newtal                 (runs:testdat-newtal testdat))
	 (itemmaps               (runs:testdat-itemmaps testdat))
	 (test-record            (runs:testdat-test-record testdat))
	 (prereqs-not-met        (runs:testdat-prereqs-not-met testdat))

	 (reglen                 (runs:dat-reglen runsdat))
	 (regfull                (runs:dat-regfull runsdat))
	 (runname                (runs:dat-runname runsdat))
	 (max-concurrent-jobs    (runs:dat-max-concurrent-jobs runsdat))
	 (run-id                 (runs:dat-run-id runsdat))
	 (test-patts             (runs:dat-test-patts runsdat))
	 (required-tests         (runs:dat-required-tests runsdat))
	 (test-registry          (runs:dat-test-registry runsdat))
	 (registry-mutex         (runs:dat-registry-mutex runsdat))
	 (flags                  (runs:dat-flags runsdat))
	 (keyvals                (runs:dat-keyvals runsdat))
	 (run-info               (runs:dat-run-info runsdat))
	 (all-tests-registry     (runs:dat-all-tests-registry runsdat))
	 (run-limits-info        (runs:dat-can-run-more-tests runsdat))
	 ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
	 (have-resources         (car run-limits-info))
	 (num-running            (list-ref run-limits-info 1))
	 (num-running-in-jobgroup(list-ref run-limits-info 2)) 
	 (max-concurrent-jobs    (list-ref run-limits-info 3))
	 (job-group-limit        (list-ref run-limits-info 4))
	 ;; (prereqs-not-met        (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
	 ;; (prereqs-not-met         (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
	 (fails                  (if (list? prereqs-not-met)
				      (runs:calc-fails prereqs-not-met)
				      (begin
					(debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met)
					'())))
	 (non-completed           (filter (lambda (x)             ;; remove hed from not completed list, duh, of course it is not completed!
					    (not (equal? x hed)))
					  (runs:calc-not-completed prereqs-not-met)))
	 (loop-list               (list hed tal reg reruns))
	 ;; configure the load runner
	 (numcpus                 (common:get-num-cpus #f))
	 (maxload                 (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3.0")))         ;; use a non-number string to disable
         (maxhomehostload         (string->number (or (configf:lookup *configdat* "jobtools" "maxhomehostload") "1.2"))) ;; use a non-number string to disable
         (waitdelay               (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60"))))
    (debug:print-info 4 *default-log-port* "have-resources: " have-resources " prereqs-not-met: (" 
		      (string-intersperse 
		       (map (lambda (t)
			      (if (vector? t)
				  (conc (db:test-get-state t) "/" (db:test-get-status t))
				  (conc " WARNING: t is not a vector=" t )))
			    prereqs-not-met)
		       ", ") ") fails: " fails
		       "\nregistered? " (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f))
			    

    
    (if (and (not (null? prereqs-not-met))
	     (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60))
	(debug:print-info 2 *default-log-port* "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", ")))

    ;; Don't know at this time if the test have been launched at some time in the past
    ;; i.e. is this a re-launch?
    (debug:print-info 4 *default-log-port* "run-limits-info = " run-limits-info)
    
    (cond
     
     ;; Check item path against item-patts, 
     ;;
     ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run
      ;; else the run is stuck, temporarily or permanently
      ;; but should check if it is due to lack of resources vs. prerequisites
      (debug:print-info 1 *default-log-port* "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts)
      (if (or (not (null? tal))(not (null? reg)))
	  (list (runs:queue-next-hed tal reg reglen regfull)
		(runs:queue-next-tal tal reg reglen regfull)
		(runs:queue-next-reg tal reg reglen regfull)
		reruns)
	  #f))
     
     ;; Register tests 
     ;;
     ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f))
      (debug:print-info 4 *default-log-port* "Pre-registering test " test-name "/" item-path " to create placeholder" )
      ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs
      (let register-loop ((numtries 15))
	(rmt:register-test run-id test-name item-path)
	(if (rmt:get-test-id run-id test-name item-path)
	    (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done)
	    (if (> numtries 0)
		(begin
		  (thread-sleep! 0.5)
		  (register-loop (- numtries 1)))
		(debug:print-error 0 *default-log-port* "failed to register test " (db:test-make-full-name test-name item-path)))))
      (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done))
	  (begin
	    (rmt:register-test run-id test-name "")
	    (if (rmt:get-test-id run-id test-name "")
		(hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))))
      (runs:shrink-can-run-more-tests-count runsdat)   ;; DELAY TWEAKER (still needed?)
      (if (and (null? tal)(null? reg))
	  (list hed tal (append reg (list hed)) reruns)
	  (list (runs:queue-next-hed tal reg reglen regfull)
		(runs:queue-next-tal tal reg reglen regfull)
		;; NB// Here we are building reg as we register tests
		;; if regfull we must pop the front item off reg
		(if regfull
		    (append (cdr reg) (list hed))
		    (append reg (list hed)))
		reruns)))
     
     ;; At this point hed test registration must be completed.
     ;;
     ((eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)
	   'start)
      (debug:print-info 0 *default-log-port* "Waiting on test registration(s): "
			(string-intersperse 
			 (filter (lambda (x)
				   (eq? (hash-table-ref/default test-registry x #f) 'start))
				 (hash-table-keys test-registry))
			 ", "))
      (thread-sleep! 0.051)
      (list hed tal reg reruns))
     
     ;; If no resources are available just kill time and loop again
     ;;
     ((not have-resources) ;; simply try again after waiting a second
      (if (runs:lownoise "no resources" 60)
	  (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ..."))
      ;; Have gone back and forth on this but db starvation is an issue.
      ;; wait one second before looking again to run jobs.
      (thread-sleep! 1)
      ;; could have done hed tal here but doing car/cdr of newtal to rotate tests
      (list (car newtal)(cdr newtal) reg reruns))
     
     ;; This is the final stage, everything is in place so launch the test
     ;;
     ((and have-resources
	   (or (null? prereqs-not-met)
	       (and (member 'toplevel testmode) ;;  'toplevel)
		    (null? non-completed)
		    (not (member 'exclusive testmode)))))
      ;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path))
      ;; we are going to reset all the counters for test retries by setting a new hash table
      ;; this means they will increment only when nothing can be run
      (set! *max-tries-hash* (make-hash-table))
      ;; well, first lets see if cpu load throttling is enabled. If so wait around until the
      ;; average cpu load is under the threshold before continuing
      (if maxload ;; only gate if maxload is specified
          (common:wait-for-cpuload maxload numcpus waitdelay))
      (if maxhomehostload
          (common:wait-for-homehost-load maxhomehostload (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload)))
      
      (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry)
      (runs:incremental-print-results run-id)
      (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running)
      (runs:shrink-can-run-more-tests-count runsdat)  ;; DELAY TWEAKER (still needed?)
      ;; (thread-sleep! *global-delta*)
      (if (or (not (null? tal))(not (null? reg)))
	  (list (runs:queue-next-hed tal reg reglen regfull)
		(runs:queue-next-tal tal reg reglen regfull)
		(runs:queue-next-reg tal reg reglen regfull)
		reruns)
	  #f))
     
     ;; must be we have unmet prerequisites
     ;;
     (else
      (debug:print 4 *default-log-port* "FAILS: " fails)
      ;; If one or more of the prereqs-not-met are FAIL then we can issue
      ;; a message and drop hed from the items to be processed.
      ;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met)
      (if (and (not (null? prereqs-not-met))
	       (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60))
	  (debug:print-info 1 *default-log-port* "waiting on tests; " (string-intersperse 
						    (runs:mixed-list-testname-and-testrec->list-of-strings 
						     prereqs-not-met) ", ")))
      (if (or (null? fails)
	      (member 'toplevel testmode))
	  (begin
	    ;; couldn't run, take a breather
	    (if  (runs:lownoise "Waiting for more work to do..." 60)
		 (debug:print-info 0 *default-log-port* "Waiting for more work to do..."))
	    (thread-sleep! 1)
	    (list (car newtal)(cdr newtal) reg reruns))
	  ;; the waiton is FAIL so no point in trying to run hed ever again
	  (if (or (not (null? reg))(not (null? tal)))
	      (if (vector? hed)
		  (begin
		    (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path
				 " from the launch list as it has prerequistes that are FAIL")
		    (let ((test-id (rmt:get-test-id run-id hed "")))
		      (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))
		    (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
		    ;; (thread-sleep! *global-delta*)
		    ;; This next is for the items
		    (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f)
		    (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed)
		    (list (runs:queue-next-hed tal reg reglen regfull)
			  (runs:queue-next-tal tal reg reglen regfull)
			  (runs:queue-next-reg tal reg reglen regfull)
			  reruns ;; WAS: (cons hed reruns) ;; but that makes no sense?
			  ))
		  (let ((nth-try (hash-table-ref/default test-registry hed 0)))
		    (cond
		     ((member "RUNNING" (map db:test-get-state prereqs-not-met))
		      (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60)
			  (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet."))
		      (thread-sleep! 4)
		      (list (runs:queue-next-hed newtal reg reglen regfull)
			    (runs:queue-next-tal newtal reg reglen regfull)
			    (runs:queue-next-reg newtal reg reglen regfull)
			    reruns))
		     ((or (not nth-try)
			  (and (number? nth-try)
			       (< nth-try 10)))
		      (hash-table-set! test-registry hed (if (number? nth-try)
							     (+ nth-try 1)
							     0))
		      (if (runs:lownoise (conc "not removing test " hed) 60)
			  (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites"))
		      ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;;  " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
		      (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
		      ;; (list hed tal reg reruns)
		      ;; (list (car newtal)(cdr newtal) reg reruns)
		      ;; (hash-table-set! test-registry hed 'removed)
		      (list (runs:queue-next-hed newtal reg reglen regfull)
			    (runs:queue-next-tal newtal reg reglen regfull)
			    (runs:queue-next-reg newtal reg reglen regfull)
			    reruns))
		     ((symbol? nth-try)
		      (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW
			  (if (null? tal)
			      #f ;; yes, really
			      (list (car tal)(cdr tal) reg reruns))
			  (begin
			    (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60)
				(debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry."))
			    (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f)
			    (hash-table-set! test-registry hed 0)
			    (list (runs:queue-next-hed newtal reg reglen regfull)
				  (runs:queue-next-tal newtal reg reglen regfull)
				  (runs:queue-next-reg newtal reg reglen regfull)
				  reruns))))
		     (else
		      (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60)
			  (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now."))
		      ;; (debug:print 0 *default-log-port* "         prereqs: " prereqs-not-met)
		      (hash-table-set! test-registry hed 'removed)
		      (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f)
		      ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug.
		      (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL
		      (list (if (null? tal)(car newtal)(car tal))
			    tal
			    reg
			    reruns)))))
	      ;; can't drop this - maybe running? Just keep trying
	      (let ((runable-tests (runs:runable-tests prereqs-not-met)))
		(if (null? runable-tests)
		    #f   ;; I think we are truly done here
		    (list (runs:queue-next-hed newtal reg reglen regfull)
			    (runs:queue-next-tal newtal reg reglen regfull)
			    (runs:queue-next-reg newtal reg reglen regfull)
			    reruns)))))))))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































Deleted emergency-patches/emergency-patch-3.scm version [73e5520573].

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
 ;; To build patch:
 ;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; ldd /p/foundry/env/pkgs/megatest/1.64/19/bin/.11/mtest
 ;;        linux-vdso.so.1 =>  (0x00002aaaaaaab000)
 ;;        libchicken.so.7 => /p/foundry/env/pkgs/megatest/1.64/chicken-4.10.0//lib/libchicken.so.7 (0x00002aaaaaaad000)
 ;;        libm.so.6 => /lib64/libm.so.6 (0x00002aaaab0a6000)
 ;;        libdl.so.2 => /lib64/libdl.so.2 (0x00002aaaab31f000)
 ;;        libc.so.6 => /lib64/libc.so.6 (0x00002aaaab523000)
 ;;        /lib64/ld-linux-x86-64.so.2 (0x0000555555554000)
 ;;
 ;;  /p/foundry/env/pkgs/megatest/1.64/chicken-4.10.0/bin/csc -s emergency-patch-3.scm
 ;;


 ;; to test patch:
 ;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; in .megatestrc, add:
 ;; (if (and (> megatest-version 1.64)
 ;;         (< megatest-version 1.6421))
 ;;   (begin
 ;;      (load "/p/foundry/env/pkgs/megatest/1.64/19/share/epatch-1.so")
 ;;      (load "/p/foundry/env/pkgs/megatest/1.64/19/share/epatch-2.so"))) 
 ;;


 ;; to productize patch:
 ;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; 
(use directory-utils regex)

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

;; Given a run id start a server process    ### NOTE ### > file 2>&1 
;; if the run-id is zero and 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* ((curr-host   (get-host-name))
         ;; (attempt-in-progress (server:start-attempted? areapath))
         ;; (dot-server-url (server:check-if-running areapath))
	 (curr-ip     (server:get-best-guess-address curr-host))
	 (curr-pid    (current-process-id))
	 (homehost    (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" ))
	 (target-host (car homehost))
	 (testsuite   (common:get-testsuite-name))
	 (logfile     (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log"))
	 (cmdln (conc (common:get-megatest-exe)
		      " -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
							   " -daemonize "
							   "")
		      ;; " -log " logfile
		      " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &")))))
	 (log-rotate  (make-thread common:rotate-logs  "server run, rotate logs thread"))
         (load-limit  (configf:lookup-number *configdat* "server" "load-limit" default: 0.9)))
    ;; 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)
    (common:wait-for-normalized-load load-limit " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever
    (system (conc "nbfake " cmdln))
    (unsetenv "TARGETHOST_LOGF")
    (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
    (thread-join! log-rotate)
    (pop-directory)))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































Deleted fsl-rebase.scm version [d4dd53982d].

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
;; given branch and baseline commit generate list of commands to cherry pick commits
;;
;;
;; Usage: fsl-rebase basecommit branch
;;         

(use regex posix)

(let* ((basecommit (cadr (argv)))
       (branch     (caddr (argv)))
       (cmd        (conc "fossil timeline after " basecommit " -n 1000000 -W 0"))
       (theregex   (conc ;; "^[^\\]]+"
			 "\\[([a-z0-9]+)\\]\\s+"
			 "(.*)"
			 "\\s+\\(.*tags:\\s+" branch 
			 ;; ".*\\)"
			 )))
  (print "basecommit: " basecommit ", branch: " branch ", theregex: " theregex ", cmd: \"" cmd "\"")
  (with-input-from-pipe
   cmd
   (lambda ()
     (let loop ((inl (read-line))
		(res '()))
       (if (not (eof-object? inl))
	   (let ((have-match (string-search theregex inl)))
	     (if have-match
		 (loop (read-line)
		       (cons (conc "fossil merge --cherrypick " (cadr have-match)
				   "\nfossil commit -m \"Cherry pick from " (cadr have-match)
				   ": " (caddr have-match) "\"")
			     res))
		 (loop (read-line) res)))
	   (map print res))))))

;; (print "match: " inl "\n   $1: " (cadr have-match) " $2: " (caddr have-match))
;; (print "no match: " theregex " " inl))
;; (loop (read-line))))))))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































Deleted iupexamples/graph.scm version [5afd5f9dcd].

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
(use iup)
(import iup-pplot)

 

(define (tl)
  (let* ((lastx 0)
	 (lastsample 2)
	 (plt (pplot 
	       #:title "MyTitle"
	       #:marginbottom "65"
	       #:marginleft   "65"
	       #:axs_xlabel   "Score" 
	       #:axs_ylabel "Count"
	       #:legendshow "YES"
	       ;; #:axs_xmin    "0"
	       ;; #:axs_ymin    "0"
	       #:axs_yautomin "YES"
	       #:axs_xautomin "YES"
	       #:axs_xautotick "YES"
	       #:axs_yautotick "YES"
	       #:ds_showvalues "YES"
	       #:size "200x200"
	       ))
	 (plt1  (call-with-pplot 
		 plt
		 (lambda (x)
		   (pplot-add! plt 10 100)
		   (pplot-add! plt 20 120)
		   (pplot-add! plt 30 200))
		 #:x-string #f
		 ))
	 (plt2  (call-with-pplot 
		 plt
		 (lambda (x)
		   (pplot-add! plt 10 180)
		   (pplot-add! plt 20 125)
		   (pplot-add! plt 30 100))
		 #:x-string #f
		 ))
	 (dlg (dialog
	       (vbox
		plt
		(hbox
		;;  (button "Redraw" size: "50x" action: (lambda (obj)
		;; 					(redraw plt)))
		 (button "Quit"   size: "50x" action: (lambda (obj)
							(exit)))
		 (button "AddPoint" size: "50x" action: (lambda (obj)
							  (set! lastx (+ lastx 10))
							  (set! lastsample (+ lastsample 1))
							  ;; (attribute-set! plt 'current 0)
							  (print "lastx: " lastx " lastsample: " lastsample)
							  (pplot-add! plt lastx (random 300) lastsample 1)
							  (attribute-set! plt "REDRAW" "1"))))))))
    (set! lastx 30)
    (attribute-set! plt 'ds_mode "LINE")
    ;; (attribute-set! plt 'ds_legend "Yada")
    (show dlg)
    (main-loop)))

(tl)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































Deleted iupexamples/iupwidgetinfo.scm version [c580d04776].

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
#! /usr/bin/env csi

(require-library srfi-4 iup)
(import srfi-4 iup iup-pplot iup-glcanvas)

(define (popup dlg . args)
  (apply show dlg #:modal? 'yes args)
  (destroy! dlg))

(define (properties ih)
  (popup (element-properties-dialog ih))
  'default)

(define dlg
  (dialog
    (vbox
      (hbox ; headline
        (fill)
        (frame (label " Inspect control and dialog classes "
                      fontsize: 15))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Dialogs" fontsize: 12)
      (hbox
        (button "dialog"
                action: (lambda (self) (properties (dialog (vbox)))))
        (button "color-dialog"
                action: (lambda (self) (properties (color-dialog))))
        (button "file-dialog"
                action: (lambda (self) (properties (file-dialog))))
        (button "font-dialog"
                action: (lambda (self) (properties (font-dialog))))
        (button "message-dialog"
                action: (lambda (self) (properties (message-dialog))))
        (fill)
        margin: '0x0)
      (hbox
        (button "layout-dialog"
                action: (lambda (self) (properties (layout-dialog))))
        (button "element-properties-dialog"
                action: (lambda (self)
                          (properties
                            (element-properties-dialog (create 'user)))))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Composition widgets" fontsize: 12)
      (hbox
        (button "fill"
                action: (lambda (self) (properties (fill))))
        (button "hbox"
                action: (lambda (self) (properties (hbox))))
        (button "vbox"
                action: (lambda (self) (properties (vbox))))
        (button "zbox"
                action: (lambda (self) (properties (zbox))))
        (button "radio"
                action: (lambda (self) (properties (radio (vbox)))))
        (button "normalizer"
                action: (lambda (self) (properties (normalizer))))
        (button "cbox"
                action: (lambda (self) (properties (cbox))))
        (button "sbox"
                action: (lambda (self) (properties (sbox (vbox)))))
        (button "split"
                action: (lambda (self) (properties (split (vbox) (vbox)))))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Standard widgets" fontsize: 12)
      (hbox
        (button "button"
                action: (lambda (self) (properties (button))))
        (button "canvas"
                action: (lambda (self) (properties (canvas))))
        (button "frame"
                action: (lambda (self) (properties (frame))))
        (button "label"
                action: (lambda (self) (properties (label))))
        (button "listbox"
                action: (lambda (self) (properties (listbox))))
        (button "progress-bar"
                action: (lambda (self) (properties (progress-bar))))
        (button "spin"
                action: (lambda (self) (properties (spin))))
        (fill)
        margin: '0x0)
      (hbox
        (button "tabs"
                action: (lambda (self) (properties (tabs))))
        (button "textbox"
                action: (lambda (self) (properties (textbox))))
        (button "toggle"
                action: (lambda (self) (properties (toggle))))
        (button "treebox"
                action: (lambda (self) (properties (treebox))))
        (button "valuator"
                action: (lambda (self) (properties (valuator ""))))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Additional widgets" fontsize: 12)
      (hbox
        (button "cells"
                action: (lambda (self) (properties (cells))))
        (button "color-bar"
                action: (lambda (self) (properties (color-bar))))
        (button "color-browser"
                action: (lambda (self) (properties (color-browser))))
        (button "dial"
                action: (lambda (self) (properties (dial ""))))
        (button "matrix"
                action: (lambda (self) (properties (matrix))))
        (fill)
        margin: '0x0)
      (hbox
        (button "pplot"
                action: (lambda (self) (properties (pplot))))
        (button "glcanvas"
                action: (lambda (self) (properties (glcanvas))))
        (button "web-browser"
                action: (lambda (self) (properties (web-browser))))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Menu widgets" fontsize: 12)
      (hbox
        (button "menu"
                action: (lambda (self) (properties (menu))))
        (button "menu-item"
                action: (lambda (self) (properties (menu-item))))
        (button "menu-separator"
                action: (lambda (self) (properties (menu-separator))))
        (fill)
        margin: '0x0)

      (label "") 
      (label "Images" fontsize: 12)
      (hbox
        (button "image/palette"
                action: (lambda (self)
                          (properties
                            (image/palette 1 1 (u8vector->blob (u8vector 0))))))
        (button "image/rgb"
                action: (lambda (self)
                          (properties
                            (image/rgb 1 1 (u8vector->blob (u8vector 0))))))
        (button "image/rgba"
                action: (lambda (self)
                          (properties
                            (image/rgba 1 1 (u8vector->blob (u8vector 0))))))
        (button "image/file"
                action: (lambda (self)
                          (properties
                            ;; same attributes as image/palette
                            (image/palette 1 1 (u8vector->blob (u8vector 0))))))
                            ;; needs a file in current directory
                            ;(image/file "chicken.ico")))) ; ok
                            ;(image/file "chicken.png")))) ; doesn't work
        (fill)
        margin: '0x0)

      (label "") 
      (label "Other widgets" fontsize: 12)
      (hbox
        (button "clipboard"
                action: (lambda (self) (properties (clipboard))))
        (button "timer"
                action: (lambda (self) (properties (timer))))
        (button "spinbox"
                action: (lambda (self) (properties (spinbox (vbox)))))
        (fill)
        margin: '0x0)

      (fill)
      (button "E&xit"
              expand: 'horizontal
              action: (lambda (self) 'close))
      )
    margin: '15x15
    title: "Iup inspector"))

(show dlg)
(main-loop)
(exit 0)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































Deleted iupexamples/tree.scm version [872c01f2cf].

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

(use test)
(require-library iup)
(import (prefix iup iup:))

(define t #f) 

(define tree-dialog
  (iup:dialog
   #:title "Tree Test"
   (let ((t1 (iup:treebox
	      #:selection_cb (lambda (obj id state)
			       (print "selection_db with id=" id " state=" state)
			       (print "USERDATA: " (iup:attribute obj "USERDATA"))
			       (print "SPECIALDATA: " (iup:attribute obj "SPECIALDATA"))
			       (print "Depth: " (iup:attribute obj "DEPTH"))
			       ))))
     (set! t t1)
     t1)))

(iup:show tree-dialog)

(map (lambda (elname el)
       (print "Adding " elname " with value " el)
       (iup:attribute-set! t elname el)
       (iup:attribute-set! t "USERDATA" el))
     '("VALUE" "NAME"    "ADDLEAF" "ADDBRANCH1" "ADDLEAF2"    "VALUE")
     '("0"     "Figures" "Other"   "triangle"   "equilateral" "4")
     )
(map (lambda (attr)
       (print attr " is " (iup:attribute t attr)))
     '("KIND1" "PARENT2" "STATE1"))

(define (tree-find-node obj path)
  ;; start at the base of the tree
  (if (null? path)
      #f ;; or 0 ????
      (let loop ((hed      (car path))
		 (tal      (cdr path))
		 (depth    0)
		 (nodenum  0))
	;; nodes in iup tree are 100% sequential so iterate over nodenum
	(if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes
	    (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum))))
		  (node-title (iup:attribute obj (conc "TITLE" nodenum))))
	      ;; (print 0 "hed: " hed ", depth: " depth ", node-depth: " node-depth ", nodenum: " nodenum ", node-title: " node-title)
	      (if (and (equal? depth node-depth)
		       (equal? hed   node-title)) ;; yep, this is the one!
		  (if (null? tal) ;; end of the line
		      nodenum
		      (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum)))
		  ;; this is the case where we found part of the hierarchy but not 
		  ;; all of it, i.e. the node-depth went from deep to less deep
		  (if (> depth node-depth) ;; (+ 1 node-depth))
		      #f
		      (loop hed tal depth (+ nodenum 1)))))
	    #f))))

;; top is the top node name zeroeth node VALUE=0
(define (tree-add-node obj top nodelst)
  (if (not (iup:attribute obj "TITLE0"))
      (iup:attribute-set! obj "ADDBRANCH0" top))
  (cond
   ((not (string=? top (iup:attribute obj "TITLE0")))
    (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0")))
   ((null? nodelst))
   (else
    (let loop ((hed      (car nodelst))
	       (tal      (cdr nodelst))
	       (depth    1)
	       (pathl    (list top)))
      ;; Because the tree dialog changes node numbers when
      ;; nodes are added or removed we must look up nodes
      ;; each and every time. 0 is the top node so default
      ;; to that.
      (let* ((newpath    (append pathl (list hed)))
	       (parentnode (tree-find-node obj pathl))
	       (nodenum    (tree-find-node obj newpath)))
	  ;; (print "newpath: " newpath ", nodenum " nodenum ", hed: " hed ", depth: " depth ", parentnode: " parentnode ", pathl: " pathl)
	  ;; Add the branch under lastnode if not found
	  (if (not nodenum)
	      (begin
		(iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed)
		(if (null? tal)
		    #t
		    ;; reset to top
		    (loop (car nodelst)(cdr nodelst) 1 (list top)))) 
	      (if (null? tal) ;; if null here then this path has already been added
		  #t
		  ;; (if nodenum
		  (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))) ;;  (if nodenum nodenum lastnode)))))))
	      ;; 	  (loop hed tal depth pathl lastnode)))))))

(define (tree-node->path obj nodenum)
  ;; (print "\ncurrnode  nodenum  depth  node-depth  node-title   path")
  (let loop ((currnode 0)
	     (depth    0)
	     (path     '()))
    (let ((node-depth (iup:attribute obj (conc "DEPTH" currnode)))
	  (node-title (iup:attribute obj (conc "TITLE" currnode))))
      ;; (display (conc "\n   "currnode "        " nodenum "       " depth "         " node-depth "          " node-title "         " path))
      (if (> currnode nodenum)
	  path
	  (if (not node-depth) ;; #f if we are out of nodes
	      '()
	      (let ((ndepth (string->number node-depth)))
		(if (eq? ndepth depth)
		    ;; This next is the match condition depth == node-depth
		    (if (eq? currnode nodenum)
			(begin
			  ;; (display " <X>")
			  (append path (list node-title)))
			(loop (+ currnode 1)
			      (+ depth 1)
			      (append path (list node-title))))
		    ;; didn't match, reset to base path and keep looking
		    ;; due to more iup odditys we don't reset to base
		    (begin 
		      ;; (display " <L>")
		      (loop (+ 1 currnode)
			    2
			    (append (take path ndepth)(list node-title)))))))))))

(test #f 0  (tree-find-node t '("Figures")))
(test #f 1  (tree-find-node t '("Figures" "Other")))
(test #f #f (tree-find-node t '("Figures" "Other"    "equilateral")))
(test #f 3  (tree-find-node t '("Figures" "triangle" "equilateral")))
(test #f #t (tree-add-node  t "Figures" '()))
(test #f #t (tree-add-node  t "Figures" '("a" "b" "c")))
(test #f 3  (tree-find-node t '("Figures" "a" "b" "c")))
(test #f #t (tree-add-node  t "Figures" '("d" "b" "c")))
(test #f 3  (tree-find-node t '("Figures" "d" "b" "c")))
(test #f 6  (tree-find-node t '("Figures" "a" "b" "c")))
(test #f #t (tree-add-node  t "Figures" '("a" "e" "c")))
(test #f 6  (tree-find-node t '("Figures" "a" "e" "c")))

(test #f '("Figures")             (tree-node->path t 0))
(test #f '("Figures" "d")         (tree-node->path t 1))
(test #f '("Figures" "d" "b" "c") (tree-node->path t 3))
(test #f '("Figures" "a")         (tree-node->path t 4))
(test #f '("Figures" "a" "b" "c")     (tree-node->path t 8)) 
(test #f '()                      (tree-node->path t 40))

(iup:main-loop)

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































Deleted loadwatch/Makefile version [d2fa89fb63].

1
2
3
4
5
6
7
8
9
10
11

all : launch-many queuefeeder queuefeeder-server

launch-many : launch-many.scm
	csc launch-many.scm

queuefeeder : queuefeeder.scm
	csc queuefeeder.scm

queuefeeder-server : queuefeeder-server.scm
	csc queuefeeder-server.scm
<
<
<
<
<
<
<
<
<
<
<






















Deleted loadwatch/bjob-count.sh version [0c8ad639ee].

1
2
3
#!/bin/bash

bqueues | grep normal |awk '{print $8}'
<
<
<






Deleted loadwatch/launch-many.scm version [141ac70432].

1
2
3
4
5
6
7
8
9
(use posix)

(let loop ((count 0))
  (if (> count 500000)
      (print "DONE")
      (let ((cmd (conc "./queuefeeder xena:22022 bsub ./testopenlava.sh " count " " (random 30))))
	(print "Running: " cmd)
	(system cmd)
	(loop (+ count 1)))))
<
<
<
<
<
<
<
<
<


















Deleted loadwatch/loadwatch.scm version [d281425009].

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
(use regex srfi-69)

(define-record processdat
  %cpu
  virt
  res
  %mem
  count
  )

(define (pp-processdat dat)
  (print "(processdat"
	 " %cpu="  (processdat-%cpu dat)
	 " virt="  (processdat-virt dat)
	 " res="   (processdat-res  dat)
	 " %mem="  (processdat-%mem dat)
	 " count=" (processdat-count dat)))


(define nrex (regexp "^(\\d+[\\d\\.]*)([mkgMKG])$"))

(define (get-number numstr)
  (let ((n (string->number numstr)))
    (if n 
	n
	(let ((nmatch (string-match nrex numstr)))
	  (if nmatch
	      (* (string->number (cadr nmatch))
		 (case (string->symbol (caddr nmatch))
		   ((k) 1024)
		   ((m) 1048576)
		   ((g) 1073741824)
		   (else 
		    (print "ERROR: Unrecognised unit: " (caddr nmatch) ", extracted for " numstr)
		    1)))
	      #f)))))


(define (snagload)
  (let ((dat (make-hash-table)) ;; user => hash-of-processdat
	(hdr (regexp "^\\s+PID"))
	(rx  (regexp "\\s+"))
	(wht (regexp "^\\s+"))
	)
    (with-input-from-pipe 
     "top -n 1 -b"
     (lambda ()
       (let loop ((inl   (read-line))
		  (inbod #f))
	 (if (eof-object? inl)
	     dat
	     (if (not inbod)
		 (if (string-search hdr inl)
		     (loop (read-line) #t)
		     (loop (read-line) #f))
		 (let* ((lparts (map (lambda (x)
				       (let ((num (get-number x)))
					 (if num num x)))
				     (string-split-fields rx (string-substitute wht "" inl) #:infix))))
		   (if (> (length lparts) 10)
		       (let* ((user   (list-ref lparts 1))
			      (virt   (list-ref lparts 4))
			      (res    (list-ref lparts 5))
			      (%cpu   (list-ref lparts 8))
			      (%mem   (list-ref lparts 9))
			      (time   (list-ref lparts 10))
			      (pname  (list-ref lparts 11))
			      (udat   (or (hash-table-ref/default dat user #f)
					  (let ((u (make-hash-table)))
					    (hash-table-set! dat user u)
					    u)))
			      (pdat   (or (hash-table-ref/default udat pname #f)
					  (let ((p (make-processdat 0 0 0 0 0)))
					    (hash-table-set! udat pname p)
					    p))))
			 (print "User: " user ", pname: " pname ", virt: " virt ", res: " res ", %cpu: " %cpu ", %mem: " %mem)
			 (processdat-%cpu-set!  pdat (+ (processdat-%cpu pdat) %cpu))
			 (processdat-%mem-set!  pdat (+ (processdat-%mem pdat) %mem))
			 (processdat-virt-set!  pdat (+ (processdat-virt pdat) virt))
			 (processdat-res-set!   pdat (+ (processdat-res pdat)  res))
			 (processdat-count-set! pdat (+ (processdat-count pdat) 1))
			 (loop (read-line) inbod))
		       dat)))))))))
    
(define x (snagload))
;; (processdat-%cpu (hash-table-ref (hash-table-ref x "matt") "evolution-calen"))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































Deleted loadwatch/queuefeeder-server.scm version [4584852f4e].

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
;;======================================================================
;; Copyright 2015-2015, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

;; Queue Feeder. Use a crude droop curve to limit feeding jobs into a queue
;;               to prevent slamming the queue

;;======================================================================
;; Methodology
;;
;;   Connect to the server, the server delays the appropriate time (if 
;;   any) and then launch the task.
;;

(use nanomsg posix regex)

;; (use trace)
;; (trace nn-bind nn-socket nn-assert nn-recv nn-send thread-terminate! nn-close )

(define port  22022)

;; get needed stuff from commandline
;;
(define queuelen #f)
(define cmd '()) ;; cmd is run to give a count of the queue length => returns number in queue

(define usage "Usage: queuefeeder-server port target_queue_length command
       where command is a script or program that gives an integer on stdout of current queue length")

(let ((args (argv)))
  (if (> (length args) 3)
      (begin
	(set! port     (cadr args))
	(set! queuelen (string->number (caddr args)))
	(set! cmd      (cadddr args))) ;; no params supported
      (begin
	(print usage)
	(exit))))

(if (not queuelen)
    (begin
      (print "queuelen must be a number")
      (print usage)
      (exit)))

(print "Running queue feeder with port=" port ", command=" cmd)

(define rep   (nn-socket 'rep))

(print "connecting, got: " (nn-bind    rep  (conc "tcp://" "*" ":" port)))

(define *current-delay* 0)
(define (exp-droop-calc x targ)
  (cond
   ((> (- x targ) 1) 136) ;; top off at 136 seconds
   (else 
    (let ((res (* 50 (exp (- x targ)))))
      (cond
       ((and (> res 0)(< res 0.01)) 0.01)
       ((> res 45)                  45) ;; cap at 45 seconds
       (else res))))))

;; x input value (current number in the queue)
;; targ is the desired queue length
;;
(define (piecewise-droop-calc x targ)
  (let ((top 50))
    (cond
     ((> (- x targ) 0)
      top) ;; top off at top seconds
     ((> x (- targ top))
      (+ (* 1 (- x (- targ top)))
	 (/ (- top targ) targ)))
     (else (let ((res (/ x targ)))
	     (if (< res 0.01)
		 0.01
		 res))))))

(define (server soc)
  (print "server starting")
  (let loop ((msg-in (nn-recv soc))
	     (count  0))
    (if (eq? 0 (modulo count 1000))
	(print "server received: " msg-in ", count=" count))
    (cond
     ((equal? msg-in "quit")
      (nn-send soc "Ok, quitting"))
     ((and (>= (string-length msg-in) 4)
	   (equal? (substring msg-in 0 4) "ping"))
      (nn-send soc (conc (current-process-id)))
      (loop (nn-recv soc)(+ count 1)))
     (else
      (mutex-lock! *current-delay-mutex*)
      (let ((current-delay *current-delay*))
	(mutex-unlock! *current-delay-mutex*)
	;; (thread-sleep! current-delay)
	(nn-send soc (conc current-delay " hello " msg-in " you waited " current-delay " seconds"))
	(loop (nn-recv soc)(if (> count 20000000)
			       0
			       (+ count 1))))))))

(define (ping-self host port #!key (return-socket #t))
  ;; send a random number along with pid and check that we get it back
  (let* ((req     (nn-socket 'req))
	 (key     "ping")
	 (success #f)
	 (keepwaiting #t)
	 (ping    (make-thread
		   (lambda ()
		     (print "ping: sending string \"" key "\", expecting " (current-process-id))
		     (nn-send req key)
		     (let ((result  (nn-recv req)))
		       (if (equal? (conc (current-process-id)) result)
			   (begin
			     (print "ping, success: received \"" result "\"")
			     (set! success #t))
			   (begin
			     (print "ping, failed: received key \"" result "\"")
			     (set! keepwaiting #f)
			     (set! success #f)))))
		   "ping"))
	 (timeout (make-thread (lambda ()
				 (let loop ((count 0))
				   (thread-sleep! 1)
				   (print "still waiting after " count " seconds...")
				   (if (and keepwaiting (< count 10))
				       (loop (+ count 1))))
				 (if keepwaiting
				     (begin
				       (print "timeout waiting for ping")
				       (thread-terminate! ping))))
			       "timeout")))
    (nn-connect req (conc "tcp://" host ":" port))
    (handle-exceptions
     exn
     (begin
       (print-call-chain)
       (print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
       (print "exn=" (condition->list exn))
       (print "ping failed to connect to " host ":" port))
     (thread-start! timeout)
     (thread-start! ping)
     (thread-join! ping)
     (if success (thread-terminate! timeout)))
    (if return-socket
	(if success req #f)
	(begin
	  (nn-close req)
	  success))))

(define *current-delay-mutex* (make-mutex))

;; update the *current-delay* value every minute or QUEUE_CHK_DELAY seconds
(thread-start! (make-thread (lambda ()
			      (let ((delay-time (string->number (or (get-environment-variable "QUEUE_CHK_DELAY") "30"))))
				(let loop ()
				  (with-input-from-pipe 
				   cmd  ;;; my query to get queue length
				   (lambda ()
				     (let* ((val       (read))
					    (droop-val (if (number? val)(piecewise-droop-calc val queuelen) #f)))
				       ;; val is number of jobs in queue. Use a linear droop of val/40
				       (mutex-lock! *current-delay-mutex*)
				       (set! *current-delay* (or droop-val 30)) ;; (/ (or droop-val 100) 50))
				       (mutex-unlock! *current-delay-mutex*)
				       (print "droop-val=" droop-val)
				       (thread-sleep! delay-time))))
				  (loop))))))

(let ((server-thread (make-thread (lambda ()(server rep)) "server")))
  (thread-start! server-thread)
  (if (ping-self (get-host-name) port)
      (begin
	(thread-join! server-thread)
	(nn-close rep))
      (print "ping failed")))

(exit)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































Deleted loadwatch/queuefeeder.scm version [b7ca858163].

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
;;======================================================================
;; Copyright 2015-2015, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

;; Queue Feeder. Use a crude droop curve to limit feeding jobs into a queue
;;               to prevent slamming the queue

;;======================================================================
;; Methodology
;;
;;   Connect to the server, the server delays the appropriate time (if 
;;   any) and then launch the task.
;;
(use nanomsg posix regex message-digest md5)

(define req   (nn-socket 'req))

;; get needed stuff from commandline
;;
(define hostport #f)
(define cmd '())

(let ((args (argv)))
  (if (> (length args) 2)
      (begin
	(set! hostport (cadr args))
	(set! cmd      (cddr args)))
      (begin
	(print "Usage: queuefeeder host:port command params ....")
	(exit))))

(nn-connect req  (conc "tcp://" hostport)) ;; xena:22022")

(define (client-send-receive soc msg)
  (nn-send soc msg)
  (nn-recv soc))

;; Generate a unique signature for this client location
;;
(define (make-signature)
  (message-digest-string (md5-primitive) 
                         (with-output-to-string
                           (lambda ()
                             (write (current-directory))))))

;; (define ((talk-to-server soc))
;;   (let loop ((cnt 200000))
;;     (let ((name (list-ref '("Matt" "Tom" "Bob" "Jill" "James" "Jane")(random 6))))
;;       ;; (print "Sending " name)
;;       ;; (print
;;       (client-send-receive req name) ;; )
;;       (if (> cnt 0)(loop (- cnt 1)))))
;;   (print (client-send-receive req "quit"))
;;   (nn-close req)
;;   (exit))
;; 

(define (get-delay signature)
  (let* ((full-msg   (client-send-receive req (conc (current-user-name) "@" (get-host-name) ":" signature))))
    (print "Got " full-msg)
    (let* ((reply-msg  (string-match "^([\\d\\.]+)\\s+(.*)$" full-msg))
	   (delay-time (if (> (length reply-msg) 2)
			   (string->number (cadr reply-msg))
			   1)) ;; fall back to one sec delay
	   (msg        (if (> (length reply-msg) 2)
			   (caddr reply-msg)
			   full-msg)))
      (values delay-time msg))))


(let ((signature (make-signature)))
  
  (thread-start! (lambda ()
		   (thread-sleep! 60)
		   (print "Give up on waiting for the server")
		   ;; (nn-close req)
		   ;; (exit)
		   ))
  (thread-join! (thread-start! (lambda ()
				 (let-values 
				  (((delay-time msg)(get-delay signature)))
				  (print "INFO: sleeping " delay-time " seconds per request of queuefeeder server")
				  (thread-sleep! delay-time)
				  (print "INFO: done waiting, now executing requested task.")))))
  (nn-close req))

(process-execute (car cmd) (cdr cmd))


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































Deleted loadwatch/testopenlava.sh version [1f61657fdf].

1
2
3
4
5
6
7
8
9
#!/bin/bash

job_order=$1
job_length=$2

echo "START: $job_order" > $job_order.log
sleep $job_length
echo "END: $job_order" >> $job_order.log

<
<
<
<
<
<
<
<
<


















Modified megatest-version.scm from [80d92d8c54] to [4c8d3d2945].

1
2
3
4
5
6
7
;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.6506)






|

1
2
3
4
5
6
7
;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.6508)

Modified mtut.scm from [8d657d6f02] to [401524b519].

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
;; given a mtutil param, return the old megatest equivalent
;;
(define (megatest-param->mtutil-param param)
  (let* ((mapping-alist (common:get-param-mapping flavor: 'switch-symbol)))
    (alist-ref (string->symbol param) mapping-alist eq? param)
    param))

(define (val->alist val)
  (let ((val-list (string-split-fields ";\\s*" val #:infix)))
    (if val-list
	(map (lambda (x)
	       (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
		 (case (length f)
		   ((0) `(,#f))  ;; null string case
		   ((1) `(,(string->symbol (car f))))
		   ((2) `(,(string->symbol (car f)) . ,(cadr f)))
		   (else f))))
	     val-list)
	'())))

(define (push-run-spec torun contour runkey spec)
  (configf:section-var-set! torun contour runkey
			    (cons spec
				  (or (configf:lookup torun contour runkey)
				      '()))))








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







263
264
265
266
267
268
269
270











271
272
273
274
275
276
277
;; given a mtutil param, return the old megatest equivalent
;;
(define (megatest-param->mtutil-param param)
  (let* ((mapping-alist (common:get-param-mapping flavor: 'switch-symbol)))
    (alist-ref (string->symbol param) mapping-alist eq? param)
    param))

(define val->alist common:val->alist)












(define (push-run-spec torun contour runkey spec)
  (configf:section-var-set! torun contour runkey
			    (cons spec
				  (or (configf:lookup torun contour runkey)
				      '()))))

545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
;;
;; Override the run start time record with sched. Usually #f is fine.
;; 
(define (create-run-pkt mtconf action area runkey target runname mode-patt 
                        tag-expr pktsdir reason contour sched dbdest append-conf
                        runtrans)
  (let* ((good-val   (lambda (inval)(and inval (string? inval)(not (string-null? inval)))))
	 (area-dat   (val->alist (or (configf:lookup mtconf "areas" area) "")))
	 (area-path  (alist-ref 'path      area-dat))
	 ;; (area-xlatr (alist-ref 'targtrans area-dat))
         ;; (xlatr-key  (if area-xlatr (string->symbol area-xlatr) #f))
         (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
			     (mapper   (if callname (hash-table-ref/default *runname-mappers* callname #f) #f)))
			;; (print "callname=" callname " runtrans=" runtrans " mapper=" mapper)
			(if (and callname







|







534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
;;
;; Override the run start time record with sched. Usually #f is fine.
;; 
(define (create-run-pkt mtconf action area runkey target runname mode-patt 
                        tag-expr pktsdir reason contour sched dbdest append-conf
                        runtrans)
  (let* ((good-val   (lambda (inval)(and inval (string? inval)(not (string-null? inval)))))
	 (area-dat   (common:val->alist (or (configf:lookup mtconf "areas" area) "")))
	 (area-path  (alist-ref 'path      area-dat))
	 ;; (area-xlatr (alist-ref 'targtrans area-dat))
         ;; (xlatr-key  (if area-xlatr (string->symbol area-xlatr) #f))
         (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
			     (mapper   (if callname (hash-table-ref/default *runname-mappers* callname #f) #f)))
			;; (print "callname=" callname " runtrans=" runtrans " mapper=" mapper)
			(if (and callname
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
			(keyparts   (string-split key ":")) ;; contour:ruletype:action:optional
			(contour    (car keyparts))
			(len-key    (length keyparts))
			(ruletype   (if (> len-key 1)(cadr keyparts) #f))
			(action     (if (> len-key 2)(caddr keyparts) #f))
			(optional   (if (> len-key 3)(cadddr keyparts) #f))
			;; (val-list   (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params
			(val-alist  (val->alist val))
			(runname    (make-runname "" ""))
			(runtrans   (alist-ref 'runtrans val-alist))

			;; these may or may not be defined and not all are used in each handler type in the case below
			(run-name   (alist-ref 'run-name val-alist))
			(target     (alist-ref 'target   val-alist))
			(crontab    (alist-ref 'cron     val-alist))







|







658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
			(keyparts   (string-split key ":")) ;; contour:ruletype:action:optional
			(contour    (car keyparts))
			(len-key    (length keyparts))
			(ruletype   (if (> len-key 1)(cadr keyparts) #f))
			(action     (if (> len-key 2)(caddr keyparts) #f))
			(optional   (if (> len-key 3)(cadddr keyparts) #f))
			;; (val-list   (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params
			(val-alist  (common:val->alist val))
			(runname    (make-runname "" ""))
			(runtrans   (alist-ref 'runtrans val-alist))

			;; these may or may not be defined and not all are used in each handler type in the case below
			(run-name   (alist-ref 'run-name val-alist))
			(target     (alist-ref 'target   val-alist))
			(crontab    (alist-ref 'cron     val-alist))
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
	       keydats))) ;; sense rules
	  (hash-table-keys rgconf))
	 
	 ;; now have to run populated
	 (for-each
	  (lambda (contour)
	    (let* ((cval       (or (configf:lookup mtconf "contours" contour) ""))
		   (cval-alist (val->alist cval))                     ;; BEWARE ... NOT the same val-alist as above!
		   (areas      (val-alist->areas cval-alist))
		   (selector   (alist-ref 'selector cval-alist))
		   (mode-tag   (and selector (string-split-fields "/" selector #:infix)))
		   (mode-patt  (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)))
		   (tag-expr   (and mode-tag (if (null? mode-tag) #f (car mode-tag)))))
	      (print "contour: " contour " areas=" areas " cval=" cval)
	      (for-each
	       (lambda (runkeydatset) 
		 ;; (print "runkeydatset: ")(pp runkeydatset)
		 (let ((runkey     (car runkeydatset))
		       (runkeydats (cadr runkeydatset)))
		   (for-each
		    (lambda (runkeydat)
		      (for-each
		       (lambda (area)
			 (if (area-allowed? area areas runkey contour mode-patt) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...)
                             (let* ((aval       (or (configf:lookup mtconf "areas" area) ""))
                                    (aval-alist (val->alist aval))
                                    (runname    (alist-ref 'runname runkeydat))
                                    (runtrans   (alist-ref 'runtrans runkeydat))
                                    
                                    (reason     (alist-ref 'message runkeydat))
                                    (sched      (alist-ref 'sched   runkeydat))
                                    (action     (alist-ref 'action  runkeydat))
                                    (dbdest     (alist-ref 'dbdest  runkeydat))







|

















|







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
	       keydats))) ;; sense rules
	  (hash-table-keys rgconf))
	 
	 ;; now have to run populated
	 (for-each
	  (lambda (contour)
	    (let* ((cval       (or (configf:lookup mtconf "contours" contour) ""))
		   (cval-alist (common:val->alist cval))                     ;; BEWARE ... NOT the same val-alist as above!
		   (areas      (val-alist->areas cval-alist))
		   (selector   (alist-ref 'selector cval-alist))
		   (mode-tag   (and selector (string-split-fields "/" selector #:infix)))
		   (mode-patt  (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)))
		   (tag-expr   (and mode-tag (if (null? mode-tag) #f (car mode-tag)))))
	      (print "contour: " contour " areas=" areas " cval=" cval)
	      (for-each
	       (lambda (runkeydatset) 
		 ;; (print "runkeydatset: ")(pp runkeydatset)
		 (let ((runkey     (car runkeydatset))
		       (runkeydats (cadr runkeydatset)))
		   (for-each
		    (lambda (runkeydat)
		      (for-each
		       (lambda (area)
			 (if (area-allowed? area areas runkey contour mode-patt) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...)
                             (let* ((aval       (or (configf:lookup mtconf "areas" area) ""))
                                    (aval-alist (common:val->alist aval))
                                    (runname    (alist-ref 'runname runkeydat))
                                    (runtrans   (alist-ref 'runtrans runkeydat))
                                    
                                    (reason     (alist-ref 'message runkeydat))
                                    (sched      (alist-ref 'sched   runkeydat))
                                    (action     (alist-ref 'action  runkeydat))
                                    (dbdest     (alist-ref 'dbdest  runkeydat))
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
(if *action*
    (case (string->symbol *action*)
      ((run remove rerun set-ss archive kill list)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (area      (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section
	      (areasec   (if area (configf:lookup mtconf "areas" area) #f))
	      (areadat   (if areasec (val->alist areasec) #f))
	      (area-path (if areadat (alist-ref 'path areadat) #f))
	      (pktsdirs  (configf:lookup mtconf "setup" "pktsdirs"))
	      (pktsdir   (if pktsdirs (car (string-split pktsdirs " ")) #f))
	      (adjargs   (hash-table-copy args:arg-hash))
	      (new-ss    (args:get-arg "-new")))
	 ;; check a few things
	 (cond







|







1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
(if *action*
    (case (string->symbol *action*)
      ((run remove rerun set-ss archive kill list)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (area      (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section
	      (areasec   (if area (configf:lookup mtconf "areas" area) #f))
	      (areadat   (if areasec (common:val->alist areasec) #f))
	      (area-path (if areadat (alist-ref 'path areadat) #f))
	      (pktsdirs  (configf:lookup mtconf "setup" "pktsdirs"))
	      (pktsdir   (if pktsdirs (car (string-split pktsdirs " ")) #f))
	      (adjargs   (hash-table-copy args:arg-hash))
	      (new-ss    (args:get-arg "-new")))
	 ;; check a few things
	 (cond

Added oldsrc/multi-dboard.scm version [de11d53f46].



































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
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
;;======================================================================
;; Copyright 2006-2013, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

(use format numbers sql-de-lite srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)

(declare (uses margs))
(declare (uses megatest-version))
(declare (uses gutils))
(declare (uses tree))
(declare (uses configf))
(declare (uses portlogger))
(declare (uses keys))
(declare (uses common))

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

(define help (conc 
	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2011

Usage: dashboard [options]
  -h                : this help
  -group groupname  : display this group of areas
  -test testid      : control test identified by testid
  -guimonitor       : control panel for runs

Misc
  -rows N         : set number of rows
"))

;; process args
(define remargs (args:get-args 
		 (argv)
		 (list  "-group" ;; display this group of areas
			"-debug"
			) 
		 (list  "-h"
			"-v"
			"-q"
			)
		 args:arg-hash
		 0))

(if (args:get-arg "-h")
    (begin
      (print help)
      (exit)))

;; (if (args:get-arg "-host")
;;     (begin
;;       (set! (common:get-remote remote) (string-split (args:get-arg "-host" ":")))
;;       (client:launch))
;;     (client:launch))

(define *runremote* #f)
(define *windows* (make-hash-table))
(define *changed-main* (make-hash-table)) ;; set path/... => #t
(define *changed-mutex* (make-mutex))     ;; use for all incoming change requests
(define *searchpatts*   (make-hash-table))

(debug:setup)

(define *tim* (iup:timer))
(define *ord* #f)

(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")

(define (message-window msg)
  (iup:show
   (iup:dialog
    (iup:vbox 
     (iup:label msg #:margin "40x40")))))

(define (iuplistbox-fill-list lb items . default)
  (let ((i 1)
	(selected-item (if (null? default) #f (car default))))
    (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
    (for-each (lambda (item)
		(iup:attribute-set! lb (number->string i) item)
		(if selected-item
		    (if (equal? selected-item item)
			(iup:attribute-set! lb "VALUE" item))) ;; (number->string i))))
		(set! i (+ i 1)))
	      items)
    i))

(define (pad-list l n)(append l (make-list (- n (length l)))))


(define (mkstr . x)
  (string-intersperse (map conc x) ","))

(define (update-search x val)
  (hash-table-set! *searchpatts* x val))


;;======================================================================
;; R E C O R D S
;;======================================================================

;; NOTE: Consider switching to defstruct.

;; data for an area (regression or testsuite)
;;
(define-record areadat
  name               ;; area name
  path               ;; mt run area home
  configdat          ;; megatest config
  denoise            ;; focal point for not putting out same messages over and over
  client-signature   ;; key for client-server conversation
  remote             ;; hash of all the client side connnections
  run-keys           ;; target keys for this area
  runs               ;; used in dashboard, hash of run-ids -> rundat
  read-only          ;; can I write to this area?
  monitordb          ;; db handle for monitor.db
  maindb             ;; db handle for main.db
  )

;; rundat, basic run data
;;
(define-record rundat
  id                 ;; the run-id
  target             ;; val1/val2 ... corrosponding to run-keys in areadat
  runname
  state              ;; state of the run, symbol 
  status             ;; status of the run, symbol
  event-time         ;; when the run was initiated
  tests              ;; hash of test-id -> testdat, QUESTION: separate by run-id?
  db                 ;; db handle
  )

;; testdat, basic test data
(define-record testdat
  run-id             ;; what run is this from
  id                 ;; test id
  testname           ;; test name
  itempath           ;; item path
  state              ;; test state, symbol
  status             ;; test status, symbol
  event-time         ;; when the test started
  duration           ;; how long the test took
  )

;; general data for the dboard application
;;
(define-record data
  cfgdat             ;; data from ~/.megatest/<group>.dat
  areas              ;; hash of areaname -> area-rec
  current-window-id  ;; 
  current-tab-id     ;; 
  update-needed      ;; flag to indicate that the tab pointed to by current tab id needs refreshing immediately
  tabs               ;; hash of tab-id -> areaname (??) should be of type "tab"
  )

;; all the components of an area display, all fits into a tab but
;; parts may be swapped in/out as needed
;;
(define-record tab
  tree
  matrix    ;; the spreadsheet 
  areadat   ;; the one-structure (one day dbstruct will be put in here)
  view-path ;; <target/path>/<runname>/...
  view-type ;; standard, etc.
  controls  ;; the controls
  data      ;; all the data kept in sync with db
  filters   ;; user filters, alist name -> filter record, eventually store these in ~/.megatest/<group>.dat?
  run-id    ;; the current run-id
  test-ids  ;; the current test id hash, run-id => test-id
  command   ;; the command from the entry field
  headers   ;; hash of header  -> colnum
  rows      ;; hash of rowname -> rownum
  )

(define-record filter
  target    ;; hash of widgets for the target
  runname   ;; the runname widget
  testpatt  ;; the testpatt widget
  )

;;======================================================================
;; D B
;;======================================================================

;; These are all using sql-de-lite and independent of area so cannot use stuff 
;; from db.scm

;; NB// run-id=#f => return dbdir only
;;
(define (areadb:dbfile-path areadat run-id)
  (let* ((cfgdat  (areadat-configdat areadat))
	 (dbdir   (or (configf:lookup cfgdat "setup" "dbdir")
		      (conc (configf:lookup cfgdat "setup" "linktree") "/.db")))
	 (fname   (if run-id
		      (case run-id
			((-1) "monitor.db")
			((0) "main.db")
			(else (conc run-id ".db")))
		      #f)))
    (handle-exceptions
     exn
     (begin
       (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
       (exit 1))
     (if (not (directory? dbdir))(create-directory dbdir #t)))
    (if fname
	(conc dbdir "/" fname)
	dbdir)))

;; -1 => monitor.db
;;  0 => main.db
;; >1 => <run-id>.db
;;
(define (areadb:open areadat run-id)
  (let* ((runs   (areadat-runs areadat))
	 (rundat (if (> run-id 0) ;; it is a run
		     (hash-table-ref/default runs run-id #f)
		     #f))
	 (db     (case run-id ;; if already opened, get the db and return it
		   ((-1) (areadat-monitordb areadat))
		   ((0)  (areadat-maindb    areadat))
		   (else (if rundat
			     (rundat-db rundat)
			     #f)))))
    (if db
	db ;; merely return the already opened db
	(let* ((dbfile (areadb:dbfile-path areadat run-id)) ;; not already opened, so open it
	       (db     (if (file-exists? dbfile)
			   (open-database dbfile)
			   (begin
			     (debug:print-error 0 *default-log-port* "I was asked to open " dbfile ", but file does not exist or is not readable.")
			     #f))))
	  (case run-id
	    ((-1)(areadat-monitordb-set! areadat db))
	    ((0) (areadat-maindb-set!    areadat db))
	    (else (rundat-db-set!        rundat  db)))
	  db))))

;; populate the areadat tests info, does NOT fill the tests data itself unless asked
;;
(define (areadb:populate-run-info areadat)
  (let* ((runs   (or (areadat-runs areadat) (make-hash-table)))
	 (keys   (areadat-run-keys areadat))
	 (maindb (areadb:open areadat 0)))
    (if maindb
	(query (for-each-row (lambda (row)
			       (let ((id  (list-ref row 0))
				     (dat (apply make-rundat (append row (list #f #f))))) ;; add placeholders for tests and db
				 (print row)
				 (hash-table-set! runs id dat))))
	       (sql maindb (conc "SELECT id,"
				 (string-intersperse keys "||'/'||")
				 ",runname,state,status,event_time FROM runs WHERE state != 'deleted';")))
	(debug:print-error 0 *default-log-port* "no main.db found at "  (areadb:dbfile-path areadat 0)))
    areadat))

;; given an areadat and target/runname patt fill up runs data
;;
;; ?????/

;; given a list of run-ids refresh/retrieve runs data into areadat
;;
(define (areadb:fill-tests areadat #!key (run-ids #f))
  (let* ((runs   (or (areadat-runs areadat) (make-hash-table))))
    (for-each
     (lambda (run-id)
       (let* ((rundat (hash-table-ref/default runs run-id #f))
	      (tests  (if (and rundat
			       (rundat-tests rundat)) ;; re-use existing hash table?
			  (rundat-tests rundat)
			  (let ((ht (make-hash-table)))
			    (rundat-tests-set! rundat ht)
			    ht)))
	      (rundb  (areadb:open areadat run-id)))
	 (query (for-each-row (lambda (row)
				(let* ((id         (list-ref row 0))
				       (testname   (list-ref row 1))
				       (itempath   (list-ref row 2))
				       (state      (list-ref row 3))
				       (status     (list-ref row 4))
				       (eventtim   (list-ref row 5))
				       (duration   (list-ref row 6)))
				  (hash-table-set! tests id
						   (make-testdat run-id id testname itempath state status eventtim duration)))))
		(sql rundb "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE state != 'DELETED';"))))
     (or run-ids (hash-table-keys runs)))
    areadat))
    

;; initialize and refresh data
;;		
(define (dboard:general-updater con port)
  (for-each
   (lambda (window-id)
     ;; (print "Processing for window-id " window-id)
     (let* ((window-dat     (hash-table-ref *windows* window-id))
	    (areas          (data-areas     window-dat))
	    ;; (keys           (areadat-run-keys area-dat))
	    (tabs           (data-tabs      window-dat))
	    (tab-ids        (hash-table-keys tabs))
	    (current-tab    (if (null? tab-ids)
				#f
				(hash-table-ref tabs (car tab-ids))))
	    (current-tree   (if (null? tab-ids) #f (tab-tree   current-tab)))
	    (current-node   (if (null? tab-ids) 0  (string->number (iup:attribute current-tree "VALUE"))))
	    (current-path   (if (eq? current-node 0)
				"Areas"
				(string-intersperse (tree:node->path current-tree current-node) "/")))
	    (current-matrix (if (null? tab-ids) #f (tab-matrix current-tab)))
	    (seen-nodes     (make-hash-table))
	    (path-changed   (if current-tab
				(equal? current-path (tab-view-path current-tab))
				#t)))
       ;; (debug:print-info 0 *default-log-port* "Current path: " current-path)
       ;; now for each area in the window gather the data
       (if path-changed
	   (begin
	     (debug:print-info 0 *default-log-port* "clearing matrix - path changed")
	     (dboard:clear-matrix current-tab)))
       (for-each
	(lambda (area-name)
	  ;; (print "Processing for area-name " area-name)
	  (let* ((area-dat  (hash-table-ref areas area-name))
		 (area-path (areadat-path   area-dat))
		 (runs      (areadat-runs   area-dat)))
	    (if (hash-table-ref/default *changed-main* area-path 'processed)
		(begin
		  (print "Processing " area-dat " for area-name " area-name)
		  (hash-table-set! *changed-main* area-path #f)
		  (areadb:populate-run-info area-dat)
		  (for-each 
		   (lambda (run-id)
		     (let* ((run     (hash-table-ref runs run-id))
			    (target  (rundat-target run))
			    (runname (rundat-runname run)))
		       (if current-tree
			   (let* ((partial-path (append (string-split target "/")(list runname)))
				  (full-path    (cons area-name partial-path)))
			     (if (not (hash-table-exists? seen-nodes full-path))
				 (begin
				   (print "INFO: Adding node " partial-path " to section " area-name)
				   (tree:add-node current-tree "Areas" full-path)
				   (areadb:fill-tests area-dat run-ids: (list run-id))))
				   (hash-table-set! seen-nodes full-path #t)))))
		   (hash-table-keys runs))))
	    (if (or (equal? "Areas" current-path)
		    (string-match (conc "^Areas/" area-name "(|\\/.*)$") current-path))
		(dboard:redraw-area area-name area-dat current-tab current-matrix current-path))))
	(hash-table-keys areas))))
   (hash-table-keys *windows*)))

;;======================================================================
;; D A S H B O A R D   D B 
;;======================================================================

;; All moved to common.scm		

;;======================================================================
;; T R E E 
;;======================================================================

;; <area> - <target - ... > - <runname> - <test> - <itempath - ...>

(define (dashboard:tree-browser data adat window-id)
  ;; (iup:split
  (let* ((tb      (iup:treebox
		   #:value 0
		   #:title "Areas"
		   #:expand "YES"
		   #:addexpanded "NO"
		   #:selection-cb
		   (lambda (obj id state)
		     ;; (print "obj: " obj ", id: " id ", state: " state)
		     (let* ((tree-path (tree:node->path obj id))
			    (area      (car tree-path))
			    (areadat-path (cdr tree-path)))
		       #f
		       ;; (test-id  (tree-path->test-id (cdr run-path))))
		       ;; (if test-id
		       ;;    (hash-table-set! (dboard:data-curr-test-ids *data*)
		       ;;		     window-id test-id))
		       ;; (print "path: " (tree:node->path obj id) " test-id: " test-id))))))
		       )))))
    ;; (iup:attribute-set! tb "VALUE" "0")
    ;; (iup:attribute-set! tb "NAME" "Runs")
    ;; (iup:attribute-set! tb "ADDEXPANDED" "NO")
    ;; (dboard:data-tests-tree-set! *data* tb)
    tb))

;;======================================================================
;; M A I N   M A T R I X
;;======================================================================

;; General displayer
;;
(define (dashboard:main-matrix data adat window-id)
  (let* (;; (tab-dat         (areadat-
	 (view-matrix     (iup:matrix
			   ;; (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f))
			   #:expand "YES"
			   ;; #:fittosize "YES"
			   #:resizematrix "YES"
			   #:scrollbar "YES"
			   #:numcol 100
			   #:numlin 100
			   #:numcol-visible 3
			   #:numlin-visible 20
			   #:click-cb (lambda (obj lin col status)
					(print "obj: " obj " lin: " lin " col: " col " status: " status " value: " (iup:attribute obj "VALUE"))))))
    
    ;; (iup:attribute-set! view-matrix "RESIZEMATRIX" "YES")
    (iup:attribute-set! view-matrix "WIDTH0" "100")
    ;; (dboard:data-runs-matrix-set! *data* runs-matrix)
    ;; (iup:hbox
    ;;  (iup:frame 
    ;;   #:title "Runs browser"
    ;;   (iup:vbox
    view-matrix))

;;======================================================================
;; A R E A S
;;======================================================================

(define (dashboard:init-area data area-name apath)
  (let* ((mtconf      (dboard:read-mtconf apath))
	 (area-dat    (let ((ad (make-areadat
				 area-name ;; area name
				 apath     ;; path to area
				 ;; 'http     ;; transport
				 mtconf    ;; megatest.config
				 (make-hash-table) ;; denoise hash
				 #f        ;; client-signature
				 #f        ;; remote connections
				 (keys:config-get-fields mtconf) ;; run keys
				 (make-hash-table) ;; run-id -> (hash of test-ids => dat)
				 (and (file-exists? apath)(file-write-access? apath)) ;; read-only
				 #f
				 #f
				 )))
			(hash-table-set! (data-areas data) area-name ad)
			ad)))
    area-dat))

;; given the keys for an area and a path from the tree browser
;; return the level: areas area runs run tests test
;;
(define (dboard:get-view-type keys current-path)
  (let* ((path-parts (string-split current-path "/"))
	 (path-len   (length path-parts)))
    (cond
     ((equal? current-path "Areas")     'areas)
     ((eq? path-len 2)                  'area)
     ((<= (+ (length keys) 2) path-len) 'runs)
     (else                              'run))))

(define (dboard:clear-matrix tab)
  (if tab
      (begin
	(iup:attribute-set! (tab-matrix tab) "CLEARVALUE" "ALL")
	(tab-headers-set! tab (make-hash-table))
	(tab-rows-set!    tab (make-hash-table)))))

;; full redraw of a given area
;;
(define (dboard:redraw-area area-name area-dat tab-dat current-matrix current-path)
  (let* ((keys      (areadat-run-keys area-dat))
	 (runs      (areadat-runs     area-dat))
	 (headers   (tab-headers   tab-dat))
	 (rows      (tab-rows      tab-dat))
	 (used-cols (hash-table-values headers))
	 (used-rows (hash-table-values rows))
	 (touched   (make-hash-table)) ;; (vector row col) ==> true, touched cell
	 (view-type (dboard:get-view-type keys current-path))
	 (changed   #f)
	 (state-statuses  (list "PASS" "FAIL" "WARN" "CHECK" "SKIP" "RUNNING" "LAUNCHED")))
    ;; (debug:print 0 *default-log-port* "current-matrix=" current-matrix)
    (case view-type
      ((areas) ;; find row for this area, if not found, create new entry
       (let* ((curr-rownum (hash-table-ref/default rows area-name #f))
	      (next-rownum (+ (apply max (cons 0 used-rows)) 1))
	      (rownum      (or curr-rownum next-rownum))
	      (coord       (conc rownum ":0")))
	 (if (not curr-rownum)(hash-table-set! rows area-name rownum))
	 (if (not (equal? (iup:attribute current-matrix coord) area-name))
	     (begin
	       (let loop ((hed  (car state-statuses))
			  (tal  (cdr state-statuses))
			  (count 1))
		 (if (not (equal? (iup:attribute current-matrix (conc "0:" count)) hed))
		     (iup:attribute-set! current-matrix (conc "0:" count) hed))
		 (iup:attribute-set! current-matrix (conc rownum ":" count) "0")
		 (if (not (null? tal))
		     (loop (car tal)(cdr tal)(+ count 1))))
	       (debug:print-info 0 *default-log-port* "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name)
	       (iup:attribute-set! current-matrix coord area-name)
	       (set! changed #t))))))
    (if changed (iup:attribute-set! current-matrix "REDRAW" "ALL"))))
	     

       
   ;; (dboard:clear-matrix current-matrix used-cols used-rows touched) ;; clear all
    
	
  
;;======================================================================
;; D A S H B O A R D
;;======================================================================

(define (dashboard:area-panel aname data window-id)
  (let* ((apath      (configf:lookup (data-cfgdat data) aname "path")) ;;  (hash-table-ref (dboard:data-cfgdat data) area-name))
	 ;;          (hash-table-ref (dboard:data-cfgdat data) aname))
	 (area-dat   (dashboard:init-area data aname apath))
	 (tb         (dashboard:tree-browser data area-dat window-id)) ;; (dboard:areas-tree-browser data)
	 (ad         (dashboard:main-matrix  data area-dat window-id))
	 (areas      (data-areas data))
	 (dboard-dat (make-tab
		      #f           ;; tree
		      #f           ;; matrix
		      area-dat     ;;
		      #f           ;; view path
		      'default     ;; view type
		      #f           ;; controls
		      (make-hash-table) ;; cached data? not sure how to use this yet :)
		      #f           ;; filters
		      #f           ;; the run-id
		      (make-hash-table) ;; run-id -> test-id, for current test id
		      ""
		      (make-hash-table) ;; headername -> colnum
		      (make-hash-table) ;; rowname    -> rownum
		      )))
    (hash-table-set! (data-areas data) aname area-dat) ;; dboard-dat)
    (hash-table-set! (data-tabs data) window-id dboard-dat)
    (tab-tree-set!   dboard-dat tb)
    (tab-matrix-set! dboard-dat ad)
    (iup:split
     #:value 200
     tb ad)))


;; Main Panel
;;
(define (dashboard:main-panel data window-id)
  (iup:dialog
   #:title "Megatest Control Panel"
;;   #:menu (dcommon:main-menu data)
   #:shrink "YES"
   (iup:vbox
    (let* ((area-names  (hash-table-keys (data-cfgdat data)))
	   (area-panels (map (lambda (aname)
			       (dashboard:area-panel aname data window-id))
			     area-names))
	   (tabtop      (apply iup:tabs  
			       #:tabchangepos-cb (lambda (obj curr prev)
						   (data-current-tab-id-set! data curr)
						   (data-update-needed-set!  data #t)
						   (print "Tab is: " curr ", prev was " prev))
			       area-panels))
	   (tabs     (data-tabs data)))
      (if (not (null? area-names))
	  (let loop ((index 0)
		     (hed   (car area-names))
		     (tal   (cdr area-names)))
	    ;; (hash-table-set! tabs index hed)
	    (debug:print 0 *default-log-port* "Adding area " hed " with index " index " to dashboard")
	    (iup:attribute-set! tabtop (conc "TABTITLE" index) hed)
	    (if (not (null? tal))
		(loop (+ index 1)(car tal)(cdr tal)))))
      tabtop))))


;;======================================================================
;; N A N O M S G   S E R V E R
;;======================================================================

(define (dboard:server-service soc port)
  (print "server starting")
  (let loop ((msg-in (nn-recv soc))
	     (count  0))
    (if (eq? 0 (modulo count 1000))
	(print "server received: " msg-in ", count=" count))
    (cond
     ;;
     ;; quit
     ;;
     ((equal? msg-in "quit")
      (nn-send soc "Ok, quitting"))
     ;;
     ;; ping
     ;;
     ((and (>= (string-length msg-in) 4)
	   (equal? (substring msg-in 0 4) "ping"))
      (nn-send soc (conc (current-process-id)))
      (loop (nn-recv soc)(+ count 1)))
     ;;
     ;; main changed
     ;;
     ((and (>= (string-length msg-in) 4)
	   (equal? (substring msg-in 0 4) "main"))
      (let ((parts (string-split msg-in " ")))
	(hash-table-set! *changed-main* (cadr parts) #t)
	(nn-send soc "got it!")))
     ;;
     ;; ??
     ;;
     (else
      (nn-send soc "hello " msg-in " you got to the else clause!")))
    (loop (nn-recv soc)(if (> count 20000000)
			   0
			   (+ count 1)))))

(define (dboard:one-time-ping-receive soc port)
  (let ((msg-in (nn-recv soc)))
    (if (and (>= (string-length msg-in) 4)
	     (equal? (substring msg-in 0 4) "ping"))
	(nn-send soc (conc (current-process-id))))))

(define (dboard:server-start given-port #!key (num-tries 200))
  (let* ((rep (nn-socket 'rep))
	 (port (or given-port  (portlogger:main "find")))
	 (con (conc "tcp://*:" port)))
    ;; register this connect here ....
    (nn-bind rep con)
    (thread-start! 
     (make-thread (lambda ()
		    (dboard:one-time-ping-receive rep port))
		  "one time receive thread"))
    (if (dboard:ping-self "localhost" port)
	(begin
	  (print "INFO: dashboard nanomsg server started on " port)
	  (values rep port))
	(begin
	  (print "WARNING: couldn't create server on port " port)
	  (portlogger:main "set" "failed")
	  (if (> num-tries 0)
	      (dboard:server-start #f (- num-tries 1))
	      (begin
		(print "ERROR: failed to start nanomsg server")
		(values #f #f)))))))

(define (dboard:server-close con port)
  (nn-close con)
  (portlogger:main "set" port "released"))

(define (dboard:ping-self host port #!key (return-socket #t))
  ;; send a random number along with pid and check that we get it back
  (let* ((req     (nn-socket 'req))
	 (key     "ping")
	 (success #f)
	 (keepwaiting #t)
	 (ping    (make-thread
		   (lambda ()
		     (print "ping: sending string \"" key "\", expecting " (current-process-id))
		     (nn-send req key)
		     (let ((result  (nn-recv req)))
		       (if (equal? (conc (current-process-id)) result)
			   (begin
			     (print "ping, success: received \"" result "\"")
			     (set! success #t))
			   (begin
			     (print "ping, failed: received key \"" result "\"")
			     (set! keepwaiting #f)
			     (set! success #f)))))
		   "ping"))
	 (timeout (make-thread (lambda ()
				 (let loop ((count 0))
				   (thread-sleep! 1)
				   (print "still waiting after " count " seconds...")
				   (if (and keepwaiting (< count 10))
				       (loop (+ count 1))))
				 (if keepwaiting
				     (begin
				       (print "timeout waiting for ping")
				       (thread-terminate! ping))))
			       "timeout")))
    (nn-connect req (conc "tcp://" host ":" port))
    (handle-exceptions
     exn
     (begin
       (print-call-chain)
       (print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
       (print "exn=" (condition->list exn))
       (print "ping failed to connect to " host ":" port))
     (thread-start! timeout)
     (thread-start! ping)
     (thread-join! ping)
     (if success (thread-terminate! timeout)))
    (if return-socket
	(if success req #f)
	(begin
	  (nn-close req)
	  success))))

;;======================================================================
;; C O N F I G U R A T I O N 
;;======================================================================

;; Get the configuration file for a group name, if the group name is "default" and it doesn't 
;; exist, create it and add the current path if it contains megatest.config
;;
(define (dboard:get-config group-name)
  (let* ((fname (conc (getenv "HOME") "/.megatest/" group-name ".dat")))
    (if (file-exists? fname)
	(read-config fname (make-hash-table) #t)
	(if (dboard:create-config fname)
	    (dboard:get-config group-name)
	    (make-hash-table)))))

(define (dboard:create-config fname)
  ;; (handle-exceptions
  ;;  exn
  ;;  
  ;;  #f ;; failed to create - just give up
   (let* ((dirname       (pathname-directory fname))
	  (file-name     (pathname-strip-directory fname))
	  (curr-mtcfgdat (find-config "megatest.config"
				      toppath: (or (get-environment-variable "MT_RUN_AREA_HOME")(current-directory))))
	  (curr-mtcfg    (if (and curr-mtcfgdat (not (null? curr-mtcfgdat)))(cadr curr-mtcfgdat) #f))
	  (curr-mtpath   (if curr-mtcfg (car curr-mtcfgdat) #f)))
     (if curr-mtpath
	 (begin
	   (debug:print-info 0 *default-log-port* "Creating config file " fname)
	   (if (not (file-exists? dirname))
	       (create-directory dirname #t))
	   (with-output-to-file fname
	     (lambda ()
	       (let ((aname (pathname-strip-directory curr-mtpath)))
		 (print "[" aname "]")
		 (print  "path " curr-mtpath))))
	   #t)
	 (begin
	   (debug:print-info 0 *default-log-port* "Need to create a config but no megatest.config found: " curr-mtcfgdat)
	   #f))))
;; )

(define (dboard:read-mtconf apath)
  (let* ((mtconffile  (conc apath "/megatest.config")))
    (call-with-environment-variables
     (list (cons "MT_RUN_AREA_HOME" apath))
     (lambda ()
       (read-config mtconffile (make-hash-table) #f)) ;; megatest.config
     )))
	 

;;======================================================================
;; G U I   S T U F F 
;;======================================================================

;;; main. Theoretically could have multiple windows (each with a group of tags, thus window-id
;;;
(define (dboard:make-window window-id)
  (let* (;; (window-id 0)
	 (groupn    (or (args:get-arg "-group") "default"))
	 (cfgdat    (dboard:get-config groupn))
	 ;; (cfgdat    (if (file-exists? cfname)(read-config cfname (make-hash-table) #t)(make-hash-table)))
	 (data      (make-data
		     cfgdat ;; this is the data from ~/.megatest for the selected group
		     (make-hash-table) ;; areaname -> area-rec
		     0                 ;; current window id
		     0                 ;; current tab id
		     #f                ;; redraw needed for current tab id
		     (make-hash-table) ;; tab-id -> areaname
		     )))
    (hash-table-set! *windows* window-id data)
    (iup:show (dashboard:main-panel data window-id))
    (iup:main-loop)))

;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))

(define (main)
  (let-values 
      (((con port)(dboard:server-start #f)))
    (let ((portnum   (if (string? port)(string->number port) port)))
      ;; got here, monitor/dashboard was started
      (mddb:register-dashboard portnum)
      (thread-start! (make-thread (lambda ()(dboard:server-service con portnum)) "server service"))
      (thread-start! (make-thread (lambda ()
				    (let loop ()
				      (dboard:general-updater con portnum)
				      (thread-sleep! 1)
				      (loop))) "general updater"))
      (dboard:make-window 0)
      (mddb:unregister-dashboard (get-host-name) portnum)
      (dboard:server-close con port))))

Added oldsrc/nmsg-transport.scm version [b30844cb1a].













































































































































































































































































































































































































































































































































































































































































































































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

;; Copyright 2006-2012, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

(require-extension (srfi 18) extras tcp s11n)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
(import (prefix sqlite3 sqlite3:))

;; (use nanomsg)

(declare (unit nmsg-transport))

(declare (uses common))
(declare (uses db))
(declare (uses tests))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(declare (uses server))

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

;; Transition to pub --> sub with pull <-- push
;;
;;   1. client sends request to server via push to the pull port
;;   2. server puts request in queue or processes immediately as appropriate
;;   3. server puts responses from completed requests into pub port 
;;
;; TODO
;;
;; Done Tested
;; [x]  [ ]    1. Add columns pullport pubport to servers table
;; [x]  [ ]    2. Add rm of monitor.db if older than 11/12/2012 
;; [x]  [ ]    3. Add create of pullport and pubport with finding of available ports
;; [x]  [ ]    4. Add client compose of request
;; [x]  [ ]        - name of client: testname/itempath-test_id-hostname 
;; [x]  [ ]        - name of request: callname, params
;; [x]  [ ]        - request key: f(clientname, callname, params)
;; [x]  [ ]    5. Add processing of subscription hits
;; [x]  [ ]        - done when get key 
;; [x]  [ ]        - return results
;; [x]  [ ]    6. Add timeout processing
;; [x]  [ ]        - after 60 seconds
;; [ ]  [ ]            i. check server alive, connect to new if necessary
;; [ ]  [ ]           ii. resend request
;; [ ]  [ ]    7. Turn self ping back on

(define (nmsg-transport:make-server-url hostport #!key (bindall #f))
  (if (not hostport)
      #f
      (conc "tcp://" (if bindall "*" (car hostport)) ":" (cadr hostport))))

(define *server-loop-heart-beat* (current-seconds))
(define *heartbeat-mutex* (make-mutex))

;;======================================================================
;; S E R V E R
;;======================================================================

(define (nmsg-transport:run dbstruct hostn run-id server-id #!key (retrynum 1000))
  (debug:print 2 *default-log-port* "Attempting to start the server ...")
  (let* ((start-port      (portlogger:open-run-close portlogger:find-port))
	 (server-thread   (make-thread (lambda ()
					 (nmsg-transport:try-start-server dbstruct run-id start-port server-id))
				       "server thread"))
	 (tdbdat          (tasks:open-db)))
    (thread-start! server-thread)
    (thread-sleep! 0.1)
    (if (nmsg-transport:ping hostn start-port timeout: 2 expected-key: (current-process-id))
	(let ((interface (if (equal? hostn "-")(get-host-name) hostn)))
	  (tasks:server-set-interface-port (db:delay-if-busy tdbdat) server-id interface start-port)
	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
	  (set! *server-info* (list hostn start-port)) ;; probably not needed anymore? currently used by keep-running
	  (thread-sleep! 3) ;; give some margin for queries to complete before switching from file based access to server based access
	  ;; (set! *inmemdb*  dbstruct)
	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
	  (thread-start! (make-thread
			  (lambda ()(nmsg-transport:keep-running server-id run-id))
			  "keep running"))
	  (thread-join! server-thread))
	(if (> retrynum 0)
	    (begin
	      (debug:print 0 *default-log-port* "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.")
	      (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature")
	      (portlogger:open-run-close portlogger:set-failed start-port)
	      (nmsg-transport:run dbstruct hostn run-id server-id))
	    (begin
	      (debug:print-error 0 *default-log-port* "could not find an open port to start server on. Giving up")
	      (exit 1))))))

(define (nmsg-transport:try-start-server dbstruct run-id portnum server-id)
  (let ((repsoc (nn-socket 'rep)))
    (nn-bind repsoc (conc "tcp://*:" portnum))
    (let loop ((msg-in (nn-recv repsoc)))
      (let* ((dat    (db:string->obj msg-in transport: 'nmsg)))
	(debug:print 0 *default-log-port* "server, received: " dat)
	(let ((result (api:execute-requests dbstruct dat)))
	  (debug:print 0 *default-log-port* "server, sending: " result)
	  (nn-send repsoc (db:obj->string result  transport: 'nmsg)))
	(loop (nn-recv repsoc))))))

;; all routes though here end in exit ...
;;
(define (nmsg-transport:launch run-id)
  (let* ((tdbdat   (tasks:open-db))
	 (dbstruct (db:setup run-id))
	 (hostn    (or (args:get-arg "-server") "-")))
    (set! *run-id*   run-id)
    (set! *inmemdb* dbstruct)
    ;; with nbfake daemonize isn't really needed
    ;;
    ;; (if (args:get-arg "-daemonize")
    ;;     (begin
    ;;       (daemon:ize)
    ;;       (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
    ;;           (begin
    ;;     	(current-error-port *alt-log-file*)
    ;;     	(current-output-port *alt-log-file*)))))
    (if (server:check-if-running run-id)
	(begin
	  (debug:print-info 0 *default-log-port* "Server for run-id " run-id " already running")
	  (exit 0)))
    (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
	       (remtries  4))
      (if (not server-id)
	  (if (> remtries 0)
	      (begin
		(thread-sleep! 2)
		(if (not (server:check-if-running run-id))
		    (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
			  (- remtries 1))
		    (begin
		      (debug:print-info 0 *default-log-port* "Another server took the slot, exiting")
		      (exit 0))))
	      (begin
		;; since we didn't get the server lock we are going to clean up and bail out
		(debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
		(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
		))
	  ;; locked in a server id, try to start up
	  (nmsg-transport:run dbstruct hostn run-id server-id))
      (set! *didsomething* #t)
      (exit))))

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

(define (nmsg-transport:mk-signature)
  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list (current-directory)
					  (argv)))))))

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

;; ping the server at host:port
;;   return the open socket if successful (return-socket == #t)
;;   expect the key expected-key returned in payload
;;   send our-key or #f as payload
;;
(define (nmsg-transport:ping hostn port #!key (timeout 3)(return-socket #t)(expected-key #f)(our-key #f)(socket #f))
  ;; send a random number along with pid and check that we get it back
  (let* ((host    (if (or (not hostn)
			  (equal? hostn "-")) ;; use localhost
		      (get-host-name)
		      hostn))
	 (req     (or socket
		      (let ((soc (nn-socket 'req)))
			(nn-connect soc (conc "tcp://" host ":" port))
			soc)))
	 (success #t)
	 (dat     (vector "ping" our-key))
	 (result  (condition-case 
		   (nmsg-transport:client-api-send-receive-raw req dat timeout: timeout)
		   ((timeout)(set! success #f) #f)))
	 (key     (if success 
		      (vector-ref result 1)
		      #f)))
    (debug:print 0 *default-log-port* "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key))
    (if (and success
	     (or (not expected-key) ;; just getting a reply is good enough then
		 (equal? key expected-key)))
	(if return-socket
	    req
	    (begin
	      (if (not socket)(nn-close req)) ;; don't want a side effect of closing socket if handed it
	      #t))
	(begin
	  (if (not socket)(nn-close req)) ;; failed to ping, close socket as side effect
	  #f))))

;; send data to server, wait max of timeout seconds for a response.
;; return #( success/fail result )
;;
;; for effiency it is easier to do the obj->string and string->obj here.
;;
(define (nmsg-transport:client-api-send-receive-raw socreq indat #!key (enable-send #t)(timeout 25))
  (let* ((success     #f)
	 (result      #f)
	 (keepwaiting #t)
	 (dat         (db:obj->string indat transport: 'nmsg))
	 (send-recv   (make-thread
		       (lambda ()
			 (nn-send socreq dat)
			 (let* ((res (nn-recv socreq)))
			   (set! success #t)
			   (set! result (db:string->obj res transport: 'nmsg))))
		       "send-recv"))
	 (timeout     (make-thread
		       (lambda ()
			 (let loop ((count 0))
			   (thread-sleep! 1)
			   (debug:print-info 1 *default-log-port* "send-receive-raw, still waiting after " count " seconds...")
			   (if (and keepwaiting (< count timeout)) ;; yes, this is very aproximate
			       (loop (+ count 1))))
			 (if keepwaiting
			     (begin
			       (print "timeout waiting for ping")
			       (thread-terminate! send-recv))))
		       "timeout")))
    ;; replace with condition-case?
    (handle-exceptions
     exn
     (set! result "timeout")
     (thread-start! timeout)
     (thread-start! send-recv)
     (thread-join! send-recv)
     (if success (thread-terminate! timeout)))
    ;; raise timeout error if timed out
    (if success
	(if (and (vector? result)
		 (vector-ref result 0)) ;; did it fail at the server?
	    result                ;; nope, all good
	    (begin
	      (debug:print-error 0 *default-log-port* "error occured at server, info=" (vector-ref result 2))
	      (debug:print 0 *default-log-port* " client call chain:")
	      (print-call-chain (current-error-port))
	      (debug:print 0 *default-log-port* " server call chain:")
	      (pp (vector-ref result 1) (current-error-port))
	      (signal (vector-ref result 0))))
	(signal (make-composite-condition
		 (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))

;; run nmsg-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (nmsg-transport:keep-running server-id run-id)
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive
  (let* ((server-info (let loop ()
                        (let ((sdat #f))
                          (mutex-lock! *heartbeat-mutex*)
                          (set! sdat *server-info*)
                          (mutex-unlock! *heartbeat-mutex*)
                          (if sdat 
			      (begin
				(debug:print-info 0 *default-log-port* "keep-running got sdat=" sdat)
				sdat)
                              (begin
                                (thread-sleep! 0.5)
                                (loop))))))
         (iface       (car server-info))
         (port        (cadr server-info))
         (last-access 0)
	 (tdbdat      (tasks:open-db))
	 (server-timeout (let ((tmo (configf:lookup  *configdat* "server" "timeout")))
			   (if (and (string? tmo)
				    (string->number tmo))
			       (* 60 60 (string->number tmo))
			       ;; (* 3 24 60 60) ;; default to three days
			       (* 60 1)         ;; default to one minute
			       ;; (* 60 60 25)      ;; default to 25 hours
			       ))))
    (print "Keep-running got server pid " server-id ", using iface " iface " and port " port)
    (let loop ((count 0))
      (thread-sleep! 4) ;; no need to do this very often
      ;; NB// sync currently does NOT return queue-length
      (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1)))
      ;; (print "Server running, count is " count)
        (if (< count 1) ;; 3x3 = 9 secs aprox
            (loop (+ count 1)))
        
        (mutex-lock! *heartbeat-mutex*)
        (set! last-access *last-db-access*)
        (mutex-unlock! *heartbeat-mutex*)
	(db:sync-touched *inmemdb* run-id force-sync: #t)
        (if (and *server-run*
	       (> (+ last-access server-timeout)
		  (current-seconds)))
            (begin
              (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
              (loop 0))
            (begin
              (debug:print-info 0 *default-log-port* "Starting to shutdown the server.")
              (set! *time-to-exit* #t)
	      (db:sync-touched *inmemdb* run-id force-sync: #t)
              (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running")
              (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
              (exit)
	      ))))))

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

(define (nmsg-transport:client-connect iface portnum)
  (let* ((reqsoc      (nmsg-transport:ping iface portnum return-socket: #t)))
    (vector iface portnum #f #f #f (current-seconds) reqsoc)))

;; returns result, there is no sucess/fail flag - handled via excpections
;;
(define (nmsg-transport:client-api-send-receive run-id connection-info cmd param #!key (remtries 5))
  ;; NB// In the html version of this routine there is a call to 
  ;;      tasks:kill-server-run-id when there is an exception
  (mutex-lock! *http-mutex*)
  (let* ((packet  (vector cmd param))
	 (reqsoc  (http-transport:server-dat-get-socket connection-info))
	 (res     (nmsg-transport:client-api-send-receive-raw reqsoc packet)))
;;	 (status  (vector-ref rawres 0))
;;	 (result  (vector-ref rawres 1)))
    (mutex-unlock! *http-mutex*)
    res)) ;; (vector status (if status (db:string->obj result transport: 'nmsg) result))))
	
;;======================================================================
;; J U N K 
;;======================================================================

;; DO NOT USE
;;
(define (nmsg-transport:client-signal-handler signum)
  (handle-exceptions
   exn
   (debug:print 0 *default-log-port* " ... exiting ...")
   (let ((th1 (make-thread (lambda ()
			     (if (not *received-response*)
				 (receive-message* *runremote*))) ;; flush out last call if applicable
			   "eat response"))
	 (th2 (make-thread (lambda ()
			     (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
			     (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
			     (debug:print 0 *default-log-port* "       Done.")
			     (exit 4))
			   "exit on ^C timer")))
     (thread-start! th2)
     (thread-start! th1)
     (thread-join! th2))))

Deleted remotediff-nmsg.scm version [50100144d4].

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
(use posix)
(use regex)
(use directory-utils)
(use srfi-18 srfi-69 nanomsg)

(define (client-send-receive soc msg)
  (nn-send soc msg)
  (nn-recv soc))

;;do as calling user
(define (do-as-calling-user proc)
  (let ((eid (current-effective-user-id))
        (cid (current-user-id)))
    (if (not (eq? eid cid)) ;; running suid
        (set! (current-effective-user-id) cid))
    (proc)
    (if (not (eq? eid cid))
        (set! (current-effective-user-id) eid))))

;; use mutex to not open/close files at same time
;;
(define (checksum mtx file #!key (cmd "shasum"))
  (mutex-lock! mtx)
  (let-values (((inp oup pid)
                (process cmd (list file))))
    (mutex-unlock! mtx)
    (let ((result (read-line inp)))
      ;; now flush out remaining output
      (let loop ((inl (read-line inp)))
        (if (eof-object? inl)
            (if (string? result)
                (begin
                  (mutex-lock! mtx)
                  (close-input-port inp)
                  (close-output-port oup)
                  (mutex-unlock! mtx)
                  (car (string-split result)))
                #f)
            (loop (read-line inp)))))))

(define *max-running* 40)

(define my-mutex-lock! conc)
(define my-mutex-unlock! conc)
;; (define my-mutex-lock! mutex-lock!)
;; (define my-mutex-unlock! mutex-unlock!)

(define (gather-dir-info path)
  (let ((mtx1     (make-mutex))
        (threads  (make-hash-table))
        (last-num 0)
        (req      (nn-socket 'req)))
    (print "starting client with pid " (current-process-id))
    (nn-connect req
                ;; "tcp://localhost:5559")
                "ipc:///tmp/test-ipc")
    (find-files 
     path 
     ;; test: #t
     action: (lambda (p res)
               (let ((info (cond
                            ((not (file-read-access? p)) '(cant-read))
                            ((directory? p)              '(dir))
                            ((symbolic-link? p)          (list 'symlink (read-symbolic-link p)))
                            (else                        '(data)))))
                 (if (eq? (car info) 'data)
                     (let loop ((start-time (current-seconds)))
                       (my-mutex-lock! mtx1)
                       (let* ((num-threads (hash-table-size threads))
                              (ok-to-run   (> *max-running* num-threads)))
                         ;; (if (> (abs (- num-threads last-num)) 2)
                         ;;     (begin
                         ;;       ;; (print "num-threads:" num-threads)
                         ;;       (set! last-num num-threads)))
                         (my-mutex-unlock! mtx1)
                         (if ok-to-run
                             (let ((run-time-start (current-seconds)))
                               ;; (print "num threads: " num-threads)
                               (let ((th1  (make-thread
                                            (lambda ()
                                              (let ((cksum (checksum mtx1 p cmd: "md5sum"))
                                                    (run-time (- (current-seconds) run-time-start)))
                                                (my-mutex-lock! mtx1)
                                                (client-send-receive req (conc p " " cksum))
                                                (my-mutex-unlock! mtx1))
                                              (let loop2 ()
                                                (my-mutex-lock! mtx1)
                                                (let ((registered (hash-table-exists? threads p)))
                                                  (if registered
                                                      (begin
                                                        ;; (print "deleting thread reference for " p)
                                                        (hash-table-delete! threads p))) ;; delete myself
                                                  (my-mutex-unlock! mtx1)
                                                  (if (not registered)
                                                      (begin
                                                        (thread-sleep! 0.5)
                                                        (loop2))))))
                                            p)))
                                 (thread-start! th1)
                                 ;; (thread-sleep! 0.05) ;; give things a little time to get going
                                 ;; (thread-join! th1) ;; 
                                 (my-mutex-lock! mtx1)
                                 (hash-table-set! threads p th1)
                                 (my-mutex-unlock! mtx1)
                                 )) ;; thread is launched
                             (let ((run-time (- (current-seconds) start-time))) ;; couldn't launch yet
                               (cond
                                ((< run-time 5)) ;; blast on through
                                ((< run-time 30)(thread-sleep! 0.1))
                                ((< run-time 60)(thread-sleep! 2))
                                ((< run-time 120)(thread-sleep! 3))
                                (else (thread-sleep! 3)))
                               (loop start-time)))))))))
    (map thread-join! (hash-table-values threads))
    (client-send-receive req "quit")
    (nn-close req)
    (exit)))

;; recieve and store the file data, note: this is effectively a *server*, not a client.
;;
(define (compare-directories path1 path2)
  (let ((p1dat       (make-hash-table))
        (p2dat       (make-hash-table))
        (numdone     0) ;; increment when recieved a quit. exit when > 2
        (rep         (nn-socket 'rep))
        (p1len       (string-length path1))
        (p2len       (string-length path2))
        (both-seen   (make-hash-table)))
    (nn-bind    rep  
                ;; "tcp://*:5559")
                "ipc:///tmp/test-ipc")
    ;; start clients
    (thread-sleep! 0.1)
    (system (conc "./remotediff-nmsg " path1 " &"))
    (system (conc "./remotediff-nmsg " path2 " &"))
    (let loop ((msg-in (nn-recv rep))
               (last-print 0))
      (if (equal? msg-in "quit")
          (set! numdone (+ numdone 1)))
      (if (and (not (equal? msg-in "quit"))
               (< numdone 2))
          (let* ((parts (string-split msg-in))
                 (filen (car parts))
                 (finfo (cadr parts))
                 (isp1  (substring-index path1 filen 0)) ;; is this a path1?
                 (isp2  (substring-index path2 filen 0)) ;; is this a path2?
                 (tpth  (substring filen (if isp1 p1len p2len) (string-length filen))))
            (hash-table-set! (if isp1 p1dat p2dat)
                             tpth
                             finfo)
            (if (and (hash-table-exists? p1dat tpth)
                     (hash-table-exists? p2dat tpth))
                (begin
                  (if (not (equal? (hash-table-ref p1dat tpth)
                                   (hash-table-ref p2dat tpth)))
                      (print "DIFF: " tpth))
                  (hash-table-set! both-seen tpth finfo)))
            (nn-send rep "done")
            (loop (nn-recv rep)
                  (if (> (- (current-seconds) last-print) 15)
                      (begin
                        (print "Processed " (hash-table-size p1dat) ", " (hash-table-size p2dat))
                        (current-seconds))
                      last-print)))))
    (print "p1: " (hash-table-size p1dat) " p2: " (hash-table-size p2dat))
    (hash-table-for-each
     p1dat
     (lambda (k v)
       (if (not (hash-table-exists? p2dat k))
           (print "REMOVED: " k))))
    (hash-table-for-each
     p2dat
     (lambda (k v)
       (if (not (hash-table-exists? p1dat k))
           (print "ADDED: " k))))
    (list p1dat p2dat)))

(if (< (length (argv)) 2)
    (begin
      (print "Usage: remotediff-nmsg file1 file2")
      (exit)))

(if (eq? (length (argv)) 2) ;; given a single path
    (gather-dir-info (cadr (argv)))
    (compare-directories (cadr (argv))(caddr (argv))))

(print "Done")
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































Deleted rpctest/rpctest-continuous-client.scm version [bb9e39b0dd].

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
;;;; rpc-demo.scm
;;;; Simple database server / client

;;; start server thusly: ./rpctest server test.db
;;; you will need to init test.db:
;;; sqlite3 test.db "CREATE TABLE foo (id INTEGER PRIMARY KEY, var TEXT, val TEXT);"

(require-extension (srfi 18) extras tcp rpc sql-de-lite)

;;; Common things

(define total-queries 0)
(define start-time (current-seconds))

(define operation (string->symbol (car (command-line-arguments))))
(define param (cadr (command-line-arguments)))
(print "Operation: " operation ", param: " param)

;; have a pool of db's to pick from
(define *dbpool* '())
(define *pool-mutex* (make-mutex))

(define (get-db)
  (mutex-lock! *pool-mutex*)
  (if (null? *dbpool*)
      (begin
	(mutex-unlock! *pool-mutex*)
	(let ((db (open-database param)))
	  (set-busy-handler! db (busy-timeout 10000))
	  (exec (sql db "PRAGMA synchronous=0;"))
	  db))
      (let ((res (car *dbpool*)))
	(set! *dbpool* (cdr *dbpool*))
	(mutex-unlock! *pool-mutex*)
	res)))

(define (return-db db)
  (mutex-lock! *pool-mutex*)
  (set! *dbpool* (cons db *dbpool* ))
  (let ((res (length *dbpool*)))
    (mutex-unlock! *pool-mutex*)
    res))

(define rpc:listener
  (if (eq? operation 'server)
      (tcp-listen (rpc:default-server-port))
      (tcp-listen 0)))

;; Start server thread
(define rpc:server
  (make-thread
   (cute (rpc:make-server rpc:listener) "rpc:server") ;; NOTE: see equivalent code below
   'rpc:server))

;; This is what the code would look like without cute
;; (define rpc:server
;;   (make-thread
;;    (lambda ()
;;      ((rpc:make-server rpc:listener) "rpc:server"))
;;    'rpc:server))

(thread-start! rpc:server)

;;; Server side

(define (server)
  (rpc:publish-procedure!
   'change-response-port
   (lambda (port)
     (rpc:default-server-port port))
   #f)
  ;;(let ((db  (get-db))(open-database param)))
  ;; (set-finalizer! db finalize!)
  (rpc:publish-procedure!
   'query
   (lambda (sqlstmt callback)
     (set! total-queries (+ total-queries 1))
     (print "Executing query '" sqlstmt "' ...")
     (let ((db (get-db)))
       (query (for-each-row
	       callback)
	      (sql db sqlstmt))
       (print "Query rate: " (/ total-queries (/ (- (current-seconds) start-time) 60)) " per minute")
       (print "num dbs: " (return-db db))
       )))
  (thread-join! rpc:server))

;;; Client side

(define (callback1 . columns)
  (let loop ((c columns) (i 0))
    (unless (null? c)
      (printf "~a=~s " i (car c))
      (loop (cdr c) (+ i 1))))
  (newline))

(define callback2-results '())

(define (callback2 . columns)
  (set! callback2-results (cons columns callback2-results)))

(define (client param)
  ((rpc:procedure 'change-response-port "localhost")
   (tcp-listener-port rpc:listener))
  ((rpc:procedure 'query "localhost") param callback1)
  (rpc:publish-procedure! 'callback2 callback2)
  ((rpc:procedure 'query "localhost") param callback2)
  (pp callback2-results)
  (rpc:close-all-connections!)
  ;; (rpc:close-connection! "localhost" (rpc:default-server-port))
  )

(define (run-query param)
  ((rpc:procedure 'query "localhost") param callback1)
  ((rpc:procedure 'query "localhost") param callback2)
  callback2-results)

(define (continuous-client #!key (duration 600)) ;; default - run for 10 minutes
  ((rpc:procedure 'change-response-port "localhost")
   (tcp-listener-port rpc:listener))
  (rpc:publish-procedure! 'callback2 callback2)
  (let loop ()
    (if (< (- (current-seconds) start-time) duration)
	(begin
	  (run-query (conc "INSERT INTO foo (var,val) VALUES (" (random 1000) "," (random 1000) ");"))
	  (let ((numrows (caaar (run-query "SELECT COUNT(id) FROM foo;"))))
	    (if (and (number? numrows)
		     (> numrows 300))
		(print (run-query (conc "DELETE FROM foo WHERE var > " (random 1000) ";")))))
	  (loop))))
  (rpc:close-all-connections!))

;;; Run it

(if (eq? operation 'server)
    (server)
    (continuous-client))

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































Deleted rpctest/rpctest.scm version [900250564a].

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
;;;; rpc-demo.scm
;;;; Simple database server / client

;;; start server thusly: ./rpctest server test.db
;;; you will need to init test.db:
;;; sqlite3 test.db "CREATE TABLE foo (id INTEGER PRIMARY KEY, var TEXT, val TEXT);"

(require-extension (srfi 18) extras tcp rpc sql-de-lite)

;;; Common things

(define total-queries 0)
(define start-time (current-seconds))

(define operation (string->symbol (car (command-line-arguments))))
(define param (cadr (command-line-arguments)))
(print "Operation: " operation ", param: " param)

;; have a pool of db's to pick from
(define *dbpool* '())
(define *pool-mutex* (make-mutex))

(define (get-db)
  (mutex-lock! *pool-mutex*)
  (if (null? *dbpool*)
      (begin
	(mutex-unlock! *pool-mutex*)
	(let ((db (open-database param)))
	  (set-busy-handler! db (busy-timeout 10000))
	  (exec (sql db "PRAGMA synchronous=0;"))
	  db))
      (let ((res (car *dbpool*)))
	(set! *dbpool* (cdr *dbpool*))
	(mutex-unlock! *pool-mutex*)
	res)))

(define (return-db db)
  (mutex-lock! *pool-mutex*)
  (set! *dbpool* (cons db *dbpool* ))
  (let ((res (length *dbpool*)))
    (mutex-unlock! *pool-mutex*)
    res))

(define rpc:listener
  (if (eq? operation 'server)
      (tcp-listen (rpc:default-server-port))
      (tcp-listen 0)))

;; Start server thread
(define rpc:server
  (make-thread
   (cute (rpc:make-server rpc:listener) "rpc:server")
   'rpc:server))

(thread-start! rpc:server)

;;; Server side

(define (server)
  (rpc:publish-procedure!
   'change-response-port
   (lambda (port)
     (rpc:default-server-port port))
   #f)
  ;;(let ((db  (get-db))(open-database param)))
  ;; (set-finalizer! db finalize!)
  (rpc:publish-procedure!
   'query
   (lambda (sqlstmt callback)
     (set! total-queries (+ total-queries 1))
     (print "Executing query '" sqlstmt "' ...")
     (let ((db (get-db)))
       (query (for-each-row
	       callback)
	      (sql db sqlstmt))
       (print "Query rate: " (/ total-queries (/ (- (current-seconds) start-time) 60)) " per minute")
       (print "num dbs: " (return-db db))
       )))
  (thread-join! rpc:server))

;;; Client side

(define (callback1 . columns)
  (let loop ((c columns) (i 0))
    (unless (null? c)
      (printf "~a=~s " i (car c))
      (loop (cdr c) (+ i 1))))
  (newline))

(define callback2-results '())

(define (callback2 . columns)
  (set! callback2-results (cons columns callback2-results)))

(define (client)
  ((rpc:procedure 'change-response-port "localhost")
   (tcp-listener-port rpc:listener))
  ((rpc:procedure 'query "localhost") param callback1)
  (rpc:publish-procedure! 'callback2 callback2)
  ((rpc:procedure 'query "localhost") param callback2)
  (pp callback2-results)
  (rpc:close-connection! "localhost" (rpc:default-server-port)))

;;; Run it

(if (eq? operation 'server)
    (server)
    (client))

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































Deleted rpctest/run-client.sh version [7217b9abad].

1
2
3
4
5
6
7
8
9
10
11
12
#!/bin/bash


while ./rpctest client "insert into foo (var,val) values ($RANDOM,$RANDOM);";do
    numrows=$(./rpctest client "select count(id) from foo;") # |wc -l)
    deletefrom=$RANDOM
    echo "numrows=$numrows, deletefrom=$deletefrom"
    if [[ $numrows -gt 300 ]];then
	echo "numrows=$numrows, deletefrom=$deletefrom"
	./rpctest client "delete from foo where var > $deletefrom;"
    fi
done
<
<
<
<
<
<
<
<
<
<
<
<
























Modified server.scm from [92475e2503] to [5a88149733].

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
	 (cmdln (conc (common:get-megatest-exe)
		      " -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
							   " -daemonize "
							   "")
		      ;; " -log " logfile
		      " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &")))))
	 (log-rotate  (make-thread common:rotate-logs  "server run, rotate logs thread"))
         (load-limit  (configf:lookup-number *configdat* "jobtools" "maxhomehostload" 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)

    (common:wait-for-normalized-load load-limit " delaying server start due to load" target-host) ;; do not try starting servers on an already overloaded machine, just wait forever
    (system (conc "nbfake " cmdln))
    (unsetenv "TARGETHOST_LOGF")
    (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
    (thread-join! log-rotate)
    (pop-directory)))








|
















>







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
	 (cmdln (conc (common:get-megatest-exe)
		      " -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
							   " -daemonize "
							   "")
		      ;; " -log " logfile
		      " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &")))))
	 (log-rotate  (make-thread common:rotate-logs  "server run, rotate logs thread"))
         (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 5000) 1000)) ;; add about a random (up to 5 seconds) initial delay. It seems pretty common that many running tests request a server at the same time
    (common:wait-for-normalized-load load-limit " delaying server start due to load" target-host) ;; do not try starting servers on an already overloaded machine, just wait forever
    (system (conc "nbfake " cmdln))
    (unsetenv "TARGETHOST_LOGF")
    (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
    (thread-join! log-rotate)
    (pop-directory)))

Deleted spreadsheet/basic/Configurations2/accelerator/current.xml version [da39a3ee5e].

Deleted spreadsheet/basic/META-INF/manifest.xml version [d7d7c2a2dc].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
<?xml version="1.0" encoding="UTF-8"?>
<manifest:manifest xmlns:manifest="urn:oasis:names:tc:opendocument:xmlns:manifest:1.0">
 <manifest:file-entry manifest:media-type="application/vnd.oasis.opendocument.spreadsheet" manifest:version="1.2" manifest:full-path="/"/>
 <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/statusbar/"/>
 <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/accelerator/current.xml"/>
 <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/accelerator/"/>
 <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/floater/"/>
 <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/popupmenu/"/>
 <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/progressbar/"/>
 <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/toolpanel/"/>
 <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/menubar/"/>
 <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/toolbar/"/>
 <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/images/Bitmaps/"/>
 <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/images/"/>
 <manifest:file-entry manifest:media-type="application/vnd.sun.xml.ui.configuration" manifest:full-path="Configurations2/"/>
 <manifest:file-entry manifest:media-type="text/xml" manifest:full-path="content.xml"/>
 <manifest:file-entry manifest:media-type="text/xml" manifest:full-path="styles.xml"/>
 <manifest:file-entry manifest:media-type="text/xml" manifest:full-path="meta.xml"/>
 <manifest:file-entry manifest:media-type="image/png" manifest:full-path="Thumbnails/thumbnail.png"/>
 <manifest:file-entry manifest:media-type="" manifest:full-path="Thumbnails/"/>
 <manifest:file-entry manifest:media-type="text/xml" manifest:full-path="settings.xml"/>
</manifest:manifest>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































Deleted spreadsheet/basic/Thumbnails/thumbnail.png version [faa30ff37d].

cannot compute difference between binary files

Deleted spreadsheet/basic/content.xml version [2fc389eb9d].

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
<?xml version="1.0" encoding="UTF-8"?>
<office:document-content xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:style="urn:oasis:names:tc:opendocument:xmlns:style:1.0" xmlns:text="urn:oasis:names:tc:opendocument:xmlns:text:1.0" xmlns:table="urn:oasis:names:tc:opendocument:xmlns:table:1.0" xmlns:draw="urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" xmlns:fo="urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:number="urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" xmlns:presentation="urn:oasis:names:tc:opendocument:xmlns:presentation:1.0" xmlns:svg="urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" xmlns:chart="urn:oasis:names:tc:opendocument:xmlns:chart:1.0" xmlns:dr3d="urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" xmlns:math="http://www.w3.org/1998/Math/MathML" xmlns:form="urn:oasis:names:tc:opendocument:xmlns:form:1.0" xmlns:script="urn:oasis:names:tc:opendocument:xmlns:script:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:ooow="http://openoffice.org/2004/writer" xmlns:oooc="http://openoffice.org/2004/calc" xmlns:dom="http://www.w3.org/2001/xml-events" xmlns:xforms="http://www.w3.org/2002/xforms" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:rpt="http://openoffice.org/2005/report" xmlns:of="urn:oasis:names:tc:opendocument:xmlns:of:1.2" xmlns:xhtml="http://www.w3.org/1999/xhtml" xmlns:grddl="http://www.w3.org/2003/g/data-view#" xmlns:tableooo="http://openoffice.org/2009/table" xmlns:field="urn:openoffice:names:experimental:ooo-ms-interop:xmlns:field:1.0" xmlns:formx="urn:openoffice:names:experimental:ooxml-odf-interop:xmlns:form:1.0" xmlns:css3t="http://www.w3.org/TR/css3-text/" office:version="1.2" grddl:transformation="http://docs.oasis-open.org/office/1.2/xslt/odf2rdf.xsl">
<office:scripts/>
<office:font-face-decls>
<style:font-face style:name="Arial" svg:font-family="Arial" style:font-family-generic="swiss" style:font-pitch="variable"/>
<style:font-face style:name="DejaVu Sans" svg:font-family="&apos;DejaVu Sans&apos;" style:font-family-generic="system" style:font-pitch="variable"/>
<style:font-face style:name="Droid Sans Fallback" svg:font-family="&apos;Droid Sans Fallback&apos;" style:font-family-generic="system" style:font-pitch="variable"/>
<style:font-face style:name="Lohit Hindi" svg:font-family="&apos;Lohit Hindi&apos;" style:font-family-generic="system" style:font-pitch="variable"/>
</office:font-face-decls>
<office:automatic-styles>
<style:style style:name="co1" style:family="table-column">
<style:table-column-properties fo:break-before="auto" style:column-width="0.8925in"/>
</style:style>
<style:style style:name="ro1" style:family="table-row">
<style:table-row-properties style:row-height="0.178in" fo:break-before="auto" style:use-optimal-row-height="true"/>
</style:style>
<style:style style:name="ta1" style:family="table" style:master-page-name="Default">
<style:table-properties table:display="true" style:writing-mode="lr-tb"/>
</style:style>
</office:automatic-styles>
<office:body>
<office:spreadsheet>
<table:table table:name="Sheet1" table:style-name="ta1" table:print="false">
<table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="string">
<text:p>Row 1,A</text:p>
</table:table-cell>
<table:table-cell office:value-type="string">
<text:p>Row 1,B</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="string">
<text:p>Row 2,A</text:p>
</table:table-cell>
<table:table-cell office:value-type="string">
<text:p>Row 2,B</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell table:number-columns-repeated="2"/>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="string">
<text:p>this is sheet one</text:p>
</table:table-cell>
<table:table-cell/>
</table:table-row>
</table:table>
<table:table table:name="Sheet2" table:style-name="ta1" table:print="false">
<table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="string">
<text:p>Row 1,A</text:p>
</table:table-cell>
<table:table-cell office:value-type="string">
<text:p>Row 1,B</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="string">
<text:p>Row 2,A</text:p>
</table:table-cell>
<table:table-cell office:value-type="string">
<text:p>Row 2,B</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell table:number-columns-repeated="2"/>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="string">
<text:p>this is sheet two</text:p>
</table:table-cell>
<table:table-cell/>
</table:table-row>
</table:table>
<table:table table:name="Sheet3" table:style-name="ta1" table:print="false">
<table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="float" office:value="1">
<text:p>1</text:p>
</table:table-cell>
<table:table-cell office:value-type="float" office:value="2">
<text:p>2</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="float" office:value="2">
<text:p>2</text:p>
</table:table-cell>
<table:table-cell office:value-type="float" office:value="4">
<text:p>4</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="float" office:value="3">
<text:p>3</text:p>
</table:table-cell>
<table:table-cell office:value-type="float" office:value="6">
<text:p>6</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="float" office:value="4">
<text:p>4</text:p>
</table:table-cell>
<table:table-cell office:value-type="float" office:value="8">
<text:p>8</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="float" office:value="5">
<text:p>5</text:p>
</table:table-cell>
<table:table-cell office:value-type="float" office:value="10">
<text:p>10</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="float" office:value="6">
<text:p>6</text:p>
</table:table-cell>
<table:table-cell office:value-type="float" office:value="12">
<text:p>12</text:p>
</table:table-cell>
</table:table-row>
</table:table>
</office:spreadsheet>
</office:body>
</office:document-content>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































Deleted spreadsheet/basic/content.xml~ version [41688395c5].

1
2
<?xml version="1.0" encoding="UTF-8"?>
<office:document-content xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:style="urn:oasis:names:tc:opendocument:xmlns:style:1.0" xmlns:text="urn:oasis:names:tc:opendocument:xmlns:text:1.0" xmlns:table="urn:oasis:names:tc:opendocument:xmlns:table:1.0" xmlns:draw="urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" xmlns:fo="urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:number="urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" xmlns:presentation="urn:oasis:names:tc:opendocument:xmlns:presentation:1.0" xmlns:svg="urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" xmlns:chart="urn:oasis:names:tc:opendocument:xmlns:chart:1.0" xmlns:dr3d="urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" xmlns:math="http://www.w3.org/1998/Math/MathML" xmlns:form="urn:oasis:names:tc:opendocument:xmlns:form:1.0" xmlns:script="urn:oasis:names:tc:opendocument:xmlns:script:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:ooow="http://openoffice.org/2004/writer" xmlns:oooc="http://openoffice.org/2004/calc" xmlns:dom="http://www.w3.org/2001/xml-events" xmlns:xforms="http://www.w3.org/2002/xforms" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:rpt="http://openoffice.org/2005/report" xmlns:of="urn:oasis:names:tc:opendocument:xmlns:of:1.2" xmlns:xhtml="http://www.w3.org/1999/xhtml" xmlns:grddl="http://www.w3.org/2003/g/data-view#" xmlns:tableooo="http://openoffice.org/2009/table" xmlns:field="urn:openoffice:names:experimental:ooo-ms-interop:xmlns:field:1.0" xmlns:formx="urn:openoffice:names:experimental:ooxml-odf-interop:xmlns:form:1.0" xmlns:css3t="http://www.w3.org/TR/css3-text/" office:version="1.2" grddl:transformation="http://docs.oasis-open.org/office/1.2/xslt/odf2rdf.xsl"><office:scripts/><office:font-face-decls><style:font-face style:name="Arial" svg:font-family="Arial" style:font-family-generic="swiss" style:font-pitch="variable"/><style:font-face style:name="DejaVu Sans" svg:font-family="&apos;DejaVu Sans&apos;" style:font-family-generic="system" style:font-pitch="variable"/><style:font-face style:name="Droid Sans Fallback" svg:font-family="&apos;Droid Sans Fallback&apos;" style:font-family-generic="system" style:font-pitch="variable"/><style:font-face style:name="Lohit Hindi" svg:font-family="&apos;Lohit Hindi&apos;" style:font-family-generic="system" style:font-pitch="variable"/></office:font-face-decls><office:automatic-styles><style:style style:name="co1" style:family="table-column"><style:table-column-properties fo:break-before="auto" style:column-width="0.8925in"/></style:style><style:style style:name="ro1" style:family="table-row"><style:table-row-properties style:row-height="0.178in" fo:break-before="auto" style:use-optimal-row-height="true"/></style:style><style:style style:name="ta1" style:family="table" style:master-page-name="Default"><style:table-properties table:display="true" style:writing-mode="lr-tb"/></style:style></office:automatic-styles><office:body><office:spreadsheet><table:table table:name="Sheet1" table:style-name="ta1" table:print="false"><table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>Row 1,A</text:p></table:table-cell><table:table-cell office:value-type="string"><text:p>Row 1,B</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>Row 2,A</text:p></table:table-cell><table:table-cell office:value-type="string"><text:p>Row 2,B</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell table:number-columns-repeated="2"/></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>this is sheet one</text:p></table:table-cell><table:table-cell/></table:table-row></table:table><table:table table:name="Sheet2" table:style-name="ta1" table:print="false"><table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>Row 1,A</text:p></table:table-cell><table:table-cell office:value-type="string"><text:p>Row 1,B</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>Row 2,A</text:p></table:table-cell><table:table-cell office:value-type="string"><text:p>Row 2,B</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell table:number-columns-repeated="2"/></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>this is sheet two</text:p></table:table-cell><table:table-cell/></table:table-row></table:table><table:table table:name="Sheet3" table:style-name="ta1" table:print="false"><table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="1"><text:p>1</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="2"><text:p>2</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="2"><text:p>2</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="4"><text:p>4</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="3"><text:p>3</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="6"><text:p>6</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="4"><text:p>4</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="8"><text:p>8</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="5"><text:p>5</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="10"><text:p>10</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="6"><text:p>6</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="12"><text:p>12</text:p></table:table-cell></table:table-row></table:table></office:spreadsheet></office:body></office:document-content>
<
<




Deleted spreadsheet/basic/meta.xml version [a8103b8c6c].

1
2
<?xml version="1.0" encoding="UTF-8"?>
<office:document-meta xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:grddl="http://www.w3.org/2003/g/data-view#" office:version="1.2" grddl:transformation="http://docs.oasis-open.org/office/1.2/xslt/odf2rdf.xsl"><office:meta><meta:initial-creator>Matt Welland</meta:initial-creator><meta:creation-date>2011-09-06T20:46:23</meta:creation-date><dc:date>2011-09-06T22:05:47</dc:date><dc:creator>Matt Welland</dc:creator><meta:editing-duration>PT1H19M25S</meta:editing-duration><meta:editing-cycles>2</meta:editing-cycles><meta:generator>LibreOffice/3.3$Linux LibreOffice_project/330m19$Build-301</meta:generator><meta:document-statistic meta:table-count="3" meta:cell-count="22" meta:object-count="0"/></office:meta></office:document-meta>
<
<




Deleted spreadsheet/basic/mimetype version [015538d968].

1
application/vnd.oasis.opendocument.spreadsheet
<


Deleted spreadsheet/basic/settings.xml version [ba07aed085].

1
2
<?xml version="1.0" encoding="UTF-8"?>
<office:document-settings xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:config="urn:oasis:names:tc:opendocument:xmlns:config:1.0" xmlns:ooo="http://openoffice.org/2004/office" office:version="1.2"><office:settings><config:config-item-set config:name="ooo:view-settings"><config:config-item config:name="VisibleAreaTop" config:type="int">0</config:config-item><config:config-item config:name="VisibleAreaLeft" config:type="int">0</config:config-item><config:config-item config:name="VisibleAreaWidth" config:type="int">4516</config:config-item><config:config-item config:name="VisibleAreaHeight" config:type="int">1799</config:config-item><config:config-item-map-indexed config:name="Views"><config:config-item-map-entry><config:config-item config:name="ViewId" config:type="string">view1</config:config-item><config:config-item-map-named config:name="Tables"><config:config-item-map-entry config:name="Sheet1"><config:config-item config:name="CursorPositionX" config:type="int">0</config:config-item><config:config-item config:name="CursorPositionY" config:type="int">0</config:config-item><config:config-item config:name="HorizontalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="VerticalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="HorizontalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="VerticalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="ActiveSplitRange" config:type="short">2</config:config-item><config:config-item config:name="PositionLeft" config:type="int">0</config:config-item><config:config-item config:name="PositionRight" config:type="int">0</config:config-item><config:config-item config:name="PositionTop" config:type="int">0</config:config-item><config:config-item config:name="PositionBottom" config:type="int">0</config:config-item><config:config-item config:name="ZoomType" config:type="short">0</config:config-item><config:config-item config:name="ZoomValue" config:type="int">100</config:config-item><config:config-item config:name="PageViewZoomValue" config:type="int">60</config:config-item><config:config-item config:name="ShowGrid" config:type="boolean">true</config:config-item></config:config-item-map-entry><config:config-item-map-entry config:name="Sheet2"><config:config-item config:name="CursorPositionX" config:type="int">0</config:config-item><config:config-item config:name="CursorPositionY" config:type="int">4</config:config-item><config:config-item config:name="HorizontalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="VerticalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="HorizontalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="VerticalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="ActiveSplitRange" config:type="short">2</config:config-item><config:config-item config:name="PositionLeft" config:type="int">0</config:config-item><config:config-item config:name="PositionRight" config:type="int">0</config:config-item><config:config-item config:name="PositionTop" config:type="int">0</config:config-item><config:config-item config:name="PositionBottom" config:type="int">0</config:config-item><config:config-item config:name="ZoomType" config:type="short">0</config:config-item><config:config-item config:name="ZoomValue" config:type="int">100</config:config-item><config:config-item config:name="PageViewZoomValue" config:type="int">60</config:config-item><config:config-item config:name="ShowGrid" config:type="boolean">true</config:config-item></config:config-item-map-entry><config:config-item-map-entry config:name="Sheet3"><config:config-item config:name="CursorPositionX" config:type="int">1</config:config-item><config:config-item config:name="CursorPositionY" config:type="int">5</config:config-item><config:config-item config:name="HorizontalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="VerticalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="HorizontalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="VerticalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="ActiveSplitRange" config:type="short">2</config:config-item><config:config-item config:name="PositionLeft" config:type="int">0</config:config-item><config:config-item config:name="PositionRight" config:type="int">0</config:config-item><config:config-item config:name="PositionTop" config:type="int">0</config:config-item><config:config-item config:name="PositionBottom" config:type="int">0</config:config-item><config:config-item config:name="ZoomType" config:type="short">0</config:config-item><config:config-item config:name="ZoomValue" config:type="int">100</config:config-item><config:config-item config:name="PageViewZoomValue" config:type="int">60</config:config-item><config:config-item config:name="ShowGrid" config:type="boolean">true</config:config-item></config:config-item-map-entry></config:config-item-map-named><config:config-item config:name="ActiveTable" config:type="string">Sheet3</config:config-item><config:config-item config:name="HorizontalScrollbarWidth" config:type="int">270</config:config-item><config:config-item config:name="ZoomType" config:type="short">0</config:config-item><config:config-item config:name="ZoomValue" config:type="int">100</config:config-item><config:config-item config:name="PageViewZoomValue" config:type="int">60</config:config-item><config:config-item config:name="ShowPageBreakPreview" config:type="boolean">false</config:config-item><config:config-item config:name="ShowZeroValues" config:type="boolean">true</config:config-item><config:config-item config:name="ShowNotes" config:type="boolean">true</config:config-item><config:config-item config:name="ShowGrid" config:type="boolean">true</config:config-item><config:config-item config:name="GridColor" config:type="long">12632256</config:config-item><config:config-item config:name="ShowPageBreaks" config:type="boolean">true</config:config-item><config:config-item config:name="HasColumnRowHeaders" config:type="boolean">true</config:config-item><config:config-item config:name="HasSheetTabs" config:type="boolean">true</config:config-item><config:config-item config:name="IsOutlineSymbolsSet" config:type="boolean">true</config:config-item><config:config-item config:name="IsSnapToRaster" config:type="boolean">false</config:config-item><config:config-item config:name="RasterIsVisible" config:type="boolean">false</config:config-item><config:config-item config:name="RasterResolutionX" config:type="int">1270</config:config-item><config:config-item config:name="RasterResolutionY" config:type="int">1270</config:config-item><config:config-item config:name="RasterSubdivisionX" config:type="int">1</config:config-item><config:config-item config:name="RasterSubdivisionY" config:type="int">1</config:config-item><config:config-item config:name="IsRasterAxisSynchronized" config:type="boolean">true</config:config-item></config:config-item-map-entry></config:config-item-map-indexed></config:config-item-set><config:config-item-set config:name="ooo:configuration-settings"><config:config-item config:name="IsKernAsianPunctuation" config:type="boolean">false</config:config-item><config:config-item config:name="IsRasterAxisSynchronized" config:type="boolean">true</config:config-item><config:config-item config:name="LinkUpdateMode" config:type="short">3</config:config-item><config:config-item config:name="SaveVersionOnClose" config:type="boolean">false</config:config-item><config:config-item config:name="AllowPrintJobCancel" config:type="boolean">true</config:config-item><config:config-item config:name="HasSheetTabs" config:type="boolean">true</config:config-item><config:config-item config:name="ShowPageBreaks" config:type="boolean">true</config:config-item><config:config-item config:name="RasterResolutionX" config:type="int">1270</config:config-item><config:config-item config:name="PrinterSetup" config:type="base64Binary"/><config:config-item config:name="RasterResolutionY" config:type="int">1270</config:config-item><config:config-item config:name="LoadReadonly" config:type="boolean">false</config:config-item><config:config-item config:name="RasterSubdivisionX" config:type="int">1</config:config-item><config:config-item config:name="ShowNotes" config:type="boolean">true</config:config-item><config:config-item config:name="ShowZeroValues" config:type="boolean">true</config:config-item><config:config-item config:name="RasterSubdivisionY" config:type="int">1</config:config-item><config:config-item config:name="ApplyUserData" config:type="boolean">true</config:config-item><config:config-item config:name="GridColor" config:type="long">12632256</config:config-item><config:config-item config:name="RasterIsVisible" config:type="boolean">false</config:config-item><config:config-item config:name="IsSnapToRaster" config:type="boolean">false</config:config-item><config:config-item config:name="PrinterName" config:type="string"/><config:config-item config:name="ShowGrid" config:type="boolean">true</config:config-item><config:config-item config:name="CharacterCompressionType" config:type="short">0</config:config-item><config:config-item config:name="HasColumnRowHeaders" config:type="boolean">true</config:config-item><config:config-item config:name="IsOutlineSymbolsSet" config:type="boolean">true</config:config-item><config:config-item config:name="AutoCalculate" config:type="boolean">true</config:config-item><config:config-item config:name="IsDocumentShared" config:type="boolean">false</config:config-item><config:config-item config:name="UpdateFromTemplate" config:type="boolean">true</config:config-item></config:config-item-set></office:settings></office:document-settings>
<
<




Deleted spreadsheet/basic/styles.xml version [e3b321fd12].

1
2
<?xml version="1.0" encoding="UTF-8"?>
<office:document-styles xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:style="urn:oasis:names:tc:opendocument:xmlns:style:1.0" xmlns:text="urn:oasis:names:tc:opendocument:xmlns:text:1.0" xmlns:table="urn:oasis:names:tc:opendocument:xmlns:table:1.0" xmlns:draw="urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" xmlns:fo="urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:number="urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" xmlns:presentation="urn:oasis:names:tc:opendocument:xmlns:presentation:1.0" xmlns:svg="urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" xmlns:chart="urn:oasis:names:tc:opendocument:xmlns:chart:1.0" xmlns:dr3d="urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" xmlns:math="http://www.w3.org/1998/Math/MathML" xmlns:form="urn:oasis:names:tc:opendocument:xmlns:form:1.0" xmlns:script="urn:oasis:names:tc:opendocument:xmlns:script:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:ooow="http://openoffice.org/2004/writer" xmlns:oooc="http://openoffice.org/2004/calc" xmlns:dom="http://www.w3.org/2001/xml-events" xmlns:rpt="http://openoffice.org/2005/report" xmlns:of="urn:oasis:names:tc:opendocument:xmlns:of:1.2" xmlns:xhtml="http://www.w3.org/1999/xhtml" xmlns:grddl="http://www.w3.org/2003/g/data-view#" xmlns:tableooo="http://openoffice.org/2009/table" xmlns:css3t="http://www.w3.org/TR/css3-text/" office:version="1.2" grddl:transformation="http://docs.oasis-open.org/office/1.2/xslt/odf2rdf.xsl"><office:font-face-decls><style:font-face style:name="Arial" svg:font-family="Arial" style:font-family-generic="swiss" style:font-pitch="variable"/><style:font-face style:name="DejaVu Sans" svg:font-family="&apos;DejaVu Sans&apos;" style:font-family-generic="system" style:font-pitch="variable"/><style:font-face style:name="Droid Sans Fallback" svg:font-family="&apos;Droid Sans Fallback&apos;" style:font-family-generic="system" style:font-pitch="variable"/><style:font-face style:name="Lohit Hindi" svg:font-family="&apos;Lohit Hindi&apos;" style:font-family-generic="system" style:font-pitch="variable"/></office:font-face-decls><office:styles><style:default-style style:family="table-cell"><style:paragraph-properties style:tab-stop-distance="0.5in"/><style:text-properties style:font-name="Arial" fo:language="en" fo:country="US" style:font-name-asian="DejaVu Sans" style:language-asian="zh" style:country-asian="CN" style:font-name-complex="DejaVu Sans" style:language-complex="hi" style:country-complex="IN"/></style:default-style><number:number-style style:name="N0"><number:number number:min-integer-digits="1"/></number:number-style><number:currency-style style:name="N104P0" style:volatile="true"><number:currency-symbol number:language="en" number:country="US">$</number:currency-symbol><number:number number:decimal-places="2" number:min-integer-digits="1" number:grouping="true"/></number:currency-style><number:currency-style style:name="N104"><style:text-properties fo:color="#ff0000"/><number:text>-</number:text><number:currency-symbol number:language="en" number:country="US">$</number:currency-symbol><number:number number:decimal-places="2" number:min-integer-digits="1" number:grouping="true"/><style:map style:condition="value()&gt;=0" style:apply-style-name="N104P0"/></number:currency-style><style:style style:name="Default" style:family="table-cell"><style:text-properties style:font-name-asian="Droid Sans Fallback" style:font-name-complex="Lohit Hindi"/></style:style><style:style style:name="Result" style:family="table-cell" style:parent-style-name="Default"><style:text-properties fo:font-style="italic" style:text-underline-style="solid" style:text-underline-width="auto" style:text-underline-color="font-color" fo:font-weight="bold"/></style:style><style:style style:name="Result2" style:family="table-cell" style:parent-style-name="Result" style:data-style-name="N104"/><style:style style:name="Heading" style:family="table-cell" style:parent-style-name="Default"><style:table-cell-properties style:text-align-source="fix" style:repeat-content="false"/><style:paragraph-properties fo:text-align="center"/><style:text-properties fo:font-size="16pt" fo:font-style="italic" fo:font-weight="bold"/></style:style><style:style style:name="Heading1" style:family="table-cell" style:parent-style-name="Heading"><style:table-cell-properties style:rotation-angle="90"/></style:style></office:styles><office:automatic-styles><style:page-layout style:name="Mpm1"><style:page-layout-properties style:writing-mode="lr-tb"/><style:header-style><style:header-footer-properties fo:min-height="0.2957in" fo:margin-left="0in" fo:margin-right="0in" fo:margin-bottom="0.0984in"/></style:header-style><style:footer-style><style:header-footer-properties fo:min-height="0.2957in" fo:margin-left="0in" fo:margin-right="0in" fo:margin-top="0.0984in"/></style:footer-style></style:page-layout><style:page-layout style:name="Mpm2"><style:page-layout-properties style:writing-mode="lr-tb"/><style:header-style><style:header-footer-properties fo:min-height="0.2957in" fo:margin-left="0in" fo:margin-right="0in" fo:margin-bottom="0.0984in" fo:border="0.0346in solid #000000" fo:padding="0.0071in" fo:background-color="#c0c0c0"><style:background-image/></style:header-footer-properties></style:header-style><style:footer-style><style:header-footer-properties fo:min-height="0.2957in" fo:margin-left="0in" fo:margin-right="0in" fo:margin-top="0.0984in" fo:border="0.0346in solid #000000" fo:padding="0.0071in" fo:background-color="#c0c0c0"><style:background-image/></style:header-footer-properties></style:footer-style></style:page-layout></office:automatic-styles><office:master-styles><style:master-page style:name="Default" style:page-layout-name="Mpm1"><style:header><text:p><text:sheet-name>???</text:sheet-name></text:p></style:header><style:header-left style:display="false"/><style:footer><text:p>Page <text:page-number>1</text:page-number></text:p></style:footer><style:footer-left style:display="false"/></style:master-page><style:master-page style:name="Report" style:page-layout-name="Mpm2"><style:header><style:region-left><text:p><text:sheet-name>???</text:sheet-name> (<text:title>???</text:title>)</text:p></style:region-left><style:region-right><text:p><text:date style:data-style-name="N2" text:date-value="2011-09-06">09/06/2011</text:date>, <text:time>22:05:47</text:time></text:p></style:region-right></style:header><style:header-left style:display="false"/><style:footer><text:p>Page <text:page-number>1</text:page-number> / <text:page-count>99</text:page-count></text:p></style:footer><style:footer-left style:display="false"/></style:master-page></office:master-styles></office:document-styles>
<
<




Deleted testhttp/example-client.scm version [57afe37838].

1
2
3
4
5
6
(use regex http-client)

(print (with-input-from-request "http://localhost:8083/?foo=1" #f 
    (lambda ()
      (let ((match (string-search (regexp "<body>(.*)<.body>") (caddr (string-split (read-string) "\n")))))
	(cadr match)))))
<
<
<
<
<
<












Deleted testhttp/example-server.scm version [1efa10faa7].

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
(use spiffy awful)

(tcp-buffer-size 2048)
(enable-sxml #t)

(define (hello-world)
  (define-page (main-page-path)
    (lambda ()
      (with-request-variables (foo)
        foo))))

(define (start-server #!key (portnum 8080))
  (handle-exceptions
   exn
   (begin
     (print-error-message exn)
     (if (< portnum 9000)
	 (begin 
	   (print "WARNING: failed to start on portnum: " portnum ", trying next port")
	   (sleep 1)
	   (start-server portnum: (+ portnum 1)))
	 (print "ERROR: Tried and tried but could not start the server")))
   (print "INFO: Trying to start server on portnum: " portnum)
   (awful-start hello-world port: portnum)))

(start-server)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































Deleted testhttp/mockupclient.scm version [fceab37de6].

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
(use posix)

(define cname "Bob")
(define runtime 10)
(let ((args (argv)))
  (if (< (length args) 3)
      (begin
	(print "Usage: mockupclient clientname runtime")
	(exit))
      (begin
	(set! cname (cadr args))
	(set! runtime (string->number (caddr args))))))
      
;; (define start-delay (/ (random 100) 9))
;; (define runtime     (+ 1 (/ (random 200) 2)))

(print "Starting client " cname " with runtime " runtime)

(include "mockupclientlib.scm")

(set! endtime (+ (current-seconds) runtime))

(let loop ()
  (let ((x (random 15))
	(varname (list-ref (list "hello" "goodbye" "saluton" "kiaorana")(random 4))))
    (case x
      ;; ((1)(dbaccess cname 'sync "nodat"    #f))
      ((2 3 4 5)(dbaccess cname 'set varname (random 999)))
      ((6 7 8 9 10)(print cname ": Get \"" varname "\" " (dbaccess cname 'get varname #f)))
      (else
       (thread-sleep! 0.011)))
    (if (< (current-seconds) endtime)
	(loop))))

(print "Client " cname " all done!!")
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































Deleted testhttp/mockupclientlib.scm version [6a9bd9de5d].

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
(define sub  (make-socket 'sub))
(define push (make-socket 'push))
(socket-option-set! sub 'subscribe cname)
(connect-socket sub "tcp://localhost:5563")
(connect-socket push "tcp://localhost:5564")

(define (dbaccess cname cmd var val #!key (numtries 1))
  (let* ((msg (conc cname ":" cmd ":" (if val (conc var " " val) var)))
	 (res #f)
	 (do-access (lambda ()
		      (print "Sending msg: " msg)
		      (send-message push msg)
		      (print "Message " msg " sent")
		      (print "Client " cname " waiting for response to " msg)
		      (print "Client " cname " received address " (receive-message* sub))
		      (set! res (receive-message* sub)))))
    (let ((th1 (make-thread do-access "do access"))
	  (th2 (make-thread (lambda ()
			      (thread-sleep! 5)
			      (if (not res)
				  (if (> numtries 0)
				      (begin
					(print "WARNING: access timed out for " cname ", trying again. Trys remaining=" numtries)
					(dbaccess cname cmd var val numtries: (- numtries 1)))
				      (begin
					(print "ERROR: dbaccess timed out. Exiting")
					(exit)))))
			    "timeout thread")))
      (thread-start! th1)
      (thread-start! th2)
      (thread-join! th1)
      res)))

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































Deleted testhttp/mockupserver.scm version [aa3c5bcdcf].

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
;; pub/sub with envelope address
;; Note that if you don't insert a sleep, the server will crash with SIGPIPE as soon
;; as a client disconnects.  Also a remaining client may receive tons of
;; messages afterward.

(use srfi-18 sqlite3 spiffy)

(define cname "server")
(define total-db-accesses 0)
(define start-time (current-seconds))

;; setup the server here
(tcp-buffer-size 2048)
(server-port 5563)

(define (open-db)
  (let* ((dbpath    "mockup.db")
	 (dbexists  (file-exists? dbpath))
	 (db        (open-database dbpath)) ;; (never-give-up-open-db dbpath))
	 (handler   (make-busy-timeout 10)))
    (set-busy-handler! db handler)
    (if (not dbexists)
	(for-each
	 (lambda (stmt)
	   (execute db stmt))
	 (list
	  "PRAGMA SYNCHRONOUS=0;"
	  "CREATE TABLE clients (id INTEGER PRIMARY KEY,name TEXT,num_accesses INTEGER DEFAULT 0);"
	  "CREATE TABLE vars    (var TEXT,val TEXT,CONSTRAINT vars_constraint UNIQUE (var));")))
    db))

(define cid-cache (make-hash-table))

(define (get-client-id db cname)
  (let ((cid (hash-table-ref/default cid-cache cname #f)))
    (if cid 
	cid
	(begin
	  (execute db "INSERT OR REPLACE INTO clients (name) VALUES(?);" cname)
	  (for-each-row 
	   (lambda (id)
	     (set! cid id))
	   db
	   "SELECT id FROM clients WHERE name=?;" cname)
	  (hash-table-set! cid-cache cname cid)
	  (set! total-db-accesses (+ total-db-accesses 2))
	  cid))))

(define (count-client db cname)
  (let ((cid (get-client-id db cname)))
    (execute db "UPDATE clients SET num_accesses=num_accesses+1 WHERE id=?;" cid)
    (set! total-db-accesses (+ total-db-accesses 1))
    ))

(define db (open-db))
;; (define queuelst '())
;; (define mx1 (make-mutex))

(define max-queue-len 0)

(define (process-queue queuelst)
  (let ((queuelen (length queuelst)))
    (if (> queuelen max-queue-len)
	(set! max-queue-len queuelen))
    (for-each
     (lambda (item)
       (let ((cname (vector-ref item 1))
	     (clcmd (vector-ref item 2))
	     (cdata (vector-ref item 3)))
	 (send-message pub cname send-more: #t)
	 (send-message pub (case clcmd
			     ((sync)
			      (conc queuelen))
			     ((set)
			      (set! total-db-accesses (+ total-db-accesses 1))
			      (apply execute db "INSERT OR REPLACE INTO vars (var,val) VALUES (?,?);" (string-split cdata))
			      "ok")
			     ((get)
			      (set! total-db-accesses (+ total-db-accesses 1))
			      (let ((res "noval"))
				(for-each-row
				 (lambda (val)
				   (set! res val))
				 db 
				 "SELECT val FROM vars WHERE var=?;" cdata)
				res))
			     (else (conc "unk cmd: " clcmd))))))
     queuelst)))

(define th1 (make-thread 
	     (lambda ()
	       (let ((last-run 0)) ;; current-seconds when run last
		 (let loop ((queuelst '()))
		   (let* ((indat (receive-message* pull))
			  (parts (string-split indat ":"))
			  (cname (car parts))                   ;; client name
			  (clcmd (string->symbol (cadr parts))) ;; client cmd
			  (cdata (caddr parts))                 ;; client data
			  (svect (vector (current-seconds) cname clcmd cdata))) ;; record for the queue
		     (count-client db cname)
		     (case clcmd
		       ((sync) ;; just process the queue
			(print "Got sync from " cname)
			(process-queue (cons svect queuelst))
			(loop '()))
		       ((get)
			(process-queue (cons svect queuelst))
			(loop '()))
		       (else
			(loop (cons svect queuelst))))))))
	     "server thread"))

(include "mockupclientlib.scm")

;; ;; send a sync to the pull port
;; (define th2 (make-thread
;; 	     (lambda ()
;; 	       (let ((last-action-time (current-seconds)))
;; 		 (let loop ()
;; 		   (thread-sleep! 5)
;; 		   (let ((queuelen (string->number (dbaccess "server" 'sync "nada" #f)))
;; 			 (last-action-delta #f))
;; 		     (if (> queuelen 1)(set! last-action-time (current-seconds)))
;; 		     (set! last-action-delta (- (current-seconds) last-action-time))
;; 		     (print "Server: Got queuelen=" queuelen ", last-action-delta=" last-action-delta)
;; 		     (if (< last-action-delta 60)
;; 			 (loop)
;; 			 (print "Server exiting, 25 seconds since last access"))))))
;; 	     "sync thread"))

(handle-not-found 
 

(thread-start! th1)
(thread-start! th2)
(thread-join! th2)

(let* ((run-time       (- (current-seconds) start-time))
       (queries/second (/  total-db-accesses run-time)))
  (print "Server exited! Total db accesses=" total-db-accesses " in " run-time " seconds for " queries/second " queries/second with max queue length of: " max-queue-len))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































Deleted testhttp/testclient.scm version [4aba6dc5d5].

1
2
3
4
5
6
7
8
(use http-client)

(with-input-from-request "http://localhost:12345/hey"
                                           ;; #f
                                           ;; msg 
                                           (list (cons 'dat "Testing eh"))
                                           read-string)

<
<
<
<
<
<
<
<
















Deleted testhttp/testserver.scm version [02c28bc9cb].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
(use spiffy uri-common intarweb spiffy-request-vars)

(root-path "/var/www")

(vhost-map `(((* any) . ,(lambda (continue)
                           (let (($ (request-vars source: 'both)))
			     (print ($ 'dat))
			     (if (equal? (uri-path (request-uri (current-request))) 
					 '(/ "hey"))
				 (send-response body: "hey there!\n"
						headers: '((content-type text/plain)))
				 (continue)))))))

(start-server port: 12345)


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































Deleted testnanomsg/basic-req-rep.scm version [1436c827c9].

1
2
3
(use nanomsg srfi-18 sqlite3 numbers)

(define resp (nn-socket 'rep))
<
<
<






Deleted testnanomsg/mockupclient.scm version [63a8c6685a].

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
(use zmq posix numbers)

(define cname "Bob")
(define runtime 10)
(let ((args (argv)))
  (if (< (length args) 3)
      (begin
	(print "Usage: mockupclient clientname runtime")
	(exit))
      (begin
	(set! cname (cadr args))
	(set! runtime (string->number (caddr args))))))
      
;; (define start-delay (/ (random 100) 9))
;; (define runtime     (+ 1 (/ (random 200) 2)))

(print "Starting client " cname " with runtime " runtime)

(include "mockupclientlib.scm")

(set! endtime (+ (current-seconds) runtime))

;; first ping the server to ensure we have a connection
(if (server-ping cname 5)
    (print "SUCCESS: Client " cname " connected to server")
    (begin
      (print "ERROR: Client " cname " failed ping of server, exiting")
      (exit)))

(let loop ()
  (let ((x (random 15))
	(varname (list-ref (list "hello" "goodbye" "saluton" "kiaorana")(random 4))))
    (case x
      ;; ((1)(dbaccess cname 'sync "nodat"    #f))
      ((2 3 4 5)(dbaccess cname 'set varname (random 999)))
      ((6 7 8 9 10)(print cname ": Get \"" varname "\" " (dbaccess cname 'get varname #f)))
      (else
       (thread-sleep! 0.011)))
    (if (< (current-seconds) endtime)
	(loop))))

(print "Client " cname " all done!!")
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































Deleted testnanomsg/mockupclientlib.scm version [3b245ba7a9].

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
(define reqs (nn-socket 'req))

(connect-socket reqs "tcp://localhost:6563")

(thread-sleep! 0.2)

(define (server-ping cname timeout)
  (let ((msg     (conc cname ":ping:" timeout))
	(maxtime (+ (current-seconds) timeout)))
    (print "pinging server from " cname " with timeout " timeout)
    (let loop ((res   #f))
      (if (< maxtime (current-seconds))
	  #f ;; failed to ping
	  (if (equal? res "Got ping")
	      #t
	      (begin
		(print "Ping received from server " res)
		(send-message push msg)
		(thread-sleep! 0.1)
		(loop (receive-message sub non-blocking: #t))))))))
  
(define (dbaccess cname cmd var val #!key (numtries 20))
  (let* ((msg (conc cname ":" cmd ":" (if val (conc var " " val) var)))
	 (res #f)
	 (mtx1 (make-mutex))
	 (do-access (lambda ()
		      (let ((tmpres #f))
			(print "Sending msg: " msg)
			(send-message push msg)
			(print "Message " msg " sent")
			(print "Client " cname " waiting for response to " msg)
			(print "Client " cname " received address " (receive-message* sub))
			(set! tmpres (receive-message* sub))
			(mutex-lock! mtx1)
			(set! res tmpres)
			(mutex-unlock! mtx1))))
	 (th1 (make-thread do-access "do access"))
	 (th2 (make-thread (lambda ()
			     (let ((result #f))
			       (mutex-lock! mtx1)
			       (set! result res)
			       (mutex-unlock! mtx1)
			       (thread-sleep! 5)
			       (if (not result)
				   (if (> numtries 0)
				       (begin
					 (print "WARNING: access timed out for " cname ", trying again. Trys remaining=" numtries)
					 (dbaccess cname cmd var val numtries: (- numtries 1)))
				       (begin
					 (print "ERROR: dbaccess timed out. Exiting")
					 (exit)))))
			     "timeout thread"))))
    (thread-start! th1)
    (thread-start! th2)
    (thread-join! th1)
    (if res (print "SUCCESS: received " res " with " numtries " remaining possible attempts"))
    res))

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































Deleted testnanomsg/mockupserver.scm version [a4d3e5594c].

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
;; pub/sub with envelope address
;; Note that if you don't insert a sleep, the server will crash with SIGPIPE as soon
;; as a client disconnects.  Also a remaining client may receive tons of
;; messages afterward.

(use nanomsg srfi-18 sqlite3 numbers)

(define resp (nn-socket 'rep))
(define cname "server")
(define total-db-accesses 0)
(define start-time (current-seconds))

(nn-bind resp  "tcp://*:6563")

(thread-sleep! 0.2)

(define (open-db)
  (let* ((dbpath    "mockup.db")
	 (dbexists  (file-exists? dbpath))
	 (db        (open-database dbpath)) ;; (never-give-up-open-db dbpath))
	 (handler   (make-busy-timeout 10)))
    (set-busy-handler! db handler)
    (if (not dbexists)
	(for-each
	 (lambda (stmt)
	   (execute db stmt))
	 (list
	  "PRAGMA SYNCHRONOUS=0;"
	  "CREATE TABLE clients (id INTEGER PRIMARY KEY,name TEXT,num_accesses INTEGER DEFAULT 0);"
	  "CREATE TABLE vars    (var TEXT,val TEXT,CONSTRAINT vars_constraint UNIQUE (var));")))
    db))

(define cid-cache (make-hash-table))

(define (get-client-id db cname)
  (let ((cid (hash-table-ref/default cid-cache cname #f)))
    (if cid 
	cid
	(begin
	  (execute db "INSERT OR REPLACE INTO clients (name) VALUES(?);" cname)
	  (for-each-row 
	   (lambda (id)
	     (set! cid id))
	   db
	   "SELECT id FROM clients WHERE name=?;" cname)
	  (hash-table-set! cid-cache cname cid)
	  (set! total-db-accesses (+ total-db-accesses 2))
	  cid))))

(define (count-client db cname)
  (let ((cid (get-client-id db cname)))
    (execute db "UPDATE clients SET num_accesses=num_accesses+1 WHERE id=?;" cid)
    (set! total-db-accesses (+ total-db-accesses 1))
    ))

(define db (open-db))
;; (define queuelst '())
;; (define mx1 (make-mutex))

(define max-queue-len 0)

(define (process-queue queuelst)
  (let ((queuelen (length queuelst)))
    (if (> queuelen max-queue-len)
	(set! max-queue-len queuelen))
    (for-each
     (lambda (item)
       (let ((cname (vector-ref item 1))
	     (clcmd (vector-ref item 2))
	     (cdata (vector-ref item 3)))
	 (send-message pub cname send-more: #t)
	 (send-message pub (case clcmd
			     ((sync)
			      (conc queuelen))
			     ((set)
			      (set! total-db-accesses (+ total-db-accesses 1))
			      (apply execute db "INSERT OR REPLACE INTO vars (var,val) VALUES (?,?);" (string-split cdata))
			      "ok")
			     ((get)
			      (set! total-db-accesses (+ total-db-accesses 1))
			      (let ((res "noval"))
				(for-each-row
				 (lambda (val)
				   (set! res val))
				 db 
				 "SELECT val FROM vars WHERE var=?;" cdata)
				res))
			     (else (conc "unk cmd: " clcmd))))))
     queuelst)))

;; SERVER THREAD
(define th1 (make-thread 
	     (lambda ()
	       (let ((last-run 0)) ;; current-seconds when run last
		 (let loop ((queuelst '()))
		   (let* ((indat (receive-message* pull))
			  (parts (string-split indat ":"))
			  (cname (car parts))                   ;; client name
			  (clcmd (string->symbol (cadr parts))) ;; client cmd
			  (cdata (caddr parts))                 ;; client data
			  (svect (vector (current-seconds) cname clcmd cdata))) ;; record for the queue
		     ;; (print "Server received message: " indat)
		     (count-client db cname)
		     (case clcmd
		       ((ping)
			(print "Got ping from " cname)
			(send-message pub cname send-more: #t)
			(send-message pub "Got ping")
			(loop queuelst))
		       ((sync) ;; just process the queue
			(print "Got sync from " cname)
			(process-queue (cons svect queuelst))
			(loop '()))
		       ((get)
			(process-queue (cons svect queuelst))
			(loop '()))
		       (else
			(loop (cons svect queuelst))))))))
	     "server thread"))

(include "mockupclientlib.scm")

;; SYNC THREAD
;; send a sync to the pull port
(define th2 (make-thread
	     (lambda ()
	       (let ((last-action-time (current-seconds)))
		 (let loop ()
		   (thread-sleep! 5)
		   (let ((queuelen (string->number (dbaccess "server" 'sync "nada" #f)))
			 (last-action-delta #f))
		     (if (> queuelen 1)(set! last-action-time (current-seconds)))
		     (set! last-action-delta (- (current-seconds) last-action-time))
		     (print "Server: Got queuelen=" queuelen ", last-action-delta=" last-action-delta)
		     (if (< last-action-delta 60)
			 (loop)
			 (print "Server exiting, 25 seconds since last access"))))))
	     "sync thread"))

(thread-start! th1)
(thread-start! th2)
(thread-join! th2)

(let* ((run-time       (- (current-seconds) start-time))
       (queries/second (/  total-db-accesses run-time)))
  (print "Server exited! Total db accesses=" total-db-accesses " in " run-time " seconds for " queries/second " queries/second with max queue length of: " max-queue-len))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































Deleted testnanomsg/pipeline.scm version [1d4d831eb6].

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
;; watch nanomsg's pipeline load-balancer in action.
(use nanomsg)

(define push (nn-socket 'push))
(define pull1 (nn-socket 'pull))
(define pull2 (nn-socket 'pull))

(nn-bind    push  "inproc://test")
(nn-connect pull1 "inproc://test")
(nn-connect pull2 "inproc://test")

(nn-send push "a")
(nn-send push "b")
(nn-send push "c")
(nn-send push "d")

(define ((th sock))
  (print (current-thread) ": " (nn-recv sock))
  (print (current-thread) ": " (nn-recv sock))
  (print (current-thread) " is done"))

(thread-start! (th pull1))
(thread-start! (th pull2))

(thread-sleep! 1)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































Deleted testnanomsg/req-rep-client.scm version [62cc97e2a5].

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
;; watch nanomsg's pipeline load-balancer in action.
(use nanomsg posix regex)

(define req   (nn-socket 'req))

(nn-connect req  "tcp://localhost:22022")

;; (with-output-to-string (lambda ()(serialize obj)))
(define (client-send-receive soc msg)
  (nn-send soc msg)
  (nn-recv soc))

(define ((talk-to-server soc))
  (let loop ((cnt 200000))
    (let ((name (list-ref '("Matt" "Tom" "Bob" "Jill" "James" "Jane")(random 6))))
      ;; (print "Sending " name)
      ;; (print
      (client-send-receive req name) ;; )
      (if (> cnt 0)(loop (- cnt 1)))))
  (print (client-send-receive req "quit"))
  (nn-close req)
  (exit))

;; (thread-start! (lambda ()
;; 		 (thread-sleep! 20)
;; 		 (print "Give up on waiting for the server")
;; 		 (nn-close req)
;; 		 (exit)))

(thread-join! (thread-start! (talk-to-server req)))

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































Deleted testnanomsg/req-rep-server.scm version [7ffb9a9d45].

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
;; watch nanomsg's pipeline load-balancer in action.
(use nanomsg posix regex)

;; (use trace)
;; (trace nn-bind nn-socket nn-assert nn-recv nn-send thread-terminate! nn-close )

(define port  22022)
(define host  "127.0.0.1")

(define rep   (nn-socket 'rep))

(print "connecting, got: " (nn-bind    rep  (conc "tcp://" "*" ":" port)))

(define (server soc)
  (print "server starting")
  (let loop ((msg-in (nn-recv soc))
	     (count  0))
    (if (eq? 0 (modulo count 1000))
	(print "server received: " msg-in ", count=" count))
    (cond
     ((equal? msg-in "quit")
      (nn-send soc "Ok, quitting"))
     ((and (>= (string-length msg-in) 4)
	   (equal? (substring msg-in 0 4) "ping"))
      (nn-send soc (conc (current-process-id)))
      (loop (nn-recv soc)(+ count 1)))
     ;;((and (>= (string-length msg-in)
     (else
      (let ((this-task  (/ (random 10) 200.0))
	    (start-time (current-milliseconds)))
	;; (thread-sleep! this-task)
	(nn-send soc (conc "hello " msg-in " this task took " this-task " seconds to complete"))
	;; (print "Actual send-receive time: " (- (current-milliseconds) start-time));
	(loop (nn-recv soc)(+ count 1)))))))

(define (ping-self host port #!key (return-socket #t))
  ;; send a random number along with pid and check that we get it back
  (let* ((req     (nn-socket 'req))
	 (key     "ping")
	 (success #f)
	 (keepwaiting #t)
	 (ping    (make-thread
		   (lambda ()
		     (print "ping: sending string \"" key "\", expecting " (current-process-id))
		     (nn-send req key)
		     (let ((result  (nn-recv req)))
		       (if (equal? (conc (current-process-id)) result)
			   (begin
			     (print "ping, success: received \"" result "\"")
			     (set! success #t))
			   (begin
			     (print "ping, failed: received key \"" result "\"")
			     (set! keepwaiting #f)
			     (set! success #f)))))
		   "ping"))
	 (timeout (make-thread (lambda ()
				 (let loop ((count 0))
				   (thread-sleep! 1)
				   (print "still waiting after count seconds...")
				   (if (and keepwaiting (< count 10))
				       (loop (+ count 1))))
				 (if keepwaiting
				     (begin
				       (print "timeout waiting for ping")
				       (thread-terminate! ping))))
			       "timeout")))
    (nn-connect req (conc "tcp://" host ":" port))
    (handle-exceptions
     exn
     (begin
       (print-call-chain)
       (print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
       (print "exn=" (condition->list exn))
       (print "ping failed to connect to " host ":" port))
     (thread-start! timeout)
     (thread-start! ping)
     (thread-join! ping)
     (if success (thread-terminate! timeout)))
    (if return-socket
	(if success req #f)
	(begin
	  (nn-close req)
	  success))))

(let ((server-thread (make-thread (lambda ()(server rep)) "server")))
  (thread-start! server-thread)
  ;; (thread-sleep! 1)
  (if (ping-self host port)
      (begin
	(thread-join! server-thread)
	(nn-close rep))
      (print "ping failed")))

(exit)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































Deleted testnanomsg/req-rep.scm version [4b0d8cd65b].

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
;; watch nanomsg's pipeline load-balancer in action.
(use nanomsg)

;; client
(define req   (nn-socket 'req))
(nn-connect req  "inproc://test") 

(define (client-send-receive soc msg)
  (nn-send soc msg)
  (nn-recv soc))

;; server
(define rep   (nn-socket 'rep))
(nn-bind    rep  "inproc://test")

(define ((server soc))
  (let loop ((msg-in (nn-recv soc)))
    (if (not (equal? msg-in "quit"))
	(begin
	  (nn-send soc (conc "hello " msg-in))
	  (loop (nn-recv soc))))))

(thread-start! (server rep))

;; client 
(print (client-send-receive req "Matt"))
(print (client-send-receive req "Tom"))

;; (client-send-receive req "quit")

(nn-close req) ;; client
(nn-close rep) ;; server
(exit)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































Deleted testrpc/client.scm version [eacc9c3c29].

1
2
3
4
5
6
7
8
;;;; client.scm
(use rpc posix)

(define call (rpc:procedure 'foo "localhost"))

(do ((i 10 (sub1 i)))
    ((zero? i))
  (print "-> " (call (random 100))))
<
<
<
<
<
<
<
<
















Deleted testrpc/server.scm version [d4d2e05e92].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
;;;; server.scm
(use rpc)

(rpc:publish-procedure!
 'foo
 (lambda (x)
   (print "foo: " x)
   #f))

(rpc:publish-procedure!
 'fini
 (lambda () (print "fini") (thread-start! (lambda () (thread-sleep! 3) (print "terminate") (exit))) #f))

((rpc:make-server (tcp-listen (rpc:default-server-port))) #t)

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























Modified tests/fdktestqa/fdk.config from [1449c69529] to [42bf4ada3c].

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
[fields]
SYSTEM TEXT
RELEASE TEXT

[setup]
# Adjust max_concurrent_jobs to limit how much you load your machines
# max_concurrent_jobs 150
max_concurrent_jobs 1000

# This is your link path, you can move it but it is generally better to keep it stable
linktree #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/../simplelinks}

[include testqa/configs/megatest.abc.config]

# timeout 0.025

[jobtools]
maxload 4

launcher nbfake


[server]
# timeout 0.01
# homehost xena
# homehost 143.182.225.38

# force server
server-query-threshold 0


[jobtools]
# launcher nbq -P ch_vp -C SLES11_EM64T_4G -Q /ciaf/fdk
launcher nbfake
maxload 4

# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log 








|






<
<


>
|
>





<

|


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







[fields]
SYSTEM TEXT
RELEASE TEXT

[setup]
# Adjust max_concurrent_jobs to limit how much you load your machines
# max_concurrent_jobs 150
max_concurrent_jobs 3000

# This is your link path, you can move it but it is generally better to keep it stable
linktree #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/../simplelinks}

[include testqa/configs/megatest.abc.config]



[jobtools]
maxload 4
# launcher smartlauncher --cores 1 --memory 1
launcher nbjob run --target pdx_soft --class 'SLES11&&1C&&1G' --qslot /icf/fdk/soft 
# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log 

[server]
# timeout 0.01
# homehost xena
# homehost 143.182.225.38

# force server
# server-query-threshold 0









Modified tests/fdktestqa/testqa/Makefile from [f65c4da07e] to [d6828dd3fb].

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
BINDIR    = $(PWD)/../../../bin
PATH     := $(BINDIR):$(PATH)
MEGATEST  = $(BINDIR)/megatest
DASHBOARD = $(BINDIR)/dashboard
NEWDASHBOARD = $(BINDIR)/newdashboard
RUNNAME   = a
NUMTESTS  = 20


all :
	$(MEGATEST) -remove-runs -target a/b -runname c -testpatt %/%
	$(MEGATEST) -run -testpatt % -target a/b -runname c

bigbig :
	for tn in a b c d;do \
	   ($(MEGATEST) -run -testpatt % -target a/b -runname $tn & ) ; \
	done

waitonpatt :
	megatest -remove-runs -runname waitonpatt -target a/b -testpatt %
	NUMTESTS=15 megatest -run -target a/b -runname waitonpatt -testpatt bigrun3/%8

waitonall :
	megatest -remove-runs -runname waitonall -target a/b -testpatt %
	NUMTESTS=20 megatest -run -target a/b -runname waitonall -testpatt alltop

bigrun :







>







|



|







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
BINDIR    = $(PWD)/../../../bin
PATH     := $(BINDIR):$(PATH)
MEGATEST  = $(BINDIR)/megatest
DASHBOARD = $(BINDIR)/dashboard
NEWDASHBOARD = $(BINDIR)/newdashboard
RUNNAME   = a
NUMTESTS  = 20
SUBTARG = b

all :
	$(MEGATEST) -remove-runs -target a/b -runname c -testpatt %/%
	$(MEGATEST) -run -testpatt % -target a/b -runname c

bigbig :
	for tn in a b c d;do \
	   (NUMTESTS=1000 $(MEGATEST) -run -testpatt % -target a/$(SUBTARG) -runname $$tn & ) ; \
	done

waitonpatt :
	megatest -remove-runs -runname waitonpatt -target a/$(SUBTARG) -testpatt %
	NUMTESTS=15 megatest -run -target a/b -runname waitonpatt -testpatt bigrun3/%8

waitonall :
	megatest -remove-runs -runname waitonall -target a/b -testpatt %
	NUMTESTS=20 megatest -run -target a/b -runname waitonall -testpatt alltop

bigrun :

Modified tests/fdktestqa/testqa/megatest.config from [96a4d22c9d] to [39f7a70093].

1
2
3
4




5
6
7
8
9
10
11
12
13
14
15
16
17
18
[setup]
testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log
# launchwait no
launch-delay 0.1





[server]
# runtime 180
# timeout is in hours, this is how long the server will stay alive when not being used.
timeout 0.1

# All these are overridden in ../fdk.config
# [jobtools]
# launcher nbfake
# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log 

[include ../fdk.config]

[include local.config]



|
>
>
>
>




|









1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
[setup]
testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log
# launchwait no
# launch-delay 0.1
launch-delay 0

[jobtools]
maxhomehostload 4

[server]
# runtime 180
# timeout is in hours, this is how long the server will stay alive when not being used.
# timeout 0.1

# All these are overridden in ../fdk.config
# [jobtools]
# launcher nbfake
# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log 

[include ../fdk.config]

[include local.config]

Modified tests/fdktestqa/testqa/runconfigs.config from [346ed47154] to [69a81e5b8c].



1
2
3
4
5
6


[default]
ALLTESTS see this variable

# Your variables here are grouped by targets [SYSTEM/RELEASE]
[SYSTEM_val/RELEASE_val]
ANOTHERVAR only defined if target is SYSTEM_val/RELEASE_val
>
>






1
2
3
4
5
6
7
8
[include local.runconfigs]

[default]
ALLTESTS see this variable

# Your variables here are grouped by targets [SYSTEM/RELEASE]
[SYSTEM_val/RELEASE_val]
ANOTHERVAR only defined if target is SYSTEM_val/RELEASE_val

Deleted testzmq/hwclient.scm version [2bca7d9a69].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
(use zmq posix srfi-18)

(define s (make-socket 'req))
(connect-socket s "tcp://*:5563")

(define myname (cadr (argv)))

(print "Start client...")

(do ((i 0 (+ i 1)))
    ((>= i 1000))
  (print "sending message #" i)
  (send-message s (conc "Hello from " myname))
  (print "sent \"Hello\", looking for a reply")
  (printf "Received reply ~a [~a]\n"
          i (receive-message s)))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































Deleted testzmq/hwserver.scm version [d8d9994146].

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
(use zmq srfi-18 posix)

(define th1 (make-thread 
	     (lambda ()
	       (let ((s (make-socket 'rep)))
		 (bind-socket s "tcp://*:5563")
		 (print "Start server...")
		 (let loop ()
		   (let* ((msg  (receive-message s))
			  (name (caddr (string-split msg " ")))
			  (resp (conc "World " name)))
		     (print "Received request: [" msg "]")
		     (thread-sleep! 0.0001)
		     (print "Sending response \"" resp "\"")
		     (send-message s resp)
		     (loop)))))))
(define th2 (make-thread
	     (lambda ()
	       (let loop ((count 0))
		 (print "count is " count)
		 (thread-sleep! 0.1)
		 (if (< count 10000)
		     (loop (+ count 1)))))))

(thread-start! th1)
(thread-start! th2)

(thread-join! th1)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































Deleted testzmq/hwtest.sh version [aa5368d04d].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
#!/bin/bash

echo Compiling hwclient and hwserver
csc hwclient.scm
csc hwserver.scm

./hwserver > hwserver.log &

sleep 1
for x in a b c d e f g h i j k l m n o p q r s t u v w x y z;do
./hwclient $x &
done

# killall -v hwserver hwclient
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























Deleted testzmq/mockupclient.scm version [63a8c6685a].

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
(use zmq posix numbers)

(define cname "Bob")
(define runtime 10)
(let ((args (argv)))
  (if (< (length args) 3)
      (begin
	(print "Usage: mockupclient clientname runtime")
	(exit))
      (begin
	(set! cname (cadr args))
	(set! runtime (string->number (caddr args))))))
      
;; (define start-delay (/ (random 100) 9))
;; (define runtime     (+ 1 (/ (random 200) 2)))

(print "Starting client " cname " with runtime " runtime)

(include "mockupclientlib.scm")

(set! endtime (+ (current-seconds) runtime))

;; first ping the server to ensure we have a connection
(if (server-ping cname 5)
    (print "SUCCESS: Client " cname " connected to server")
    (begin
      (print "ERROR: Client " cname " failed ping of server, exiting")
      (exit)))

(let loop ()
  (let ((x (random 15))
	(varname (list-ref (list "hello" "goodbye" "saluton" "kiaorana")(random 4))))
    (case x
      ;; ((1)(dbaccess cname 'sync "nodat"    #f))
      ((2 3 4 5)(dbaccess cname 'set varname (random 999)))
      ((6 7 8 9 10)(print cname ": Get \"" varname "\" " (dbaccess cname 'get varname #f)))
      (else
       (thread-sleep! 0.011)))
    (if (< (current-seconds) endtime)
	(loop))))

(print "Client " cname " all done!!")
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































Deleted testzmq/mockupclientlib.scm version [1577031d21].

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
(define sub  (make-socket 'sub))
(define push (make-socket 'push))
(socket-option-set! sub 'subscribe cname)
(socket-option-set! sub 'hwm 1000)
(socket-option-set! push 'hwm 1000)

(connect-socket sub "tcp://localhost:6563")
(connect-socket push "tcp://localhost:6564")

(thread-sleep! 0.2)

(define (server-ping cname timeout)
  (let ((msg     (conc cname ":ping:" timeout))
	(maxtime (+ (current-seconds) timeout)))
    (print "pinging server from " cname " with timeout " timeout)
    (let loop ((res   #f))
      (if (< maxtime (current-seconds))
	  #f ;; failed to ping
	  (if (equal? res "Got ping")
	      #t
	      (begin
		(print "Ping received from server " res)
		(send-message push msg)
		(thread-sleep! 0.1)
		(loop (receive-message sub non-blocking: #t))))))))
  
(define (dbaccess cname cmd var val #!key (numtries 20))
  (let* ((msg (conc cname ":" cmd ":" (if val (conc var " " val) var)))
	 (res #f)
	 (mtx1 (make-mutex))
	 (do-access (lambda ()
		      (let ((tmpres #f))
			(print "Sending msg: " msg)
			(send-message push msg)
			(print "Message " msg " sent")
			(print "Client " cname " waiting for response to " msg)
			(print "Client " cname " received address " (receive-message* sub))
			(set! tmpres (receive-message* sub))
			(mutex-lock! mtx1)
			(set! res tmpres)
			(mutex-unlock! mtx1))))
	 (th1 (make-thread do-access "do access"))
	 (th2 (make-thread (lambda ()
			     (let ((result #f))
			       (mutex-lock! mtx1)
			       (set! result res)
			       (mutex-unlock! mtx1)
			       (thread-sleep! 5)
			       (if (not result)
				   (if (> numtries 0)
				       (begin
					 (print "WARNING: access timed out for " cname ", trying again. Trys remaining=" numtries)
					 (dbaccess cname cmd var val numtries: (- numtries 1)))
				       (begin
					 (print "ERROR: dbaccess timed out. Exiting")
					 (exit)))))
			     "timeout thread"))))
    (thread-start! th1)
    (thread-start! th2)
    (thread-join! th1)
    (if res (print "SUCCESS: received " res " with " numtries " remaining possible attempts"))
    res))

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































Deleted testzmq/mockupserver.scm version [f130435054].

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
;; pub/sub with envelope address
;; Note that if you don't insert a sleep, the server will crash with SIGPIPE as soon
;; as a client disconnects.  Also a remaining client may receive tons of
;; messages afterward.

(use zmq srfi-18 sqlite3 numbers)

(define pub (make-socket 'pub))
(define pull (make-socket 'pull))
(define cname "server")
(define total-db-accesses 0)
(define start-time (current-seconds))

(socket-option-set! pub 'hwm 1000)
(socket-option-set! pull 'hwm 1000)

(bind-socket pub "tcp://*:6563")
(bind-socket pull "tcp://*:6564")

(thread-sleep! 0.2)

(define (open-db)
  (let* ((dbpath    "mockup.db")
	 (dbexists  (file-exists? dbpath))
	 (db        (open-database dbpath)) ;; (never-give-up-open-db dbpath))
	 (handler   (make-busy-timeout 10)))
    (set-busy-handler! db handler)
    (if (not dbexists)
	(for-each
	 (lambda (stmt)
	   (execute db stmt))
	 (list
	  "PRAGMA SYNCHRONOUS=0;"
	  "CREATE TABLE clients (id INTEGER PRIMARY KEY,name TEXT,num_accesses INTEGER DEFAULT 0);"
	  "CREATE TABLE vars    (var TEXT,val TEXT,CONSTRAINT vars_constraint UNIQUE (var));")))
    db))

(define cid-cache (make-hash-table))

(define (get-client-id db cname)
  (let ((cid (hash-table-ref/default cid-cache cname #f)))
    (if cid 
	cid
	(begin
	  (execute db "INSERT OR REPLACE INTO clients (name) VALUES(?);" cname)
	  (for-each-row 
	   (lambda (id)
	     (set! cid id))
	   db
	   "SELECT id FROM clients WHERE name=?;" cname)
	  (hash-table-set! cid-cache cname cid)
	  (set! total-db-accesses (+ total-db-accesses 2))
	  cid))))

(define (count-client db cname)
  (let ((cid (get-client-id db cname)))
    (execute db "UPDATE clients SET num_accesses=num_accesses+1 WHERE id=?;" cid)
    (set! total-db-accesses (+ total-db-accesses 1))
    ))

(define db (open-db))
;; (define queuelst '())
;; (define mx1 (make-mutex))

(define max-queue-len 0)

(define (process-queue queuelst)
  (let ((queuelen (length queuelst)))
    (if (> queuelen max-queue-len)
	(set! max-queue-len queuelen))
    (for-each
     (lambda (item)
       (let ((cname (vector-ref item 1))
	     (clcmd (vector-ref item 2))
	     (cdata (vector-ref item 3)))
	 (send-message pub cname send-more: #t)
	 (send-message pub (case clcmd
			     ((sync)
			      (conc queuelen))
			     ((set)
			      (set! total-db-accesses (+ total-db-accesses 1))
			      (apply execute db "INSERT OR REPLACE INTO vars (var,val) VALUES (?,?);" (string-split cdata))
			      "ok")
			     ((get)
			      (set! total-db-accesses (+ total-db-accesses 1))
			      (let ((res "noval"))
				(for-each-row
				 (lambda (val)
				   (set! res val))
				 db 
				 "SELECT val FROM vars WHERE var=?;" cdata)
				res))
			     (else (conc "unk cmd: " clcmd))))))
     queuelst)))

;; SERVER THREAD
(define th1 (make-thread 
	     (lambda ()
	       (let ((last-run 0)) ;; current-seconds when run last
		 (let loop ((queuelst '()))
		   (let* ((indat (receive-message* pull))
			  (parts (string-split indat ":"))
			  (cname (car parts))                   ;; client name
			  (clcmd (string->symbol (cadr parts))) ;; client cmd
			  (cdata (caddr parts))                 ;; client data
			  (svect (vector (current-seconds) cname clcmd cdata))) ;; record for the queue
		     ;; (print "Server received message: " indat)
		     (count-client db cname)
		     (case clcmd
		       ((ping)
			(print "Got ping from " cname)
			(send-message pub cname send-more: #t)
			(send-message pub "Got ping")
			(loop queuelst))
		       ((sync) ;; just process the queue
			(print "Got sync from " cname)
			(process-queue (cons svect queuelst))
			(loop '()))
		       ((get)
			(process-queue (cons svect queuelst))
			(loop '()))
		       (else
			(loop (cons svect queuelst))))))))
	     "server thread"))

(include "mockupclientlib.scm")

;; SYNC THREAD
;; send a sync to the pull port
(define th2 (make-thread
	     (lambda ()
	       (let ((last-action-time (current-seconds)))
		 (let loop ()
		   (thread-sleep! 5)
		   (let ((queuelen (string->number (dbaccess "server" 'sync "nada" #f)))
			 (last-action-delta #f))
		     (if (> queuelen 1)(set! last-action-time (current-seconds)))
		     (set! last-action-delta (- (current-seconds) last-action-time))
		     (print "Server: Got queuelen=" queuelen ", last-action-delta=" last-action-delta)
		     (if (< last-action-delta 60)
			 (loop)
			 (print "Server exiting, 25 seconds since last access"))))))
	     "sync thread"))

(thread-start! th1)
(thread-start! th2)
(thread-join! th2)

(let* ((run-time       (- (current-seconds) start-time))
       (queries/second (/  total-db-accesses run-time)))
  (print "Server exited! Total db accesses=" total-db-accesses " in " run-time " seconds for " queries/second " queries/second with max queue length of: " max-queue-len))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































Deleted testzmq/random.scm version [7090f9f44f].

1
2
3
4
5
6
7
8
(use posix numbers)
(randomize (inexact->exact (current-seconds)))

(define low (string->number (cadr (argv))))
(define hi  (string->number (caddr (argv))))

(print (+ low (random (- hi low))))

<
<
<
<
<
<
<
<
















Deleted testzmq/testmockup.sh version [8905872c25].

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
#!/bin/bash

rm -f mockup.db

echo Compiling mockupserver.scm and mockupclient.scm

# Clean up first
killall mockupserver mockupclient -v

csc random.scm
csc mockupserver.scm
csc mockupclient.scm

echo Starting server
./mockupserver &

sleep 1

rm -f mockupclients.log

echo Starting clients
for i in a b c d e f g h i j k l m n o p q s t u v w x y z; 
  do
  for k in a b;
    do
    for j in 0 1 2 3 4 5 6 7 8 9;
      do
      waittime=`./random 0 60`
      runtime=`./random 5 120`
      echo "Starting client $i$k$j with waittime $waittime and runtime $runtime" 
      (sleep $waittime;./mockupclient $i$k$j $runtime) &
      # >> mockupclients.log &
    done
  done
done

wait
echo testmockup.sh script done
# echo "Waiting for 5 seconds then killing all mockupserver and mockupclient processes"
# sleep 30
# killall -v mockupserver mockupclient
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































Modified utils/cleanup-pkts.sh from [8b0ea2d6b7] to [4166ea994c].

1
2
3
4
5
6
7
8
9
10
11
12
#!/bin/bash

pushd $1

for x in *.pkt;do
    if grep 'T configf' $x > /dev/null;then
        echo rm $x
    else
        echo skip $x
    fi
done







|





1
2
3
4
5
6
7
8
9
10
11
12
#!/bin/bash

pushd $1

for x in *.pkt;do
    if grep 'T configf' $x > /dev/null;then
        rm $x
    else
        echo skip $x
    fi
done