Megatest

Changes On Branch 8a73112be852c6b8
Login

Changes In Branch v1.6569-diet Excluding Merge-Ins

This is equivalent to a diff from 2769e4b7c9 to 8a73112be8

2021-03-01
17:42
Manually patched in the new view check-in: f5206150ee user: mrwellan tags: v1.6569-new-view
2021-01-26
14:00
Fix for the > crash. Maybe... Leaf check-in: 5a05fc04ff user: matt tags: v1.6569-gt-crash-fix
2021-01-25
12:03
rebased lazy-queue rollup check-in: 07ab120544 user: matt tags: v1.65-lazyqueue-items-rollup
2021-01-18
15:22
Merged diet2 and fixed wrong use of optional (should be key). Closed-Leaf check-in: 8a73112be8 user: matt tags: v1.6569-diet
11:10
Repaired some rmt:get-preq calls. ==1.08/0.44/1205/PASS/mars== check-in: f5ecefc579 user: matt tags: v1.65-diet2
2021-01-16
23:19
Moved sauth and datashare files to appropriate subdirs, commented couple more unused functions. check-in: 155720494a user: matt tags: v1.6569-diet
2021-01-15
22:46
begin diet check-in: badd71f3b3 user: matt tags: v1.6569-diet
21:34
eval-string-in-environment if was disabled, re-enabled check-in: 9564772564 user: matt tags: v1.6569-reenable-eval-if
2021-01-08
11:42
enable custom value for max delay between archive time and test last update time Leaf check-in: 86a3d1148e user: pjhatwal tags: v1.6569-refactor
2020-11-25
12:00
Fixed issues in server gating code Leaf check-in: 063273e8cb user: mrwellan tags: v1.6569-server-gate-fix
2020-11-24
22:27
Added support for resetting run - allows to reload tests-paths to add tests to a run part way though. Just run megatest -clean-cache -runname $MT_RUNNAME Leaf check-in: 213021e02d user: mrwellan tags: v1.6596-reload-tests-paths
2020-10-13
16:46
Changed version from 69 to 76. No other changes. Will compile with chicken 13 check-in: 87ca35010f user: mmgraham tags: v1.65, v1.6576
2020-10-12
16:49
Reduced message from failed to info. Reverted a delay which seems to help pass full stack ext-tests. Leaf check-in: 9e35b1252c user: mrwellan tags: v1.65-minor-patch
10:18
Safe vector access in rmt. check-in: 58bb6d997a user: mrwellan tags: v1.65-side2
2020-10-11
22:46
Patched forward adjutant code. check-in: f936717bfa user: matt tags: v1.65-adjutant-again
2020-10-05
22:49
Do not exit on failure to create directory - race conditons on NFS cause false fail scenarios - just keep going and cross your fingers... (cherrypicked from v1.6572) check-in: 05b253a452 user: matt tags: v1.65-sidework
22:46
run duration testdat check-in: 4a0b43f3c6 user: matt tags: v1.65-test-rundat2
2020-09-21
15:36
merged in 1.65-test-rundat branch ==/FAIL/orion,mars/== check-in: cfd25d66e9 user: mmgraham tags: v1.6571, v1.65-failed-testdat
07:00
Added get-testsuite-name all over launch:setup and still not set when needed! This did NOT work. Closed-Leaf check-in: 2efe8ad422 user: mrwellan tags: v1.65-get-testsuitename
2020-09-19
04:21
Start moving test_rundat to no-sync db. ==/20/2/WARN/1203/mars/== check-in: abfabdb839 user: matt tags: v1.65-test-rundat
2020-09-18
17:30
added check for file existence before file delete ==/14/1.9/WARN/orion,mars/== NOTE: This is the last v1.65 before the split off. I.e code from before this point IS in the far future v1.65 branch. Code from this point to that branch might NOT be in the branch. check-in: 2769e4b7c9 user: mmgraham tags: v1.65, v1.6569
12:27
cherry picked 2 fixes, changed version to 1.6569 ==/7.2/2.0/PASS/1201/mars/== check-in: d145d0eb02 user: mmgraham tags: v1.65

Modified Makefile from [0dc94ad098] to [1550d5f6a0].

20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
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		\
           process.scm runs.scm tasks.scm tests.scm genexample.scm	\
           http-transport.scm filedb.scm tdb.scm client.scm mt.scm	\
           ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm		\
           subrun.scm portlogger.scm archive.scm env.scm		\
           diff-report.scm cgisetup/models/pgdb.scm

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

GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\
          dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm	\
          vg.scm







|
|





|







20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
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		\
           process.scm runs.scm tasks.scm tests.scm genexample.scm	\
           http-transport.scm tdb.scm client.scm mt.scm	\
           ezsteps.scm sdb.scm rmt.scm api.scm		\
           subrun.scm portlogger.scm archive.scm env.scm		\
           diff-report.scm cgisetup/models/pgdb.scm

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

GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\
          dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm	\
          vg.scm
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
	configf.o \
	db.o \
	env.o \
	http-transport.o \
	items.o \
	keys.o \
	launch.o \
	lock-queue.o \
	margs.o \
	mt.o \
	ods.o \
	portlogger.o \
	process.o \
	rmt.o \
	runconfig.o \







<







106
107
108
109
110
111
112

113
114
115
116
117
118
119
	configf.o \
	db.o \
	env.o \
	http-transport.o \
	items.o \
	keys.o \
	launch.o \

	margs.o \
	mt.o \
	ods.o \
	portlogger.o \
	process.o \
	rmt.o \
	runconfig.o \
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

# common.o : mofiles/commonmod.o megatest-fossil-hash.scm

# commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm

tests.o db.o launch.o runs.o dashboard-tests.o				\
dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o	\
monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm

tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o  : run_records.scm

db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm

tests.o tasks.o dashboard-tasks.o : task_records.scm

runs.o : test_records.scm

megatest.o : megatest-fossil-hash.scm megatest-version.scm

rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm

common_records.scm : altdb.scm



# mofiles/stml2.o : mofiles/cookie.o
# configf.o : mofiles/commonmod.o

vg.o dashboard.o : vg_records.scm megatest-version.scm

dcommon.o : run_records.scm







|



|



<
<


|


>
>







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

# common.o : mofiles/commonmod.o megatest-fossil-hash.scm

# commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm

tests.o db.o launch.o runs.o dashboard-tests.o				\
dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o	\
dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm

tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o  : run_records.scm

db.o ezsteps.o keys.o launch.o megatest.o runs-for-ref.o runs.o tests.o : key_records.scm

tests.o tasks.o dashboard-tasks.o : task_records.scm



megatest.o : megatest-fossil-hash.scm megatest-version.scm

rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm

common_records.scm : altdb.scm

runs.o tests.o : test_records.scm

# mofiles/stml2.o : mofiles/cookie.o
# configf.o : mofiles/commonmod.o

vg.o dashboard.o : vg_records.scm megatest-version.scm

dcommon.o : run_records.scm
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
	$(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest
	utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest
	chmod a+x $(PREFIX)/bin/megatest

$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard
	$(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard

$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper
	utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard
	chmod a+x $(PREFIX)/bin/newdashboard

# mtutil

$(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut
	$(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut

install-mtut : mtut
	$(INSTALL) mtut $(PREFIX)/bin/mtut







<
<
<
<







212
213
214
215
216
217
218




219
220
221
222
223
224
225
	$(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest
	utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest
	chmod a+x $(PREFIX)/bin/megatest

$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard
	$(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard





# mtutil

$(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut
	$(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut

install-mtut : mtut
	$(INSTALL) mtut $(PREFIX)/bin/mtut
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
          $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
          $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \
	  $(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \
	  $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \
          $(PREFIX)/share/js/jquery-3.1.0.slim.min.js 
#         $(PREFIX)/bin/.$(ARCHSTR)/ndboard

# $(PREFIX)/bin/newdashboard

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

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







<
<
<







316
317
318
319
320
321
322



323
324
325
326
327
328
329
          $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
          $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \
	  $(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \
	  $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \
          $(PREFIX)/share/js/jquery-3.1.0.slim.min.js 




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

test: tests/tests.scm
	cd tests;csi -I .. -b -n tests.scm
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363

clean : 
	rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS)		\
            $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut	\
            tcmt readline-fix.scm serialize-env dboard *.o		\
            megatest-fossil-hash.* altdb.scm mofiles/*.o                \
            mofiles/*.o vg.o cookie.o dashboard-main.o	                \
            ducttape-lib.o ftail.o mutils.o pkts.o rmtmod.o stml2.o	\
            tcmt.o *.import.scm *.import.o
	rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS)		\
            $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut	\
            tcmt ftail.import.scm readline-fix.scm serialize-env	\
            dboard dboard.o megatest.o dashboard.o			\
            megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o
	rm -rf share

#======================================================================
# Make the records files
#======================================================================







|



|







337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355

clean : 
	rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS)		\
            $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut	\
            tcmt readline-fix.scm serialize-env dboard *.o		\
            megatest-fossil-hash.* altdb.scm mofiles/*.o                \
            mofiles/*.o vg.o cookie.o dashboard-main.o	                \
            ducttape-lib.o mutils.o pkts.o rmtmod.o stml2.o	\
            tcmt.o *.import.scm *.import.o
	rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS)		\
            $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut	\
            tcmt readline-fix.scm serialize-env	\
            dboard dboard.o megatest.o dashboard.o			\
            megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o
	rm -rf share

#======================================================================
# Make the records files
#======================================================================
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
	if  csi -ne '(use mysql-client)';then \
           echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
	fi
	if csi -ne '(use postgresql)';then \
	   echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
	fi

portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
	csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o

# create a pdf dot graphviz diagram from notations in rmt.scm
rmt.pdf : rmt.scm
	grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf

buildmanual:
	cd docs/manual && make







|
|







422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
	if  csi -ne '(use mysql-client)';then \
           echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
	fi
	if csi -ne '(use postgresql)';then \
	   echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
	fi

portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o http-transport.o items.o keys.o launch.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
	csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o http-transport.o items.o keys.o launch.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o

# create a pdf dot graphviz diagram from notations in rmt.scm
rmt.pdf : rmt.scm
	grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf

buildmanual:
	cd docs/manual && make

Modified api.scm from [4fa67bb6bd] to [02956a2985].

161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
				   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)))
            (foo               (begin
                                 (common:telemetry-log (conc "api-in:"(->string cmd))
                                                       payload: `((params . ,params)))
                                 
                                 #t))
            (res    
             (if writecmd-in-readonly-mode
                 (conc "attempt to run write command "cmd" on a read-only database")







|







161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
				   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)))
            #;(foo               (begin
                                 (common:telemetry-log (conc "api-in:"(->string cmd))
                                                       payload: `((params . ,params)))
                                 
                                 #t))
            (res    
             (if writecmd-in-readonly-mode
                 (conc "attempt to run write command "cmd" on a read-only database")
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
       ;; 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
           (begin
             (common:telemetry-log (conc "api-out:"(->string cmd))
                                   payload: `((params . ,params)
                                              (ok-res . #t)))
	     (vector #f res))
           (begin
             (common:telemetry-log (conc "api-out:"(->string cmd))
                                   payload: `((params . ,params)
                                              (ok-res . #f)))
             (vector #t res))))))))

;; http-server  send-response
;;                 api:process-request
;;                    db:*







|




|







357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
       ;; 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
           (begin
             #;(common:telemetry-log (conc "api-out:"(->string cmd))
                                   payload: `((params . ,params)
                                              (ok-res . #t)))
	     (vector #f res))
           (begin
             #;(common:telemetry-log (conc "api-out:"(->string cmd))
                                   payload: `((params . ,params)
                                              (ok-res . #f)))
             (vector #t res))))))))

;; http-server  send-response
;;                 api:process-request
;;                    db:*
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
	 (success (vector-ref resdat 0))
	 (res     (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?)
    (if (not success)
	(debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params))
    (if (> *api-process-request-count* *max-api-process-requests*)
	(set! *max-api-process-requests* *api-process-request-count*))
    (set! *api-process-request-count* (- *api-process-request-count* 1))
    ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
    ;; (rmt:dat->json-str
    ;;  (if (or (string? res)
    ;;          (list?   res)
    ;;          (number? res)
    ;;          (boolean? res))
    ;;      res 
    ;;      (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
    (db:obj->string res transport: 'http)))








<
<
<
<
<
<
<
<


386
387
388
389
390
391
392








393
394
	 (success (vector-ref resdat 0))
	 (res     (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?)
    (if (not success)
	(debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params))
    (if (> *api-process-request-count* *max-api-process-requests*)
	(set! *max-api-process-requests* *api-process-request-count*))
    (set! *api-process-request-count* (- *api-process-request-count* 1))








    (db:obj->string res transport: 'http)))

Modified archive.scm from [f391351322] to [25dd06b4d1].

29
30
31
32
33
34
35
36
37
38
39
40
41
42
43

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

;; NOT CURRENTLY USED
;;
(define (archive:main linktree target runname testname itempath options)
  (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempatt))
	(flavor  'plain) ;; type of machine to run jobs on
	(maxload 1.5)   ;; max allowed load for this work
	(adisks  (archive:get-archive-disks)))
    ;; get testdir size
    ;;   - hand off du to job mgr
    (if (and (common:file-exists? testdir)







|







29
30
31
32
33
34
35
36
37
38
39
40
41
42
43

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

;; NOT CURRENTLY USED
;;
#;(define (archive:main linktree target runname testname itempath options)
  (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempatt))
	(flavor  'plain) ;; type of machine to run jobs on
	(maxload 1.5)   ;; max allowed load for this work
	(adisks  (archive:get-archive-disks)))
    ;; get testdir size
    ;;   - hand off du to job mgr
    (if (and (common:file-exists? testdir)
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
		     (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)
		     (debug:print-info 0 *default-log-port* "Archiving data with bup")
		     (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
               (else
                   (debug:print-info 0 *default-log-port* "No support for databse archiving with " archiver)))
               (debug:print-error 0 *default-log-port* "There was an error rsyncing tmp database")))))

(define (archive:restore-db archive-path ts)
   (let* ((bup-exe               (or (configf:lookup *configdat* "archive" "bup") "bup"))
         (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" ))
         (bup-restore-params  (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
		 (debug:print-info 0 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
		 (run-n-wait bup-exe params: bup-restore-params print-cmd: #f))
      (db:multi-db-sync 
       (db:setup #f)







|







362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
		     (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)
		     (debug:print-info 0 *default-log-port* "Archiving data with bup")
		     (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
               (else
                   (debug:print-info 0 *default-log-port* "No support for databse archiving with " archiver)))
               (debug:print-error 0 *default-log-port* "There was an error rsyncing tmp database")))))

#;(define (archive:restore-db archive-path ts)
   (let* ((bup-exe               (or (configf:lookup *configdat* "archive" "bup") "bup"))
         (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" ))
         (bup-restore-params  (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
		 (debug:print-info 0 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
		 (run-n-wait bup-exe params: bup-restore-params print-cmd: #f))
      (db:multi-db-sync 
       (db:setup #f)

Added attic/fdb_records.scm version [f1c8030bb0].









































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;; Single record for managing a filedb
;; make-vector-record "Filedb record" filedb fdb db dbpath pathcache idcache partcache
;; Filedb record
(define (make-filedb:fdb)(make-vector 5))
(define-inline (filedb:fdb-get-db          vec)    (vector-ref  vec 0))
(define-inline (filedb:fdb-get-dbpath      vec)    (vector-ref  vec 1))
(define-inline (filedb:fdb-get-pathcache   vec)    (vector-ref  vec 2))
(define-inline (filedb:fdb-get-idcache     vec)    (vector-ref  vec 3))
(define-inline (filedb:fdb-get-partcache   vec)    (vector-ref  vec 4))
(define-inline (filedb:fdb-set-db!         vec val)(vector-set! vec 0 val))
(define-inline (filedb:fdb-set-dbpath!     vec val)(vector-set! vec 1 val))
(define-inline (filedb:fdb-set-pathcache!  vec val)(vector-set! vec 2 val))
(define-inline (filedb:fdb-set-idcache!    vec val)(vector-set! vec 3 val))
(define-inline (filedb:fdb-set-partcache!  vec val)(vector-set! vec 4 val))

;; children records, should have use something other than "child"
(define-inline (filedb:child-get-id vec)       (vector-ref vec 0))
(define-inline (filedb:child-get-path vec)     (vector-ref vec 1))
(define-inline (filedb:child-get-parent_id vec)(vector-ref vec 2))

Added attic/filedb.scm version [f18fb77b48].































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;; Copyright 2006-2011, Matthew Welland.
;;
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex)
(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
(import (prefix sqlite3 sqlite3:))

(declare (unit filedb))

(include "fdb_records.scm")
;; (include "settings.scm")

(define (filedb:open-db dbpath)
  (let* ((fdb      (make-filedb:fdb))
	 (dbexists (common:file-exists? dbpath))
	 (db (sqlite3:open-database dbpath)))
    (filedb:fdb-set-db!        fdb db)
    (filedb:fdb-set-dbpath!    fdb dbpath)
    (filedb:fdb-set-pathcache! fdb (make-hash-table))
    (filedb:fdb-set-idcache!   fdb (make-hash-table))
    (filedb:fdb-set-partcache! fdb (make-hash-table))
    (sqlite3:set-busy-handler!  db (make-busy-timeout 136000))
    (if (not dbexists)
	(begin
	  (sqlite3:execute db "PRAGMA synchronous = OFF;")
	  (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
	  (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
	  ;; NB// We store a useful subset of file attributes but do not attempt to store all
	  (sqlite3:execute db "CREATE TABLE paths (id        INTEGER PRIMARY KEY,
                                                   path      TEXT,
                                                   parent_id INTEGER,
                                                   mode      INTEGER DEFAULT -1,
                                                   uid       INTEGER DEFAULT -1,
                                                   gid       INTEGER DEFAULT -1,
                                                   size      INTEGER DEFAULT -1,
                                                   mtime     INTEGER DEFAULT -1);")
	  (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
	  (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT,                  updated TIMESTAMP);")))
    ;; close the sqlite3 db and open it as needed
    (filedb:finalize-db! fdb)
    (filedb:fdb-set-db! fdb #f)
    fdb))

(define (filedb:reopen-db fdb)
  (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb))))
    (filedb:fdb-set-db! fdb db)
    (sqlite3:set-busy-handler!  db (make-busy-timeout 136000))))
  
(define (filedb:finalize-db! fdb)
  (sqlite3:finalize! (filedb:fdb-get-db fdb)))

(define (filedb:get-current-time-string)
  (string-chomp (time->string (seconds->local-time (current-seconds)))))

(define (filedb:get-base-id db path)
  (let ((stmt   (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;"))
        (id-num #f))
    (sqlite3:for-each-row 
     (lambda (num) (set! id-num num)) stmt path)
    (sqlite3:finalize! stmt)
    id-num))

(define (filedb:get-path-id db path parent)
  (let ((stmt   (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;"))
        (id-num #f))
    (sqlite3:for-each-row 
     (lambda (num) (set! id-num num)) stmt path parent)
    (sqlite3:finalize! stmt)
    id-num))

(define (filedb:add-base db path)
  (let ((existing (filedb:get-base-id db path)))
    (if existing #f
        (begin
          (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string))))))

;; index 	value 	field 	notes
;; 0 	inode number 	st_ino 	
;; 1 	mode 	st_mode 	bitfield combining file permissions and file type
;; 2 	number of hard links 	st_nlink 	
;; 3 	UID of owner 	st_uid 	as with file-owner
;; 4 	GID of owner 	st_gid 	
;; 5 	size 	st_size 	as with file-size
;; 6 	access time 	st_atime 	as with file-access-time
;; 7 	change time 	st_ctime 	as with file-change-time
;; 8 	modification time 	st_mtime 	as with file-modification-time
;; 9 	parent device ID 	st_dev 	ID of device on which this file resides
;; 10 	device ID 	st_rdev 	device ID for special files (i.e. the raw major/minor number)
;; 11 	block size 	st_blksize 	
;; 12 	number of blocks allocated 	st_blocks 	

(define (filedb:add-path-stat db path parent statinfo)
  (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);")))
	(sqlite3:execute stmt
			 path
			 parent
			 (vector-ref statinfo 1) ;; mode
			 (vector-ref statinfo 3) ;; uid
			 (vector-ref statinfo 4) ;; gid
			 (vector-ref statinfo 5) ;; size
			 (vector-ref statinfo 8) ;; mtime
			 )
	(sqlite3:finalize! stmt))) ;;  (filedb:get-current-time-string))))
  
(define (filedb:add-path db path parent)
  (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);")))
    (sqlite3:execute stmt path parent)
    (sqlite3:finalize! stmt)))

(define (filedb:register-path fdb path #!key (save-stat #f))
  (let* ((db        (filedb:fdb-get-db        fdb))
	 (pathcache (filedb:fdb-get-pathcache fdb))
	 (stat      (if save-stat (file-stat path #t)))
	 (id        (hash-table-ref/default pathcache path #f)))
    (if (not db)(filedb:reopen-db fdb))
    (if id id 
        (let ((plist (string-split path "/")))
          (let loop ((head (car plist))
                     (tail (cdr plist))
                     (parent 0))
            (let ((id (filedb:get-path-id db head parent))
                  (done (null? tail)))
              (if id          ;; we'll have a id if the path is already registered
                  (if done 
                      (begin
                        (hash-table-set! pathcache path id)
                        id) ;; return the last path id for a result
                      (loop (car tail)(cdr tail) id))
                  (begin      ;; add the path and then repeat the loop with the same data
		    (if save-stat
			(filedb:add-path-stat db head parent stat) 
			(filedb:add-path db head parent))
                    (loop head tail parent)))))))))

(define (filedb:update-recursively fdb path #!key (save-stat #f))
  (let ((p  (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path))))
    (print "processed 0 files...")
    (let loop ((l  (read-line p))
               (lc 0)) ;; line count
      (if (eof-object? l) 
	  (begin
	    (print "          " lc " files")
	    (close-input-port p))
          (begin
            (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info
            (if (= (modulo lc 100) 0)
                (print "          " lc " files"))
            (loop (read-line p)(+ lc 1)))))))

(define (filedb:update fdb path #!key (save-stat #f))
  ;; first get the realpath and add it to the bases table
  (let ((real-path path) ;; (filedb:get-real-path path))
	(db        (filedb:fdb-get-db    fdb)))
    (filedb:add-base db real-path)
    (filedb:update-recursively fdb path save-stat: save-stat)))

;; not used and broken
;;
(define (filedb:get-real-path path)
  (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path))))
         (pth (read-line p)))
    (if (eof-object? pth) path
	(begin
	  (close-input-port p)
	  pth))))

(define (filedb:drop-base fdb path)
  (print "Sorry, I don't do anything yet"))

(define (filedb:find-all fdb pattern action)
  (let* ((db     (filedb:fdb-get-db fdb))
	 (stmt   (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;"))
	 (result '()))
    (sqlite3:for-each-row 
     (lambda (num)
       (action num)
       (set! result (cons num result))) stmt pattern)
    (sqlite3:finalize! stmt)
    result))

(define (filedb:get-path-record fdb id)
  (let* ((db        (filedb:fdb-get-db        fdb))
	 (partcache (filedb:fdb-get-partcache fdb))
	 (dat (hash-table-ref/default partcache id #f)))
    (if dat dat
	(let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;"))
	      (result #f))
	  (sqlite3:for-each-row 
	   (lambda (path parent_id)(set! result (list path parent_id))) stmt id)
	  (hash-table-set! partcache id result)
	  (sqlite3:finalize! stmt)
	  result))))

(define (filedb:get-children fdb parent-id)
  (let* ((db        (filedb:fdb-get-db fdb))
	 (res       '()))
    (sqlite3:for-each-row
     (lambda (id path parent-id)
       (set! res (cons (vector id path parent-id) res)))
     db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;"
     parent-id)
    res))

;; retrieve all that have children and those without
;; children that match patt
(define (filedb:get-children-patt fdb parent-id search-patt)
  (let* ((db        (filedb:fdb-get-db fdb))
	 (res       '()))
    ;; first get the children that have no children
    (sqlite3:for-each-row
     (lambda (id path parent-id)
       (set! res (cons (vector id path parent-id) res)))
     db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND 
            (id IN (SELECT parent_id FROM paths) OR path LIKE ?);"
     parent-id search-patt)
    res))

(define (filedb:get-path fdb id)
  (let* ((db      (filedb:fdb-get-db      fdb))
	 (idcache (filedb:fdb-get-idcache fdb))
	 (path    (hash-table-ref/default idcache id #f)))
    (if (not db)(filedb:reopen-db fdb))
    (if path path
        (let loop ((curr-id id)
                   (path    ""))
          (let ((path-record (filedb:get-path-record fdb curr-id)))
            (if (not path-record) #f ;; this id has no path
                (let* ((parent-id (list-ref path-record 1))
                       (pname     (list-ref path-record 0))
                       (newpath   (string-append  "/" pname path)))
                  (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0
                      (begin
                        (hash-table-set! idcache id newpath)
                        newpath)
                      (loop parent-id newpath)))))))))

(define (filedb:search db pattern)
  (let ((action (lambda (id)(print (filedb:get-path db id)))))
    (filedb:find-all db pattern action)))

Added attic/fs-transport.scm version [d1050dcefe].









































































































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

;; Copyright 2006-2012, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

(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 spiffy uri-common intarweb http-client spiffy-request-vars)

(tcp-buffer-size 2048)

(declare (unit fs-transport))

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

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


;;======================================================================
;; F S   T R A N S P O R T   S E R V E R
;;======================================================================

;; There is no "server" per se but a convience routine to make it non
;; necessary to be reopening the db over and over again.
;;

(define (fs:process-queue-item packet)
  (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called
      (set! *dbstruct-db* (db:setup-db)))
  (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet)
  (db:process-queue-item *dbstruct-db* packet))
      

Added attic/ftail.scm version [96a7ff77a3].

























































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;======================================================================
;; Copyright 2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(declare (unit ftail))

(module ftail
    (
     open-tail-db
     tail-write
     tail-get-fid
     file-tail
     )

(import scheme chicken data-structures extras)
(use (prefix sqlite3 sqlite3:) posix typed-records)

(define (open-tail-db )
  (let* ((basedir   (create-directory (conc "/tmp/" (current-user-name))))
	 (dbpath    (conc basedir "/megatest_logs.db"))
	 (dbexists  (file-exists? dbpath))
	 (db        (sqlite3:open-database dbpath))
	 (handler   (sqlite3:make-busy-timeout 136000)))
    (sqlite3:set-busy-handler! db handler)
    (sqlite3:execute db "PRAGMA synchronous = 0;")
    (if (not dbexists)
	(begin
	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data  (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
	  ))
    db))

(define (tail-write db fid lines)
  (sqlite3:with-transaction
   db
   (lambda ()
     (for-each
      (lambda (line)
	(sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
      lines))))

(define (tail-get-fid db fname)
  (let ((fid   (handle-exceptions
		   exn
		   #f
		 (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
    (if fid
	fid
	(begin
	  (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
	  (tail-get-fid db fname)))))

(define (file-tail fname #!key (db-in #f))
  (let* ((inp (open-input-file fname))
	 (db  (or db-in (open-tail-db)))
	 (fid (tail-get-fid db fname)))
    (let loop ((inl    (read-line inp))
	       (lines '())
	       (lastwr (current-seconds)))
      (if (eof-object? inl)
	  (let ((timed-out (> (- (current-seconds) lastwr) 60)))
	    (if timed-out (tail-write db fid (reverse lines)))
	    (sleep 1)
	    (if timed-out
		(loop (read-line inp) '() (current-seconds))
		(loop (read-line inp) lines lastwr)))
	  (let* ((savelines (> (length lines) 19)))
	    ;; (print inl)
	    (if savelines (tail-write db fid (reverse lines)))
	    (loop (read-line inp)
		  (if savelines
		      '()
		      (cons inl lines))
		  (if savelines
		      (current-seconds)
		      lastwr)))))))

;; offset -20 means get last 20 lines
;;
(define (tail-get-lines db fid offset count)
  (if (> offset 0)
      (sqlite3:map-row (lambda (id line)
		 (vector id line))
	       db
	       "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
      (reverse ;; get N from the end
       (sqlite3:map-row (lambda (id line)
		  (vector id line))
		db
		"SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))

)

Added attic/lock-queue.scm version [21543b63ce].



























































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;; Copyright 2006-2013, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

(use (prefix sqlite3 sqlite3:) srfi-18)

(declare (unit lock-queue))
(declare (uses common))
(declare (uses tasks))

;;======================================================================
;; attempt to prevent overlapping updates of rollup files by queueing
;; update requests in an sqlite db
;;======================================================================

;;======================================================================
;; db record, <vector db path-to-db>
;;======================================================================

(define (make-lock-queue:db-dat)(make-vector 3))
(define-inline (lock-queue:db-dat-get-db        vec)    (vector-ref  vec 0))
(define-inline (lock-queue:db-dat-get-path      vec)    (vector-ref  vec 1))
(define-inline (lock-queue:db-dat-set-db!       vec val)(vector-set! vec 0 val))
(define-inline (lock-queue:db-dat-set-path!     vec val)(vector-set! vec 1 val))

(define (lock-queue:delete-lock-db dbdat)
  (let ((fname (lock-queue:db-dat-get-path dbdat)))
    (system (conc "rm -f " fname "*"))))

(define (lock-queue:open-db fname #!key (count 10))
  (let* ((actualfname (conc fname ".lockdb"))
	 (dbexists (common:file-exists? actualfname))
	 (db       (sqlite3:open-database actualfname))
	 (handler  (make-busy-timeout 136000)))
    (if dbexists
	(vector db actualfname)
	(begin
	  (handle-exceptions
	   exn
	   (begin
	     (thread-sleep! 10)
	     (if (> count 0)
		 (lock-queue:open-db fname count: (- count 1))
		 (vector db actualfname)))
	   (sqlite3:with-transaction
	    db
	    (lambda ()
	      (sqlite3:execute 
	       db
	       "CREATE TABLE IF NOT EXISTS queue (
     	         id         INTEGER PRIMARY KEY,
                 test_id    INTEGER,
                 start_time INTEGER,
                 state      TEXT,
                 CONSTRAINT queue_constraint UNIQUE (test_id));")
	      (sqlite3:execute
	       db
	       "CREATE TABLE IF NOT EXISTS runlocks (
                 id         INTEGER PRIMARY KEY,
                 test_id    INTEGER,
                 run_lock   TEXT,
                 CONSTRAINT runlock_constraint UNIQUE (run_lock));"))))))
    (sqlite3:set-busy-handler! db handler)
    (vector db actualfname)))

(define (lock-queue:set-state dbdat test-id newstate #!key (remtries 10))
  (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
  (handle-exceptions
   exn
   (if (> remtries 0)
       (begin
	 (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.")
	 (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	 (thread-sleep! 30)
	 (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1)))
       (begin
	 (debug:print-error 0 *default-log-port* " Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
	 #f))
   (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;"
		    newstate
		    test-id)))

(define (lock-queue:any-younger? dbdat mystart test-id #!key (remtries 10))
  ;; no need to wait on journal on read only queries
  ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
  (handle-exceptions
   exn
   (if (> remtries 0)
       (begin
	 (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.")
	 (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	 (thread-sleep! 5)
         (lock-queue:delete-lock-db dbdat)
	 (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1)))
       (begin
	 (debug:print-error 0 *default-log-port* " Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
	 #f))
   (let ((res #f))
     (sqlite3:for-each-row
      (lambda (tid)
	;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as 
	(if (not (equal? tid test-id)) 
	    (set! res tid)))
      (lock-queue:db-dat-get-db dbdat)
      "SELECT test_id FROM queue WHERE start_time > ?;" mystart)
     res)))

(define (lock-queue:get-lock dbdat test-id #!key (count 10)(waiting-msg #f))
  (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 remove: #t waiting-msg: "lock-queue:get-lock, waiting on journal")
  (let* ((res       #f)
	 (db        (lock-queue:db-dat-get-db dbdat))
	 (lckqry    (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';"))
	 (mklckqry  (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');")))
    (let ((result 
	   (handle-exceptions
	    exn
	    (begin
	      (debug:print 0 *default-log-port* "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds")
	      (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	      (thread-sleep! 10)
	      ;; (if (> count 0)	
	      ;;  #f ;; (lock-queue:get-lock dbdat test-id count: (- count 1)) - give up on retries 
	      ;; (begin ;; never recovered, remote the lock file and return #f, no lock obtained
	      (lock-queue:delete-lock-db dbdat)
	      #f)
	    (sqlite3:with-transaction
	     db
	     (lambda ()
	       (sqlite3:for-each-row (lambda (tid lockstate)
				       (set! res (list tid lockstate)))
				     lckqry)
	       (if res
		   (if (equal? (car res) test-id)
		       #t ;; already have the lock
		       #f)
		   (begin
		     (sqlite3:execute mklckqry test-id)
		     ;; if no error handled then return #t for got the lock
		     #t)))))))
      (sqlite3:finalize! lckqry)
      (sqlite3:finalize! mklckqry)
      result)))

(define (lock-queue:release-lock fname test-id #!key (count 10))
  (let* ((dbdat (lock-queue:open-db fname)))
    (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:release-lock; waiting on journal")
    (handle-exceptions
     exn
     (begin
       (debug:print 0 *default-log-port* "WARNING: Failed to release queue lock. Will try again in few seconds")
       (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
       (thread-sleep! (/ count 10))
       (if (> count 0)
	   (begin
	     (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))
	     (lock-queue:release-lock fname test-id count: (- count 1)))
	   (let ((journal (conc fname "-journal")))
	     ;; If we've tried ten times and failed there is a serious problem
	     ;; try to remove the lock db and allow it to be recreated
	     (handle-exceptions
	      exn
	      #f
	      (if (common:file-exists? journal)(delete-file journal))
	      (if (common:file-exists? fname)  (delete-file fname))
	      #f))))
     (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id)
     (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)))))

(define (lock-queue:steal-lock dbdat test-id #!key (count 10))
  (debug:print-info 0 *default-log-port* "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat))
  (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal")
  (handle-exceptions
   exn
   (begin
     (debug:print 0 *default-log-port* "WARNING: Failed to steal queue lock. Will try again in few seconds")
     (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
     (thread-sleep! 10)
     (if (> count 0)
	 (lock-queue:steal-lock dbdat test-id count: (- count 1))
	 #f))
   (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';"))
  (lock-queue:get-lock dbdat test-it))

;; returns #f if ok to skip the task
;; returns #t if ok to proceed with task
;; otherwise waits
;;
(define (lock-queue:wait-turn fname test-id #!key (count 10)(waiting-msg #f))
  (let* ((dbdat   (lock-queue:open-db fname))
	 (mystart (current-seconds))
	 (db      (lock-queue:db-dat-get-db dbdat)))
    ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
    (handle-exceptions
     exn
     (begin
       (debug:print 0 *default-log-port* "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds")
       (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
       (print-call-chain (current-error-port))
       (thread-sleep! 10)
       (if (> count 0)
	   (begin
	     (sqlite3:finalize! db)
	     (lock-queue:wait-turn fname test-id count: (- count 1)))
	   (begin
	     (debug:print 0 *default-log-port* "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain")
	     (print-call-chain (current-error-port))
	     #f)))
     ;; wait 10 seconds and then check to see if someone is already updating the html
     (thread-sleep! 10)
     (if (not (lock-queue:any-younger? dbdat mystart test-id)) ;; no processing in flight, must try to start processing
	 (begin
	   (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
	   (sqlite3:execute
	    db
	    "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');"
	    test-id mystart)
	   ;; (thread-sleep! 1) ;; give other tests a chance to register
	   (let ((result 
		  (let loop ((younger-waiting (lock-queue:any-younger? dbdat mystart test-id)))
		    (if younger-waiting
			(begin
			  ;; no need for us to wait. mark in the lock queue db as skipping
			  ;; no point in marking anything in the queue - simply never register this
			  ;; test as it is *covered* by a previously started update to the html file
			  ;; (lock-queue:set-state dbdat test-id "skipping")
			  #f) ;; let the calling process know that nothing needs to be done
			(if (lock-queue:get-lock dbdat test-id)
			    #t
			    (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock
				(lock-queue:steal-lock dbdat test-id)
				(begin
				  (thread-sleep! 1)
				  (loop (lock-queue:any-younger? dbdat mystart test-id)))))))))
	     (sqlite3:finalize! db)
	     result))))))
	  
            
;; (use trace)
;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state)

Added attic/mlaunch.scm version [5bcd34288f].



































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;; Copyright 2006-2014, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

;;======================================================================
;; MLAUNCH
;;
;;   take jobs from the given queue and keep launching them keeping
;;   the cpu load at the targeted level
;;
;;======================================================================

(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)

(declare (unit mlaunch))
(declare (uses db))
(declare (uses common))

Added attic/monitor.scm version [3df55c85ea].



































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;; Copyright 2006-2012, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
(import (prefix sqlite3 sqlite3:))

(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))

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

Added attic/newdashboard.scm version [3cc17ecae4].













































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;======================================================================
;; Copyright 2006-2016, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(use format)

(use (prefix iup iup:))

(use canvas-draw)
(import canvas-draw-iup)

(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
     (prefix dbi dbi:))

(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))

;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
(declare (uses dcommon))
;; (declare (uses tree))
;; 
;; (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
  -server host:port : connect to host:port instead of db access
  -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  "-rows"
			"-run"
			"-test"
			"-debug"
			"-host" 
			) 
		 (list  "-h"
			"-guimonitor"
			"-main"
			"-v"
			"-q"
		       )
		 args:arg-hash
		 0))

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

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

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


;; data for each specific tab goes here
;;
(defstruct dboard:tabdat 
  ;; runs
  ((allruns         '())                 : list)        ;; list of dboard:rundat records
  ((allruns-by-id    (make-hash-table))  : hash-table)  ;; hash of run-id -> dboard:rundat records
  ((done-runs       '())                 : list)        ;; list of runs already drawn
  ((not-done-runs   '())                 : list)        ;; list of runs not yet drawn
  (header            #f)                                ;; header for decoding the run records
  (keys              #f)                                ;; keys for this run (i.e. target components)
  ((numruns          (string->number (or (args:get-arg "-cols") "10")))                 : number)      ;; 
  ((tot-runs          0)                 : number)
  ((last-data-update  0)                 : number)      ;; last time the data in allruns was updated
  ((last-runs-update  0)                 : number)      ;; last time we pulled the runs info to update the tree
  (runs-mutex         (make-mutex))                     ;; use to prevent parallel access to draw objects
  ((run-update-times  (make-hash-table)) : hash-table)  ;; update times indexed by run-id
  ((last-test-dat      (make-hash-table)) : hash-table)  ;; cache last tests dat by run-id
  ((run-db-paths      (make-hash-table)) : hash-table)  ;; cache the paths to the run db files

  ;; Runs view
  ((buttondat         (make-hash-table)) : hash-table)  ;;     
  ((item-test-names  '())                : list)        ;; list of itemized tests
  ((run-keys          (make-hash-table)) : hash-table)
  (runs-matrix        #f)                               ;; used in newdashboard
  ((start-run-offset   0)                : number)      ;; left-right slider value
  ((start-test-offset  0)                : number)      ;; up-down slider value
  ((runs-btn-height    (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string)  ;; was 12
  ((runs-btn-fontsz    (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string)   ;; was 8
  ((runs-cell-width    (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string)   ;; was 50
  ((all-test-names     '())              : list)
  
  ;; Canvas and drawing data
  (cnv                #f)
  (cnv-obj            #f)
  (drawing            #f)
  ((run-start-row     0)                 : number)
  ((max-row           0)                 : number)
  ((running-layout    #f)                : boolean)
  (originx            #f)
  (originy            #f)
  ((layout-update-ok  #t)                : boolean)
  ((compact-layout    #t)                : boolean)

  ;; Run times layout
  ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
  (graph-matrix     #f)
  ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
  ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
  ((graph-matrix-row 1) : number)
  ((graph-matrix-col 1) : number)

  ;; Controls used to launch runs etc.
  ((command          "")                 : string)      ;; for run control this is the command being built up
  (command-tb        #f)	                        ;; widget for the type of command; run, remove-runs etc.
  (test-patterns-textbox #f)                            ;; text box widget for editing a list of test patterns
  (key-listboxes     #f)			         
  (key-lbs           #f)			         
  run-name                                              ;; from run name setting widget
  states                                                ;; states for -state s1,s2 ...
  statuses                                              ;; statuses for -status s1,s2 ...
						         
  ;; Selector variables				         
  curr-run-id                                           ;; current row to display in Run summary view
  prev-run-id                                           ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
  curr-test-ids                                         ;; used only in dcommon:run-update which is used in newdashboard
  ((filters-changed  #t)                  : boolean)    ;; to indicate that the user changed filters for this tab
  ((last-filter-str  "")                  : string)      ;; conc the target runname and testpatt for a signature of changed filters
  ((hide-empty-runs  #f)                  : boolean)     
  ((hide-not-hide    #t)                  : boolean)     ;; toggle for hide/not hide empty runs
  (hide-not-hide-button #f)
  ((searchpatts        (make-hash-table)) : hash-table)  ;;
  ((state-ignore-hash  (make-hash-table)) : hash-table)  ;; hash of  STATE => #t/#f for display control
  ((status-ignore-hash (make-hash-table)) : hash-table)  ;; hash of STATUS => #t/#f
  (target              #f)
  (test-patts          #f)

  ;; db info to file the .db files for the area
  (access-mode        (db:get-access-mode))             ;; use cached db or not
  (dbdir               #f)
  (dbfpath             #f)
  (dbkeys              #f)
  ((last-db-update     (make-hash-table)) : hash-table) ;; last db file timestamp
  (monitor-db-path     #f)                              ;; where to find monitor.db
  ro                                                    ;; is the database read-only?

  ;; tests data
  ((num-tests          10)               : number)      ;; total number of tests to show (used in the old runs display)

  ;; runs tree
  ((path-run-ids       (make-hash-table)) : hash-table) ;; path (target / runname) => id
  (runs-tree           #f)
  ((runs-tree-ht       (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)

  ;; tab data
  ((view-changed       #t)                : boolean)   
  ((xadj               0)                 : number)     ;; x slider number (if using canvas)
  ((yadj               0)                 : number)     ;; y slider number (if using canvas)
  ;; runs-summary tab state
  ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) )   : list)
  ((runs-summary-mode-buttons '())               : list)
  ((runs-summary-mode  'one-run)            : symbol)
  ((runs-summary-mode-change-callbacks '()) : list)
  (runs-summary-source-runname-label #f)
  (runs-summary-dest-runname-label #f)
  ;; runs summary view
  
  tests-tree       ;; used in newdashboard
  )



;; mtest is actually the megatest.config file
;;
(define (mtest toppath window-id)
  (let* ((curr-row-num     0)
	 ;; (rawconfig        (read-config (conc toppath "/megatest.config") #f 'return-string))
	 (keys-matrix      (iup:matrix)) ;; (dcommon:keys-matrix rawconfig))
	 (setup-matrix     (iup:matrix)) ;; (dcommon:section-matrix rawconfig "setup" "Varname" "Value"))
	 (jobtools-matrix  (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 5
			    #:numcol-visible 1
			    #:numlin-visible 3))
	 (validvals-matrix (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 2
			    #:numcol-visible 1
			    #:numlin-visible 2))
	 (envovrd-matrix   (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 20
			    #:numcol-visible 1
			    #:numlin-visible 8))
	 (disks-matrix     (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 20
			    #:numcol-visible 1
			    #:numlin-visible 8))
	 )
    (iup:attribute-set! disks-matrix "0:0" "Disk Name")
    (iup:attribute-set! disks-matrix "0:1" "Disk Path")
    (iup:attribute-set! disks-matrix "WIDTH1" "120")
    (iup:attribute-set! disks-matrix "WIDTH0" "100")
    (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
    (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
    (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")

    ;; fill in existing info
    (for-each 
     (lambda (mat fname)
       (set! curr-row-num 1)
       (for-each
	(lambda (var)
	  (iup:attribute-set! mat (conc curr-row-num ":0") var)
	  ;; (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
	  (set! curr-row-num (+ curr-row-num 1)))
	'()));; (configf:section-vars rawconfig fname)))
     (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
     (list "setup"      "jobtools"      "validvalues"      "env-override" "disks"))

    (for-each
     (lambda (mat)
       (iup:attribute-set! mat "0:1" "Value")
       (iup:attribute-set! mat "0:0" "Var")
       (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
       (iup:attribute-set! mat "FIXTOTEXT" "C1")
       (iup:attribute-set! mat "RESIZEMATRIX" "YES")
       (iup:attribute-set! mat "WIDTH1" "120")
       (iup:attribute-set! mat "WIDTH0" "100")
       )
     (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix))

    (iup:attribute-set! validvals-matrix "WIDTH1" "290")
    (iup:attribute-set! envovrd-matrix   "WIDTH1" "290")

    (iup:vbox
     (iup:hbox
       
      (iup:vbox
       (let ((tabs (iup:tabs 
		    ;; The required tab
		    (iup:hbox
		     ;; The keys
		     (iup:frame 
		      #:title "Keys (required)"
		      (iup:vbox
		       (iup:label (conc "Set the fields for organising your runs\n"
					"here. Note: can only be changed before\n"
					"running the first run when megatest.db\n"
					"is created."))
		       keys-matrix))
		     (iup:vbox
		      ;; The setup section
		      (iup:frame
		       #:title "Setup"
		       (iup:vbox
			(iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n"
					 "linktree : directory where linktree will be created."))
			setup-matrix))
		      ;; The jobtools
		      (iup:frame
		       #:title "Jobtools"
		       (iup:vbox 
			(iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n"
					 "useshell : use system to run your launcher\n"
					 "workhosts : spread jobs out on these hosts"))
			jobtools-matrix))
		      ;; The disks
		      (iup:frame
		       #:title "Disks"
		       (iup:vbox
			(iup:label (conc "Enter names and existing paths of locations to run tests")) 
			disks-matrix))))
		    ;; The optional tab
		    (iup:vbox
		     ;; The Environment Overrides
		     (iup:frame 
		      #:title "Env override"
		      envovrd-matrix)
		     ;; The valid values
		     (iup:frame
		      #:title "Validvalues"
		      validvals-matrix)
		     ))))
	 (iup:attribute-set! tabs "TABTITLE0" "Required settings")
	 (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
	 tabs))
       ))))

;; The runconfigs.config file
;;
(define (rconfig window-id)
  (iup:vbox
   (iup:frame #:title "Default")))

;;======================================================================
;; T E S T S
;;======================================================================

(define (tree-path->test-id path)
  (if (not (null? path))
      (hash-table-ref/default (dboard:data-path-test-ids *data*) path #f)
      #f))

(define (test-panel window-id)
  (let* ((curr-row-num 0)
	 (viewlog    (lambda (x)
		       (if (common:file-exists? logfile)
					;(system (conc "firefox " logfile "&"))
			   (iup:send-url logfile)
			   (message-window (conc "File " logfile " not found")))))
	 (xterm      (lambda (x)
		       (if (directory-exists? rundir)
			   (let ((shell (if (get-environment-variable "SHELL") 
					    (conc "-e " (get-environment-variable "SHELL"))
					    "")))
			     (system (conc "cd " rundir 
					   ";xterm -T \"" (string-translate testfullname "()" "  ") "\" " shell "&")))
			   (message-window  (conc "Directory " rundir " not found")))))
	 (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12"))
	 (command-launch-button (iup:button "Execute!" 
					    ;; #:expand "HORIZONTAL"
					    #:size "50x"
					    #:action (lambda (x)
						       (let ((cmd (iup:attribute command-text-box "VALUE")))
							 (system (conc cmd "  &"))))))
	 (run-test  (lambda (x)
		      (iup:attribute-set! 
		       command-text-box "VALUE"
		       (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname 
			     " -runtests " (conc testname "/" (if (equal? item-path "")
								  "%" 
								  item-path))
			     ";echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
	 (remove-test (lambda (x)
			(iup:attribute-set!
			 command-text-box "VALUE"
			 (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname
			       " -testpatt " (conc testname "/" (if (equal? item-path "")
								    "%"
								    item-path))
			       " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
    	 (run-info-matrix  (iup:matrix 		            
			    #:expand "YES"
			    ;; #:scrollbar "YES"
			    #:numcol 1
			    #:numlin 4
			    #:numcol-visible 1
			    #:numlin-visible 4
			    #:click-cb (lambda (obj lin col status)
					 (print "obj: " obj " lin: " lin " col: " col " status: " status))))
	 (test-info-matrix (iup:matrix
		            #:expand "YES"
		            #:numcol 1
		            #:numlin 7
		            #:numcol-visible 1
		            #:numlin-visible 7))
	 (test-run-matrix  (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 5
			    #:numcol-visible 1
			    #:numlin-visible 5))
	 (meta-dat-matrix  (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 5
			    #:numcol-visible 1
			    #:numlin-visible 5))
	 (steps-matrix     (iup:matrix
			    #:expand "YES"
			    #:numcol 6
			    #:numlin 50
			    #:numcol-visible 6
			    #:numlin-visible 8))
	 (data-matrix      (iup:matrix
			    #:expand "YES"
			    #:numcol 8
			    #:numlin 50
			    #:numcol-visible 8
			    #:numlin-visible 8))
	 (updater          (lambda (testdat)
			     (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix))))

    ;; Set the updater in updaters
    ;; (hash-table-set! (dboard:data-updaters *data*) window-id updater)
    ;; 
    (for-each
     (lambda (mat)
       ;; (iup:attribute-set! mat "0:1" "Value")
       ;; (iup:attribute-set! mat "0:0" "Var")
       (iup:attribute-set! mat "HEIGHT0" 0)
       (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
       ;; (iup:attribute-set! mat "FIXTOTEXT" "C1")
       (iup:attribute-set! mat "RESIZEMATRIX" "YES"))
       ;; (iup:attribute-set! mat "WIDTH1" "120")
       ;; (iup:attribute-set! mat "WIDTH0" "100"))
     (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix))

    ;; Steps matrix
    (iup:attribute-set! steps-matrix "0:1" "Step Name")
    (iup:attribute-set! steps-matrix "0:2" "Start")
    (iup:attribute-set! steps-matrix "WIDTH2" "40")
    (iup:attribute-set! steps-matrix "0:3" "End")
    (iup:attribute-set! steps-matrix "WIDTH3" "40")
    (iup:attribute-set! steps-matrix "0:4" "Status")
    (iup:attribute-set! steps-matrix "WIDTH4" "40")
    (iup:attribute-set! steps-matrix "0:5" "Duration")
    (iup:attribute-set! steps-matrix "WIDTH5" "40")
    (iup:attribute-set! steps-matrix "0:6" "Log File")
    (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
    ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
    (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
    ;; (iup:attribute-set! steps-matrix "WIDTH1" "120")
    ;; (iup:attribute-set! steps-matrix "WIDTH0" "100")

    ;; Data matrix
    ;; 
    (let ((rownum 1))
      (for-each
       (lambda (x)
	 (iup:attribute-set! data-matrix (conc "0:" rownum) x)
	 (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50")
	 (set! rownum (+ rownum 1)))
       (list "Category" "Variable" "Value" "Expected" "Tolerance"  "Status" "Units" "Type" "Comment")))
    (iup:attribute-set! data-matrix "REDRAW" "ALL")
    
    (for-each 
     (lambda (data)
       (let ((mat    (car data))
	     (keys   (cadr data))
	     (rownum 1))
	 (for-each
	  (lambda (key)
	    (iup:attribute-set! mat (conc rownum ":0") key)
	    (set! rownum (+ rownum 1)))
	  keys)
	 (iup:attribute-set! mat "REDRAW" "ALL")))
     (list
      (list run-info-matrix  '("Run Id"  "Target"   "Runname" "Run Start Time" ))
      (list test-info-matrix '("Test Id" "Testname" "Itempath" "State"   "Status" "Test Start Time" "Comment"))
      (list test-run-matrix  '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration"))
      (list meta-dat-matrix  '("Author"   "Owner"     "Last Reviewed" "Tags" "Description"))))
	    
    (iup:split
      #:orientation "HORIZONTAL"
      (iup:vbox
       (iup:hbox
	(iup:vbox
	 run-info-matrix
	 test-info-matrix)
       ;; test-info-matrix)
	(iup:vbox
	 test-run-matrix
	 meta-dat-matrix))
       (iup:vbox
	(iup:vbox
	 (iup:hbox 
	  (iup:button "View Log"    #:action viewlog      #:size "60x" )   ;; #:size "30x" 
	  (iup:button "Start Xterm" #:action xterm        #:size "60x" ))	 ;; #:size "30x" 
	 (iup:hbox
	   (iup:button "Run Test"    #:action run-test    #:size "60x" )	 ;; #:size "30x" 
	   (iup:button "Clean Test"  #:action remove-test #:size "60x" )))	 ;; #:size "30x" 
	(iup:hbox
	 ;; hiup:split ;; hbox
	 ;; #:orientation "HORIZONTAL"
	 ;; #:value 300
	 command-text-box
	 command-launch-button)))
      (iup:vbox
       (let ((tabs (iup:tabs
		    steps-matrix
		    data-matrix)))
	 (iup:attribute-set! tabs "TABTITLE0" "Test Steps")
	 (iup:attribute-set! tabs "TABTITLE1" "Test Data")
	 tabs)))))
       
;; Test browser
(define (tests window-id)
  (iup:split
   (let* ((tb      (iup:treebox
		    #:selection-cb
		    (lambda (obj id state)
		      ;; (print "obj: " obj ", id: " id ", state: " state)
		      (let* ((run-path (tree:node->path obj id))
			     (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)
   (test-panel window-id)))

;; The function to update the fields in the test view panel
(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
  ;; get test-id
  ;; then get test record
  (if testdat
      (let* ((test-id      0) ;; (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f))
	     (test-data    (hash-table-ref/default testdat test-id #f))
	     (run-id       (db:test-get-run_id test-data))
	     (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*) 
						   run-id
						   '()))
	     (target       (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
	     (runname      (if (null? targ/runname) "" (car (cdr targ/runname))))
	     (steps-dat    (tests:get-compressed-steps *dbstruct-local* run-id test-id)))
				
	(if test-data
	    (begin
	      ;; 
	      (for-each 
	       (lambda (data)
		 (let ((mat    (car data))
		       (vals   (cadr data))
		       (rownum 1))
		   (for-each 
		    (lambda (key)
		      (let ((cell   (conc rownum ":1")))
			(if (not (equal? (iup:attribute mat cell)(conc key)))
			    (begin
			      ;; (print "setting cell " cell " in matrix " mat " to value " key)
			      (iup:attribute-set! mat cell (conc key))
			      (iup:attribute-set! mat "REDRAW" cell)))
			(set! rownum (+ rownum 1))))
		    vals)))
	       (list 
		(list run-info-matrix
		      (if test-id
			  (list (db:test-get-run_id test-data)
				target
				runname
				"n/a")
			  (make-list 4 "")))
		(list test-info-matrix
		      (if test-id
			  (list test-id
				(db:test-get-testname test-data)
				(db:test-get-item-path test-data)
				(db:test-get-state    test-data)
				(db:test-get-status   test-data)
				(seconds->string (db:test-get-event_time test-data))
				(db:test-get-comment  test-data))
			  (make-list 7 "")))
		(list test-run-matrix
		      (if test-id
			  (list (db:test-get-host     test-data)
				(db:test-get-uname    test-data)
				(db:test-get-diskfree test-data)
				(db:test-get-cpuload  test-data)
				(seconds->hr-min-sec (db:test-get-run_duration test-data)))
			  (make-list 5 "")))
		))
	      (dcommon:populate-steps steps-dat steps-matrix))))))
		;;(list meta-dat-matrix
		;;      (if test-id
		;;	  (list (

  
;; db:test-get-id           
;; db:test-get-run_id       
;; db:test-get-testname     
;; db:test-get-state        
;; db:test-get-status       
;; db:test-get-event_time   
;; db:test-get-host         
;; db:test-get-cpuload      
;; db:test-get-diskfree     
;; db:test-get-uname        
;; db:test-get-rundir       
;; db:test-get-item-path    
;; db:test-get-run_duration 
;; db:test-get-final_logf   
;; db:test-get-comment      
;; db:test-get-fullname     	  


;;======================================================================
;; R U N   C O N T R O L
;;======================================================================

;; Overall runs browser
;;
(define (runs window-id)
  (let* ((runs-matrix     (iup:matrix
			   #:expand "YES"
			   ;; #:fittosize "YES"
			   #:scrollbar "YES"
			   #:numcol 100
			   #:numlin 100
			   #:numcol-visible 7
			   #:numlin-visible 7
			   #:click-cb (lambda (obj lin col status)
					(print "obj: " obj " lin: " lin " col: " col " status: " status)))))

    (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
    (iup:attribute-set! runs-matrix "WIDTH0" "100")

    ;; (dboard:data-runs-matrix-set! *data* runs-matrix)
    (iup:hbox
     (iup:frame 
      #:title "Runs browser"
      (iup:vbox
       runs-matrix)))))

;; Browse and control a single run
;;
(define (runcontrol window-id)
  (iup:hbox))

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

;; Main Panel
(define (main-panel window-id)
  (iup:dialog
   #:title "Megatest Control Panel"
   #:menu (dcommon:main-menu)
   #:shrink "YES"
   (let ((tabtop (iup:tabs 
		  (runs window-id)
		  (tests window-id)
		  (runcontrol window-id)
		  (mtest *toppath* window-id) 
		  (rconfig window-id)
		  )))
     (iup:attribute-set! tabtop "TABTITLE0" "Runs")
     (iup:attribute-set! tabtop "TABTITLE1" "Tests")
     (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
     (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") 
     (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
     tabtop)))

(define *current-window-id* 0)

(define (newdashboard dbstruct)
  (let* ((data     (make-hash-table))
	 (keys     '()) ;; (db:get-keys dbstruct))
	 (runname  "%")
	 (testpatt "%")
	 (keypatts '()) ;; (map (lambda (k)(list k "%")) keys))
         (states   '())
	 (statuses '())
	 (nextmintime (current-milliseconds))
	 (my-window-id *current-window-id*))
    (set! *current-window-id* (+ 1 *current-window-id*))
   ;; (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application
    (iup:show (main-panel my-window-id))
    ;; Yes, running iup:show will pop up a new panel
    ;; (iup:show (main-panel my-window-id))
    (iup:callback-set! *tim*
		       "ACTION_CB"
		       (lambda (x)
			 ;; Want to dedicate no more than 50% of the time to this so skip if
			 ;; 2x delta time has not passed since last query
			 (if (< nextmintime (current-milliseconds))
			     (let* ((starttime (current-milliseconds))
				    ;; (changes   (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
				    (endtime   (current-milliseconds)))
			       (set! nextmintime (+ endtime (* 2 (- endtime starttime))))
			       ;; (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
                               )
			     (debug:print-info 11 *default-log-port* "Server overloaded"))))))

;; (dboard:data-updaters-set! *data* (make-hash-table))
(newdashboard #f) ;; *dbstruct-local*)    
(iup:main-loop)

Added attic/records-vs-vectors-vs-coops.scm version [a207631458].





























































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;; (include "vg.scm")

;; (declare (uses vg))

(use foof-loop defstruct coops)

(defstruct obj     type fill-color angle)

(define (make-vg:obj)(make-vector 3))
(define-inline (vg:obj-get-type         vec)    (vector-ref  vec 0))
(define-inline (vg:obj-get-fill-color   vec)    (vector-ref  vec 1))
(define-inline (vg:obj-get-angle        vec)    (vector-ref  vec 2))
(define-inline (vg:obj-set-type!        vec val)(vector-set! vec 0 val))
(define-inline (vg:obj-set-fill-color!  vec val)(vector-set! vec 1 val))
(define-inline (vg:obj-set-angle!       vec val)(vector-set! vec 2 val))

(use simple-exceptions)
(define vgs:obj-exn (make-exception "wrong record type, expected vgs:obj." 'assert))
(define (make-vgs:obj)(let ((v (make-vector 4)))(vector-set! v 0 'vgs:obj) v))
(define-inline (vgs:obj-type             vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref  vec 1)(raise (vgs:obj-exn 'vgs:obj-type 'xpr))))
(define-inline (vgs:obj-fill-color       vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref  vec 2)(raise (vgs:obj-exn 'vgs:obj-fill-color 'xpr))))
(define-inline (vgs:obj-angle            vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref  vec 3)(raise (vgs:obj-exn 'vgs:obj-angle 'xpr))))
(define-inline (vgs:obj-type-set!        vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 1 val)(raise (vgs:obj-exn 'type))))
(define-inline (vgs:obj-fill-color-set!  vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 2 val)(raise (vgs:obj-exn 'fill-color))))
(define-inline (vgs:obj-angle-set!       vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 3 val)(raise (vgs:obj-exn 'angle))))

(define-class <vgc> ()
  ((type)
   (fill-color)
   (angle)))


;; first use raw vectors
(print "Using vectors")
(time
 (loop ((for r (up-from 0 (to 255))))
       (loop ((for g (up-from 0 (to 255))))
	     (loop ((for b (up-from 0 (to 255))))
		   (let ((obj (make-vg:obj)))
		     (vg:obj-set-type! obj 'abc)
		     (vg:obj-set-fill-color! obj "green")
		     (vg:obj-set-angle! obj 135)
		     (let ((a (vg:obj-get-type obj))
			   (b (vg:obj-get-fill-color obj))
			   (c (vg:obj-get-angle obj)))
		       obj))))))

;; first use raw vectors with safe mode
(print "Using vectors (safe mode)")
(time
 (loop ((for r (up-from 0 (to 255))))
       (loop ((for g (up-from 0 (to 255))))
	     (loop ((for b (up-from 0 (to 255))))
		   (let ((obj (make-vgs:obj)))
		     ;; (badobj (make-vector 20)))
		     (vgs:obj-type-set! obj 'abc)
		     (vgs:obj-fill-color-set! obj "green")
		     (vgs:obj-angle-set! obj 135)
		     (let ((a (vgs:obj-type obj))
			   (b (vgs:obj-fill-color obj))
			   (c (vgs:obj-angle obj)))
		       obj))))))

;; first use defstruct
(print "Using defstruct")
(time
 (loop ((for r (up-from 0 (to 255))))
       (loop ((for g (up-from 0 (to 255))))
	     (loop ((for b (up-from 0 (to 255))))
		   (let ((obj (make-obj)))
		     (obj-type-set! obj 'abc)
		     (obj-fill-color-set! obj "green")
		     (obj-angle-set! obj 135)
		     (let ((a (obj-type obj))
			   (b (obj-fill-color obj))
			   (c (obj-angle obj)))
		       obj))))))
		   

;; first use defstruct
(print "Using coops")
(time
 (loop ((for r (up-from 0 (to 255))))
       (loop ((for g (up-from 0 (to 255))))
	     (loop ((for b (up-from 0 (to 255))))
		   (let ((obj (make <vgc>)))
		     (set! (slot-value obj 'type) 'abc)
		     (set! (slot-value obj 'fill-color) "green")
		     (set! (slot-value obj 'angle) 135)
		     (let ((a (slot-value obj 'type))
			   (b (slot-value obj 'fill-color))
			   (c (slot-value obj 'angle)))
		       obj))))))

Added attic/rmtdb.scm version [62ddf7898c].









































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
;;======================================================================
;; Copyright 2006-2013, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

Modified client.scm from [9da8d7475d] to [c493234f19].

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
(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.

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

;; client:get-signature
(define (client:get-signature)
  (if *my-client-signature* *my-client-signature*
      (let ((sig (conc (get-host-name) " " (current-process-id))))
	(set! *my-client-signature* sig)
	*my-client-signature*)))

;; Not currently used! But, I think it *should* be used!!!
#;(define (client:logout serverdat)
  (let ((ok (and (socket? serverdat)
		 (cdb:logout serverdat *toppath* (client:get-signature)))))
    ok))

#;(define (client:connect iface port)
  (http-transport:client-connect iface port)
  #;(case (server:get-transport)
    ((rpc)  (rpc:client-connect  iface port))
    ((http) (http:client-connect iface port))
    ((zmq)  (zmq:client-connect  iface port))
    (else   (rpc:client-connect  iface port))))

(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0))
  (client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)
  #;(case (server:get-transport)
    ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id))
    ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects))
    (else  (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id))))

;; Do all the connection work, look up the transport type and set up the
;; connection if required.
;;
;; There are two scenarios. 
;;   1. We are a test manager and we received *transport-type* and *runremote* via cmdline
;;   2. We are a run tests, list runs or other interactive process and we must figure out







|
|





<
<
<
<
<

<
<
<
<
<
<
<
<

|
<
<
<
<







29
30
31
32
33
34
35
36
37
38
39
40
41
42





43








44
45




46
47
48
49
50
51
52
(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.

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

;; client:get-signature, not used right now but likely needed
#;(define (client:get-signature)
  (if *my-client-signature* *my-client-signature*
      (let ((sig (conc (get-host-name) " " (current-process-id))))
	(set! *my-client-signature* sig)
	*my-client-signature*)))















(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0))
  (client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects))





;; Do all the connection work, look up the transport type and set up the
;; connection if required.
;;
;; There are two scenarios. 
;;   1. We are a test manager and we received *transport-type* and *runremote* via cmdline
;;   2. We are a run tests, list runs or other interactive process and we must figure out
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
	    (let ((host  (cadr  server-dat))
		  (port  (caddr server-dat)))
	      (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
	      (if (and (not area-dat)
		       (not *runremote*))
		  (set! *runremote* (make-remote)))
	      (if (and host port)
		  (let* ((start-res (case *transport-type*
				      ((http)(http-transport:client-connect host port))))
			 (ping-res  (case *transport-type* 
				      ((http)(rmt:login-no-auto-client-setup start-res)))))
		    (if (and start-res
			     ping-res)
			(let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago
			  (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res)
			  (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))
			  start-res)
			(begin    ;; login failed but have a server record, clean out the record and try again
			  (debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid.  Fixes part of Randy;s ticket 1405717332
			  (case *transport-type* 
			    ((http)(http-transport:close-connections)))
			  (remote-conndat-set! runremote #f)  ;; (hash-table-delete! runremote run-id)
			  (thread-sleep! 1)
			  (client:setup-http areapath remaining-tries: (- remaining-tries 1))
			  )))
		  (begin    ;; no server registered
		    ;; (server:kind-run areapath)
		    (server:start-and-wait areapath)
		    (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries)
		    (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries))))  ;; give server a little time to start up, randomize a little to avoid start storms.
		    (client:setup-http areapath remaining-tries: (- remaining-tries 1)))))))))








<
|
<
|








<
|











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
	    (let ((host  (cadr  server-dat))
		  (port  (caddr server-dat)))
	      (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
	      (if (and (not area-dat)
		       (not *runremote*))
		  (set! *runremote* (make-remote)))
	      (if (and host port)

		  (let* ((start-res (http-transport:client-connect host port))

			 (ping-res  (rmt:login-no-auto-client-setup start-res)))
		    (if (and start-res
			     ping-res)
			(let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago
			  (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res)
			  (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))
			  start-res)
			(begin    ;; login failed but have a server record, clean out the record and try again
			  (debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid.  Fixes part of Randy;s ticket 1405717332

			  (http-transport:close-connections)
			  (remote-conndat-set! runremote #f)  ;; (hash-table-delete! runremote run-id)
			  (thread-sleep! 1)
			  (client:setup-http areapath remaining-tries: (- remaining-tries 1))
			  )))
		  (begin    ;; no server registered
		    ;; (server:kind-run areapath)
		    (server:start-and-wait areapath)
		    (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries)
		    (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries))))  ;; give server a little time to start up, randomize a little to avoid start storms.
		    (client:setup-http areapath remaining-tries: (- remaining-tries 1)))))))))

Deleted codescanlib.scm version [6e625610ce].

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
;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

;; gotta compile with csc, doesn't work with csi -s for whatever reason

(use srfi-69)
(use matchable)
(use utils)
(use ports)
(use extras)
(use srfi-1)
(use posix)
(use srfi-12)

;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )
(define (load-scm-file scm-file)
  ;;(print "load "scm-file)
  (handle-exceptions
   exn
   '()
   (with-input-from-string
       (conc "("
             (with-input-from-file scm-file read-all)
             ")" )
     read)))

;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
;;   -- be advised:
;;      * this may be fooled by macros, since this code does not take them into account.
;;      * this code does only checks for form (define (<procname> ... ) <body>)
;;           so it excludes from reckoning
;;               - generated functions, as in things like foo-set! from defstructs,
;;               - define-inline, (
;;               - define procname (lambda ..
;;               - etc...
(define (get-toplevel-procs+file+args+body filename)
  (let* ((scm-tree (load-scm-file filename))
         (procs
          (filter identity
                  (map
                   (match-lambda 
                    [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
                    [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
                    [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
                    [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>)
                     (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
                         (list defname filename args body)
                         #f)]
                    [else #f] ) scm-tree))))
    procs))


;; given a sexp, return a flat list of atoms in that sexp
(define (get-atoms-in-body body)
  (cond
   ((null? body) '())
   ((atom? body) (list body))
   (else
    (apply append (map get-atoms-in-body body)))))

;;  given a file, return a list of procname, file, list of atoms in said procname
(define (get-procs+file+atoms file)
  (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
         (res
          (map
           (lambda (item)
             (let* ((proc (car item))
                    (file (cadr item))
                    (args (caddr item))
                    (body (cadddr item))
                    (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
               (list proc file atoms)))
           toplevel-proc-items)))
    res))

;; uniquify a list of atoms 
(define (unique-atoms lst)
  (let loop ((lst (flatten lst)) (res '()))
    (if (null? lst)
        (reverse res)
        (let ((c (car lst)))
          (loop (cdr lst) (if (member c res) res (cons c res)))))))

;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
;; returning alist mapping procname to procname that calls said procname
(define (get-callers-alist all-procs+file+calls)
  (let* ((all-procs (map car all-procs+file+calls))
         (caller-ht (make-hash-table))) 
    ;; let's cross reference with a hash table
    (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
    (for-each (lambda (item)
               (let* ((proc (car item))
                      (file (cadr item))
                      (calls (caddr item)))
                 (for-each (lambda (callee)
                             (hash-table-set! caller-ht callee
                                              (cons proc
                                                    (hash-table-ref caller-ht callee))))
                           calls)))
              all-procs+file+calls)
    (map (lambda (x)
           (let ((k (car x))
                 (r (unique-atoms (cdr x))))
             (cons k r)))                    
         (hash-table->alist caller-ht))))

;; create a handy cross-reference of callees to callers in the form of an alist.
(define (get-xref all-scm-files)
  (let* ((all-procs+file+atoms
          (apply append (map get-procs+file+atoms all-scm-files)))
         (all-procs (map car all-procs+file+atoms))
         (all-procs+file+calls  ; proc calls things in calls list
          (map (lambda (item)
                 (let* ((proc (car item))
                        (file (cadr item))
                        (atoms (caddr item))
                        (calls
                         (filter identity
                                 (map
                                  (lambda (x)
                                    (if (and ;; (not (equal? x proc))  ;; uncomment to prevent listing self
                                         (member x all-procs))
                                        x
                                        #f))
                                  atoms))))
                   (list proc file calls)))
               all-procs+file+atoms))
         (callers (get-callers-alist all-procs+file+calls))) 
    callers))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































Modified common.scm from [33c7316880] to [c39ecb5538].

1
2
3
4
5
6
7
8
;;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
|







1
2
3
4
5
6
7
8
;get-u;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
	  (sparse-vector-set! new-row y val)))))

;;======================================================================
;; L O C K E R S   A N D   B L O C K E R S 
;;======================================================================

;; block further accesses to databases. Call this before shutting db down
(define (common:db-block-further-queries)
  (mutex-lock! *db-access-mutex*)
  (set! *db-access-allowed* #f)
  (mutex-unlock! *db-access-mutex*))

(define (common:db-access-allowed?)
  (let ((val (begin
	       (mutex-lock! *db-access-mutex*)
	       *db-access-allowed*
	       (mutex-unlock! *db-access-mutex*))))
    val))

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







|




|







651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
	  (sparse-vector-set! new-row y val)))))

;;======================================================================
;; L O C K E R S   A N D   B L O C K E R S 
;;======================================================================

;; block further accesses to databases. Call this before shutting db down
#;(define (common:db-block-further-queries)
  (mutex-lock! *db-access-mutex*)
  (set! *db-access-allowed* #f)
  (mutex-unlock! *db-access-mutex*))

#;(define (common:db-access-allowed?)
  (let ((val (begin
	       (mutex-lock! *db-access-mutex*)
	       *db-access-allowed*
	       (mutex-unlock! *db-access-mutex*))))
    val))

;;======================================================================
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
      (if (> num-tries 0) ;; should be "num-tries-left". 
	  (if (common:low-noise-print 30 (conc (round effective-load) "-load-acceptable-" effective-host))
	      (debug:print 0 *default-log-port* "Load on " effective-host " is acceptable at effective normalized load of "
			   effective-normalized-load "  continuing."))
	  (debug:print 0 *default-log-port* "Load on " effective-host ", "
		       first" could not be retrieved. Giving up and continuing."))))))

;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load
;;
;; (define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f)(num-tries 5))
;;   (let* ((loadavg (common:get-cpu-load remote-host))
;; 	 (numcpus (if (<= 1 numcpus-in) ;; not possible to have zero.  If we get 1, it's possible that we got the previous default, and we should check again
;; 		      (common:get-num-cpus remote-host)
;; 		      numcpus-in))
;; 	 (maxload (if force-maxload
;; 		      maxload-in
;; 		      (if (number? maxload-in)
;; 			  (max maxload-in 0.5)
;; 			  0.5))) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
;; 	 (first   (car loadavg))
;; 	 (next    (cadr loadavg))
;; 	 (adjmaxload (* maxload (max 1 numcpus))) ;; possible bug where
;; 					       ;; numcpus (or could be
;; 					       ;; maxload) is zero,
;; 					       ;; crude fallback is to
;; 					       ;; at least use 1
;; 	 (loadjmp (- first (if (> next (* numcpus 0.7)) ;; could do something with average of first and next?
;; 			       0
;; 			       next))) ;; we will force a conservative calculation any time next is large.
;; 	 (first-next-avg    (/ (+ first next) 2))
;; 	 ;; add some randomness to the time to break any alignment
;; 	 ;; where netbatch dumps many jobs to machines simultaneously
;;          (adjwait           (min (+ 300 (random 10)) (abs (* (+ (random 10)
;; 								(/ (- 1000 count) 10)
;; 								waitdelay)
;; 							     (- first adjmaxload) ))))
;; 	 (load-jump-limit   (configf:lookup-number *configdat* "setup" "load-jump-limit"))
;; 	 ;; effective load accounts for load jumps, this should elminate all the first-next-avg, adjwait, load-jump-limit
;; 	 ;; etc.
;; 	 (effective-load    (common:get-intercept first next))
;; 	 (effective-host    (or remote-host "localhost"))
;; 	 (normalized-effective-load (/ effective-load numcpus))
;; 	 (will-wait                 (> normalized-effective-load maxload)))
;; 	 
;;     ;; let's let the user know once in a long while that load checking
;;     ;; is happening but not constantly report it
;;     #;(if (common:low-noise-print 30 (conc "cpuload" (or remote-host "localhost"))) ;; (> (random 100) 75) ;; about 25% of the time
;; 	(debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload
;;     ", load: " first ", adjmaxload: " adjmaxload ", loadjmp: " loadjmp))
;; 
;;     (debug:print-info 1 *default-log-port*
;; 		      "On host: " effective-host
;; 		      ", effective load: " effective-load
;; 		      ", numcpus: " numcpus
;; 		      ", normalized effective load: " normalized-effective-load
;; 		      )
;;     
;;     (cond
;;      ;; bad data, try again to get the data
;;      ((and (< first 0) ;; this indicates the loadavg data is bad - machine may not be reachable
;; 	   (> num-tries 0))
;;       (debug:print 0 *default-log-port* "WARNING: received bad data from get-cpu-load " first ", we'll sleep 10s and try " num-tries " more times.")
;;       (thread-sleep! 10)
;;       (common:wait-for-cpuload maxload-in numcpus-in waitdelay
;; 			       count: count remote-host: remote-host force-maxload: force-maxload num-tries: (- num-tries 1)))
;;      ;; need to wait for load to drop
;;      ((and will-wait ;; (> first adjmaxload)
;; 	   (> count 0))
;;       (debug:print-info 0 *default-log-port*
;; 			"Delaying " 15 ;; adjwait
;; 			" seconds due to normalized effective load " normalized-effective-load ;; first
;; 			" exceeding max of " adjmaxload
;; 			" on server " (or remote-host (get-host-name))
;; 			" (normalized load-limit: " maxload ") " (if msg msg ""))
;;       (thread-sleep! 15) ;; adjwait)
;;       (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
;;      ((and (> loadjmp (cond
;; 		       (load-jump-limit load-jump-limit)
;; 		       ((> numcpus 8)(/ numcpus 2))
;; 		       ((> numcpus 4)(/ numcpus 1.2))
;; 		       (else 0.5)))
;; 	   (> count 0))
;;       (debug:print-info 0 *default-log-port* "waiting " adjwait " seconds due to possible load jump " loadjmp ". "
;; 			(if msg msg ""))
;;       (thread-sleep! adjwait)
;;       (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
;;      (else
;;       (if (> num-tries 0)
;; 	  (if (common:low-noise-print 30 (conc (round first) "-load-acceptable-" (or remote-host "localhost")))
;; 	      (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") " is acceptable at " first " continuing."))
;; 	  (debug:print 0 *default-log-port* "Load on " (or remote-host "localhost") ", "first" could not be retrieved. Giving up and continuing."))))))
;; 
(define (get-uname . params)
  (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
	 (uname #f))
    (if (null? (car uname-res))
	"unknown"
	(caar uname-res))))

;; for reasons I don't understand multiple calls to real-path in parallel threads
;; must be protected by mutexes
;;
(define (common:real-path inpath)
  ;; (process:cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params)
  ;; (let-values 
  ;;  (((inp oup pid) (process "readlink" (list "-f" inpath))))
  ;;  (with-input-from-port inp
  ;;    (let loop ((inl (read-line))
  ;;       	(res #f))
  ;;      (print "inl=" inl)
  ;;      (if (eof-object? inl)
  ;;          (begin
  ;;            (close-input-port inp)
  ;;            (close-output-port oup)
  ;;            ;; (process-wait pid)
  ;;            res)
  ;;          (loop (read-line) inl))))))
  (with-input-from-pipe (conc "readlink -f " inpath) read-line))

;;======================================================================
;; D I S K   S P A C E 
;;======================================================================

(define (common:get-disk-space-used fpath)







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











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







2230
2231
2232
2233
2234
2235
2236





















































































2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247














2248
2249
2250
2251
2252
2253
2254
      (if (> num-tries 0) ;; should be "num-tries-left". 
	  (if (common:low-noise-print 30 (conc (round effective-load) "-load-acceptable-" effective-host))
	      (debug:print 0 *default-log-port* "Load on " effective-host " is acceptable at effective normalized load of "
			   effective-normalized-load "  continuing."))
	  (debug:print 0 *default-log-port* "Load on " effective-host ", "
		       first" could not be retrieved. Giving up and continuing."))))))






















































































(define (get-uname . params)
  (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
	 (uname #f))
    (if (null? (car uname-res))
	"unknown"
	(caar uname-res))))

;; for reasons I don't understand multiple calls to real-path in parallel threads
;; must be protected by mutexes
;;
(define (common:real-path inpath)














  (with-input-from-pipe (conc "readlink -f " inpath) read-line))

;;======================================================================
;; D I S K   S P A C E 
;;======================================================================

(define (common:get-disk-space-used fpath)
2571
2572
2573
2574
2575
2576
2577

2578
2579
2580
2581
2582
2583
2584
2585
		 (delete-directory d))))
	 (sort (hash-table-keys directories) (lambda (a b)(> (string-length a)(string-length b))))))
    ))

;;======================================================================
;; E N V I R O N M E N T   V A R S
;;======================================================================

(define (bb-check-path #!key (msg "check-path: "))
  (let ((path (or (get-environment-variable "PATH") "none")))
    (debug:print-info 0 *default-log-port* (conc msg" : $PATH="path))
    (if (string-match "^.*/isoenv-core/.*" path)
        (debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod
        (debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**")))))

	      







>
|







2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
		 (delete-directory d))))
	 (sort (hash-table-keys directories) (lambda (a b)(> (string-length a)(string-length b))))))
    ))

;;======================================================================
;; E N V I R O N M E N T   V A R S
;;======================================================================

#;(define (bb-check-path #!key (msg "check-path: "))
  (let ((path (or (get-environment-variable "PATH") "none")))
    (debug:print-info 0 *default-log-port* (conc msg" : $PATH="path))
    (if (string-match "^.*/isoenv-core/.*" path)
        (debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod
        (debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**")))))

	      
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
   ((equal? status "WARN")    "orange")
   ((equal? status "KILLED")  "orange")
   ((equal? status "KILLREQ") "purple")
   ((equal? status "RUNNING") "blue")
   ((equal? status "ABORT")   "brown")
   (else "black")))

;; ;;======================================================================
;; ;; N A N O M S G   C L I E N T
;; ;;======================================================================
;; 
;; 
;; 
;; (define (common:send-dboard-main-changed)
;;   (let* ((dashboard-ips (mddb:get-dashboards)))
;;     (for-each
;;      (lambda (ipadr)
;;        (let* ((soc (common:open-nm-req (conc "tcp://" ipadr)))
;; 	      (msg (conc "main " *toppath*))
;; 	      (res (common:nm-send-receive-timeout soc msg)))
;; 	 (if (not res) ;; couldn't reach that dashboard - remove it from db
;; 	     (print "ERROR: couldn't reach dashboard " ipadr))
;; 	 res))
;;      dashboard-ips)))
;;     
;;     
;; ;;======================================================================
;; ;; D A S H B O A R D   D B 
;; ;;======================================================================
;; 
;; (define (mddb:open-db)
;;   (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db"))))
;;     (set-busy-handler! db (busy-timeout 10000))
;;     (for-each
;;      (lambda (qry)
;;        (exec (sql db qry)))
;;      (list 
;;       "CREATE TABLE IF NOT EXISTS vars       (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));"
;;       "CREATE TABLE IF NOT EXISTS dashboards (
;;           id         INTEGER PRIMARY KEY,
;;           pid        INTEGER,
;;           username   TEXT,
;;           hostname   TEXT,
;;           ipaddr     TEXT,
;;           portnum    INTEGER,
;;           start_time TIMESTAMP DEFAULT (strftime('%s','now')),
;;              CONSTRAINT hostport UNIQUE (hostname,portnum)
;;         );"
;;       ))
;;     db))
;; 
;; ;; register a dashboard 
;; ;;
;; (define (mddb:register-dashboard port)
;;   (let* ((pid      (current-process-id))
;; 	 (hostname (get-host-name))
;; 	 (ipaddr   (server:get-best-guess-address hostname))
;; 	 (username (current-user-name)) ;; (car userinfo)))
;; 	 (db      (mddb:open-db)))
;;     (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username)
;;     (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);")
;; 	   pid username hostname ipaddr port)
;;     (close-database db)))
;; 
;; ;; unregister a monitor
;; ;;
;; (define (mddb:unregister-dashboard host port)
;;   (let* ((db      (mddb:open-db)))
;;     (print "Register unregister monitor, host:port=" host ":" port)
;;     (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port)
;;     (close-database db)))
;; 
;; ;; get registered dashboards
;; ;;
;; (define (mddb:get-dashboards)
;;   (let ((db (mddb:open-db)))
;;     (query fetch-column
;; 	   (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;"))))
    
;;======================================================================
;;  T E S T   L A U N C H I N G   P E R   I T E M   W I T H   H O S T   T Y P E S
;;======================================================================
;; 
;; [hosts]
;; arm cubie01 cubie02







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







2988
2989
2990
2991
2992
2993
2994







































































2995
2996
2997
2998
2999
3000
3001
   ((equal? status "WARN")    "orange")
   ((equal? status "KILLED")  "orange")
   ((equal? status "KILLREQ") "purple")
   ((equal? status "RUNNING") "blue")
   ((equal? status "ABORT")   "brown")
   (else "black")))








































































    
;;======================================================================
;;  T E S T   L A U N C H I N G   P E R   I T E M   W I T H   H O S T   T Y P E S
;;======================================================================
;; 
;; [hosts]
;; arm cubie01 cubie02
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
	     (begin
	       (debug:print 0 *default-log-port* "joining threads failed. exn=" exn)
               #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception
             (thread-join! thread))
           )))
   (hash-table-keys *common:thread-punchlist*)))

(define *common:telemetry-log-state* 'startup)
(define *common:telemetry-log-socket* #f)

(define (common:telemetry-log-open)
  (if (eq? *common:telemetry-log-state* 'startup)
      (let* ((serverhost (configf:lookup *configdat* "telemetry" "host"))
             (serverport (configf:lookup-number *configdat* "telemetry" "port"))
             (user (or (get-environment-variable "USER") "unknown"))
             (host (or (get-environment-variable "HOST") "unknown")))
        (set! *common:telemetry-log-state*
              (handle-exceptions
               exn
               (begin
                 (debug:print-info 0 *default-log-port* "common-telemetry-log open udp port failure")
                 'broken)
               (if (and serverhost serverport user host)
                   (let* ((s (udp-open-socket)))
                     ;;(udp-bind! s #f 0)
                     (udp-connect! s serverhost serverport)
                     (set! *common:telemetry-log-socket* s)
                     'open)
                   'not-needed))))))
  
(define (common:telemetry-log event #!key (payload '()))
  (if (eq? *common:telemetry-log-state* 'startup)
      (common:telemetry-log-open))

  (if (eq? 'open *common:telemetry-log-state*)
      (handle-exceptions
       exn
       (begin







|
|

|



















|







3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
	     (begin
	       (debug:print 0 *default-log-port* "joining threads failed. exn=" exn)
               #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception
             (thread-join! thread))
           )))
   (hash-table-keys *common:thread-punchlist*)))

#;(define *common:telemetry-log-state* 'startup)
#;(define *common:telemetry-log-socket* #f)

#;(define (common:telemetry-log-open)
  (if (eq? *common:telemetry-log-state* 'startup)
      (let* ((serverhost (configf:lookup *configdat* "telemetry" "host"))
             (serverport (configf:lookup-number *configdat* "telemetry" "port"))
             (user (or (get-environment-variable "USER") "unknown"))
             (host (or (get-environment-variable "HOST") "unknown")))
        (set! *common:telemetry-log-state*
              (handle-exceptions
               exn
               (begin
                 (debug:print-info 0 *default-log-port* "common-telemetry-log open udp port failure")
                 'broken)
               (if (and serverhost serverport user host)
                   (let* ((s (udp-open-socket)))
                     ;;(udp-bind! s #f 0)
                     (udp-connect! s serverhost serverport)
                     (set! *common:telemetry-log-socket* s)
                     'open)
                   'not-needed))))))
  
#;(define (common:telemetry-log event #!key (payload '()))
  (if (eq? *common:telemetry-log-state* 'startup)
      (common:telemetry-log-open))

  (if (eq? 'open *common:telemetry-log-state*)
      (handle-exceptions
       exn
       (begin
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
                   (base64:base64-encode
                    (z3:encode-buffer
                     (with-output-to-string (lambda () (pp payload))))))
                  (msg     (conc user":"host":"start":"(current-process-id)":"(car (argv))":"
                                 toppath":"payload-serialized)))
             (udp-send *common:telemetry-log-socket* msg))))))
  
(define (common:telemetry-log-close)
  (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*)
    (handle-exceptions
     exn
     (begin
       (define *common:telemetry-log-state* 'closed-fail)
       (debug:print-info 0 *default-log-port* "common-telemetry-log closure failure")
       )
     (begin
       (define *common:telemetry-log-state* 'closed)
       (udp-close-socket *common:telemetry-log-socket*)
       (set! *common:telemetry-log-socket* #f)))))








|












3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
                   (base64:base64-encode
                    (z3:encode-buffer
                     (with-output-to-string (lambda () (pp payload))))))
                  (msg     (conc user":"host":"start":"(current-process-id)":"(car (argv))":"
                                 toppath":"payload-serialized)))
             (udp-send *common:telemetry-log-socket* msg))))))
  
#;(define (common:telemetry-log-close)
  (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*)
    (handle-exceptions
     exn
     (begin
       (define *common:telemetry-log-state* 'closed-fail)
       (debug:print-info 0 *default-log-port* "common-telemetry-log closure failure")
       )
     (begin
       (define *common:telemetry-log-state* 'closed)
       (udp-close-socket *common:telemetry-log-socket*)
       (set! *common:telemetry-log-socket* #f)))))

Modified common_records.scm from [80f9e14f2d] to [99a020d843].

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
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  (if *logging*
	      (db:log-event (apply conc params))
	      (apply print params)
	      )))))


;; Brandon's debug printer shortcut (indulge me :)
(define *BB-process-starttime* (current-milliseconds))
(define (BB> . in-args)
  (let* ((stack (get-call-chain))
         (location "??"))
    (for-each
     (lambda (frame)
       (let* ((this-loc (vector-ref frame 0))
              (temp     (string-split (->string this-loc) " "))
              (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
         (if (equal? this-func "BB>")
             (set! location this-loc))))
     stack)
    (let* ((color-on "\x1b[1m")
           (color-off "\x1b[0m")
           (dp-args
            (append
             (list 0 *default-log-port*
                   (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off "   ")  )
             in-args)))
      (apply debug:print dp-args))))

(define *BBpp_custom_expanders_list* (make-hash-table))



;; register hash tables with BBpp.
(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
                 (cons hash-table? hash-table->alist))

;; test name converter
(define (BBpp_custom_converter arg)
  (let ((res #f))
    (for-each
     (lambda (custom-type-name)
       (let* ((custom-type-info      (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
              (custom-type-test      (car custom-type-info))
              (custom-type-converter (cdr custom-type-info)))
         (when (and (not res) (custom-type-test arg))
           (set! res (custom-type-converter arg)))))
     (hash-table-keys *BBpp_custom_expanders_list*))
    (if res (BBpp_ res) arg)))

(define (BBpp_ arg)
  (cond
   ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
   ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
   ((hash-table? arg)
    (let ((al (hash-table->alist arg)))
      (BBpp_ (cons HASH_TABLE: al))))
   ((null? arg) '())
   ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
   ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
   (else (BBpp_custom_converter arg))))

;; Brandon's pretty printer.  It expands hashes and custom types in addition to regular pp
(define (BBpp arg)
  (pp (BBpp_ arg)))

;(use define-macro)
(define-syntax inspect
  (syntax-rules ()
    [(_ x)
    ;; (with-output-to-port (current-error-port)







>

|
|



















|




|



|











|












|







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
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  (if *logging*
	      (db:log-event (apply conc params))
	      (apply print params)
	      )))))

;; Useful stuff. Do not remove - commented and removed to trim mem usage for now (might make no difference).
;; Brandon's debug printer shortcut (indulge me :)
#;(define *BB-process-starttime* (current-milliseconds))
#;(define (BB> . in-args)
  (let* ((stack (get-call-chain))
         (location "??"))
    (for-each
     (lambda (frame)
       (let* ((this-loc (vector-ref frame 0))
              (temp     (string-split (->string this-loc) " "))
              (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
         (if (equal? this-func "BB>")
             (set! location this-loc))))
     stack)
    (let* ((color-on "\x1b[1m")
           (color-off "\x1b[0m")
           (dp-args
            (append
             (list 0 *default-log-port*
                   (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off "   ")  )
             in-args)))
      (apply debug:print dp-args))))

#;(define *BBpp_custom_expanders_list* (make-hash-table))



;; register hash tables with BBpp.
#;(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
                 (cons hash-table? hash-table->alist))

;; test name converter
#;(define (BBpp_custom_converter arg)
  (let ((res #f))
    (for-each
     (lambda (custom-type-name)
       (let* ((custom-type-info      (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
              (custom-type-test      (car custom-type-info))
              (custom-type-converter (cdr custom-type-info)))
         (when (and (not res) (custom-type-test arg))
           (set! res (custom-type-converter arg)))))
     (hash-table-keys *BBpp_custom_expanders_list*))
    (if res (BBpp_ res) arg)))

#;(define (BBpp_ arg)
  (cond
   ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
   ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
   ((hash-table? arg)
    (let ((al (hash-table->alist arg)))
      (BBpp_ (cons HASH_TABLE: al))))
   ((null? arg) '())
   ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
   ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
   (else (BBpp_custom_converter arg))))

;; Brandon's pretty printer.  It expands hashes and custom types in addition to regular pp
#;(define (BBpp arg)
  (pp (BBpp_ arg)))

;(use define-macro)
(define-syntax inspect
  (syntax-rules ()
    [(_ x)
    ;; (with-output-to-port (current-error-port)

Modified configf.scm from [b115fef76f] to [e77955d6cf].

124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
					((sect var)(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))"))
					(else
					 (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
					 "(lambda (ht) #f)")))
				((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				;; ((rget)           (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
		;; (print "fullcmd=" fullcmd)
		(handle-exceptions
		 exn
		 (begin
		   (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn)
		   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
		   ;; (print "exn=" (condition->list exn))
		   (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
		 (if (or allow-system
			 (not (member cmdtype '("system" "shell" "sh"))))
		     (with-input-from-string fullcmd
		       (lambda ()
			 (set! result ((eval (read)) ht))))
		     (set! result (conc "#{(" cmdtype ") "  cmd "}"))))







<





<







124
125
126
127
128
129
130

131
132
133
134
135

136
137
138
139
140
141
142
					((sect var)(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))"))
					(else
					 (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
					 "(lambda (ht) #f)")))
				((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				;; ((rget)           (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))

		(handle-exceptions
		 exn
		 (begin
		   (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn)
		   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))

		   (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
		 (if (or allow-system
			 (not (member cmdtype '("system" "shell" "sh"))))
		     (with-input-from-string fullcmd
		       (lambda ()
			 (set! result ((eval (read)) ht))))
		     (set! result (conc "#{(" cmdtype ") "  cmd "}"))))
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
;;
(define (read-config path ht allow-system #!key (environ-patt #f)            (curr-section #f)   
		     (sections #f)              (settings (make-hash-table)) (keep-filenames #f)
		     (post-section-procs '())   (apply-wildcards #t) )
  (debug:print 9 *default-log-port* "START: " path)
;; (if *configdat*
;;     (common:save-pkt `((action . read-config)
;;       		 (f      . ,(cond ((string? path) path)
;;       				  ((port?   path) "port")
;;       				  (else (conc path))))
;;                        (T      . configf))
;;       	       *configdat* #t add-only: #t))
  (if (and (not (port? path))
	   (not (common:file-exists? path))) ;; for case where we are handed a port
      (begin 
	(debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory))
	;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
	#f) ;; (if (not ht)(make-hash-table) ht))
      (let ((inp        (if (string? path)







<
<
<
<
<
<
<







261
262
263
264
265
266
267







268
269
270
271
272
273
274
;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
;;
(define (read-config path ht allow-system #!key (environ-patt #f)            (curr-section #f)   
		     (sections #f)              (settings (make-hash-table)) (keep-filenames #f)
		     (post-section-procs '())   (apply-wildcards #t) )
  (debug:print 9 *default-log-port* "START: " path)







  (if (and (not (port? path))
	   (not (common:file-exists? path))) ;; for case where we are handed a port
      (begin 
	(debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory))
	;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
	#f) ;; (if (not ht)(make-hash-table) ht))
      (let ((inp        (if (string? path)

Added danglers-to-ignore.txt version [b2a2845e76].









>
>
>
>
1
2
3
4
spublish:lst->path
megatest-param->mtutil-param
add-target-mapper
add-runname-mapper

Modified dashboard-context-menu.scm from [48947370a7] to [e217fccd36].

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
                           subst-alist)))
               (iup:menu-item
                (conc "*"menu-item-text)
                #:action
                (lambda (obj)

                  (let* ((scheme-match (string-match "^#(\\(.*)" command-line)))
                    ;;(BB> "cmdline is >"command-line"<")
                    (common:with-env-vars
                     ;; TODO: with-env-vars <runconfig target vars, env-override vars from mtest>
                     ;; TODO: with-env-vars MT_*
                     (runs:get-mt-env-alist run-id run-name target test-name item-path)
                     
                     (lambda ()
                       (if scheme-match
                           (begin
                             (handle-exceptions
                              exn
                              (print "error with custom menu scheme, exn=" exn)
                              (begin
                                ;;(BB> "gonna eval it!")
                                (eval (with-input-from-string (cadr scheme-match) read)))))
                           (common:run-a-command command-line with-vars: #t))))))))
             #f)))
     vars)))

(define (dashboard:context-menu  run-id test-id target runname test-name testpatt item-test-path test-info)
  (let* ((run-menu-items







<












<







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
                           subst-alist)))
               (iup:menu-item
                (conc "*"menu-item-text)
                #:action
                (lambda (obj)

                  (let* ((scheme-match (string-match "^#(\\(.*)" command-line)))

                    (common:with-env-vars
                     ;; TODO: with-env-vars <runconfig target vars, env-override vars from mtest>
                     ;; TODO: with-env-vars MT_*
                     (runs:get-mt-env-alist run-id run-name target test-name item-path)
                     
                     (lambda ()
                       (if scheme-match
                           (begin
                             (handle-exceptions
                              exn
                              (print "error with custom menu scheme, exn=" exn)
                              (begin

                                (eval (with-input-from-string (cadr scheme-match) read)))))
                           (common:run-a-command command-line with-vars: #t))))))))
             #f)))
     vars)))

(define (dashboard:context-menu  run-id test-id target runname test-name testpatt item-test-path test-info)
  (let* ((run-menu-items

Modified dashboard-guimonitor.scm from [9920d4908c] to [03f2c3c501].

169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
    (iup:show topdialog)
    (iup:callback-set! *tim* "ACTION_CB"
		       (lambda (x)
			 (refreshdat)
			 (if *exit-started*
			     (set! *exit-started* 'ok))))))

(define (main-window setuptab fsltab collateraltab toolstab)
  (iup:show
   (iup:dialog #:title "FSL Power Window" #:size "290x190" ; #:expand "YES"
               (let ((tabtop (iup:tabs setuptab collateraltab fsltab toolstab)))
                 (iup:attribute-set! tabtop "TABTITLE0" "Setup") 
                 (iup:attribute-set! tabtop "TABTITLE1" "Collateral")
                 (iup:attribute-set! tabtop "TABTITLE2" "Fossil")
                 (iup:attribute-set! tabtop "TABTITLE3" "Tools")
                 tabtop))))

;; BUG: Remember to re-instate this!!!!
;; (on-exit (lambda ()
;; 	   (let ((tdb (tasks:open-db)))
;; 	     ;; (print "On-exit called")
;; 	     (tasks:remove-monitor-record tdb)
;; 	     (sqlite3:finalize! tdb))))







|
|
|
|
|
|
|
|
|







169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
    (iup:show topdialog)
    (iup:callback-set! *tim* "ACTION_CB"
		       (lambda (x)
			 (refreshdat)
			 (if *exit-started*
			     (set! *exit-started* 'ok))))))

;; (define (main-window setuptab fsltab collateraltab toolstab)
;;   (iup:show
;;    (iup:dialog #:title "FSL Power Window" #:size "290x190" ; #:expand "YES"
;;                (let ((tabtop (iup:tabs setuptab collateraltab fsltab toolstab)))
;;                  (iup:attribute-set! tabtop "TABTITLE0" "Setup") 
;;                  (iup:attribute-set! tabtop "TABTITLE1" "Collateral")
;;                  (iup:attribute-set! tabtop "TABTITLE2" "Fossil")
;;                  (iup:attribute-set! tabtop "TABTITLE3" "Tools")
;;                  tabtop))))

;; BUG: Remember to re-instate this!!!!
;; (on-exit (lambda ()
;; 	   (let ((tdb (tasks:open-db)))
;; 	     ;; (print "On-exit called")
;; 	     (tasks:remove-monitor-record tdb)
;; 	     (sqlite3:finalize! tdb))))

Modified dashboard-tests.scm from [237d160a6c] to [6f441d3adc].

752
753
754
755
756
757
758
759

760
761
762
763
764
765
766
767
768
							    #:numlin 100
							    #:numcol-visible 9
							    #:numlin-visible 5
							    #:click-cb (lambda (obj lin col status)
									 ;; (if (equal? col 6)
									 (let* ((mtrx-rc  (conc lin ":" 6))
										(fname    (iup:attribute obj mtrx-rc))
                                                                                (stepname (iup:attribute obj (conc lin ":" 1)))                                                                                            (comment  (iup:attribute obj (conc lin ":" 7))))

                                                                           (case col
                                                                             
                                                                             ((7) (print "Comment from step "stepname": "comment))
                                                                             ((8) (ezsteps:spawn-run-from testdat stepname #t))
                                                                             ((9) (ezsteps:spawn-run-from testdat stepname #f))
                                                                             (else (view-a-log fname))))))))
					 ;; (let loop ((count 0))
					 ;;   (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count))
					 ;;   (if (< count 30)







|
>

<







752
753
754
755
756
757
758
759
760
761

762
763
764
765
766
767
768
							    #:numlin 100
							    #:numcol-visible 9
							    #:numlin-visible 5
							    #:click-cb (lambda (obj lin col status)
									 ;; (if (equal? col 6)
									 (let* ((mtrx-rc  (conc lin ":" 6))
										(fname    (iup:attribute obj mtrx-rc))
                                                                                (stepname (iup:attribute obj (conc lin ":" 1)))
										(comment  (iup:attribute obj (conc lin ":" 7))))
                                                                           (case col

                                                                             ((7) (print "Comment from step "stepname": "comment))
                                                                             ((8) (ezsteps:spawn-run-from testdat stepname #t))
                                                                             ((9) (ezsteps:spawn-run-from testdat stepname #f))
                                                                             (else (view-a-log fname))))))))
					 ;; (let loop ((count 0))
					 ;;   (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count))
					 ;;   (if (< count 30)

Modified dashboard.scm from [935bf4d2df] to [eb8b06f2b9].

46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses mt))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")

(define help (conc 
	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest







<







46
47
48
49
50
51
52

53
54
55
56
57
58
59
(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses mt))

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

(include "task_records.scm")
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")

(define help (conc 
	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
  ;; runs summary view
  
  tests-tree       ;; used in newdashboard
  )

;; register tabdat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle
(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
                 (cons dboard:tabdat?
                       (lambda (tabdat-item)
                         (filter
                          (lambda (alist-entry)
                            (member (car alist-entry)
                                    '(allruns-by-id allruns))) ;; FIELDS OF INTEREST
                          (dboard:tabdat->alist tabdat-item)))))







|







348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
  ;; runs summary view
  
  tests-tree       ;; used in newdashboard
  )

;; register tabdat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle
#;(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
                 (cons dboard:tabdat?
                       (lambda (tabdat-item)
                         (filter
                          (lambda (alist-entry)
                            (member (car alist-entry)
                                    '(allruns-by-id allruns))) ;; FIELDS OF INTEREST
                          (dboard:tabdat->alist tabdat-item)))))
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
  status
  start-time
  duration
  )

;; register dboard:rundat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
                 (cons dboard:rundat?
                       (lambda (tabdat-item)
                         (filter
                          (lambda (alist-entry)
                            (member (car alist-entry)
                                    '(run run-data-offset ))) ;; FIELDS OF INTEREST
                          (dboard:rundat->alist tabdat-item)))))







|







498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
  status
  start-time
  duration
  )

;; register dboard:rundat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
#;(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
                 (cons dboard:rundat?
                       (lambda (tabdat-item)
                         (filter
                          (lambda (alist-entry)
                            (member (car alist-entry)
                                    '(run run-data-offset ))) ;; FIELDS OF INTEREST
                          (dboard:rundat->alist tabdat-item)))))
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
      (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
      #f))

(define (new-tree-path->run-id rdat path)
  (if (not (null? path))
      (hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f)
      #f))

;; (define (dboard:get-tests-dat tabdat run-id last-update)
;;   (let* ((access-mode     (dboard:tabdat-access-mode tabdat))
;;          (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
;;                                              run-id 
;; 					     (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; 					     (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))  ;; '()
;; 					     (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '()
;; 					     #f #f                                                       ;; offset limit
;; 					     (dboard:tabdat-hide-not-hide tabdat)                        ;; not-in
;; 					     #f #f                                                       ;; sort-by sort-order
;; 					     #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration"                        ;; qryval
;;                                              (if (dboard:tabdat-filters-changed tabdat)
;; 					         0
;; 					         last-update)
;; 					     *dashboard-mode*)
;; 		  '()))) ;; get 'em all
;;     ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id)
;;     (sort tdat (lambda (a b)
;; 		 (let* ((aval (vector-ref a 2))
;; 			(bval (vector-ref b 2))
;; 			(anum (string->number aval))
;; 			(bnum (string->number bval)))
;; 		   (if (and anum bnum)
;; 		       (< anum bnum)
;; 		       (string<= aval bval)))))))


(define (dashboard:safe-cadr-assoc name lst)
  (let ((res (assoc name lst)))
    (if (and res (> (length res) 1))
	(cadr res)
	#f)))








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







1824
1825
1826
1827
1828
1829
1830



























1831
1832
1833
1834
1835
1836
1837
      (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
      #f))

(define (new-tree-path->run-id rdat path)
  (if (not (null? path))
      (hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f)
      #f))




























(define (dashboard:safe-cadr-assoc name lst)
  (let ((res (assoc name lst)))
    (if (and res (> (length res) 1))
	(cadr res)
	#f)))

2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
                         (lambda ()

                           ;; Bummer - we dont have the global get/set api mapped in chicken
                           ;; (let* ((modkeys (iup:global "MODKEYSTATE")))
                           ;;   (BB> "modkeys="modkeys))

                           (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status)
                           ;; status is corrupted on Brandon's home machine.  will have to wait until after shutdown to see if it is still broken in PDX SLES
                           (let* ((toolpath (car (argv)))
                                  (key      (conc lin ":" col))
                                  (test-id   (hash-table-ref/default cell-lookup key -1))
                                  (run-id   (dboard:tabdat-curr-run-id tabdat))
                                  (run-info (rmt:get-run-info run-id))
                                  (target   (rmt:get-target run-id))
                                  (runname  (db:get-value-by-header (db:get-rows run-info)







<







2275
2276
2277
2278
2279
2280
2281

2282
2283
2284
2285
2286
2287
2288
                         (lambda ()

                           ;; Bummer - we dont have the global get/set api mapped in chicken
                           ;; (let* ((modkeys (iup:global "MODKEYSTATE")))
                           ;;   (BB> "modkeys="modkeys))

                           (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status)

                           (let* ((toolpath (car (argv)))
                                  (key      (conc lin ":" col))
                                  (test-id   (hash-table-ref/default cell-lookup key -1))
                                  (run-id   (dboard:tabdat-curr-run-id tabdat))
                                  (run-info (rmt:get-run-info run-id))
                                  (target   (rmt:get-target run-id))
                                  (runname  (db:get-value-by-header (db:get-rows run-info)
2469
2470
2471
2472
2473
2474
2475
2476
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
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
					 #:action (lambda (obj val index lbstate)
						    (set! *tests-sort-reverse* index)
						    (mark-for-update tabdat))))
		(default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*))))
                
	   (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd)
	   
	   ;; (set! hide-empty (iup:button "HideEmpty"
	   ;; 				;; #:expand HORIZONTAL"
	   ;; 				#:expand "NO" #:size "80x15"
	   ;; 				#:action (lambda (obj)
	   ;; 					   (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat)))
	   ;; 					   (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE"))
	   ;; 					   (mark-for-update tabdat))))
	   (set! hide (iup:button "Hide"
				  #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
					     ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide"))
					     (iup:attribute-set! hide "BGCOLOR" sel-color)
					     (iup:attribute-set! show "BGCOLOR" nonsel-color)
					     (mark-for-update tabdat))))
	   (set! show (iup:button "Show"
				  #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
					     (iup:attribute-set! show "BGCOLOR" sel-color)
					     (iup:attribute-set! hide "BGCOLOR" nonsel-color)
					     (mark-for-update tabdat))))
	   (iup:attribute-set! hide "BGCOLOR" sel-color)
	   (iup:attribute-set! show "BGCOLOR" nonsel-color)
	   ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ...
           (iup:vbox
            (iup:hbox hide show)
            sort-lb))) 
	)

        ;; insert extra widget here
        (if extra-widget
            extra-widget
            (iup:hbox)) ;; empty widget

        

        
        )))

     (let* ((status-toggles (map (lambda (status)
				   (iup:toggle (conc status)
					       #:fontsize 8 ;; btn-fontsz ;; "10"
					       ;; #:expand "HORIZONTAL"







<
<
<
<
<
<
<

















<









<
<
<







2440
2441
2442
2443
2444
2445
2446







2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463

2464
2465
2466
2467
2468
2469
2470
2471
2472



2473
2474
2475
2476
2477
2478
2479
					 #:action (lambda (obj val index lbstate)
						    (set! *tests-sort-reverse* index)
						    (mark-for-update tabdat))))
		(default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*))))
                
	   (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd)
	   







	   (set! hide (iup:button "Hide"
				  #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
					     ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide"))
					     (iup:attribute-set! hide "BGCOLOR" sel-color)
					     (iup:attribute-set! show "BGCOLOR" nonsel-color)
					     (mark-for-update tabdat))))
	   (set! show (iup:button "Show"
				  #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
					     (iup:attribute-set! show "BGCOLOR" sel-color)
					     (iup:attribute-set! hide "BGCOLOR" nonsel-color)
					     (mark-for-update tabdat))))
	   (iup:attribute-set! hide "BGCOLOR" sel-color)
	   (iup:attribute-set! show "BGCOLOR" nonsel-color)

           (iup:vbox
            (iup:hbox hide show)
            sort-lb))) 
	)

        ;; insert extra widget here
        (if extra-widget
            extra-widget
            (iup:hbox)) ;; empty widget



        
        )))

     (let* ((status-toggles (map (lambda (status)
				   (iup:toggle (conc status)
					       #:fontsize 8 ;; btn-fontsz ;; "10"
					       ;; #:expand "HORIZONTAL"
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046

(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
  (or please-update-buttons
      (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
	   (> modtime (- last-db-update-time 3)) ;; add three seconds of margin
	   (> (current-seconds)(+ last-db-update-time 1)))))

;; (define *monitor-db-path* #f)
(define *last-monitor-update-time* 0)

;; Force creation of the db in case it isn't already there.
;; (tasks:open-db)

(define (dashboard:get-youngest-run-db-mod-time dbdir)
  (handle-exceptions







<







2992
2993
2994
2995
2996
2997
2998

2999
3000
3001
3002
3003
3004
3005

(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
  (or please-update-buttons
      (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
	   (> modtime (- last-db-update-time 3)) ;; add three seconds of margin
	   (> (current-seconds)(+ last-db-update-time 1)))))


(define *last-monitor-update-time* 0)

;; Force creation of the db in case it isn't already there.
;; (tasks:open-db)

(define (dashboard:get-youngest-run-db-mod-time dbdir)
  (handle-exceptions
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
		(vg:drawing-cache-set! dwg '())
		(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
		;; (dboard:tabdat-allruns-set! tabdat '())
		(dboard:tabdat-max-row-set! tabdat 0)
		(dboard:tabdat-last-filter-str-set! tabdat filtrstr)))
	  (update-rundat tabdat
			 runpatt
			 ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") 
			 (dboard:tabdat-numruns tabdat)
			 testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
			 ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
			 
			 targpatt
			 
			 ;; old method 
			 ;; (let ((res '()))
			 ;;   (for-each (lambda (key)
			 ;;      	 (if (not (equal? key "runname"))
			 ;;      	     (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
			 ;;      	       (if val (set! res (cons (list key val) res))))))
			 ;;             (dboard:tabdat-dbkeys tabdat))
			 ;;   res)
			 )))))

;; run times canvas updater
;;
(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
  (let ((cnv (dboard:tabdat-cnv tabdat))
	(dwg (dboard:tabdat-drawing tabdat))
	(mtx (dboard:tabdat-runs-mutex tabdat))
	(vch (dboard:tabdat-view-changed tabdat)))
    (if (and cnv dwg vch)
	(begin
	  (vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat))
	  (vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat))
	  (mutex-lock! mtx)
	  (canvas-clear! cnv)
	  (vg:draw dwg tabdat)
	  (mutex-unlock! mtx)
	  (dboard:tabdat-view-changed-set! tabdat #f)))))
  
;; doesn't work.
;;
;;(define (gotoescape tabdat escape)
;;  (or (dboard:tabdat-layout-update-ok tabdat)
;;      (escape #t)))

(define (dboard:graph-db-open dbstr)
  (let* ((parts (string-split dbstr ":"))
	 (dbpth (if (< (length parts) 2) ;; assume then a filename was provided
		    dbstr
		    (if (equal? (car parts) "sqlite3")
			(cadr parts)
			(begin







<

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


















<
<
<
<
<
<







3214
3215
3216
3217
3218
3219
3220

3221


3222
3223










3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241






3242
3243
3244
3245
3246
3247
3248
		(vg:drawing-cache-set! dwg '())
		(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
		;; (dboard:tabdat-allruns-set! tabdat '())
		(dboard:tabdat-max-row-set! tabdat 0)
		(dboard:tabdat-last-filter-str-set! tabdat filtrstr)))
	  (update-rundat tabdat
			 runpatt

			 (dboard:tabdat-numruns tabdat)


			 testpatt			 
			 targpatt)))))











;; run times canvas updater
;;
(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
  (let ((cnv (dboard:tabdat-cnv tabdat))
	(dwg (dboard:tabdat-drawing tabdat))
	(mtx (dboard:tabdat-runs-mutex tabdat))
	(vch (dboard:tabdat-view-changed tabdat)))
    (if (and cnv dwg vch)
	(begin
	  (vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat))
	  (vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat))
	  (mutex-lock! mtx)
	  (canvas-clear! cnv)
	  (vg:draw dwg tabdat)
	  (mutex-unlock! mtx)
	  (dboard:tabdat-view-changed-set! tabdat #f)))))
  






(define (dboard:graph-db-open dbstr)
  (let* ((parts (string-split dbstr ":"))
	 (dbpth (if (< (length parts) 2) ;; assume then a filename was provided
		    dbstr
		    (if (equal? (car parts) "sqlite3")
			(cadr parts)
			(begin

Added datashare-src/datashare.scm version [2c1663032f].



















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825

;; Copyright 2006-2013, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

(use ssax)
(use sxml-serializer)
(use sxml-modifications)
(use regex)
(use srfi-69)
(use regex-case)
(use posix)
(use json)
(use csv)
(use srfi-18)
(use format)

(require-library iup)
(import (prefix iup iup:))
(require-library ini-file)
(import (prefix ini-file ini:))

(use canvas-draw)
(import canvas-draw-iup)

(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))

(declare (uses configf))
(declare (uses tree))
(declare (uses margs))
;; (declare (uses dcommon))
;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses synchash))
;; (declare (uses server))
;; (declare (uses megatest-version))
;; (declare (uses tbd))

(include "megatest-fossil-hash.scm")

;;
;; GLOBALS
;;
(define *datashare:current-tab-number* 0)
(define *args-hash* (make-hash-table))
(define datashare:help (conc "Usage: datashare [action [params ...]]

Note: run datashare without parameters to start the gui.

  list-areas                          : List the allowed areas

  list-versions <area>                : List versions available in <area>
         options : -full, -vpatt patt

  publish <path> <area> <version>     : Publish data for area and with version

  get <area> <version>                : Get a link to data, put the link in destpath
         options : -i iteration

  update <area>                       : Update the link to data to the latest iteration.

Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash)) ;; "

;;======================================================================
;; RECORDS
;;======================================================================

;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment
;; testing
(define (make-datashare:pkg)(make-vector 15))
(define-inline (datashare:pkg-get-id             vec)    (vector-ref  vec 0))
(define-inline (datashare:pkg-get-area           vec)    (vector-ref  vec 1))
(define-inline (datashare:pkg-get-version_name   vec)    (vector-ref  vec 2))
(define-inline (datashare:pkg-get-store_type     vec)    (vector-ref  vec 3))
(define-inline (datashare:pkg-get-copied         vec)    (vector-ref  vec 4))
(define-inline (datashare:pkg-get-source_path    vec)    (vector-ref  vec 5))
(define-inline (datashare:pkg-get-iteration      vec)    (vector-ref  vec 6))
(define-inline (datashare:pkg-get-submitter      vec)    (vector-ref  vec 7))
(define-inline (datashare:pkg-get-datetime       vec)    (vector-ref  vec 8))
(define-inline (datashare:pkg-get-storegrp       vec)    (vector-ref  vec 9))
(define-inline (datashare:pkg-get-datavol        vec)    (vector-ref  vec 10))
(define-inline (datashare:pkg-get-quality        vec)    (vector-ref  vec 11))
(define-inline (datashare:pkg-get-disk_id        vec)    (vector-ref  vec 12))
(define-inline (datashare:pkg-get-comment        vec)    (vector-ref  vec 13))
(define-inline (datashare:pkg-get-stored_path    vec)    (vector-ref  vec 14))
(define-inline (datashare:pkg-set-id!            vec val)(vector-set! vec 0 val))
(define-inline (datashare:pkg-set-area!          vec val)(vector-set! vec 1 val))
(define-inline (datashare:pkg-set-version_name!  vec val)(vector-set! vec 2 val))
(define-inline (datashare:pkg-set-store_type!    vec val)(vector-set! vec 3 val))
(define-inline (datashare:pkg-set-copied!        vec val)(vector-set! vec 4 val))
(define-inline (datashare:pkg-set-source_path!   vec val)(vector-set! vec 5 val))
(define-inline (datashare:pkg-set-iteration!     vec val)(vector-set! vec 6 val))
(define-inline (datashare:pkg-set-submitter!     vec val)(vector-set! vec 7 val))
(define-inline (datashare:pkg-set-datetime!      vec val)(vector-set! vec 8 val))
(define-inline (datashare:pkg-set-storegrp!      vec val)(vector-set! vec 9 val))
(define-inline (datashare:pkg-set-datavol!       vec val)(vector-set! vec 10 val))
(define-inline (datashare:pkg-set-quality!       vec val)(vector-set! vec 11 val))
(define-inline (datashare:pkg-set-disk_id!       vec val)(vector-set! vec 12 val))
(define-inline (datashare:pkg-set-comment!       vec val)(vector-set! vec 13 val))
(define-inline (datashare:pkg-set-stored_path!   vec val)(vector-set! vec 14 val))

;;======================================================================
;; DB
;;======================================================================

(define (datashare:initialize-db db)
  (for-each
   (lambda (qry)
     (sqlite3:execute db qry))
   (list 
    "CREATE TABLE pkgs 
         (id           INTEGER PRIMARY KEY,
          area         TEXT,
          version_name TEXT,
          store_type   TEXT DEFAULT 'copy',
          copied       INTEGER DEFAULT 0,
          source_path  TEXT,
          stored_path  TEXT,
          iteration    INTEGER DEFAULT 0,
          submitter    TEXT,
          datetime     TIMESTAMP DEFAULT (strftime('%s','now')),
          storegrp     TEXT,
          datavol      INTEGER,
          quality      TEXT,
          disk_id      INTEGER,
          comment      TEXT);"
    "CREATE TABLE refs
         (id        INTEGER PRIMARY KEY,
          pkg_id    INTEGER,
          destlink  TEXT);"
    "CREATE TABLE disks
         (id         INTEGER PRIMARY KEY,
          storegrp   TEXT,
          path       TEXT);")))

(define (datashare:register-data db area version-name store-type submitter quality source-path comment)
  (let ((iter-qry       (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;"))
	(next-iteration 0))
    (sqlite3:with-transaction
     db
     (lambda ()
       (sqlite3:for-each-row
	(lambda (iteration)
	  (if (and (number? iteration)
		   (>= iteration next-iteration))
	      (set! next-iteration (+ iteration 1))))
	iter-qry area version-name)
       ;; now store the data
       (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) 
                                 VALUES (?,?,?,?,?,?,?,?);"
			area version-name next-iteration (conc store-type) submitter source-path quality comment)))
    (sqlite3:finalize! iter-qry)
    next-iteration))

(define (datashare:get-id db area version-name iteration)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     db
     "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
     area version-name iteration)
    res))

(define (datashare:set-stored-path db id path)
  (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id))

(define (datashare:set-copied db id value)
  (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id))
  
(define (datashare:get-pkg-record db area version-name iteration)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (a . b)
       (set! res (apply vector a b)))
     db 
     "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
     area 
     version-name
     iteration)
    res))

;; take version-name iteration and register or update "lastest/0"
;;
(define (datashare:set-latest db id area version-name iteration)
  (let* ((rec         (datashare:get-pkg-record db area version-name iteration))
	 (latest-id   (datashare:get-id db area "latest" 0))
	 (stored-path (datashare:pkg-get-stored_path rec)))
    (if latest-id ;; have a record - bump the link pointer
	(datashare:set-stored-path db latest-id stored-path)
	(datashare:register-data db area "latest" 'link "auto" "na" stored-path "latest data"))))

;; set a package ref, this is the location where the link back to the stored data 
;; is put. 
;;
;; if there is nothing at that location then the record can be removed
;; if there are no refs for a particular pkg-id then that pkg-id is a 
;; candidate for removal
;;
(define (datashare:record-pkg-ref db pkg-id dest-link)
  (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link))
  
(define (datashare:count-refs db pkg-id)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
       (set! res count))
     db
     "SELECT count(id) FROM refs WHERE pkg_id=?;"
     pkg-id)
    res))

;; Create the sqlite db
(define (datashare:open-db configdat) 
  (let ((path (configf:lookup configdat "database" "location")))
    (if (and path
	     (directory? path)
	     (file-read-access? path))
	(let* ((dbpath    (conc path "/datashare.db"))
	       (writeable (file-write-access? dbpath))
	       (dbexists  (common:file-exists? dbpath))
	       (handler   (make-busy-timeout 136000)))
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
			  ((condition-property-accessor 'exn 'message) exn))
	     (exit))
	   (set! db (sqlite3:open-database dbpath)))
	  (if *db-write-access* (sqlite3:set-busy-handler! db handler))
	  (if (not dbexists)
	      (begin
		(datashare:initialize-db db)))
	  db)
	(print "ERROR: invalid path for storing database: " path))))

(define (open-run-close-exception-handling proc idb . params)
  (handle-exceptions
   exn
   (let ((sleep-time (random 30))
         (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
     (case err-status
       ((busy)
        (thread-sleep! sleep-time))
       (else
        (print "EXCEPTION: database overloaded or unreadable.")
        (print " message: " ((condition-property-accessor 'exn 'message) exn))
        (print "exn=" (condition->list exn))
        (print " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
        (print-call-chain (current-error-port))
        (thread-sleep! sleep-time)
        (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
     (apply open-run-close-exception-handling proc idb params))
   (apply open-run-close-no-exception-handling proc idb params)))

(define (open-run-close-no-exception-handling  proc idb . params)
  ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
  (let* ((db (cond
	      ((sqlite3:database? idb)     idb)
	      ((not idb)                   (print "ERROR: cannot open-run-close with #f anymore"))
	      ((procedure? idb)            (idb))
	      (else                        (print "ERROR: cannot open-run-close with #f anymore"))))
	 (res #f))
    (set! res (apply proc db params))
    (if (not idb)(sqlite3:finalize! dbstruct))
    ;; (print "open-run-close-no-exception-handling END" )
    res))

(define open-run-close open-run-close-no-exception-handling)

(define (datashare:get-pkgs db area-filter version-filter iter-filter)
  (let ((res '()))
    (sqlite3:for-each-row ;; replace with fold ...
     (lambda (a . b)
       (set! res (cons (list->vector (cons a b)) res)))
     db 
     (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
	   " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";")
     area-filter version-filter)
    (reverse res)))

(define (datashare:get-pkg db area-name version-name #!key (iteration #f))
  (let ((dat '())
	(res #f))
    (sqlite3:for-each-row ;; replace with fold ...
     (lambda (a . b)
       (set! dat (cons (list->vector (cons a b)) dat)))
     db 
     (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
	   " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;")
     area-name version-name)
    ;; now filter for iteration, either max if #f or specific one
    (if (null? dat)
	#f
	(let loop ((hed (car dat))
		   (tal (cdr dat))
		   (cur 0))
	  (let ((itr (datashare:pkg-get-iteration hed)))
	    (if (equal? itr iteration) ;; this is the one if iteration is specified
		hed
		(if (null? tal)
		    hed
		    (loop (car tal)(cdr tal)))))))))

(define (datashare:get-versions-for-area db area-name #!key (version-patt #f))
  (let ((res '())
	(data (make-hash-table)))
    (sqlite3:for-each-row
     (lambda (version-name submitter iteration submitted-time comment)
       ;;                                              0           1         2           3           4
       (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment)))
     db 
     "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;"
     (or version-patt "%"))
    (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=))))

;;======================================================================
;; DATA IMPORT/EXPORT
;;======================================================================

(define (datashare:import-data configdat source-path dest-path area version iteration)
  (let* ((space-avail (car dest-path))
	 (disk-path   (cdr dest-path))
	 (targ-path   (conc disk-path "/" area "/" version "/" iteration))
	 (id          (datashare:get-id db area version iteration))
	 (db          (datashare:open-db configdat)))
    (if (> space-avail 10000) ;; dumb heuristic
	(begin
	  (create-directory targ-path #t)
	  (datashare:set-stored-path db id targ-path)
	  (print "Running command: rsync -av " source-path "/ " targ-path "/")
	  (let ((th1 (make-thread (lambda ()
				    (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/")))))
				      (process-wait pid)
				      (datashare:set-copied db id "yes")
				      (sqlite3:finalize! db)))
				   "Data copy")))
	    (thread-start! th1))
	  #t)
	(begin
	  (print "ERROR: Not enough space in storage area " dest-path)
	  (datashare:set-copied db id "no")
	  (sqlite3:finalize! db)
	  #f))))

(define (datashare:get-areas configdat)
  (let* ((areadat (configf:get-section configdat "areas"))
	 (areas   (if areadat (map car areadat) '())))
    areas))

(define (datashare:publish configdat publish-type area-name version comment spath submitter quality)
  ;; input checks
  (cond 
   ((not (member area-name (datashare:get-areas configdat)))
    (cons #f (conc "Illegal area name \"" area-name "\"")))
   (else
    (let ((db          (datashare:open-db configdat))
	  (iteration   (datashare:register-data db area-name version publish-type submitter quality spath comment))
	  (dest-store  (datashare:get-best-storage configdat)))
      (if iteration
	  (if (eq? 'copy publish-type)
	      (begin
		(datashare:import-data configdat spath dest-store area-name version iteration)
		(let ((id (datashare:get-id db area-name version iteration)))
		  (datashare:set-latest db id area-name version iteration)))
	      (let ((id (datashare:get-id db area-name version iteration)))
		(datashare:set-stored-path db id spath)
		(datashare:set-copied db id "yes")
		(datashare:set-copied db id "n/a")
		(datashare:set-latest db id area-name version iteration)))
	  (print "ERROR: Failed to get an iteration number"))
      (sqlite3:finalize! db)
      (cons #t "Successfully saved data")))))

(define (datashare:get-best-storage configdat)
  (let* ((storage     (configf:lookup configdat "settings" "storage"))
	 (store-areas (if storage (string-split storage) '())))
    (print "Looking for available space in " store-areas)
    (datashare:find-most-space store-areas)))

;; (string->number (list-ref (with-input-from-pipe "df -B1000000 /tmp" (lambda ()(read-line)(string-split (read-line)))) 3))

(define (datashare:find-most-space paths)
  (fold (lambda (area res)
	  ;; (print "area=" area " res=" res)
	  (let ((maxspace (car res))
		(currpath (cdr res)))
	    ;; (print currpath " " maxspace)
	    (if (file-write-access? area)
		(let ((currspace (string->number
				  (list-ref
				   (with-input-from-pipe 
				    ;; (conc "df --output=avail " area)
				    (conc "df -B1000000 " area)
				    ;; (lambda ()(read)(read))
				    (lambda ()(read-line)(string-split (read-line))))
				   3))))
		  (if (> currspace maxspace) 
		      (cons currspace area)
		      res))
		res)))
	(cons 0 #f)
	paths))

;; remove existing link and if possible ...
;; create path to next of tip of target, create link back to source
(define (datashare:build-dir-make-link source target)
  (if (common:file-exists? target)(datashare:backup-move target))
  (create-directory (pathname-directory target) #t)
  (create-symbolic-link source target))

(define (datashare:backup-move path)
  (let* ((trashdir  (conc (pathname-directory path) "/.trash"))
	 (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
    (create-directory trashdir #t)
    (if (directory? path)
	(system (conc "mv " path " " trashfile))
	(file-move path trash-file))))

;;======================================================================
;; GUI
;;======================================================================

;; The main menu 
(define (datashare:main-menu)
  (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
   (iup:menu-item "Files" (iup:menu   ;; Note that you can use either #:action or action: for options
		       (iup:menu-item "Open"  action: (lambda (obj)
							(iup:show (iup:file-dialog))
							(print "File->open " obj)))
		       (iup:menu-item "Save"  #:action (lambda (obj)(print "File->save " obj)))
		       (iup:menu-item "Exit"  #:action (lambda (obj)(exit)))))
   (iup:menu-item "Tools" (iup:menu
		       (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
		       ;; (iup:menu-item "Show dialog"     #:action (lambda (obj)
		       ;;  					   (show message-window
		       ;;  					     #:modal? #t
		       ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
		       ;;  					     ;; #:x 'mouse
		       ;;  					     ;; #:y 'mouse
		       ;;  )					     
		       ))))

(define (datashare:publish-view configdat)
  ;; (pp (hash-table->alist configdat))
  (let* ((areas       (configf:get-section configdat "areas"))
	 (label-size  "70x")
	 (areas-sel   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
	 (version-tb  (iup:textbox #:expand "HORIZONTAL")) ;;  #:size "50x"))
	 (areas-sel   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
	 (component   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" ))
	 (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x"))
	 ;; (copy-link   (iup:toggle  #:expand "HORIZONTAL"))
	 ;; (iteration   (iup:textbox #:expand "YES" #:size "20x"))
	 ;; (iteration   (iup:textbox #:expand "HORIZONTAL" #:size "20x"))
	 (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%"))
	 (comment-tb  (iup:textbox #:expand "YES" #:multiline "YES"))
	 (source-tb   (iup:textbox #:expand "HORIZONTAL"
				   #:value (or (configf:lookup configdat "settings" "basepath")
					       "")))
	 (publish     (lambda (publish-type)
			(let* ((area-num    (or (string->number (iup:attribute areas-sel "VALUE")) 0))
			       (area-dat    (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED")))
			       (area-path   (cadr area-dat))
			       (area-name   (car  area-dat))
			       (version     (iup:attribute version-tb "VALUE"))
			       (comment     (iup:attribute comment-tb "VALUE"))
			       (spath       (iup:attribute source-tb  "VALUE"))
			       (submitter   (current-user-name))
			       (quality     2))
			  (datashare:publish configdat publish-type area-name version comment spath submitter quality))))
	 (copy        (iup:button "Copy and Publish"
				  #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (publish 'copy))))
	 (link        (iup:button "Link and Publish"
				  #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (publish 'link))))
	 (browse-btn  (iup:button "Browse"
				  #:size "40x"
				  #:action (lambda (obj)
					     (let* ((fd  (iup:file-dialog #:dialogtype "DIR"))
						    (top (iup:show fd #:modal? "YES")))
					       (iup:attribute-set! source-tb "VALUE"
								   (iup:attribute fd "VALUE"))
					       (iup:destroy! fd))))))
    (print "areas")
    ;; (pp areas)
    (fold (lambda (areadat num)
	    ;; (print "Adding num=" num ", areadat=" areadat)
	    (iup:attribute-set! areas-sel (conc num) (car areadat))
	    (+ 1 num))
	  1 areas)
    (iup:vbox
     (iup:hbox (iup:label "Area:"        #:size label-size) ;; area-filter 
	       areas-sel)
     (iup:hbox (iup:label "Version:"     #:size label-size)   version-tb)
     ;; (iup:hbox (iup:label "Link only"    #:size label-size)   copy-link)
     ;; 	       (iup:label "Iteration:")   iteration)
     (iup:hbox (iup:label "Comment:"     #:size label-size)   comment-tb)
     (iup:hbox (iup:label "Source base path:" #:size label-size)   source-tb browse-btn)
     (iup:hbox copy link))))

(define (datashare:lst->path pathlst)
  (conc "/" (string-intersperse (map conc pathlst) "/")))

(define (datashare:path->lst path)
  (string-split path "/"))

(define (datashare:pathdat-apply-heuristics configdat path)
  (cond
   ((common:file-exists? path) "found")
   (else (conc path " not installed"))))

(define (datashare:get-view configdat)
  (iup:vbox
   (iup:hbox
    (let* ((label-size     "60x")
	   ;; filter elements
	   (area-filter    "%")
	   (version-filter "%")
	   (iter-filter    ">= 0")
	   ;; reverse lookup from path to data for src and installed
	   (srcdat         (make-hash-table)) ;; reverse lookup
	   (installed-dat  (make-hash-table))
	   ;; config values
	   (basepath       (configf:lookup configdat "settings" "basepath"))
	   ;; gui elements
	   (submitter      (iup:label "" #:expand "HORIZONTAL"))
	   (date-submitted (iup:label "" #:expand "HORIZONTAL"))
	   (comment        (iup:label "" #:expand "HORIZONTAL"))
	   (copy-link      (iup:label "" #:expand "HORIZONTAL"))
	   (quality        (iup:label "" #:expand "HORIZONTAL"))
	   (installed-status (iup:label "" #:expand "HORIZONTAL"))
	   ;; misc 
	   (curr-record    #f)
	   ;; (source-data    (iup:label "" #:expand "HORIZONTAL"))
	   (tb             (iup:treebox
			    #:value 0
			    #:name "Packages"
			    #:expand "YES"
			    #:addexpanded "NO"
			    #:selection-cb
			    (lambda (obj id state)
			      ;; (print "obj: " obj ", id: " id ", state: " state)
			      (let* ((path   (datashare:lst->path (cdr (tree:node->path obj id))))
				     (record (hash-table-ref/default srcdat path #f)))
				(if record
				    (begin
				      (set! curr-record record)
				      (iup:attribute-set! submitter      "TITLE" (datashare:pkg-get-submitter record))
				      (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datashare:pkg-get-datetime record))))
				      (iup:attribute-set! comment        "TITLE" (datashare:pkg-get-comment record))
				      (iup:attribute-set! quality        "TITLE" (datashare:pkg-get-quality record))
				      (iup:attribute-set! copy-link      "TITLE" (datashare:pkg-get-store_type record))
				      ))
				;; (print  "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id)
				))))
	   (tb2             (iup:treebox
			    #:value 0
			    #:name "Installed"
			    #:expand "YES"
			    #:addexpanded "NO"
			    #:selection-cb
			    (lambda (obj id state)
			      ;; (print "obj: " obj ", id: " id ", state: " state)
			      (let* ((path   (datashare:lst->path (cdr (tree:node->path obj id))))
				     (status (hash-table-ref/default installed-dat path #f)))
				(iup:attribute-set! installed-status "TITLE" (if status status ""))
				))))
	   (refresh        (lambda (obj)
			     (let* ((db    (datashare:open-db configdat))
				    (areas (or (configf:get-section configdat "areas") '())))
			       ;;
			       ;; first update the Sources
			       ;;
			       (for-each
				(lambda (pkgitem)
				  (let* ((pkg-path   (list (datashare:pkg-get-area  pkgitem)
							   (datashare:pkg-get-version_name pkgitem)
							   (datashare:pkg-get-iteration pkgitem)))
					 (pkg-id     (datashare:pkg-get-id          pkgitem))
					 (path       (datashare:lst->path pkg-path)))
				    ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id)
				    (if (not (hash-table-ref/default srcdat path #f))
					(tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id)))
				    ;; (print "path=" path " pkgitem=" pkgitem)
				    (hash-table-set! srcdat path pkgitem)))
				(datashare:get-pkgs db area-filter version-filter iter-filter))
			       ;;
			       ;; then update the installed
			       ;;
			       (for-each
				(lambda (area)
				  (let* ((path     (conc "/" (cadr area)))
					 (fullpath (conc basepath path)))
				    (if (not (hash-table-ref/default installed-dat path #f))
					(tree:add-node tb2 "Installed" (datashare:path->lst path)))
				    (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath))))
				areas)
			       (sqlite3:finalize! db))))
	   (apply          (iup:button "Apply"
				       #:action
				       (lambda (obj)
					 (if curr-record
					     (let* ((area        (datashare:pkg-get-area        curr-record))
						    (stored-path (datashare:pkg-get-stored_path curr-record))
						    (source-type (datashare:pkg-get-store_type  curr-record))
						    (source-path (case source-type ;;  (equal? source-type "link"))
								   ((link)(datashare:pkg-get-source-path curr-record))
								   ((copy)stored-path)
								   (else #f)))
						    (dest-stub   (configf:lookup configdat "areas" area))
						    (target-path (conc basepath "/" dest-stub)))
					       (datashare:build-dir-make-link stored-path target-path)
					       (print "Creating link from " stored-path " to " target-path)))))))
      (iup:vbox 
       (iup:hbox tb tb2)
       (iup:frame 
	#:title "Source Info"
	(iup:vbox
	 (iup:hbox (iup:button "Refresh" #:action refresh) apply)
	 (iup:hbox (iup:label "Submitter: ") ;;  #:size label-size)
		   submitter 
		   (iup:label "Submitted on: ") ;;  #:size label-size)
		   date-submitted)
	 (iup:hbox (iup:label "Data stored: ")
		   copy-link
		   (iup:label "Quality: ")
		   quality)
	 (iup:hbox (iup:label "Comment: ")
		   comment)))
       (iup:frame
	#:title "Installed Info"
	(iup:vbox
	 (iup:hbox (iup:label "Installed status/path: ") installed-status)))
       )))))

(define (datashare:manage-view configdat)
  (iup:vbox
   (iup:hbox 
    (iup:button "Pushme"
		#:expand "YES"
		))))

(define (datashare:gui configdat)
  (iup:show
   (iup:dialog 
    #:title (conc "DataShare dashboard " (current-user-name) ":" (current-directory))   
    #:menu (datashare:main-menu)
    (let* ((tabs (iup:tabs
		  #:tabchangepos-cb (lambda (obj curr prev)
				      (set! *datashare:current-tab-number* curr))
		  (datashare:publish-view configdat)
		  (datashare:get-view configdat)
		  (datashare:manage-view configdat)
		  )))
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
	(iup:attribute-set! tabs "TABTITLE0" "Publish")
	(iup:attribute-set! tabs "TABTITLE1" "Get")
	(iup:attribute-set! tabs "TABTITLE2" "Manage")
	;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
	tabs)))
  (iup:main-loop))

;;======================================================================
;; MISC
;;======================================================================


(define (datashare: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))
    ;; (print "running as " (current-effective-user-id))
    (proc)
    (if (not (eq? eid cid))
        (set! (current-effective-user-id) eid))))

(define (datashare:find name paths)
  (if (null? paths)
      #f
      (let loop ((hed (car paths))
		 (tal (cdr paths)))
	(if (common:file-exists? (conc hed "/" name))
	    hed
	    (if (null? tal)
		#f
		(loop (car tal)(cdr tal)))))))

;;======================================================================
;; MAIN
;;======================================================================

(define (datashare:load-config exe-dir exe-name)
  (let* ((fname   (conc exe-dir "/." exe-name ".config")))
    (ini:property-separator-patt " *  *")
    (ini:property-separator #\space)
    (if (common:file-exists? fname)
	;; (ini:read-ini fname)
	(read-config fname #f #t)
	(make-hash-table))))

(define (datashare:process-action configdat action . args)
  (case (string->symbol action)
    ((get)
     (if (< (length args) 2)
	 (begin 
	   (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	   (exit 1))
	 (let* ((basepath    (configf:lookup configdat "settings" "basepath"))
		(db          (datashare:open-db configdat))
		(area        (car args))
		(version     (cadr args)) ;;    iteration
		(remargs     (args:get-args args '("-i") '() args:arg-hash 0))
		(iteration   (if (args:get-arg "-i")(string->number (args:get-arg "-i")) #f))
		(curr-record (datashare:get-pkg db area version iteration: iteration)))
	   (if (not curr-record)
	       (begin
		 (print "ERROR: No matching record found; area=" area ", version=" version ", iteration=" (if iteration iteration "(max)"))
		 (exit 1))
	       (let* ((stored-path (datashare:pkg-get-stored_path curr-record))
		      (source-type (datashare:pkg-get-store_type  curr-record))
		      (source-path (case source-type ;;  (equal? source-type "link"))
				     ((link) (datashare:pkg-get-source-path curr-record))
				     ((copy) stored-path)
				     (else #f)))
		      (dest-stub   (configf:lookup configdat "areas" area))
		      (target-path (conc basepath "/" dest-stub)))
		 (datashare:build-dir-make-link stored-path target-path)
		 (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path)
		 (sqlite3:finalize! db)
		 (print "Creating link from " stored-path " to " target-path))))))
    ((publish)
     (if (< (length args) 3)
	 (begin 
	   (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	   (exit 1))
	 (let* ((srcpath  (list-ref args 0))
		(areaname (list-ref args 1))
		(version  (list-ref args 2))
		(remargs  (args:get-args (drop args 2)
					 '("-type" ;; link or copy (default is copy)
					   "-m")
 					 '()
 					 args:arg-hash
 					 0))
		(publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy))
		(comment      (or (args:get-arg "-m") ""))
		(submitter    (current-user-name))
		(quality      (args:get-arg "-quality"))
		(publish-res  (datashare:publish configdat publish-type areaname version comment srcpath submitter quality)))
	   (if (not (car publish-res))
	       (begin
		 (print "ERROR: " (cdr publish-res))
		 (exit 1))))))
    ((list-versions)
     (let ((area-name (car args)) ;;      version patt   full print
	   (remargs   (args:get-args args '("-vpatt") '("-full") args:arg-hash 0))
	   (db        (datashare:open-db configdat))
	   (versions  (datashare:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt"))))
       ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*))
       (map (lambda (x)
	      (if (args:get-arg "-full")
		  (format #t 
			  "~10a~10a~4a~27a~30a\n"
			  (vector-ref x 0)
			  (vector-ref x 1) 
			  (vector-ref x 2) 
			  (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
			  (conc "\"" (vector-ref x 4) "\""))
		  (print (vector-ref x 0))))
	    versions)
       (sqlite3:finalize! db)))))

;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc")))
  (if (common:file-exists? debugcontrolf)
      (load debugcontrolf)))

(define (main)
  (let* ((args      (argv))
	 (prog      (car args))
	 (rema      (cdr args))
	 (exe-name  (pathname-file (car (argv))))
	 (exe-dir   (or (pathname-directory prog)
			(datashare:find exe-name (string-split (get-environment-variable "PATH") ":"))))
	 (configdat (datashare:load-config exe-dir exe-name)))
    (cond
     ;; one-word commands
     ((eq? (length rema) 1)
      (case (string->symbol (car rema))
	((help -h -help --h --help)
	 (print datashare:help))
	((list-areas)
	 (map print (datashare:get-areas configdat)))
	(else
	 (print "ERROR: Unrecognised command. Try \"datashare help\""))))
     ;; multi-word commands
     ((null? rema)(datashare:gui configdat))
     ((>= (length rema) 2)
      (apply datashare:process-action configdat (car rema)(cdr rema)))
     (else (print "ERROR: Unrecognised command. Try \"datashare help\"")))))

(main)

Deleted datashare.scm version [2c1663032f].

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
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825

;; Copyright 2006-2013, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

(use ssax)
(use sxml-serializer)
(use sxml-modifications)
(use regex)
(use srfi-69)
(use regex-case)
(use posix)
(use json)
(use csv)
(use srfi-18)
(use format)

(require-library iup)
(import (prefix iup iup:))
(require-library ini-file)
(import (prefix ini-file ini:))

(use canvas-draw)
(import canvas-draw-iup)

(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))

(declare (uses configf))
(declare (uses tree))
(declare (uses margs))
;; (declare (uses dcommon))
;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses synchash))
;; (declare (uses server))
;; (declare (uses megatest-version))
;; (declare (uses tbd))

(include "megatest-fossil-hash.scm")

;;
;; GLOBALS
;;
(define *datashare:current-tab-number* 0)
(define *args-hash* (make-hash-table))
(define datashare:help (conc "Usage: datashare [action [params ...]]

Note: run datashare without parameters to start the gui.

  list-areas                          : List the allowed areas

  list-versions <area>                : List versions available in <area>
         options : -full, -vpatt patt

  publish <path> <area> <version>     : Publish data for area and with version

  get <area> <version>                : Get a link to data, put the link in destpath
         options : -i iteration

  update <area>                       : Update the link to data to the latest iteration.

Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash)) ;; "

;;======================================================================
;; RECORDS
;;======================================================================

;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment
;; testing
(define (make-datashare:pkg)(make-vector 15))
(define-inline (datashare:pkg-get-id             vec)    (vector-ref  vec 0))
(define-inline (datashare:pkg-get-area           vec)    (vector-ref  vec 1))
(define-inline (datashare:pkg-get-version_name   vec)    (vector-ref  vec 2))
(define-inline (datashare:pkg-get-store_type     vec)    (vector-ref  vec 3))
(define-inline (datashare:pkg-get-copied         vec)    (vector-ref  vec 4))
(define-inline (datashare:pkg-get-source_path    vec)    (vector-ref  vec 5))
(define-inline (datashare:pkg-get-iteration      vec)    (vector-ref  vec 6))
(define-inline (datashare:pkg-get-submitter      vec)    (vector-ref  vec 7))
(define-inline (datashare:pkg-get-datetime       vec)    (vector-ref  vec 8))
(define-inline (datashare:pkg-get-storegrp       vec)    (vector-ref  vec 9))
(define-inline (datashare:pkg-get-datavol        vec)    (vector-ref  vec 10))
(define-inline (datashare:pkg-get-quality        vec)    (vector-ref  vec 11))
(define-inline (datashare:pkg-get-disk_id        vec)    (vector-ref  vec 12))
(define-inline (datashare:pkg-get-comment        vec)    (vector-ref  vec 13))
(define-inline (datashare:pkg-get-stored_path    vec)    (vector-ref  vec 14))
(define-inline (datashare:pkg-set-id!            vec val)(vector-set! vec 0 val))
(define-inline (datashare:pkg-set-area!          vec val)(vector-set! vec 1 val))
(define-inline (datashare:pkg-set-version_name!  vec val)(vector-set! vec 2 val))
(define-inline (datashare:pkg-set-store_type!    vec val)(vector-set! vec 3 val))
(define-inline (datashare:pkg-set-copied!        vec val)(vector-set! vec 4 val))
(define-inline (datashare:pkg-set-source_path!   vec val)(vector-set! vec 5 val))
(define-inline (datashare:pkg-set-iteration!     vec val)(vector-set! vec 6 val))
(define-inline (datashare:pkg-set-submitter!     vec val)(vector-set! vec 7 val))
(define-inline (datashare:pkg-set-datetime!      vec val)(vector-set! vec 8 val))
(define-inline (datashare:pkg-set-storegrp!      vec val)(vector-set! vec 9 val))
(define-inline (datashare:pkg-set-datavol!       vec val)(vector-set! vec 10 val))
(define-inline (datashare:pkg-set-quality!       vec val)(vector-set! vec 11 val))
(define-inline (datashare:pkg-set-disk_id!       vec val)(vector-set! vec 12 val))
(define-inline (datashare:pkg-set-comment!       vec val)(vector-set! vec 13 val))
(define-inline (datashare:pkg-set-stored_path!   vec val)(vector-set! vec 14 val))

;;======================================================================
;; DB
;;======================================================================

(define (datashare:initialize-db db)
  (for-each
   (lambda (qry)
     (sqlite3:execute db qry))
   (list 
    "CREATE TABLE pkgs 
         (id           INTEGER PRIMARY KEY,
          area         TEXT,
          version_name TEXT,
          store_type   TEXT DEFAULT 'copy',
          copied       INTEGER DEFAULT 0,
          source_path  TEXT,
          stored_path  TEXT,
          iteration    INTEGER DEFAULT 0,
          submitter    TEXT,
          datetime     TIMESTAMP DEFAULT (strftime('%s','now')),
          storegrp     TEXT,
          datavol      INTEGER,
          quality      TEXT,
          disk_id      INTEGER,
          comment      TEXT);"
    "CREATE TABLE refs
         (id        INTEGER PRIMARY KEY,
          pkg_id    INTEGER,
          destlink  TEXT);"
    "CREATE TABLE disks
         (id         INTEGER PRIMARY KEY,
          storegrp   TEXT,
          path       TEXT);")))

(define (datashare:register-data db area version-name store-type submitter quality source-path comment)
  (let ((iter-qry       (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;"))
	(next-iteration 0))
    (sqlite3:with-transaction
     db
     (lambda ()
       (sqlite3:for-each-row
	(lambda (iteration)
	  (if (and (number? iteration)
		   (>= iteration next-iteration))
	      (set! next-iteration (+ iteration 1))))
	iter-qry area version-name)
       ;; now store the data
       (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) 
                                 VALUES (?,?,?,?,?,?,?,?);"
			area version-name next-iteration (conc store-type) submitter source-path quality comment)))
    (sqlite3:finalize! iter-qry)
    next-iteration))

(define (datashare:get-id db area version-name iteration)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     db
     "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
     area version-name iteration)
    res))

(define (datashare:set-stored-path db id path)
  (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id))

(define (datashare:set-copied db id value)
  (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id))
  
(define (datashare:get-pkg-record db area version-name iteration)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (a . b)
       (set! res (apply vector a b)))
     db 
     "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;"
     area 
     version-name
     iteration)
    res))

;; take version-name iteration and register or update "lastest/0"
;;
(define (datashare:set-latest db id area version-name iteration)
  (let* ((rec         (datashare:get-pkg-record db area version-name iteration))
	 (latest-id   (datashare:get-id db area "latest" 0))
	 (stored-path (datashare:pkg-get-stored_path rec)))
    (if latest-id ;; have a record - bump the link pointer
	(datashare:set-stored-path db latest-id stored-path)
	(datashare:register-data db area "latest" 'link "auto" "na" stored-path "latest data"))))

;; set a package ref, this is the location where the link back to the stored data 
;; is put. 
;;
;; if there is nothing at that location then the record can be removed
;; if there are no refs for a particular pkg-id then that pkg-id is a 
;; candidate for removal
;;
(define (datashare:record-pkg-ref db pkg-id dest-link)
  (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link))
  
(define (datashare:count-refs db pkg-id)
  (let ((res 0))
    (sqlite3:for-each-row
     (lambda (count)
       (set! res count))
     db
     "SELECT count(id) FROM refs WHERE pkg_id=?;"
     pkg-id)
    res))

;; Create the sqlite db
(define (datashare:open-db configdat) 
  (let ((path (configf:lookup configdat "database" "location")))
    (if (and path
	     (directory? path)
	     (file-read-access? path))
	(let* ((dbpath    (conc path "/datashare.db"))
	       (writeable (file-write-access? dbpath))
	       (dbexists  (common:file-exists? dbpath))
	       (handler   (make-busy-timeout 136000)))
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
			  ((condition-property-accessor 'exn 'message) exn))
	     (exit))
	   (set! db (sqlite3:open-database dbpath)))
	  (if *db-write-access* (sqlite3:set-busy-handler! db handler))
	  (if (not dbexists)
	      (begin
		(datashare:initialize-db db)))
	  db)
	(print "ERROR: invalid path for storing database: " path))))

(define (open-run-close-exception-handling proc idb . params)
  (handle-exceptions
   exn
   (let ((sleep-time (random 30))
         (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
     (case err-status
       ((busy)
        (thread-sleep! sleep-time))
       (else
        (print "EXCEPTION: database overloaded or unreadable.")
        (print " message: " ((condition-property-accessor 'exn 'message) exn))
        (print "exn=" (condition->list exn))
        (print " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
        (print-call-chain (current-error-port))
        (thread-sleep! sleep-time)
        (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
     (apply open-run-close-exception-handling proc idb params))
   (apply open-run-close-no-exception-handling proc idb params)))

(define (open-run-close-no-exception-handling  proc idb . params)
  ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
  (let* ((db (cond
	      ((sqlite3:database? idb)     idb)
	      ((not idb)                   (print "ERROR: cannot open-run-close with #f anymore"))
	      ((procedure? idb)            (idb))
	      (else                        (print "ERROR: cannot open-run-close with #f anymore"))))
	 (res #f))
    (set! res (apply proc db params))
    (if (not idb)(sqlite3:finalize! dbstruct))
    ;; (print "open-run-close-no-exception-handling END" )
    res))

(define open-run-close open-run-close-no-exception-handling)

(define (datashare:get-pkgs db area-filter version-filter iter-filter)
  (let ((res '()))
    (sqlite3:for-each-row ;; replace with fold ...
     (lambda (a . b)
       (set! res (cons (list->vector (cons a b)) res)))
     db 
     (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
	   " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";")
     area-filter version-filter)
    (reverse res)))

(define (datashare:get-pkg db area-name version-name #!key (iteration #f))
  (let ((dat '())
	(res #f))
    (sqlite3:for-each-row ;; replace with fold ...
     (lambda (a . b)
       (set! dat (cons (list->vector (cons a b)) dat)))
     db 
     (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path "
	   " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;")
     area-name version-name)
    ;; now filter for iteration, either max if #f or specific one
    (if (null? dat)
	#f
	(let loop ((hed (car dat))
		   (tal (cdr dat))
		   (cur 0))
	  (let ((itr (datashare:pkg-get-iteration hed)))
	    (if (equal? itr iteration) ;; this is the one if iteration is specified
		hed
		(if (null? tal)
		    hed
		    (loop (car tal)(cdr tal)))))))))

(define (datashare:get-versions-for-area db area-name #!key (version-patt #f))
  (let ((res '())
	(data (make-hash-table)))
    (sqlite3:for-each-row
     (lambda (version-name submitter iteration submitted-time comment)
       ;;                                              0           1         2           3           4
       (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment)))
     db 
     "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;"
     (or version-patt "%"))
    (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=))))

;;======================================================================
;; DATA IMPORT/EXPORT
;;======================================================================

(define (datashare:import-data configdat source-path dest-path area version iteration)
  (let* ((space-avail (car dest-path))
	 (disk-path   (cdr dest-path))
	 (targ-path   (conc disk-path "/" area "/" version "/" iteration))
	 (id          (datashare:get-id db area version iteration))
	 (db          (datashare:open-db configdat)))
    (if (> space-avail 10000) ;; dumb heuristic
	(begin
	  (create-directory targ-path #t)
	  (datashare:set-stored-path db id targ-path)
	  (print "Running command: rsync -av " source-path "/ " targ-path "/")
	  (let ((th1 (make-thread (lambda ()
				    (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/")))))
				      (process-wait pid)
				      (datashare:set-copied db id "yes")
				      (sqlite3:finalize! db)))
				   "Data copy")))
	    (thread-start! th1))
	  #t)
	(begin
	  (print "ERROR: Not enough space in storage area " dest-path)
	  (datashare:set-copied db id "no")
	  (sqlite3:finalize! db)
	  #f))))

(define (datashare:get-areas configdat)
  (let* ((areadat (configf:get-section configdat "areas"))
	 (areas   (if areadat (map car areadat) '())))
    areas))

(define (datashare:publish configdat publish-type area-name version comment spath submitter quality)
  ;; input checks
  (cond 
   ((not (member area-name (datashare:get-areas configdat)))
    (cons #f (conc "Illegal area name \"" area-name "\"")))
   (else
    (let ((db          (datashare:open-db configdat))
	  (iteration   (datashare:register-data db area-name version publish-type submitter quality spath comment))
	  (dest-store  (datashare:get-best-storage configdat)))
      (if iteration
	  (if (eq? 'copy publish-type)
	      (begin
		(datashare:import-data configdat spath dest-store area-name version iteration)
		(let ((id (datashare:get-id db area-name version iteration)))
		  (datashare:set-latest db id area-name version iteration)))
	      (let ((id (datashare:get-id db area-name version iteration)))
		(datashare:set-stored-path db id spath)
		(datashare:set-copied db id "yes")
		(datashare:set-copied db id "n/a")
		(datashare:set-latest db id area-name version iteration)))
	  (print "ERROR: Failed to get an iteration number"))
      (sqlite3:finalize! db)
      (cons #t "Successfully saved data")))))

(define (datashare:get-best-storage configdat)
  (let* ((storage     (configf:lookup configdat "settings" "storage"))
	 (store-areas (if storage (string-split storage) '())))
    (print "Looking for available space in " store-areas)
    (datashare:find-most-space store-areas)))

;; (string->number (list-ref (with-input-from-pipe "df -B1000000 /tmp" (lambda ()(read-line)(string-split (read-line)))) 3))

(define (datashare:find-most-space paths)
  (fold (lambda (area res)
	  ;; (print "area=" area " res=" res)
	  (let ((maxspace (car res))
		(currpath (cdr res)))
	    ;; (print currpath " " maxspace)
	    (if (file-write-access? area)
		(let ((currspace (string->number
				  (list-ref
				   (with-input-from-pipe 
				    ;; (conc "df --output=avail " area)
				    (conc "df -B1000000 " area)
				    ;; (lambda ()(read)(read))
				    (lambda ()(read-line)(string-split (read-line))))
				   3))))
		  (if (> currspace maxspace) 
		      (cons currspace area)
		      res))
		res)))
	(cons 0 #f)
	paths))

;; remove existing link and if possible ...
;; create path to next of tip of target, create link back to source
(define (datashare:build-dir-make-link source target)
  (if (common:file-exists? target)(datashare:backup-move target))
  (create-directory (pathname-directory target) #t)
  (create-symbolic-link source target))

(define (datashare:backup-move path)
  (let* ((trashdir  (conc (pathname-directory path) "/.trash"))
	 (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
    (create-directory trashdir #t)
    (if (directory? path)
	(system (conc "mv " path " " trashfile))
	(file-move path trash-file))))

;;======================================================================
;; GUI
;;======================================================================

;; The main menu 
(define (datashare:main-menu)
  (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
   (iup:menu-item "Files" (iup:menu   ;; Note that you can use either #:action or action: for options
		       (iup:menu-item "Open"  action: (lambda (obj)
							(iup:show (iup:file-dialog))
							(print "File->open " obj)))
		       (iup:menu-item "Save"  #:action (lambda (obj)(print "File->save " obj)))
		       (iup:menu-item "Exit"  #:action (lambda (obj)(exit)))))
   (iup:menu-item "Tools" (iup:menu
		       (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
		       ;; (iup:menu-item "Show dialog"     #:action (lambda (obj)
		       ;;  					   (show message-window
		       ;;  					     #:modal? #t
		       ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
		       ;;  					     ;; #:x 'mouse
		       ;;  					     ;; #:y 'mouse
		       ;;  )					     
		       ))))

(define (datashare:publish-view configdat)
  ;; (pp (hash-table->alist configdat))
  (let* ((areas       (configf:get-section configdat "areas"))
	 (label-size  "70x")
	 (areas-sel   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
	 (version-tb  (iup:textbox #:expand "HORIZONTAL")) ;;  #:size "50x"))
	 (areas-sel   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES"))
	 (component   (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" ))
	 (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x"))
	 ;; (copy-link   (iup:toggle  #:expand "HORIZONTAL"))
	 ;; (iteration   (iup:textbox #:expand "YES" #:size "20x"))
	 ;; (iteration   (iup:textbox #:expand "HORIZONTAL" #:size "20x"))
	 (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%"))
	 (comment-tb  (iup:textbox #:expand "YES" #:multiline "YES"))
	 (source-tb   (iup:textbox #:expand "HORIZONTAL"
				   #:value (or (configf:lookup configdat "settings" "basepath")
					       "")))
	 (publish     (lambda (publish-type)
			(let* ((area-num    (or (string->number (iup:attribute areas-sel "VALUE")) 0))
			       (area-dat    (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED")))
			       (area-path   (cadr area-dat))
			       (area-name   (car  area-dat))
			       (version     (iup:attribute version-tb "VALUE"))
			       (comment     (iup:attribute comment-tb "VALUE"))
			       (spath       (iup:attribute source-tb  "VALUE"))
			       (submitter   (current-user-name))
			       (quality     2))
			  (datashare:publish configdat publish-type area-name version comment spath submitter quality))))
	 (copy        (iup:button "Copy and Publish"
				  #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (publish 'copy))))
	 (link        (iup:button "Link and Publish"
				  #:expand "HORIZONTAL"
				  #:action (lambda (obj)
					     (publish 'link))))
	 (browse-btn  (iup:button "Browse"
				  #:size "40x"
				  #:action (lambda (obj)
					     (let* ((fd  (iup:file-dialog #:dialogtype "DIR"))
						    (top (iup:show fd #:modal? "YES")))
					       (iup:attribute-set! source-tb "VALUE"
								   (iup:attribute fd "VALUE"))
					       (iup:destroy! fd))))))
    (print "areas")
    ;; (pp areas)
    (fold (lambda (areadat num)
	    ;; (print "Adding num=" num ", areadat=" areadat)
	    (iup:attribute-set! areas-sel (conc num) (car areadat))
	    (+ 1 num))
	  1 areas)
    (iup:vbox
     (iup:hbox (iup:label "Area:"        #:size label-size) ;; area-filter 
	       areas-sel)
     (iup:hbox (iup:label "Version:"     #:size label-size)   version-tb)
     ;; (iup:hbox (iup:label "Link only"    #:size label-size)   copy-link)
     ;; 	       (iup:label "Iteration:")   iteration)
     (iup:hbox (iup:label "Comment:"     #:size label-size)   comment-tb)
     (iup:hbox (iup:label "Source base path:" #:size label-size)   source-tb browse-btn)
     (iup:hbox copy link))))

(define (datashare:lst->path pathlst)
  (conc "/" (string-intersperse (map conc pathlst) "/")))

(define (datashare:path->lst path)
  (string-split path "/"))

(define (datashare:pathdat-apply-heuristics configdat path)
  (cond
   ((common:file-exists? path) "found")
   (else (conc path " not installed"))))

(define (datashare:get-view configdat)
  (iup:vbox
   (iup:hbox
    (let* ((label-size     "60x")
	   ;; filter elements
	   (area-filter    "%")
	   (version-filter "%")
	   (iter-filter    ">= 0")
	   ;; reverse lookup from path to data for src and installed
	   (srcdat         (make-hash-table)) ;; reverse lookup
	   (installed-dat  (make-hash-table))
	   ;; config values
	   (basepath       (configf:lookup configdat "settings" "basepath"))
	   ;; gui elements
	   (submitter      (iup:label "" #:expand "HORIZONTAL"))
	   (date-submitted (iup:label "" #:expand "HORIZONTAL"))
	   (comment        (iup:label "" #:expand "HORIZONTAL"))
	   (copy-link      (iup:label "" #:expand "HORIZONTAL"))
	   (quality        (iup:label "" #:expand "HORIZONTAL"))
	   (installed-status (iup:label "" #:expand "HORIZONTAL"))
	   ;; misc 
	   (curr-record    #f)
	   ;; (source-data    (iup:label "" #:expand "HORIZONTAL"))
	   (tb             (iup:treebox
			    #:value 0
			    #:name "Packages"
			    #:expand "YES"
			    #:addexpanded "NO"
			    #:selection-cb
			    (lambda (obj id state)
			      ;; (print "obj: " obj ", id: " id ", state: " state)
			      (let* ((path   (datashare:lst->path (cdr (tree:node->path obj id))))
				     (record (hash-table-ref/default srcdat path #f)))
				(if record
				    (begin
				      (set! curr-record record)
				      (iup:attribute-set! submitter      "TITLE" (datashare:pkg-get-submitter record))
				      (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datashare:pkg-get-datetime record))))
				      (iup:attribute-set! comment        "TITLE" (datashare:pkg-get-comment record))
				      (iup:attribute-set! quality        "TITLE" (datashare:pkg-get-quality record))
				      (iup:attribute-set! copy-link      "TITLE" (datashare:pkg-get-store_type record))
				      ))
				;; (print  "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id)
				))))
	   (tb2             (iup:treebox
			    #:value 0
			    #:name "Installed"
			    #:expand "YES"
			    #:addexpanded "NO"
			    #:selection-cb
			    (lambda (obj id state)
			      ;; (print "obj: " obj ", id: " id ", state: " state)
			      (let* ((path   (datashare:lst->path (cdr (tree:node->path obj id))))
				     (status (hash-table-ref/default installed-dat path #f)))
				(iup:attribute-set! installed-status "TITLE" (if status status ""))
				))))
	   (refresh        (lambda (obj)
			     (let* ((db    (datashare:open-db configdat))
				    (areas (or (configf:get-section configdat "areas") '())))
			       ;;
			       ;; first update the Sources
			       ;;
			       (for-each
				(lambda (pkgitem)
				  (let* ((pkg-path   (list (datashare:pkg-get-area  pkgitem)
							   (datashare:pkg-get-version_name pkgitem)
							   (datashare:pkg-get-iteration pkgitem)))
					 (pkg-id     (datashare:pkg-get-id          pkgitem))
					 (path       (datashare:lst->path pkg-path)))
				    ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id)
				    (if (not (hash-table-ref/default srcdat path #f))
					(tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id)))
				    ;; (print "path=" path " pkgitem=" pkgitem)
				    (hash-table-set! srcdat path pkgitem)))
				(datashare:get-pkgs db area-filter version-filter iter-filter))
			       ;;
			       ;; then update the installed
			       ;;
			       (for-each
				(lambda (area)
				  (let* ((path     (conc "/" (cadr area)))
					 (fullpath (conc basepath path)))
				    (if (not (hash-table-ref/default installed-dat path #f))
					(tree:add-node tb2 "Installed" (datashare:path->lst path)))
				    (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath))))
				areas)
			       (sqlite3:finalize! db))))
	   (apply          (iup:button "Apply"
				       #:action
				       (lambda (obj)
					 (if curr-record
					     (let* ((area        (datashare:pkg-get-area        curr-record))
						    (stored-path (datashare:pkg-get-stored_path curr-record))
						    (source-type (datashare:pkg-get-store_type  curr-record))
						    (source-path (case source-type ;;  (equal? source-type "link"))
								   ((link)(datashare:pkg-get-source-path curr-record))
								   ((copy)stored-path)
								   (else #f)))
						    (dest-stub   (configf:lookup configdat "areas" area))
						    (target-path (conc basepath "/" dest-stub)))
					       (datashare:build-dir-make-link stored-path target-path)
					       (print "Creating link from " stored-path " to " target-path)))))))
      (iup:vbox 
       (iup:hbox tb tb2)
       (iup:frame 
	#:title "Source Info"
	(iup:vbox
	 (iup:hbox (iup:button "Refresh" #:action refresh) apply)
	 (iup:hbox (iup:label "Submitter: ") ;;  #:size label-size)
		   submitter 
		   (iup:label "Submitted on: ") ;;  #:size label-size)
		   date-submitted)
	 (iup:hbox (iup:label "Data stored: ")
		   copy-link
		   (iup:label "Quality: ")
		   quality)
	 (iup:hbox (iup:label "Comment: ")
		   comment)))
       (iup:frame
	#:title "Installed Info"
	(iup:vbox
	 (iup:hbox (iup:label "Installed status/path: ") installed-status)))
       )))))

(define (datashare:manage-view configdat)
  (iup:vbox
   (iup:hbox 
    (iup:button "Pushme"
		#:expand "YES"
		))))

(define (datashare:gui configdat)
  (iup:show
   (iup:dialog 
    #:title (conc "DataShare dashboard " (current-user-name) ":" (current-directory))   
    #:menu (datashare:main-menu)
    (let* ((tabs (iup:tabs
		  #:tabchangepos-cb (lambda (obj curr prev)
				      (set! *datashare:current-tab-number* curr))
		  (datashare:publish-view configdat)
		  (datashare:get-view configdat)
		  (datashare:manage-view configdat)
		  )))
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
	(iup:attribute-set! tabs "TABTITLE0" "Publish")
	(iup:attribute-set! tabs "TABTITLE1" "Get")
	(iup:attribute-set! tabs "TABTITLE2" "Manage")
	;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
	tabs)))
  (iup:main-loop))

;;======================================================================
;; MISC
;;======================================================================


(define (datashare: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))
    ;; (print "running as " (current-effective-user-id))
    (proc)
    (if (not (eq? eid cid))
        (set! (current-effective-user-id) eid))))

(define (datashare:find name paths)
  (if (null? paths)
      #f
      (let loop ((hed (car paths))
		 (tal (cdr paths)))
	(if (common:file-exists? (conc hed "/" name))
	    hed
	    (if (null? tal)
		#f
		(loop (car tal)(cdr tal)))))))

;;======================================================================
;; MAIN
;;======================================================================

(define (datashare:load-config exe-dir exe-name)
  (let* ((fname   (conc exe-dir "/." exe-name ".config")))
    (ini:property-separator-patt " *  *")
    (ini:property-separator #\space)
    (if (common:file-exists? fname)
	;; (ini:read-ini fname)
	(read-config fname #f #t)
	(make-hash-table))))

(define (datashare:process-action configdat action . args)
  (case (string->symbol action)
    ((get)
     (if (< (length args) 2)
	 (begin 
	   (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	   (exit 1))
	 (let* ((basepath    (configf:lookup configdat "settings" "basepath"))
		(db          (datashare:open-db configdat))
		(area        (car args))
		(version     (cadr args)) ;;    iteration
		(remargs     (args:get-args args '("-i") '() args:arg-hash 0))
		(iteration   (if (args:get-arg "-i")(string->number (args:get-arg "-i")) #f))
		(curr-record (datashare:get-pkg db area version iteration: iteration)))
	   (if (not curr-record)
	       (begin
		 (print "ERROR: No matching record found; area=" area ", version=" version ", iteration=" (if iteration iteration "(max)"))
		 (exit 1))
	       (let* ((stored-path (datashare:pkg-get-stored_path curr-record))
		      (source-type (datashare:pkg-get-store_type  curr-record))
		      (source-path (case source-type ;;  (equal? source-type "link"))
				     ((link) (datashare:pkg-get-source-path curr-record))
				     ((copy) stored-path)
				     (else #f)))
		      (dest-stub   (configf:lookup configdat "areas" area))
		      (target-path (conc basepath "/" dest-stub)))
		 (datashare:build-dir-make-link stored-path target-path)
		 (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path)
		 (sqlite3:finalize! db)
		 (print "Creating link from " stored-path " to " target-path))))))
    ((publish)
     (if (< (length args) 3)
	 (begin 
	   (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	   (exit 1))
	 (let* ((srcpath  (list-ref args 0))
		(areaname (list-ref args 1))
		(version  (list-ref args 2))
		(remargs  (args:get-args (drop args 2)
					 '("-type" ;; link or copy (default is copy)
					   "-m")
 					 '()
 					 args:arg-hash
 					 0))
		(publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy))
		(comment      (or (args:get-arg "-m") ""))
		(submitter    (current-user-name))
		(quality      (args:get-arg "-quality"))
		(publish-res  (datashare:publish configdat publish-type areaname version comment srcpath submitter quality)))
	   (if (not (car publish-res))
	       (begin
		 (print "ERROR: " (cdr publish-res))
		 (exit 1))))))
    ((list-versions)
     (let ((area-name (car args)) ;;      version patt   full print
	   (remargs   (args:get-args args '("-vpatt") '("-full") args:arg-hash 0))
	   (db        (datashare:open-db configdat))
	   (versions  (datashare:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt"))))
       ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*))
       (map (lambda (x)
	      (if (args:get-arg "-full")
		  (format #t 
			  "~10a~10a~4a~27a~30a\n"
			  (vector-ref x 0)
			  (vector-ref x 1) 
			  (vector-ref x 2) 
			  (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
			  (conc "\"" (vector-ref x 4) "\""))
		  (print (vector-ref x 0))))
	    versions)
       (sqlite3:finalize! db)))))

;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc")))
  (if (common:file-exists? debugcontrolf)
      (load debugcontrolf)))

(define (main)
  (let* ((args      (argv))
	 (prog      (car args))
	 (rema      (cdr args))
	 (exe-name  (pathname-file (car (argv))))
	 (exe-dir   (or (pathname-directory prog)
			(datashare:find exe-name (string-split (get-environment-variable "PATH") ":"))))
	 (configdat (datashare:load-config exe-dir exe-name)))
    (cond
     ;; one-word commands
     ((eq? (length rema) 1)
      (case (string->symbol (car rema))
	((help -h -help --h --help)
	 (print datashare:help))
	((list-areas)
	 (map print (datashare:get-areas configdat)))
	(else
	 (print "ERROR: Unrecognised command. Try \"datashare help\""))))
     ;; multi-word commands
     ((null? rema)(datashare:gui configdat))
     ((>= (length rema) 2)
      (apply datashare:process-action configdat (car rema)(cdr rema)))
     (else (print "ERROR: Unrecognised command. Try \"datashare help\"")))))

(main)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Modified db.scm from [fb3a18f52f] to [1d483e1919].

1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
      (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
      (if (common:low-noise-print 30 "sync new to old")
          (if sync-needed
              (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
              (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
      res))

;; keeping it around for debugging purposes only
#;(define (open-run-close-no-exception-handling  proc idb . params)
  (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
  (print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...")
  (exit)
  (if (or *db-write-access*
	  (not #t)) ;; was: (member proc * db:all-write-procs *)))
      (let* ((db (cond
		  ((pair? idb)                 (db:dbdat-get-db idb))
		  ((sqlite3:database? idb)     idb)
		  ((not idb)                   (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))
		  ((procedure? idb)            (idb))
		  (else   	               (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))))
	     (res #f))
	(set! res (apply proc db params))
	(if (not idb)(sqlite3:finalize! dbstruct))
	(debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" )
	res)
      #f))

#;(define (open-run-close-exception-handling proc idb . params)
  (handle-exceptions
   exn
   (let ((sleep-time (random 30))
	 (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
     (case err-status
       ((busy)
	(thread-sleep! sleep-time))
       (else
	(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.")
	(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	(debug:print 5 *default-log-port* "exn=" (condition->list exn))
	(debug:print 0 *default-log-port* " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
	(print-call-chain (current-error-port))
	(thread-sleep! sleep-time)
	(debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
     (apply open-run-close-exception-handling proc idb params))
   (apply open-run-close-no-exception-handling proc idb params)))

;; (define open-run-close 
#;(define open-run-close open-run-close-exception-handling)
		;;	   open-run-close-no-exception-handling
;;			   open-run-close-exception-handling)
;;)

(define db:trigger-list 
     (list (list "update_runs_trigger"  "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
                             FOR EACH ROW
                               BEGIN 
                                 UPDATE runs SET last_update=(strftime('%s','now'))
                                   WHERE id=old.id;
                               END;" ) 







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







1171
1172
1173
1174
1175
1176
1177













































1178
1179
1180
1181
1182
1183
1184
      (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
      (if (common:low-noise-print 30 "sync new to old")
          (if sync-needed
              (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
              (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
      res))














































(define db:trigger-list 
     (list (list "update_runs_trigger"  "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
                             FOR EACH ROW
                               BEGIN 
                                 UPDATE runs SET last_update=(strftime('%s','now'))
                                   WHERE id=old.id;
                               END;" ) 
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
	(lambda (id archive-disk-id disk-path last-du last-du-time creation-time)
	  (set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time)))
	db
	"SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;"
	archive-block-id)
       res))))

;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
;;   (let* ((dbdat        (db:get-db dbstruct #f)) ;; archive tables are in main.db
;; 	 (db           (db:dbdat-get-db dbdat))
;; 	 (res          '())
;; 	 (blocks       '())) ;; a block is an archive chunck that can be added too if there is space
;;     (sqlite3:for-each-row  #f)

;;======================================================================
;; L O G G I N G    D B 
;;======================================================================

(define (open-logging-db)
  (let* ((dbpath    (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
	 (dbexists  (common:file-exists? dbpath))







<
<
<
<
<
<
<







1614
1615
1616
1617
1618
1619
1620







1621
1622
1623
1624
1625
1626
1627
	(lambda (id archive-disk-id disk-path last-du last-du-time creation-time)
	  (set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time)))
	db
	"SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;"
	archive-block-id)
       res))))








;;======================================================================
;; L O G G I N G    D B 
;;======================================================================

(define (open-logging-db)
  (let* ((dbpath    (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
	 (dbexists  (common:file-exists? dbpath))
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
;; 1. Look at test records either deleted or part of deleted run:
;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
;;    b. If test dir gone, delete the test record
;; 2. Look at run records
;;    a. If have tests that are not deleted, set state='unknown'
;;    b. ....
;;
(define (db:clean-up-rundb dbdat)
  ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
  (let* ((db         (db:dbdat-get-db dbdat))
	 (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
	(statements
	 (map (lambda (stmt)
		(sqlite3:prepare db stmt))
	      (list







|







1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
;; 1. Look at test records either deleted or part of deleted run:
;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
;;    b. If test dir gone, delete the test record
;; 2. Look at run records
;;    a. If have tests that are not deleted, set state='unknown'
;;    b. ....
;;
#;(define (db:clean-up-rundb dbdat)
  ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
  (let* ((db         (db:dbdat-get-db dbdat))
	 (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
	(statements
	 (map (lambda (stmt)
		(sqlite3:prepare db stmt))
	      (list
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
	(lambda (runname)
	  (set! res runname))
	db
	"SELECT runname FROM runs WHERE id=?;"
	run-id)
       res))))

(define (db:get-run-key-val dbstruct run-id key)
  (db:with-db
   dbstruct
   #f
   #f
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row







|







2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
	(lambda (runname)
	  (set! res runname))
	db
	"SELECT runname FROM runs WHERE id=?;"
	run-id)
       res))))

#;(define (db:get-run-key-val dbstruct run-id key)
  (db:with-db
   dbstruct
   #f
   #f
   (lambda (db)
     (let ((res #f))
       (sqlite3:for-each-row
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
	    0))))

;; tags: '("tag%" "tag2" "%ag6")
;;

;; done with run when:
;;   0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
(define (db:estimated-tests-remaining dbstruct run-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (sqlite3:first-result
      db







|







3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
	    0))))

;; tags: '("tag%" "tag2" "%ag6")
;;

;; done with run when:
;;   0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
#;(define (db:estimated-tests-remaining dbstruct run-id)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (sqlite3:first-result
      db
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
	      (loop (+ new-id 1))
	      (begin
		(debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id)
		(sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id)))))))

;; move test ids into the 30k * run_id range
;;
(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs)
  (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id)
  (let ((min-test-id (* run-id 30000)))
    (for-each 
     (lambda (testrec)
       (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields))))
	 (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id)))
     testrecs)))
	
;; 1. move test ids into the 30k * run_id range
;; 2. move step ids into the 30k * run_id range
;;
(define (db:prep-megatest.db-for-migration mtdb)
  (let* ((run-ids (db:get-all-run-ids mtdb)))
    (for-each 
     (lambda (run-id)
       (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
	 (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs)))
     run-ids)))








|











|







3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
	      (loop (+ new-id 1))
	      (begin
		(debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id)
		(sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id)))))))

;; move test ids into the 30k * run_id range
;;
#;(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs)
  (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id)
  (let ((min-test-id (* run-id 30000)))
    (for-each 
     (lambda (testrec)
       (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields))))
	 (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id)))
     testrecs)))
	
;; 1. move test ids into the 30k * run_id range
;; 2. move step ids into the 30k * run_id range
;;
#;(define (db:prep-megatest.db-for-migration mtdb)
  (let* ((run-ids (db:get-all-run-ids mtdb)))
    (for-each 
     (lambda (run-id)
       (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
	 (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs)))
     run-ids)))

3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
	 (begin
	   (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
           (print-call-chain (current-error-port))
	   msg))) ;; crude reply for when things go awry
    ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
    (else msg))) ;; rpc

;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
;; ;
;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
;;  (let ((dbdat  (db:get-db dbstruct run-id)))
;;    (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
;; 	(db:general-call dbdat 'set-test-start-time (list test-id)))
;;    ;; (if msg
;;    ;; 	(db:general-call dbdat 'state-status-msg (list state status msg test-id))
;;    ;; 	(db:general-call dbdat 'state-status     (list state status test-id)))
;;    (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
;;    ;; process the test_data table
;;    (if (and test-id state status (equal? status "AUTO")) 
;; 	(db:test-data-rollup dbstruct run-id test-id status))
;;    (mt:process-triggers dbstruct run-id test-id state status)))

;; state is the priority rollup of all states
;; status is the priority rollup of all completed statesfu
;;
;; if test-name is an integer work off that instead of test-name test-path
;;
(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
  ;; establish info on incoming test followed by info on top level test







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







3900
3901
3902
3903
3904
3905
3906















3907
3908
3909
3910
3911
3912
3913
	 (begin
	   (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
           (print-call-chain (current-error-port))
	   msg))) ;; crude reply for when things go awry
    ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
    (else msg))) ;; rpc
















;; state is the priority rollup of all states
;; status is the priority rollup of all completed statesfu
;;
;; if test-name is an integer work off that instead of test-name test-path
;;
(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
  ;; establish info on incoming test followed by info on top level test
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
           (all-curr-statuses    (common:special-sort  ;; worst -> best
                                    (delete-duplicates
                                      (if (and state status (not (member state *common:dont-roll-up-states*)))
                                          (cons status (map dbr:counts-status state-status-counts))
                                          (map dbr:counts-status state-status-counts)))
                                                   *common:std-statuses* >))
           (non-completes        (filter (lambda (x)
							 										 (not (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
						       									all-curr-states))
			     (preq-fails        (filter (lambda (x)
							 								(equal? x "PREQ_FAIL"))
						       							all-curr-statuses))
           (num-non-completes (length non-completes))
 					 (newstate          (cond
															((> running 0)           "RUNNING")            ;; anything running, call the situation running
                              ((> (length preq-fails) 0) "NOT_STARTED")
															((> bad-not-started 0)   "COMPLETED")          ;; we have an ugly situation, it is completed in the sense we cannot do more.
															((> num-non-completes 0) (car non-completes))  ;;  (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED
															(else                    (car all-curr-states))))
           (newstatus         (cond
                              ((> (length preq-fails) 0)  "PREQ_FAIL")
                              ((or (> bad-not-started 0)
                                   (and (equal? newstate "NOT_STARTED")
                                      (> num-non-completes 0)))
                                            "STARTED")
                              (else (car all-curr-statuses)))))
 					(debug:print-info 2 *default-log-port*
                                         "\n--> probe db:set-state-status-and-roll-up-items: "
                                         "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
                                         "\n--> running:             "running
                                         "\n--> bad-not-started:     "bad-not-started
                                         "\n--> non-non-completes:   "num-non-completes
                                         "\n--> non-completes:       "non-completes
                                         "\n--> all-curr-states:     "all-curr-states
                                         "\n--> all-curr-statuses:     "all-curr-statuses
                                         "\n--> newstate              "newstate
                                         "\n--> newstatus            "newstatus
                                         "\n\n")

                        ;; NB// Pass the db so it is part of the transaction
         (list newstate newstatus)))

(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
    (mutex-lock! *db-transaction-mutex*)
    (db:with-db
     dbstruct #f #f
     (lambda (db)
       (let ((tr-res
              (sqlite3:with-transaction
               db
               (lambda ()
                   (let* ((state-status-counts  (db:get-all-state-status-counts-for-run dbstruct run-id))
													(state-stauses (db:roll-up-rules state-status-counts #f #f ))
                          (newstate (car state-stauses))
                          (newstatus (cadr state-stauses))) 
                    (if (or (not (eq? newstate curr-state)) (not (eq?  newstatus curr-status)))
                   (db:set-run-state-status dbstruct run-id newstate newstatus )))))))
         (mutex-unlock! *db-transaction-mutex*)
         tr-res))))


(define (db:get-all-state-status-counts-for-run dbstruct run-id)
 (let* ((test-count-recs (db:with-db
                                  dbstruct #f #f
                                  (lambda (db)
                                    (sqlite3:map-row
                                     (lambda (state status count)
                                        (make-dbr:counts state: state status: status count: count))
                                     db
                                     "SELECT state,status,count(id) FROM tests WHERE run_id=?  GROUP BY state,status;"
                                     run-id )))))
   test-count-recs))


;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
;;
;; NOTE: This is called within a transaction
;;
(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in)
  (let* ((test-info   (db:get-test-info dbstruct run-id test-name item-path))







|
|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

<

|
|
|
|
|
|
|
|
|
|
<







3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032

4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043

4044
4045
4046
4047
4048
4049
4050
           (all-curr-statuses    (common:special-sort  ;; worst -> best
                                    (delete-duplicates
                                      (if (and state status (not (member state *common:dont-roll-up-states*)))
                                          (cons status (map dbr:counts-status state-status-counts))
                                          (map dbr:counts-status state-status-counts)))
                                                   *common:std-statuses* >))
           (non-completes        (filter (lambda (x)
					   (not (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
					 all-curr-states))
	   (preq-fails        (filter (lambda (x)
					(equal? x "PREQ_FAIL"))
				      all-curr-statuses))
           (num-non-completes (length non-completes))
	   (newstate          (cond
			       ((> running 0)           "RUNNING")            ;; anything running, call the situation running
			       ((> (length preq-fails) 0) "NOT_STARTED")
			       ((> bad-not-started 0)   "COMPLETED")          ;; we have an ugly situation, it is completed in the sense we cannot do more.
			       ((> num-non-completes 0) (car non-completes))  ;;  (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED
			       (else                    (car all-curr-states))))
           (newstatus         (cond
			       ((> (length preq-fails) 0)  "PREQ_FAIL")
			       ((or (> bad-not-started 0)
				    (and (equal? newstate "NOT_STARTED")
					 (> num-non-completes 0)))
				"STARTED")
			       (else (car all-curr-statuses)))))
		  (debug:print-info 2 *default-log-port*
				    "\n--> probe db:set-state-status-and-roll-up-items: "
				    "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
				    "\n--> running:             "running
				    "\n--> bad-not-started:     "bad-not-started
				    "\n--> non-non-completes:   "num-non-completes
				    "\n--> non-completes:       "non-completes
				    "\n--> all-curr-states:     "all-curr-states
				    "\n--> all-curr-statuses:     "all-curr-statuses
				    "\n--> newstate              "newstate
				    "\n--> newstatus            "newstatus
				    "\n\n")
		  
		  ;; NB// Pass the db so it is part of the transaction
		  (list newstate newstatus)))

(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
  (mutex-lock! *db-transaction-mutex*)
  (db:with-db
   dbstruct #f #f
   (lambda (db)
     (let ((tr-res
	    (sqlite3:with-transaction
	     db
	     (lambda ()
	       (let* ((state-status-counts  (db:get-all-state-status-counts-for-run dbstruct run-id))
		      (state-stauses (db:roll-up-rules state-status-counts #f #f ))
		      (newstate (car state-stauses))
		      (newstatus (cadr state-stauses))) 
		 (if (or (not (eq? newstate curr-state)) (not (eq?  newstatus curr-status)))
		     (db:set-run-state-status dbstruct run-id newstate newstatus )))))))
       (mutex-unlock! *db-transaction-mutex*)
       tr-res))))


(define (db:get-all-state-status-counts-for-run dbstruct run-id)
  (let* ((test-count-recs (db:with-db
			   dbstruct #f #f
			   (lambda (db)
			     (sqlite3:map-row
			      (lambda (state status count)
				(make-dbr:counts state: state status: status count: count))
			      db
			      "SELECT state,status,count(id) FROM tests WHERE run_id=?  GROUP BY state,status;"
			      run-id )))))
    test-count-recs))


;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
;;
;; NOTE: This is called within a transaction
;;
(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in)
  (let* ((test-info   (db:get-test-info dbstruct run-id test-name item-path))
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
         (nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec))))
         
         (unrelated-rec-list   
          (filter nonmatch-countrec-lambda other-items-count-recs)))
    
    (cons updated-count-rec unrelated-rec-list)))

;; (define (db:get-all-item-states db run-id test-name)
;;   (sqlite3:map-row 
;;    (lambda (a) a)
;;    db
;;    "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?"
;;    run-id test-name))
;; 
;; (define (db:get-all-item-statuses db run-id test-name)
;;   (sqlite3:map-row 
;;    (lambda (a) a)
;;    db
;;    "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?"
;;    run-id test-name))

(define (db:test-get-logfile-info dbstruct run-id test-name)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (let ((res #f))







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







4078
4079
4080
4081
4082
4083
4084














4085
4086
4087
4088
4089
4090
4091
         (nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec))))
         
         (unrelated-rec-list   
          (filter nonmatch-countrec-lambda other-items-count-recs)))
    
    (cons updated-count-rec unrelated-rec-list)))















(define (db:test-get-logfile-info dbstruct run-id test-name)
  (db:with-db
   dbstruct
   run-id
   #f
   (lambda (db)
     (let ((res #f))

Modified db_records.scm from [37c233f08b] to [7834b1e5f5].

104
105
106
107
108
109
110

111
112
113






114
115
116
117
118
119
120
(define-inline (db:test-get-comment      vec) (vector-ref vec 14))
(define-inline (db:test-get-process_id   vec) (vector-ref vec 16))
(define-inline (db:test-get-archived     vec) (vector-ref vec 17))
(define-inline (db:test-get-last_update     vec) (vector-ref vec 18))

;; (define-inline (db:test-get-pass_count   vec) (vector-ref vec 15))
;; (define-inline (db:test-get-fail_count   vec) (vector-ref vec 16))

(define-inline (db:test-get-fullname     vec)
  (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))







;; replace runs:make-full-test-name with this routine
(define (db:test-make-full-name testname itempath)
  (if (equal? itempath "") testname (conc testname "/" itempath)))

(define-inline (db:test-get-first_err    vec) (printable (vector-ref vec 15)))
(define-inline (db:test-get-first_warn   vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated








>



>
>
>
>
>
>







104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
(define-inline (db:test-get-comment      vec) (vector-ref vec 14))
(define-inline (db:test-get-process_id   vec) (vector-ref vec 16))
(define-inline (db:test-get-archived     vec) (vector-ref vec 17))
(define-inline (db:test-get-last_update     vec) (vector-ref vec 18))

;; (define-inline (db:test-get-pass_count   vec) (vector-ref vec 15))
;; (define-inline (db:test-get-fail_count   vec) (vector-ref vec 16))

(define-inline (db:test-get-fullname     vec)
  (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))

(define-inline (test:test-get-fullname test)
   (conc (db:test-get-testname test)
	 (if (equal? (db:test-get-item-path test) "")
	     ""
	     (conc "(" (db:test-get-item-path test) ")"))))

;; replace runs:make-full-test-name with this routine
(define (db:test-make-full-name testname itempath)
  (if (equal? itempath "") testname (conc testname "/" itempath)))

(define-inline (db:test-get-first_err    vec) (printable (vector-ref vec 15)))
(define-inline (db:test-get-first_warn   vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated

238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
(define-inline (tdb:steps-table-get-log-file   vec)    (vector-ref  vec 5))

(define-inline (tdb:step-stable-set-stepname!  vec val)(vector-set! vec 0 val))
(define-inline (tdb:step-stable-set-start!     vec val)(vector-set! vec 1 val))
(define-inline (tdb:step-stable-set-end!       vec val)(vector-set! vec 2 val))
(define-inline (tdb:step-stable-set-status!    vec val)(vector-set! vec 3 val))
(define-inline (tdb:step-stable-set-runtime!   vec val)(vector-set! vec 4 val))

;; The data structure for handing off requests via wire
(define (make-cdb:packet)(make-vector 6))
(define-inline (cdb:packet-get-client-sig   vec)    (vector-ref  vec 0))
(define-inline (cdb:packet-get-qtype        vec)    (vector-ref  vec 1))
(define-inline (cdb:packet-get-immediate    vec)    (vector-ref  vec 2))
(define-inline (cdb:packet-get-query-sig    vec)    (vector-ref  vec 3))
(define-inline (cdb:packet-get-params       vec)    (vector-ref  vec 4))
(define-inline (cdb:packet-get-qtime        vec)    (vector-ref  vec 5))
(define-inline (cdb:packet-set-client-sig!  vec val)(vector-set! vec 0 val))
(define-inline (cdb:packet-set-qtype!       vec val)(vector-set! vec 1 val))
(define-inline (cdb:packet-set-immediate!   vec val)(vector-set! vec 2 val))
(define-inline (cdb:packet-set-query-sig!   vec val)(vector-set! vec 3 val))
(define-inline (cdb:packet-set-params!      vec val)(vector-set! vec 4 val))
(define-inline (cdb:packet-set-qtime!       vec val)(vector-set! vec 5 val))







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
245
246
247
248
249
250
251















(define-inline (tdb:steps-table-get-log-file   vec)    (vector-ref  vec 5))

(define-inline (tdb:step-stable-set-stepname!  vec val)(vector-set! vec 0 val))
(define-inline (tdb:step-stable-set-start!     vec val)(vector-set! vec 1 val))
(define-inline (tdb:step-stable-set-end!       vec val)(vector-set! vec 2 val))
(define-inline (tdb:step-stable-set-status!    vec val)(vector-set! vec 3 val))
(define-inline (tdb:step-stable-set-runtime!   vec val)(vector-set! vec 4 val))















Modified dcommon.scm from [0db7864f6b] to [7100ed6ff9].

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
    (if (not (equal? curr-val new-val)) 
	(begin
	  (iup:attribute-set! mtrx cell-name new-val) ;; was col-name
	  #t) ;; need a re-draw
	prev-changed)))


;; TO-DO
;;  1. Make "data" hash-table hierarchial store of all displayed data
;;  2. Update synchash to understand "get-runs", "get-tests" etc.
;;  3. Add extraction of filters to synchash calls
;;
;;    NOTE: Used in newdashboard
;;
;; Mode is 'full or 'incremental for full refresh or incremental refresh
;; (define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id)
;;   (let* (;; count and offset => #f so not used
;; 	 ;; the synchash calls modify the "data" hash
;; 	 (changed         #f)
;; 	 (get-runs-sig    (conc (client:get-signature) " get-runs"))
;; 	 (get-tests-sig   (conc (client:get-signature) " get-tests"))
;; 	 (get-details-sig (conc (client:get-signature) " get-test-details"))
;; 
;; 	 ;; test-ids to get and display are indexed on window-id in curr-test-ids hash
;; 	 (test-ids        (hash-table-values (dboard:tabdat-curr-test-ids data)))
;; 	 ;; run-id is #f in next line to send the query to server 0
;;  	 (run-changes     (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts))
;; 	 (tests-detail-changes (if (not (null? test-ids))
;; 				   (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0  data #f test-ids)
;; 				   '()))
;; 
;; 	 ;; Now can calculate the run-ids
;; 	 (run-hash    (hash-table-ref/default data get-runs-sig #f))
;; 	 (run-ids     (if run-hash (filter number? (hash-table-keys run-hash)) '()))
;; 
;; 	 (all-test-changes (let ((res (make-hash-table)))
;; 			     (for-each (lambda (run-id)
;; 					 (if (> run-id 0)
;; 					     (hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f))))
;; 				       run-ids)
;; 			     res))
;; 	 (runs-hash    (hash-table-ref/default data get-runs-sig #f))
;; 	 (header       (hash-table-ref/default runs-hash "header" #f))
;; 	 (run-ids      (sort (filter number? (hash-table-keys runs-hash))
;; 			     (lambda (a b)
;; 			       (let* ((record-a (hash-table-ref runs-hash a))
;; 				      (record-b (hash-table-ref runs-hash b))
;; 				      (time-a   (db:get-value-by-header record-a header "event_time"))
;; 				      (time-b   (db:get-value-by-header record-b header "event_time")))
;; 				 (> time-a time-b)))
;; 			     ))
;; 	 (runid-to-col    (hash-table-ref *cachedata* "runid-to-col"))
;; 	 (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) 
;; 	 (colnum       1)
;; 	 (rownum       0)
;; 	 (cellname (conc rownum ":" colnum))) ;; rownum = 0 is the header
;; ;; (debug:print 0 *default-log-port* "test-ids " test-ids ", tests-detail-changes " tests-detail-changes)
;;     
;; 	 ;; tests related stuff
;; 	 ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes))))
;; 
;;     ;; Given a run-id and testname/item_path calculate a cell R:C
;; 
;;     ;; NOTE: Also build the test tree browser and look up table
;;     ;;
;;     ;; Each run is unique on its keys and runname or run-id, store in hash on colnum
;;     (for-each (lambda (run-id)
;; 		(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
;; 		       (key-vals   (map (lambda (key)(db:get-value-by-header run-record header key))
;; 					keys))
;; 		       (run-name   (db:get-value-by-header run-record header "runname"))
;; 		       (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))
;; 		       (run-path   (append key-vals (list run-name))))
;; 		  (hash-table-set! (dboard:tabdat-run-keys data) run-id run-path)
;; 		  ;; modify cell - but only if changed
;; 		  (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed))
;; 		  (hash-table-set! runid-to-col run-id (list colnum run-record))
;; 		  ;; Here we update the tests treebox and tree keys
;; 		  (tree:add-node (dboard:tabdat-tests-tree data) "Runs" (append key-vals (list run-name))
;; 				 userdata: (conc "run-id: " run-id))
;; 		  (set! colnum (+ colnum 1))))
;; 	      run-ids)
;; 
;;     ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table
;;     ;; Do this analysis in the order of the run-ids, the most recent run wins
;;     (for-each (lambda (run-id)
;; 		(let* ((run-path       (hash-table-ref (dboard:tabdat-run-keys data) run-id))
;; 		       (test-changes   (hash-table-ref all-test-changes run-id))
;; 		       (new-test-dat   (car test-changes))
;; 		       (removed-tests  (cadr test-changes))
;; 		       (tests          (sort (map cadr (filter (lambda (testrec)
;; 								 (eq? run-id (db:mintest-get-run_id (cadr testrec))))
;; 							       new-test-dat))
;; 					     (lambda (a b)
;; 					       (let ((time-a (db:mintest-get-event_time a))
;; 						     (time-b (db:mintest-get-event_time b)))
;; 						 (> time-a time-b)))))
;; 		       ;; test-changes is a list of (( id record ) ... )
;; 		       ;; Get list of test names sorted by time, remove tests
;; 		       (test-names (delete-duplicates (map (lambda (t)
;; 							     (let ((i (db:mintest-get-item_path t))
;; 								   (n (db:mintest-get-testname  t)))
;; 							       (if (string=? i "")
;; 								   (conc "   " i)
;; 								   n)))
;; 							   tests)))
;; 		       (colnum     (car (hash-table-ref runid-to-col run-id))))
;; 		  ;; for each test name get the slot if it exists and fill in the cell
;; 		  ;; or take the next slot and fill in the cell, deal with items in the
;; 		  ;; run view panel? The run view panel can have a tree selector for
;; 		  ;; browsing the tests/items
;; 
;; 		  ;; SWITCH THIS TO USING CHANGED TESTS ONLY
;; 		  (for-each (lambda (test)
;; 			      (let* ((test-id   (db:mintest-get-id test))
;; 				     (state     (db:mintest-get-state test))
;; 				     (status    (db:mintest-get-status test))
;; 				     (testname  (db:mintest-get-testname test))
;; 				     (itempath  (db:mintest-get-item_path test))
;; 				     (fullname  (conc testname "/" itempath))
;; 				     (dispname  (if (string=? itempath "") testname (conc "   " itempath)))
;; 				     (rownum    (hash-table-ref/default testname-to-row fullname #f))
;; 				     (test-path (append run-path (if (equal? itempath "") 
;; 								     (list testname)
;; 								     (list testname itempath))))
;; 				     (tb         (dboard:tabdat-tests-tree data)))
;; 				(print "INFONOTE: run-path: " run-path)
;; 				(tree:add-node (dboard:tabdat-tests-tree data) "Runs" 
;; 					       test-path
;; 					       userdata: (conc "test-id: " test-id))
;; 				(let ((node-num (tree:find-node tb (cons "Runs" test-path)))
;; 				      (color    (car (gutils:get-color-for-state-status state status))))
;; 				  (debug:print 0 *default-log-port* "node-num: " node-num ", color: " color)
;; 
;; 				  (set! changed (dcommon:modifiy-if-different 
;; 						 tb
;; 						 (conc "COLOR" node-num)
;; 						 color changed))
;; 
;; 				  ;; (iup:attribute-set! tb (conc "COLOR" node-num) color)
;; 				  )
;; 				(hash-table-set! (dboard:tabdat-path-test-ids data) test-path test-id)
;; 				(if (not rownum)
;; 				    (let ((rownums (hash-table-values testname-to-row)))
;; 				      (set! rownum (if (null? rownums)
;; 						       1
;; 						       (+ 1 (common:max rownums))))
;; 				      (hash-table-set! testname-to-row fullname rownum)
;; 				      ;; create the label
;; 				      (set! changed (dcommon:modifiy-if-different 
;; 						     (dboard:tabdat-runs-matrix data)
;; 						     (conc rownum ":" 0)
;; 						     dispname
;; 						     changed))
;; 				      ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
;; 				      ;;   		  (conc rownum ":" 0) dispname)
;; 				      ))
;; 				;; set the cell text and color
;; 				;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status)
;; 				(set! changed (dcommon:modifiy-if-different 
;; 						     (dboard:tabdat-runs-matrix data)
;; 						     (conc rownum ":" colnum)
;; 						     (if (member state '("ARCHIVED" "COMPLETED"))
;; 							 status
;; 							 state)
;; 						     changed))
;; 				;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
;; 				;; 		    (conc rownum ":" colnum)
;; 				;; 		    (if (member state '("ARCHIVED" "COMPLETED"))
;; 				;; 			status
;; 				;; 			state))
;; 				(set! changed (dcommon:modifiy-if-different 
;; 					       (dboard:tabdat-runs-matrix data)
;; 					       (conc "BGCOLOR" rownum ":" colnum)
;; 					       (car (gutils:get-color-for-state-status state status))
;; 					       changed))
;; 				;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
;; 				;; 		    (conc "BGCOLOR" rownum ":" colnum)
;; 				;; 		    (car (gutils:get-color-for-state-status state status)))
;; 				))
;; 			    tests)))
;; 	      run-ids)
;; 
;;     (let ((updater (hash-table-ref/default  (dboard:commondat-updaters commondat) window-id #f)))
;;       (if updater (updater (hash-table-ref/default data get-details-sig #f))))
;; 
;;     (if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL"))
;;     ;; (debug:print 2 *default-log-port* "run-changes: " run-changes)
;;     ;; (debug:print 2 *default-log-port* "test-changes: " test-changes)
;;     (list run-changes all-test-changes)))

#;(define (dcommon:runsdat-get-col-num dat target runname force-set)
  (let* ((runs-index (dboard:runsdat-runs-index dat))
	 (col-name   (conc target "/" runname))
	 (res        (hash-table-ref/default runs-index col-name #f)))
    (if res
	res
	(if force-set
	    (let ((max-col-num (+ 1 (common:max (cons-1 (hash-table-values runs-index))))))
	      (hash-table-set! runs-index col-name max-col-num)
	      max-col-num)))))

#;(define (dcommon:runsdat-get-row-num dat testname itempath force-set)
  (let* ((tests-index (dboard:runsdat-runs-index dat))
	 (row-name    (conc testname "/" itempath))
	 (res         (hash-table-ref/default runs-index row-name #f)))
    (if res
	res
	(if force-set
	    (let ((max-row-num (+ 1 (common:max (cons -1 (hash-table-values tests-index))))))
	      (hash-table-set! runs-index row-name max-row-num)
	      max-row-num)))))

(define (dcommon:rundat-copy-tests-to-by-name rundat)
  (let ((src-ht (dboard:rundat-tests rundat))
	(trg-ht (dboard:rundat-tests-by-name rundat)))
    (if (and (hash-table? src-ht)(hash-table? trg-ht))
	(begin
	  (hash-table-clear! trg-ht)







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







149
150
151
152
153
154
155













































































































































































































156
157
158
159
160
161
162
    (if (not (equal? curr-val new-val)) 
	(begin
	  (iup:attribute-set! mtrx cell-name new-val) ;; was col-name
	  #t) ;; need a re-draw
	prev-changed)))
















































































































































































































(define (dcommon:rundat-copy-tests-to-by-name rundat)
  (let ((src-ht (dboard:rundat-tests rundat))
	(trg-ht (dboard:rundat-tests-by-name rundat)))
    (if (and (hash-table? src-ht)(hash-table? trg-ht))
	(begin
	  (hash-table-clear! trg-ht)
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
				    (dboard:tabdat-test-patts-use tabdat))
			   #:expand "YES"
			   #:size "x30" ;; was 10x30
			   #:multiline "YES")))
      (set! test-patterns-textbox tb)
      (dboard:tabdat-test-patterns-textbox-set! tabdat tb)
      tb))
;; (iup:frame
;;  #:title "Target"
;;  ;; Target selectors
;;  (apply iup:hbox
;; 	   (let* ((dat      (dashboard:update-target-selector tabdat action-proc: update-keyvals))
;; 		  (key-lb   (car dat))
;; 		  (combos   (cadr dat)))
;; 	     combos)))
   ;; (iup:hbox
   ;;  ;; Text box for STATES
   ;;  (iup:frame
   ;;   #:title "States"
   ;;   (dashboard:text-list-toggle-box 
   ;;    ;; Move these definitions to common and find the other useages and replace!
   ;;    (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED")
   ;;    (lambda (all)
   ;;      (dboard:tabdat-states-set! tabdat all)
   ;;      (dashboard:update-run-command tabdat))))
   ;;  ;; Text box for STATES
   ;;  (iup:frame
   ;;   #:title "Statuses"
   ;;   (dashboard:text-list-toggle-box 
   ;;    (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
   ;;    (lambda (all)
   ;;      (dboard:tabdat-statuses-set! tabdat all)
   ;;      (dashboard:update-run-command tabdat)))))
   ))

(define (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)
  (iup:frame
   #:title "Tests and Tasks"
   (let* ((updater #f)
	  (last-xadj 0)







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







1008
1009
1010
1011
1012
1013
1014


























1015
1016
1017
1018
1019
1020
1021
				    (dboard:tabdat-test-patts-use tabdat))
			   #:expand "YES"
			   #:size "x30" ;; was 10x30
			   #:multiline "YES")))
      (set! test-patterns-textbox tb)
      (dboard:tabdat-test-patterns-textbox-set! tabdat tb)
      tb))


























   ))

(define (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)
  (iup:frame
   #:title "Tests and Tasks"
   (let* ((updater #f)
	  (last-xadj 0)

Modified ezsteps.scm from [5de5d166c7] to [46c6ac1060].

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
     z3 csv typed-records pathname-expand matchable)

(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
;; (declare (uses filedb))

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


;;(rmt:get-test-info-by-id run-id test-id) -> testdat

;; TODO: deprecate me in favor of ezsteps.scm
;;
(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
  (let* ((stepname       (car ezstep))  ;; do stuff to run the step
	 (stepinfo       (cadr ezstep))
	;; (let ((info (cadr ezstep)))
	;; 		   (if (proc? info) "" info)))
	;; (stepproc       (let ((info (cadr ezstep)))
	;; 		   (if (proc? info) info #f)))
	 (stepparts      (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo))
	 (stepparams     (if (and (list? stepparts)
				  (> (length stepparts) 1))
			     (list-ref stepparts 2)
			     #f)) ;; for future use, {VAR=1,2,3}, run step for each
	 (paramparts     (if (string? stepparams)
			     (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams))







<
<






<
|
|





<
<
<
<







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
     z3 csv typed-records pathname-expand matchable)

(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))



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


;; (rmt:get-test-info-by-id run-id test-id) -> testdat
;;
;; TODO: deprecate me in favor of ezsteps.scm
;;
(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
  (let* ((stepname       (car ezstep))  ;; do stuff to run the step
	 (stepinfo       (cadr ezstep))




	 (stepparts      (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo))
	 (stepparams     (if (and (list? stepparts)
				  (> (length stepparts) 1))
			     (list-ref stepparts 2)
			     #f)) ;; for future use, {VAR=1,2,3}, run step for each
	 (paramparts     (if (string? stepparams)
			     (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams))

Deleted fdb_records.scm version [f1c8030bb0].

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
;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;; Single record for managing a filedb
;; make-vector-record "Filedb record" filedb fdb db dbpath pathcache idcache partcache
;; Filedb record
(define (make-filedb:fdb)(make-vector 5))
(define-inline (filedb:fdb-get-db          vec)    (vector-ref  vec 0))
(define-inline (filedb:fdb-get-dbpath      vec)    (vector-ref  vec 1))
(define-inline (filedb:fdb-get-pathcache   vec)    (vector-ref  vec 2))
(define-inline (filedb:fdb-get-idcache     vec)    (vector-ref  vec 3))
(define-inline (filedb:fdb-get-partcache   vec)    (vector-ref  vec 4))
(define-inline (filedb:fdb-set-db!         vec val)(vector-set! vec 0 val))
(define-inline (filedb:fdb-set-dbpath!     vec val)(vector-set! vec 1 val))
(define-inline (filedb:fdb-set-pathcache!  vec val)(vector-set! vec 2 val))
(define-inline (filedb:fdb-set-idcache!    vec val)(vector-set! vec 3 val))
(define-inline (filedb:fdb-set-partcache!  vec val)(vector-set! vec 4 val))

;; children records, should have use something other than "child"
(define-inline (filedb:child-get-id vec)       (vector-ref vec 0))
(define-inline (filedb:child-get-path vec)     (vector-ref vec 1))
(define-inline (filedb:child-get-parent_id vec)(vector-ref vec 2))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































Deleted filedb.scm version [f18fb77b48].

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
;; Copyright 2006-2011, Matthew Welland.
;;
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex)
(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
(import (prefix sqlite3 sqlite3:))

(declare (unit filedb))

(include "fdb_records.scm")
;; (include "settings.scm")

(define (filedb:open-db dbpath)
  (let* ((fdb      (make-filedb:fdb))
	 (dbexists (common:file-exists? dbpath))
	 (db (sqlite3:open-database dbpath)))
    (filedb:fdb-set-db!        fdb db)
    (filedb:fdb-set-dbpath!    fdb dbpath)
    (filedb:fdb-set-pathcache! fdb (make-hash-table))
    (filedb:fdb-set-idcache!   fdb (make-hash-table))
    (filedb:fdb-set-partcache! fdb (make-hash-table))
    (sqlite3:set-busy-handler!  db (make-busy-timeout 136000))
    (if (not dbexists)
	(begin
	  (sqlite3:execute db "PRAGMA synchronous = OFF;")
	  (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
	  (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
	  ;; NB// We store a useful subset of file attributes but do not attempt to store all
	  (sqlite3:execute db "CREATE TABLE paths (id        INTEGER PRIMARY KEY,
                                                   path      TEXT,
                                                   parent_id INTEGER,
                                                   mode      INTEGER DEFAULT -1,
                                                   uid       INTEGER DEFAULT -1,
                                                   gid       INTEGER DEFAULT -1,
                                                   size      INTEGER DEFAULT -1,
                                                   mtime     INTEGER DEFAULT -1);")
	  (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
	  (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT,                  updated TIMESTAMP);")))
    ;; close the sqlite3 db and open it as needed
    (filedb:finalize-db! fdb)
    (filedb:fdb-set-db! fdb #f)
    fdb))

(define (filedb:reopen-db fdb)
  (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb))))
    (filedb:fdb-set-db! fdb db)
    (sqlite3:set-busy-handler!  db (make-busy-timeout 136000))))
  
(define (filedb:finalize-db! fdb)
  (sqlite3:finalize! (filedb:fdb-get-db fdb)))

(define (filedb:get-current-time-string)
  (string-chomp (time->string (seconds->local-time (current-seconds)))))

(define (filedb:get-base-id db path)
  (let ((stmt   (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;"))
        (id-num #f))
    (sqlite3:for-each-row 
     (lambda (num) (set! id-num num)) stmt path)
    (sqlite3:finalize! stmt)
    id-num))

(define (filedb:get-path-id db path parent)
  (let ((stmt   (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;"))
        (id-num #f))
    (sqlite3:for-each-row 
     (lambda (num) (set! id-num num)) stmt path parent)
    (sqlite3:finalize! stmt)
    id-num))

(define (filedb:add-base db path)
  (let ((existing (filedb:get-base-id db path)))
    (if existing #f
        (begin
          (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string))))))

;; index 	value 	field 	notes
;; 0 	inode number 	st_ino 	
;; 1 	mode 	st_mode 	bitfield combining file permissions and file type
;; 2 	number of hard links 	st_nlink 	
;; 3 	UID of owner 	st_uid 	as with file-owner
;; 4 	GID of owner 	st_gid 	
;; 5 	size 	st_size 	as with file-size
;; 6 	access time 	st_atime 	as with file-access-time
;; 7 	change time 	st_ctime 	as with file-change-time
;; 8 	modification time 	st_mtime 	as with file-modification-time
;; 9 	parent device ID 	st_dev 	ID of device on which this file resides
;; 10 	device ID 	st_rdev 	device ID for special files (i.e. the raw major/minor number)
;; 11 	block size 	st_blksize 	
;; 12 	number of blocks allocated 	st_blocks 	

(define (filedb:add-path-stat db path parent statinfo)
  (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);")))
	(sqlite3:execute stmt
			 path
			 parent
			 (vector-ref statinfo 1) ;; mode
			 (vector-ref statinfo 3) ;; uid
			 (vector-ref statinfo 4) ;; gid
			 (vector-ref statinfo 5) ;; size
			 (vector-ref statinfo 8) ;; mtime
			 )
	(sqlite3:finalize! stmt))) ;;  (filedb:get-current-time-string))))
  
(define (filedb:add-path db path parent)
  (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);")))
    (sqlite3:execute stmt path parent)
    (sqlite3:finalize! stmt)))

(define (filedb:register-path fdb path #!key (save-stat #f))
  (let* ((db        (filedb:fdb-get-db        fdb))
	 (pathcache (filedb:fdb-get-pathcache fdb))
	 (stat      (if save-stat (file-stat path #t)))
	 (id        (hash-table-ref/default pathcache path #f)))
    (if (not db)(filedb:reopen-db fdb))
    (if id id 
        (let ((plist (string-split path "/")))
          (let loop ((head (car plist))
                     (tail (cdr plist))
                     (parent 0))
            (let ((id (filedb:get-path-id db head parent))
                  (done (null? tail)))
              (if id          ;; we'll have a id if the path is already registered
                  (if done 
                      (begin
                        (hash-table-set! pathcache path id)
                        id) ;; return the last path id for a result
                      (loop (car tail)(cdr tail) id))
                  (begin      ;; add the path and then repeat the loop with the same data
		    (if save-stat
			(filedb:add-path-stat db head parent stat) 
			(filedb:add-path db head parent))
                    (loop head tail parent)))))))))

(define (filedb:update-recursively fdb path #!key (save-stat #f))
  (let ((p  (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path))))
    (print "processed 0 files...")
    (let loop ((l  (read-line p))
               (lc 0)) ;; line count
      (if (eof-object? l) 
	  (begin
	    (print "          " lc " files")
	    (close-input-port p))
          (begin
            (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info
            (if (= (modulo lc 100) 0)
                (print "          " lc " files"))
            (loop (read-line p)(+ lc 1)))))))

(define (filedb:update fdb path #!key (save-stat #f))
  ;; first get the realpath and add it to the bases table
  (let ((real-path path) ;; (filedb:get-real-path path))
	(db        (filedb:fdb-get-db    fdb)))
    (filedb:add-base db real-path)
    (filedb:update-recursively fdb path save-stat: save-stat)))

;; not used and broken
;;
(define (filedb:get-real-path path)
  (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path))))
         (pth (read-line p)))
    (if (eof-object? pth) path
	(begin
	  (close-input-port p)
	  pth))))

(define (filedb:drop-base fdb path)
  (print "Sorry, I don't do anything yet"))

(define (filedb:find-all fdb pattern action)
  (let* ((db     (filedb:fdb-get-db fdb))
	 (stmt   (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;"))
	 (result '()))
    (sqlite3:for-each-row 
     (lambda (num)
       (action num)
       (set! result (cons num result))) stmt pattern)
    (sqlite3:finalize! stmt)
    result))

(define (filedb:get-path-record fdb id)
  (let* ((db        (filedb:fdb-get-db        fdb))
	 (partcache (filedb:fdb-get-partcache fdb))
	 (dat (hash-table-ref/default partcache id #f)))
    (if dat dat
	(let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;"))
	      (result #f))
	  (sqlite3:for-each-row 
	   (lambda (path parent_id)(set! result (list path parent_id))) stmt id)
	  (hash-table-set! partcache id result)
	  (sqlite3:finalize! stmt)
	  result))))

(define (filedb:get-children fdb parent-id)
  (let* ((db        (filedb:fdb-get-db fdb))
	 (res       '()))
    (sqlite3:for-each-row
     (lambda (id path parent-id)
       (set! res (cons (vector id path parent-id) res)))
     db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;"
     parent-id)
    res))

;; retrieve all that have children and those without
;; children that match patt
(define (filedb:get-children-patt fdb parent-id search-patt)
  (let* ((db        (filedb:fdb-get-db fdb))
	 (res       '()))
    ;; first get the children that have no children
    (sqlite3:for-each-row
     (lambda (id path parent-id)
       (set! res (cons (vector id path parent-id) res)))
     db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND 
            (id IN (SELECT parent_id FROM paths) OR path LIKE ?);"
     parent-id search-patt)
    res))

(define (filedb:get-path fdb id)
  (let* ((db      (filedb:fdb-get-db      fdb))
	 (idcache (filedb:fdb-get-idcache fdb))
	 (path    (hash-table-ref/default idcache id #f)))
    (if (not db)(filedb:reopen-db fdb))
    (if path path
        (let loop ((curr-id id)
                   (path    ""))
          (let ((path-record (filedb:get-path-record fdb curr-id)))
            (if (not path-record) #f ;; this id has no path
                (let* ((parent-id (list-ref path-record 1))
                       (pname     (list-ref path-record 0))
                       (newpath   (string-append  "/" pname path)))
                  (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0
                      (begin
                        (hash-table-set! idcache id newpath)
                        newpath)
                      (loop parent-id newpath)))))))))

(define (filedb:search db pattern)
  (let ((action (lambda (id)(print (filedb:get-path db id)))))
    (filedb:find-all db pattern action)))

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






























































































































































































































































































































































































































































































































Deleted fs-transport.scm version [d1050dcefe].

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

;; Copyright 2006-2012, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

(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 spiffy uri-common intarweb http-client spiffy-request-vars)

(tcp-buffer-size 2048)

(declare (unit fs-transport))

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

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


;;======================================================================
;; F S   T R A N S P O R T   S E R V E R
;;======================================================================

;; There is no "server" per se but a convience routine to make it non
;; necessary to be reopening the db over and over again.
;;

(define (fs:process-queue-item packet)
  (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called
      (set! *dbstruct-db* (db:setup-db)))
  (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet)
  (db:process-queue-item *dbstruct-db* packet))
      
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































Deleted ftail.scm version [96a7ff77a3].

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
;;======================================================================
;; Copyright 2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(declare (unit ftail))

(module ftail
    (
     open-tail-db
     tail-write
     tail-get-fid
     file-tail
     )

(import scheme chicken data-structures extras)
(use (prefix sqlite3 sqlite3:) posix typed-records)

(define (open-tail-db )
  (let* ((basedir   (create-directory (conc "/tmp/" (current-user-name))))
	 (dbpath    (conc basedir "/megatest_logs.db"))
	 (dbexists  (file-exists? dbpath))
	 (db        (sqlite3:open-database dbpath))
	 (handler   (sqlite3:make-busy-timeout 136000)))
    (sqlite3:set-busy-handler! db handler)
    (sqlite3:execute db "PRAGMA synchronous = 0;")
    (if (not dbexists)
	(begin
	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data  (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
	  ))
    db))

(define (tail-write db fid lines)
  (sqlite3:with-transaction
   db
   (lambda ()
     (for-each
      (lambda (line)
	(sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
      lines))))

(define (tail-get-fid db fname)
  (let ((fid   (handle-exceptions
		   exn
		   #f
		 (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
    (if fid
	fid
	(begin
	  (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
	  (tail-get-fid db fname)))))

(define (file-tail fname #!key (db-in #f))
  (let* ((inp (open-input-file fname))
	 (db  (or db-in (open-tail-db)))
	 (fid (tail-get-fid db fname)))
    (let loop ((inl    (read-line inp))
	       (lines '())
	       (lastwr (current-seconds)))
      (if (eof-object? inl)
	  (let ((timed-out (> (- (current-seconds) lastwr) 60)))
	    (if timed-out (tail-write db fid (reverse lines)))
	    (sleep 1)
	    (if timed-out
		(loop (read-line inp) '() (current-seconds))
		(loop (read-line inp) lines lastwr)))
	  (let* ((savelines (> (length lines) 19)))
	    ;; (print inl)
	    (if savelines (tail-write db fid (reverse lines)))
	    (loop (read-line inp)
		  (if savelines
		      '()
		      (cons inl lines))
		  (if savelines
		      (current-seconds)
		      lastwr)))))))

;; offset -20 means get last 20 lines
;;
(define (tail-get-lines db fid offset count)
  (if (> offset 0)
      (sqlite3:map-row (lambda (id line)
		 (vector id line))
	       db
	       "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
      (reverse ;; get N from the end
       (sqlite3:map-row (lambda (id line)
		  (vector id line))
		db
		"SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))

)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































Modified index-tree.scm from [10c620fbfc] to [d670650718].

32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
(declare (uses items))
(declare (uses runconfig))

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

;; Populate the links tree with index.html files
;;
;;   - start from most recent tests and work towards oldest -OR-
;;     start from deepest hierarchy and work way up
;;   - look up tests in megatest.db
;;   - cross-reference the tests to stats.db







<







32
33
34
35
36
37
38

39
40
41
42
43
44
45
(declare (uses items))
(declare (uses runconfig))

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


;; Populate the links tree with index.html files
;;
;;   - start from most recent tests and work towards oldest -OR-
;;     start from deepest hierarchy and work way up
;;   - look up tests in megatest.db
;;   - cross-reference the tests to stats.db

Deleted lock-queue.scm version [21543b63ce].

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
;; Copyright 2006-2013, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

(use (prefix sqlite3 sqlite3:) srfi-18)

(declare (unit lock-queue))
(declare (uses common))
(declare (uses tasks))

;;======================================================================
;; attempt to prevent overlapping updates of rollup files by queueing
;; update requests in an sqlite db
;;======================================================================

;;======================================================================
;; db record, <vector db path-to-db>
;;======================================================================

(define (make-lock-queue:db-dat)(make-vector 3))
(define-inline (lock-queue:db-dat-get-db        vec)    (vector-ref  vec 0))
(define-inline (lock-queue:db-dat-get-path      vec)    (vector-ref  vec 1))
(define-inline (lock-queue:db-dat-set-db!       vec val)(vector-set! vec 0 val))
(define-inline (lock-queue:db-dat-set-path!     vec val)(vector-set! vec 1 val))

(define (lock-queue:delete-lock-db dbdat)
  (let ((fname (lock-queue:db-dat-get-path dbdat)))
    (system (conc "rm -f " fname "*"))))

(define (lock-queue:open-db fname #!key (count 10))
  (let* ((actualfname (conc fname ".lockdb"))
	 (dbexists (common:file-exists? actualfname))
	 (db       (sqlite3:open-database actualfname))
	 (handler  (make-busy-timeout 136000)))
    (if dbexists
	(vector db actualfname)
	(begin
	  (handle-exceptions
	   exn
	   (begin
	     (thread-sleep! 10)
	     (if (> count 0)
		 (lock-queue:open-db fname count: (- count 1))
		 (vector db actualfname)))
	   (sqlite3:with-transaction
	    db
	    (lambda ()
	      (sqlite3:execute 
	       db
	       "CREATE TABLE IF NOT EXISTS queue (
     	         id         INTEGER PRIMARY KEY,
                 test_id    INTEGER,
                 start_time INTEGER,
                 state      TEXT,
                 CONSTRAINT queue_constraint UNIQUE (test_id));")
	      (sqlite3:execute
	       db
	       "CREATE TABLE IF NOT EXISTS runlocks (
                 id         INTEGER PRIMARY KEY,
                 test_id    INTEGER,
                 run_lock   TEXT,
                 CONSTRAINT runlock_constraint UNIQUE (run_lock));"))))))
    (sqlite3:set-busy-handler! db handler)
    (vector db actualfname)))

(define (lock-queue:set-state dbdat test-id newstate #!key (remtries 10))
  (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
  (handle-exceptions
   exn
   (if (> remtries 0)
       (begin
	 (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.")
	 (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	 (thread-sleep! 30)
	 (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1)))
       (begin
	 (debug:print-error 0 *default-log-port* " Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
	 #f))
   (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;"
		    newstate
		    test-id)))

(define (lock-queue:any-younger? dbdat mystart test-id #!key (remtries 10))
  ;; no need to wait on journal on read only queries
  ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
  (handle-exceptions
   exn
   (if (> remtries 0)
       (begin
	 (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.")
	 (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	 (thread-sleep! 5)
         (lock-queue:delete-lock-db dbdat)
	 (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1)))
       (begin
	 (debug:print-error 0 *default-log-port* " Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
	 #f))
   (let ((res #f))
     (sqlite3:for-each-row
      (lambda (tid)
	;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as 
	(if (not (equal? tid test-id)) 
	    (set! res tid)))
      (lock-queue:db-dat-get-db dbdat)
      "SELECT test_id FROM queue WHERE start_time > ?;" mystart)
     res)))

(define (lock-queue:get-lock dbdat test-id #!key (count 10)(waiting-msg #f))
  (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 remove: #t waiting-msg: "lock-queue:get-lock, waiting on journal")
  (let* ((res       #f)
	 (db        (lock-queue:db-dat-get-db dbdat))
	 (lckqry    (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';"))
	 (mklckqry  (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');")))
    (let ((result 
	   (handle-exceptions
	    exn
	    (begin
	      (debug:print 0 *default-log-port* "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds")
	      (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	      (thread-sleep! 10)
	      ;; (if (> count 0)	
	      ;;  #f ;; (lock-queue:get-lock dbdat test-id count: (- count 1)) - give up on retries 
	      ;; (begin ;; never recovered, remote the lock file and return #f, no lock obtained
	      (lock-queue:delete-lock-db dbdat)
	      #f)
	    (sqlite3:with-transaction
	     db
	     (lambda ()
	       (sqlite3:for-each-row (lambda (tid lockstate)
				       (set! res (list tid lockstate)))
				     lckqry)
	       (if res
		   (if (equal? (car res) test-id)
		       #t ;; already have the lock
		       #f)
		   (begin
		     (sqlite3:execute mklckqry test-id)
		     ;; if no error handled then return #t for got the lock
		     #t)))))))
      (sqlite3:finalize! lckqry)
      (sqlite3:finalize! mklckqry)
      result)))

(define (lock-queue:release-lock fname test-id #!key (count 10))
  (let* ((dbdat (lock-queue:open-db fname)))
    (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:release-lock; waiting on journal")
    (handle-exceptions
     exn
     (begin
       (debug:print 0 *default-log-port* "WARNING: Failed to release queue lock. Will try again in few seconds")
       (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
       (thread-sleep! (/ count 10))
       (if (> count 0)
	   (begin
	     (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))
	     (lock-queue:release-lock fname test-id count: (- count 1)))
	   (let ((journal (conc fname "-journal")))
	     ;; If we've tried ten times and failed there is a serious problem
	     ;; try to remove the lock db and allow it to be recreated
	     (handle-exceptions
	      exn
	      #f
	      (if (common:file-exists? journal)(delete-file journal))
	      (if (common:file-exists? fname)  (delete-file fname))
	      #f))))
     (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id)
     (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)))))

(define (lock-queue:steal-lock dbdat test-id #!key (count 10))
  (debug:print-info 0 *default-log-port* "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat))
  (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal")
  (handle-exceptions
   exn
   (begin
     (debug:print 0 *default-log-port* "WARNING: Failed to steal queue lock. Will try again in few seconds")
     (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
     (thread-sleep! 10)
     (if (> count 0)
	 (lock-queue:steal-lock dbdat test-id count: (- count 1))
	 #f))
   (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';"))
  (lock-queue:get-lock dbdat test-it))

;; returns #f if ok to skip the task
;; returns #t if ok to proceed with task
;; otherwise waits
;;
(define (lock-queue:wait-turn fname test-id #!key (count 10)(waiting-msg #f))
  (let* ((dbdat   (lock-queue:open-db fname))
	 (mystart (current-seconds))
	 (db      (lock-queue:db-dat-get-db dbdat)))
    ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
    (handle-exceptions
     exn
     (begin
       (debug:print 0 *default-log-port* "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds")
       (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
       (print-call-chain (current-error-port))
       (thread-sleep! 10)
       (if (> count 0)
	   (begin
	     (sqlite3:finalize! db)
	     (lock-queue:wait-turn fname test-id count: (- count 1)))
	   (begin
	     (debug:print 0 *default-log-port* "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain")
	     (print-call-chain (current-error-port))
	     #f)))
     ;; wait 10 seconds and then check to see if someone is already updating the html
     (thread-sleep! 10)
     (if (not (lock-queue:any-younger? dbdat mystart test-id)) ;; no processing in flight, must try to start processing
	 (begin
	   (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
	   (sqlite3:execute
	    db
	    "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');"
	    test-id mystart)
	   ;; (thread-sleep! 1) ;; give other tests a chance to register
	   (let ((result 
		  (let loop ((younger-waiting (lock-queue:any-younger? dbdat mystart test-id)))
		    (if younger-waiting
			(begin
			  ;; no need for us to wait. mark in the lock queue db as skipping
			  ;; no point in marking anything in the queue - simply never register this
			  ;; test as it is *covered* by a previously started update to the html file
			  ;; (lock-queue:set-state dbdat test-id "skipping")
			  #f) ;; let the calling process know that nothing needs to be done
			(if (lock-queue:get-lock dbdat test-id)
			    #t
			    (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock
				(lock-queue:steal-lock dbdat test-id)
				(begin
				  (thread-sleep! 1)
				  (loop (lock-queue:any-younger? dbdat mystart test-id)))))))))
	     (sqlite3:finalize! db)
	     result))))))
	  
            
;; (use trace)
;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































Modified megatest.scm from [0e58f17e0f] to [1259d711a8].

1
2
3
4
5
6
7
8
;; Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
|







1
2
3
4
5
6
7
8
>;; Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
;; (import ftail)

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

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
     readline apropos json http-client directory-utils typed-records
     http-client srfi-18 extras format)

;; Added for csv stuff - will be removed







<







45
46
47
48
49
50
51

52
53
54
55
56
57
58
;; (import ftail)

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

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

(include "megatest-fossil-hash.scm")

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
     readline apropos json http-client directory-utils typed-records
     http-client srfi-18 extras format)

;; Added for csv stuff - will be removed
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
;;======================================================================
;; Remove old run(s)
;;======================================================================

;; since several actions can be specified on the command line the removal
;; is done first
(define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default"
  (let* ((runrec (runs:runrec-make-record))
	 (target (or target-in   (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target
	 (runname (or runname-in
		      (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls
	 (testpatt (or (args:get-arg "-testpatt")
		       (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH
			    (common:get-full-test-name))
		       (and (eq? action 'kill-runs)
			    "%/%") ;; I'm just guessing that this is correct :(







<
|







1079
1080
1081
1082
1083
1084
1085

1086
1087
1088
1089
1090
1091
1092
1093
;;======================================================================
;; Remove old run(s)
;;======================================================================

;; since several actions can be specified on the command line the removal
;; is done first
(define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default"

  (let* ((target (or target-in   (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target
	 (runname (or runname-in
		      (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls
	 (testpatt (or (args:get-arg "-testpatt")
		       (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH
			    (common:get-full-test-name))
		       (and (eq? action 'kill-runs)
			    "%/%") ;; I'm just guessing that this is correct :(
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
(define (get-value-by-fieldname datavec test-field-index fieldname)
  (let ((indx (hash-table-ref/default test-field-index fieldname #f)))
    (if indx
	(if (>= indx (vector-length datavec))
	    #f ;; index too high, should raise an error I suppose
	    (vector-ref datavec indx))
	#f)))





(when (args:get-arg "-testdata-csv")
  (if (launch:setup)
      (let* ((keys        (rmt:get-keys)) ;; (db:get-keys dbstruct))
             (runpatt     (or (args:get-arg "-runname") "%"))
             (testpatt    (common:args-get-testpatt #f))
             (datapatt    (args:get-arg "-testdata-csv"))







<
<
<
<







1236
1237
1238
1239
1240
1241
1242




1243
1244
1245
1246
1247
1248
1249
(define (get-value-by-fieldname datavec test-field-index fieldname)
  (let ((indx (hash-table-ref/default test-field-index fieldname #f)))
    (if indx
	(if (>= indx (vector-length datavec))
	    #f ;; index too high, should raise an error I suppose
	    (vector-ref datavec indx))
	#f)))





(when (args:get-arg "-testdata-csv")
  (if (launch:setup)
      (let* ((keys        (rmt:get-keys)) ;; (db:get-keys dbstruct))
             (runpatt     (or (args:get-arg "-runname") "%"))
             (testpatt    (common:args-get-testpatt #f))
             (datapatt    (args:get-arg "-testdata-csv"))

Deleted mlaunch.scm version [5bcd34288f].

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
;; Copyright 2006-2014, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

;;======================================================================
;; MLAUNCH
;;
;;   take jobs from the given queue and keep launching them keeping
;;   the cpu load at the targeted level
;;
;;======================================================================

(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)

(declare (unit mlaunch))
(declare (uses db))
(declare (uses common))

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


































































Deleted monitor.scm version [3df55c85ea].

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
;; Copyright 2006-2012, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
(import (prefix sqlite3 sqlite3:))

(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))

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

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


































































Modified mt.scm from [e9055c2687] to [b5988fd08c].

31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
(declare (uses rmt))
;; (declare (uses filedb))

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

;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
;; here.

;;======================================================================
;;  R U N S
;;======================================================================







<







31
32
33
34
35
36
37

38
39
40
41
42
43
44
(declare (uses rmt))
;; (declare (uses filedb))

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


;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
;; here.

;;======================================================================
;;  R U N S
;;======================================================================
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
		   (if last-time
		       (< (current-seconds)(+ last-time 5))
		       #f))))
    (if useres
	(let ((result (vector-ref res 1)))
	  (debug:print 4 *default-log-port* "Using lazy value res: " result)
	  result)
	(let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmaps: itemmaps)))
	  (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres))
	  newres))))

(define (mt:get-run-stats dbstruct run-id)
;;  Get run stats from local access, move this ... but where?
  (db:get-run-stats dbstruct run-id))








|







99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
		   (if last-time
		       (< (current-seconds)(+ last-time 5))
		       #f))))
    (if useres
	(let ((result (vector-ref res 1)))
	  (debug:print 4 *default-log-port* "Using lazy value res: " result)
	  result)
	(let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode itemmaps)))
	  (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres))
	  newres))))

(define (mt:get-run-stats dbstruct run-id)
;;  Get run stats from local access, move this ... but where?
  (db:get-run-stats dbstruct run-id))

Modified mtut.scm from [2855879998] to [3d579ca767].

53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
       in-stml))))

;; helpers for mappers/checkers
(define (add-target-mapper name proc)
  (hash-table-set! *target-mappers* name proc))
(define (add-runname-mapper name proc)
  (hash-table-set! *runname-mappers* name proc))
(define (add-area-checker name proc)
  (hash-table-set! *area-checkers* name proc))

;; given a runkey, xlatr-key and other info return one of the following:
;;   list of targets, null list to skip processing
;;   
(define (map-targets mtconf aval-alist runkey area contour #!key (xlatr-key-in #f))
  (pp aval-alist)







|







53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
       in-stml))))

;; helpers for mappers/checkers
(define (add-target-mapper name proc)
  (hash-table-set! *target-mappers* name proc))
(define (add-runname-mapper name proc)
  (hash-table-set! *runname-mappers* name proc))
(define (add-area-checker name proc) ;; util, USED EXTERNALLY, do not remove.
  (hash-table-set! *area-checkers* name proc))

;; given a runkey, xlatr-key and other info return one of the following:
;;   list of targets, null list to skip processing
;;   
(define (map-targets mtconf aval-alist runkey area contour #!key (xlatr-key-in #f))
  (pp aval-alist)
1688
1689
1690
1691
1692
1693
1694
1695

1696
1697
1698
1699
1700
1701
1702
                  (prev-seen (make-hash-table))) ;; catch duplicates
             (if user-info
              (begin
               (for-each
              (lambda (listener)
                (let ((host-port (car listener))
                      (attrib (val->alist (cadr listener))))
                  (if (and (equal? msg "time-to-die") (not (can-user-kill-listner user-info attrib)))

                   (begin
                      (debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'")
                      (exit 1)))
                  (print "sending " msg " to " host-port )
                  (open-send-close-nn host-port msg attrib timeout: time-out )))
              listeners))
              (begin







|
>







1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
                  (prev-seen (make-hash-table))) ;; catch duplicates
             (if user-info
              (begin
               (for-each
              (lambda (listener)
                (let ((host-port (car listener))
                      (attrib (val->alist (cadr listener))))
                  (if (and (equal? msg "time-to-die")
			   (not (can-user-kill-listner user-info attrib)))
                   (begin
                      (debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'")
                      (exit 1)))
                  (print "sending " msg " to " host-port )
                  (open-send-close-nn host-port msg attrib timeout: time-out )))
              listeners))
              (begin
1716
1717
1718
1719
1720
1721
1722
1723

1724
1725
1726
1727
1728
1729
1730
                  (prev-seen (make-hash-table))) ;; catch duplicates
             (if user-info
              (begin
               (for-each
              (lambda (listener)
                (let ((host-port (car listener))
                      (attrib (val->alist (cadr listener))))
                  (if (and (equal? msg "time-to-die") (not (can-user-kill-listner user-info attrib)))

                   (begin
                      (debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'")
                      (exit 1)))
                  (print "sending " msg " to " host-port )
                  (open-send-receive-nn host-port msg attrib timeout: time-out )))
              listeners))
              (begin







|
>







1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
                  (prev-seen (make-hash-table))) ;; catch duplicates
             (if user-info
              (begin
               (for-each
              (lambda (listener)
                (let ((host-port (car listener))
                      (attrib (val->alist (cadr listener))))
                  (if (and (equal? msg "time-to-die")
			   (not (can-user-kill-listner user-info attrib)))
                   (begin
                      (debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'")
                      (exit 1)))
                  (print "sending " msg " to " host-port )
                  (open-send-receive-nn host-port msg attrib timeout: time-out )))
              listeners))
              (begin

Deleted newdashboard.scm version [3cc17ecae4].

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
;;======================================================================
;; Copyright 2006-2016, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(use format)

(use (prefix iup iup:))

(use canvas-draw)
(import canvas-draw-iup)

(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
     (prefix dbi dbi:))

(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))

;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
(declare (uses dcommon))
;; (declare (uses tree))
;; 
;; (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
  -server host:port : connect to host:port instead of db access
  -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  "-rows"
			"-run"
			"-test"
			"-debug"
			"-host" 
			) 
		 (list  "-h"
			"-guimonitor"
			"-main"
			"-v"
			"-q"
		       )
		 args:arg-hash
		 0))

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

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

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


;; data for each specific tab goes here
;;
(defstruct dboard:tabdat 
  ;; runs
  ((allruns         '())                 : list)        ;; list of dboard:rundat records
  ((allruns-by-id    (make-hash-table))  : hash-table)  ;; hash of run-id -> dboard:rundat records
  ((done-runs       '())                 : list)        ;; list of runs already drawn
  ((not-done-runs   '())                 : list)        ;; list of runs not yet drawn
  (header            #f)                                ;; header for decoding the run records
  (keys              #f)                                ;; keys for this run (i.e. target components)
  ((numruns          (string->number (or (args:get-arg "-cols") "10")))                 : number)      ;; 
  ((tot-runs          0)                 : number)
  ((last-data-update  0)                 : number)      ;; last time the data in allruns was updated
  ((last-runs-update  0)                 : number)      ;; last time we pulled the runs info to update the tree
  (runs-mutex         (make-mutex))                     ;; use to prevent parallel access to draw objects
  ((run-update-times  (make-hash-table)) : hash-table)  ;; update times indexed by run-id
  ((last-test-dat      (make-hash-table)) : hash-table)  ;; cache last tests dat by run-id
  ((run-db-paths      (make-hash-table)) : hash-table)  ;; cache the paths to the run db files

  ;; Runs view
  ((buttondat         (make-hash-table)) : hash-table)  ;;     
  ((item-test-names  '())                : list)        ;; list of itemized tests
  ((run-keys          (make-hash-table)) : hash-table)
  (runs-matrix        #f)                               ;; used in newdashboard
  ((start-run-offset   0)                : number)      ;; left-right slider value
  ((start-test-offset  0)                : number)      ;; up-down slider value
  ((runs-btn-height    (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string)  ;; was 12
  ((runs-btn-fontsz    (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string)   ;; was 8
  ((runs-cell-width    (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string)   ;; was 50
  ((all-test-names     '())              : list)
  
  ;; Canvas and drawing data
  (cnv                #f)
  (cnv-obj            #f)
  (drawing            #f)
  ((run-start-row     0)                 : number)
  ((max-row           0)                 : number)
  ((running-layout    #f)                : boolean)
  (originx            #f)
  (originy            #f)
  ((layout-update-ok  #t)                : boolean)
  ((compact-layout    #t)                : boolean)

  ;; Run times layout
  ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
  (graph-matrix     #f)
  ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
  ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
  ((graph-matrix-row 1) : number)
  ((graph-matrix-col 1) : number)

  ;; Controls used to launch runs etc.
  ((command          "")                 : string)      ;; for run control this is the command being built up
  (command-tb        #f)	                        ;; widget for the type of command; run, remove-runs etc.
  (test-patterns-textbox #f)                            ;; text box widget for editing a list of test patterns
  (key-listboxes     #f)			         
  (key-lbs           #f)			         
  run-name                                              ;; from run name setting widget
  states                                                ;; states for -state s1,s2 ...
  statuses                                              ;; statuses for -status s1,s2 ...
						         
  ;; Selector variables				         
  curr-run-id                                           ;; current row to display in Run summary view
  prev-run-id                                           ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
  curr-test-ids                                         ;; used only in dcommon:run-update which is used in newdashboard
  ((filters-changed  #t)                  : boolean)    ;; to indicate that the user changed filters for this tab
  ((last-filter-str  "")                  : string)      ;; conc the target runname and testpatt for a signature of changed filters
  ((hide-empty-runs  #f)                  : boolean)     
  ((hide-not-hide    #t)                  : boolean)     ;; toggle for hide/not hide empty runs
  (hide-not-hide-button #f)
  ((searchpatts        (make-hash-table)) : hash-table)  ;;
  ((state-ignore-hash  (make-hash-table)) : hash-table)  ;; hash of  STATE => #t/#f for display control
  ((status-ignore-hash (make-hash-table)) : hash-table)  ;; hash of STATUS => #t/#f
  (target              #f)
  (test-patts          #f)

  ;; db info to file the .db files for the area
  (access-mode        (db:get-access-mode))             ;; use cached db or not
  (dbdir               #f)
  (dbfpath             #f)
  (dbkeys              #f)
  ((last-db-update     (make-hash-table)) : hash-table) ;; last db file timestamp
  (monitor-db-path     #f)                              ;; where to find monitor.db
  ro                                                    ;; is the database read-only?

  ;; tests data
  ((num-tests          10)               : number)      ;; total number of tests to show (used in the old runs display)

  ;; runs tree
  ((path-run-ids       (make-hash-table)) : hash-table) ;; path (target / runname) => id
  (runs-tree           #f)
  ((runs-tree-ht       (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)

  ;; tab data
  ((view-changed       #t)                : boolean)   
  ((xadj               0)                 : number)     ;; x slider number (if using canvas)
  ((yadj               0)                 : number)     ;; y slider number (if using canvas)
  ;; runs-summary tab state
  ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) )   : list)
  ((runs-summary-mode-buttons '())               : list)
  ((runs-summary-mode  'one-run)            : symbol)
  ((runs-summary-mode-change-callbacks '()) : list)
  (runs-summary-source-runname-label #f)
  (runs-summary-dest-runname-label #f)
  ;; runs summary view
  
  tests-tree       ;; used in newdashboard
  )



;; mtest is actually the megatest.config file
;;
(define (mtest toppath window-id)
  (let* ((curr-row-num     0)
	 ;; (rawconfig        (read-config (conc toppath "/megatest.config") #f 'return-string))
	 (keys-matrix      (iup:matrix)) ;; (dcommon:keys-matrix rawconfig))
	 (setup-matrix     (iup:matrix)) ;; (dcommon:section-matrix rawconfig "setup" "Varname" "Value"))
	 (jobtools-matrix  (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 5
			    #:numcol-visible 1
			    #:numlin-visible 3))
	 (validvals-matrix (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 2
			    #:numcol-visible 1
			    #:numlin-visible 2))
	 (envovrd-matrix   (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 20
			    #:numcol-visible 1
			    #:numlin-visible 8))
	 (disks-matrix     (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 20
			    #:numcol-visible 1
			    #:numlin-visible 8))
	 )
    (iup:attribute-set! disks-matrix "0:0" "Disk Name")
    (iup:attribute-set! disks-matrix "0:1" "Disk Path")
    (iup:attribute-set! disks-matrix "WIDTH1" "120")
    (iup:attribute-set! disks-matrix "WIDTH0" "100")
    (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT")
    (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1")
    (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES")

    ;; fill in existing info
    (for-each 
     (lambda (mat fname)
       (set! curr-row-num 1)
       (for-each
	(lambda (var)
	  (iup:attribute-set! mat (conc curr-row-num ":0") var)
	  ;; (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var))
	  (set! curr-row-num (+ curr-row-num 1)))
	'()));; (configf:section-vars rawconfig fname)))
     (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix)
     (list "setup"      "jobtools"      "validvalues"      "env-override" "disks"))

    (for-each
     (lambda (mat)
       (iup:attribute-set! mat "0:1" "Value")
       (iup:attribute-set! mat "0:0" "Var")
       (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
       (iup:attribute-set! mat "FIXTOTEXT" "C1")
       (iup:attribute-set! mat "RESIZEMATRIX" "YES")
       (iup:attribute-set! mat "WIDTH1" "120")
       (iup:attribute-set! mat "WIDTH0" "100")
       )
     (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix))

    (iup:attribute-set! validvals-matrix "WIDTH1" "290")
    (iup:attribute-set! envovrd-matrix   "WIDTH1" "290")

    (iup:vbox
     (iup:hbox
       
      (iup:vbox
       (let ((tabs (iup:tabs 
		    ;; The required tab
		    (iup:hbox
		     ;; The keys
		     (iup:frame 
		      #:title "Keys (required)"
		      (iup:vbox
		       (iup:label (conc "Set the fields for organising your runs\n"
					"here. Note: can only be changed before\n"
					"running the first run when megatest.db\n"
					"is created."))
		       keys-matrix))
		     (iup:vbox
		      ;; The setup section
		      (iup:frame
		       #:title "Setup"
		       (iup:vbox
			(iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n"
					 "linktree : directory where linktree will be created."))
			setup-matrix))
		      ;; The jobtools
		      (iup:frame
		       #:title "Jobtools"
		       (iup:vbox 
			(iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n"
					 "useshell : use system to run your launcher\n"
					 "workhosts : spread jobs out on these hosts"))
			jobtools-matrix))
		      ;; The disks
		      (iup:frame
		       #:title "Disks"
		       (iup:vbox
			(iup:label (conc "Enter names and existing paths of locations to run tests")) 
			disks-matrix))))
		    ;; The optional tab
		    (iup:vbox
		     ;; The Environment Overrides
		     (iup:frame 
		      #:title "Env override"
		      envovrd-matrix)
		     ;; The valid values
		     (iup:frame
		      #:title "Validvalues"
		      validvals-matrix)
		     ))))
	 (iup:attribute-set! tabs "TABTITLE0" "Required settings")
	 (iup:attribute-set! tabs "TABTITLE1" "Optional settings")
	 tabs))
       ))))

;; The runconfigs.config file
;;
(define (rconfig window-id)
  (iup:vbox
   (iup:frame #:title "Default")))

;;======================================================================
;; T E S T S
;;======================================================================

(define (tree-path->test-id path)
  (if (not (null? path))
      (hash-table-ref/default (dboard:data-path-test-ids *data*) path #f)
      #f))

(define (test-panel window-id)
  (let* ((curr-row-num 0)
	 (viewlog    (lambda (x)
		       (if (common:file-exists? logfile)
					;(system (conc "firefox " logfile "&"))
			   (iup:send-url logfile)
			   (message-window (conc "File " logfile " not found")))))
	 (xterm      (lambda (x)
		       (if (directory-exists? rundir)
			   (let ((shell (if (get-environment-variable "SHELL") 
					    (conc "-e " (get-environment-variable "SHELL"))
					    "")))
			     (system (conc "cd " rundir 
					   ";xterm -T \"" (string-translate testfullname "()" "  ") "\" " shell "&")))
			   (message-window  (conc "Directory " rundir " not found")))))
	 (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12"))
	 (command-launch-button (iup:button "Execute!" 
					    ;; #:expand "HORIZONTAL"
					    #:size "50x"
					    #:action (lambda (x)
						       (let ((cmd (iup:attribute command-text-box "VALUE")))
							 (system (conc cmd "  &"))))))
	 (run-test  (lambda (x)
		      (iup:attribute-set! 
		       command-text-box "VALUE"
		       (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname 
			     " -runtests " (conc testname "/" (if (equal? item-path "")
								  "%" 
								  item-path))
			     ";echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
	 (remove-test (lambda (x)
			(iup:attribute-set!
			 command-text-box "VALUE"
			 (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname
			       " -testpatt " (conc testname "/" (if (equal? item-path "")
								    "%"
								    item-path))
			       " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
    	 (run-info-matrix  (iup:matrix 		            
			    #:expand "YES"
			    ;; #:scrollbar "YES"
			    #:numcol 1
			    #:numlin 4
			    #:numcol-visible 1
			    #:numlin-visible 4
			    #:click-cb (lambda (obj lin col status)
					 (print "obj: " obj " lin: " lin " col: " col " status: " status))))
	 (test-info-matrix (iup:matrix
		            #:expand "YES"
		            #:numcol 1
		            #:numlin 7
		            #:numcol-visible 1
		            #:numlin-visible 7))
	 (test-run-matrix  (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 5
			    #:numcol-visible 1
			    #:numlin-visible 5))
	 (meta-dat-matrix  (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 5
			    #:numcol-visible 1
			    #:numlin-visible 5))
	 (steps-matrix     (iup:matrix
			    #:expand "YES"
			    #:numcol 6
			    #:numlin 50
			    #:numcol-visible 6
			    #:numlin-visible 8))
	 (data-matrix      (iup:matrix
			    #:expand "YES"
			    #:numcol 8
			    #:numlin 50
			    #:numcol-visible 8
			    #:numlin-visible 8))
	 (updater          (lambda (testdat)
			     (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix))))

    ;; Set the updater in updaters
    ;; (hash-table-set! (dboard:data-updaters *data*) window-id updater)
    ;; 
    (for-each
     (lambda (mat)
       ;; (iup:attribute-set! mat "0:1" "Value")
       ;; (iup:attribute-set! mat "0:0" "Var")
       (iup:attribute-set! mat "HEIGHT0" 0)
       (iup:attribute-set! mat "ALIGNMENT1" "ALEFT")
       ;; (iup:attribute-set! mat "FIXTOTEXT" "C1")
       (iup:attribute-set! mat "RESIZEMATRIX" "YES"))
       ;; (iup:attribute-set! mat "WIDTH1" "120")
       ;; (iup:attribute-set! mat "WIDTH0" "100"))
     (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix))

    ;; Steps matrix
    (iup:attribute-set! steps-matrix "0:1" "Step Name")
    (iup:attribute-set! steps-matrix "0:2" "Start")
    (iup:attribute-set! steps-matrix "WIDTH2" "40")
    (iup:attribute-set! steps-matrix "0:3" "End")
    (iup:attribute-set! steps-matrix "WIDTH3" "40")
    (iup:attribute-set! steps-matrix "0:4" "Status")
    (iup:attribute-set! steps-matrix "WIDTH4" "40")
    (iup:attribute-set! steps-matrix "0:5" "Duration")
    (iup:attribute-set! steps-matrix "WIDTH5" "40")
    (iup:attribute-set! steps-matrix "0:6" "Log File")
    (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
    ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
    (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
    ;; (iup:attribute-set! steps-matrix "WIDTH1" "120")
    ;; (iup:attribute-set! steps-matrix "WIDTH0" "100")

    ;; Data matrix
    ;; 
    (let ((rownum 1))
      (for-each
       (lambda (x)
	 (iup:attribute-set! data-matrix (conc "0:" rownum) x)
	 (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50")
	 (set! rownum (+ rownum 1)))
       (list "Category" "Variable" "Value" "Expected" "Tolerance"  "Status" "Units" "Type" "Comment")))
    (iup:attribute-set! data-matrix "REDRAW" "ALL")
    
    (for-each 
     (lambda (data)
       (let ((mat    (car data))
	     (keys   (cadr data))
	     (rownum 1))
	 (for-each
	  (lambda (key)
	    (iup:attribute-set! mat (conc rownum ":0") key)
	    (set! rownum (+ rownum 1)))
	  keys)
	 (iup:attribute-set! mat "REDRAW" "ALL")))
     (list
      (list run-info-matrix  '("Run Id"  "Target"   "Runname" "Run Start Time" ))
      (list test-info-matrix '("Test Id" "Testname" "Itempath" "State"   "Status" "Test Start Time" "Comment"))
      (list test-run-matrix  '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration"))
      (list meta-dat-matrix  '("Author"   "Owner"     "Last Reviewed" "Tags" "Description"))))
	    
    (iup:split
      #:orientation "HORIZONTAL"
      (iup:vbox
       (iup:hbox
	(iup:vbox
	 run-info-matrix
	 test-info-matrix)
       ;; test-info-matrix)
	(iup:vbox
	 test-run-matrix
	 meta-dat-matrix))
       (iup:vbox
	(iup:vbox
	 (iup:hbox 
	  (iup:button "View Log"    #:action viewlog      #:size "60x" )   ;; #:size "30x" 
	  (iup:button "Start Xterm" #:action xterm        #:size "60x" ))	 ;; #:size "30x" 
	 (iup:hbox
	   (iup:button "Run Test"    #:action run-test    #:size "60x" )	 ;; #:size "30x" 
	   (iup:button "Clean Test"  #:action remove-test #:size "60x" )))	 ;; #:size "30x" 
	(iup:hbox
	 ;; hiup:split ;; hbox
	 ;; #:orientation "HORIZONTAL"
	 ;; #:value 300
	 command-text-box
	 command-launch-button)))
      (iup:vbox
       (let ((tabs (iup:tabs
		    steps-matrix
		    data-matrix)))
	 (iup:attribute-set! tabs "TABTITLE0" "Test Steps")
	 (iup:attribute-set! tabs "TABTITLE1" "Test Data")
	 tabs)))))
       
;; Test browser
(define (tests window-id)
  (iup:split
   (let* ((tb      (iup:treebox
		    #:selection-cb
		    (lambda (obj id state)
		      ;; (print "obj: " obj ", id: " id ", state: " state)
		      (let* ((run-path (tree:node->path obj id))
			     (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)
   (test-panel window-id)))

;; The function to update the fields in the test view panel
(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
  ;; get test-id
  ;; then get test record
  (if testdat
      (let* ((test-id      0) ;; (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f))
	     (test-data    (hash-table-ref/default testdat test-id #f))
	     (run-id       (db:test-get-run_id test-data))
	     (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*) 
						   run-id
						   '()))
	     (target       (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
	     (runname      (if (null? targ/runname) "" (car (cdr targ/runname))))
	     (steps-dat    (tests:get-compressed-steps *dbstruct-local* run-id test-id)))
				
	(if test-data
	    (begin
	      ;; 
	      (for-each 
	       (lambda (data)
		 (let ((mat    (car data))
		       (vals   (cadr data))
		       (rownum 1))
		   (for-each 
		    (lambda (key)
		      (let ((cell   (conc rownum ":1")))
			(if (not (equal? (iup:attribute mat cell)(conc key)))
			    (begin
			      ;; (print "setting cell " cell " in matrix " mat " to value " key)
			      (iup:attribute-set! mat cell (conc key))
			      (iup:attribute-set! mat "REDRAW" cell)))
			(set! rownum (+ rownum 1))))
		    vals)))
	       (list 
		(list run-info-matrix
		      (if test-id
			  (list (db:test-get-run_id test-data)
				target
				runname
				"n/a")
			  (make-list 4 "")))
		(list test-info-matrix
		      (if test-id
			  (list test-id
				(db:test-get-testname test-data)
				(db:test-get-item-path test-data)
				(db:test-get-state    test-data)
				(db:test-get-status   test-data)
				(seconds->string (db:test-get-event_time test-data))
				(db:test-get-comment  test-data))
			  (make-list 7 "")))
		(list test-run-matrix
		      (if test-id
			  (list (db:test-get-host     test-data)
				(db:test-get-uname    test-data)
				(db:test-get-diskfree test-data)
				(db:test-get-cpuload  test-data)
				(seconds->hr-min-sec (db:test-get-run_duration test-data)))
			  (make-list 5 "")))
		))
	      (dcommon:populate-steps steps-dat steps-matrix))))))
		;;(list meta-dat-matrix
		;;      (if test-id
		;;	  (list (

  
;; db:test-get-id           
;; db:test-get-run_id       
;; db:test-get-testname     
;; db:test-get-state        
;; db:test-get-status       
;; db:test-get-event_time   
;; db:test-get-host         
;; db:test-get-cpuload      
;; db:test-get-diskfree     
;; db:test-get-uname        
;; db:test-get-rundir       
;; db:test-get-item-path    
;; db:test-get-run_duration 
;; db:test-get-final_logf   
;; db:test-get-comment      
;; db:test-get-fullname     	  


;;======================================================================
;; R U N   C O N T R O L
;;======================================================================

;; Overall runs browser
;;
(define (runs window-id)
  (let* ((runs-matrix     (iup:matrix
			   #:expand "YES"
			   ;; #:fittosize "YES"
			   #:scrollbar "YES"
			   #:numcol 100
			   #:numlin 100
			   #:numcol-visible 7
			   #:numlin-visible 7
			   #:click-cb (lambda (obj lin col status)
					(print "obj: " obj " lin: " lin " col: " col " status: " status)))))

    (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
    (iup:attribute-set! runs-matrix "WIDTH0" "100")

    ;; (dboard:data-runs-matrix-set! *data* runs-matrix)
    (iup:hbox
     (iup:frame 
      #:title "Runs browser"
      (iup:vbox
       runs-matrix)))))

;; Browse and control a single run
;;
(define (runcontrol window-id)
  (iup:hbox))

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

;; Main Panel
(define (main-panel window-id)
  (iup:dialog
   #:title "Megatest Control Panel"
   #:menu (dcommon:main-menu)
   #:shrink "YES"
   (let ((tabtop (iup:tabs 
		  (runs window-id)
		  (tests window-id)
		  (runcontrol window-id)
		  (mtest *toppath* window-id) 
		  (rconfig window-id)
		  )))
     (iup:attribute-set! tabtop "TABTITLE0" "Runs")
     (iup:attribute-set! tabtop "TABTITLE1" "Tests")
     (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
     (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") 
     (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
     tabtop)))

(define *current-window-id* 0)

(define (newdashboard dbstruct)
  (let* ((data     (make-hash-table))
	 (keys     '()) ;; (db:get-keys dbstruct))
	 (runname  "%")
	 (testpatt "%")
	 (keypatts '()) ;; (map (lambda (k)(list k "%")) keys))
         (states   '())
	 (statuses '())
	 (nextmintime (current-milliseconds))
	 (my-window-id *current-window-id*))
    (set! *current-window-id* (+ 1 *current-window-id*))
   ;; (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application
    (iup:show (main-panel my-window-id))
    ;; Yes, running iup:show will pop up a new panel
    ;; (iup:show (main-panel my-window-id))
    (iup:callback-set! *tim*
		       "ACTION_CB"
		       (lambda (x)
			 ;; Want to dedicate no more than 50% of the time to this so skip if
			 ;; 2x delta time has not passed since last query
			 (if (< nextmintime (current-milliseconds))
			     (let* ((starttime (current-milliseconds))
				    ;; (changes   (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
				    (endtime   (current-milliseconds)))
			       (set! nextmintime (+ endtime (* 2 (- endtime starttime))))
			       ;; (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
                               )
			     (debug:print-info 11 *default-log-port* "Server overloaded"))))))

;; (dboard:data-updaters-set! *data* (make-hash-table))
(newdashboard #f) ;; *dbstruct-local*)    
(iup:main-loop)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Modified process.scm from [f9dfbe5500] to [98d616da06].

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
(define (process:conservative-read port)
  (let loop ((res ""))
    (if (not (eof-object? (peek-char port)))
	(loop (conc res (read-char port)))
	res)))

(define (process:cmd-run-with-stderr->list cmd . params)
  ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
;;  (handle-exceptions
;;   exn
;;   (begin
;;     (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
;;     (print "       " ((condition-property-accessor 'exn 'message) exn))
;;     #f)
   (let-values (((fh fho pid fhe) (if (null? params)
				      (process* cmd)
				      (process* cmd params))))
       (let loop ((curr (read-line fh))
		  (result  '()))
	 (let ((errstr (process:conservative-read fhe)))
	   (if (not (string=? errstr ""))
	       (set! result (append result (list errstr)))))
       (if (not (eof-object? curr))
	   (loop (read-line fh)
		 (append result (list curr)))
	   (begin
	     (close-input-port fh)
	     (close-input-port fhe)
	     (close-output-port fho)
	     result))))) ;; )

(define (process:cmd-run-with-stderr-and-exitcode->list cmd . params)
  ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
;;  (handle-exceptions
;;   exn
;;   (begin
;;     (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
;;     (print "       " ((condition-property-accessor 'exn 'message) exn))
;;     #f)
   (let-values (((fh fho pid fhe) (if (null? params)
				      (process* cmd)
				      (process* cmd params))))
       (let loop ((curr (read-line fh))
		  (result  '()))
	 (let ((errstr (process:conservative-read fhe)))
	   (if (not (string=? errstr ""))
	       (set! result (append result (list errstr)))))
       (if (not (eof-object? curr))
	   (loop (read-line fh)
		 (append result (list curr)))
	   (begin
             (let-values (((anotherpid normalexit? exitstatus)  (process-wait pid)))
	     (close-input-port fh)
	     (close-input-port fhe)
	     (close-output-port fho)
               (list result (if normalexit? exitstatus -1))))))))

(define (process:cmd-run-proc-each-line cmd proc . params)
  ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
  (handle-exceptions
   exn
   (begin
     (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
     (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
     (debug:print 5 *default-log-port* "exn=" (condition->list exn))
     #f)







<
<
<
<
<
<
<


















<
<
<
<
<
<
<



















<







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
(define (process:conservative-read port)
  (let loop ((res ""))
    (if (not (eof-object? (peek-char port)))
	(loop (conc res (read-char port)))
	res)))

(define (process:cmd-run-with-stderr->list cmd . params)







   (let-values (((fh fho pid fhe) (if (null? params)
				      (process* cmd)
				      (process* cmd params))))
       (let loop ((curr (read-line fh))
		  (result  '()))
	 (let ((errstr (process:conservative-read fhe)))
	   (if (not (string=? errstr ""))
	       (set! result (append result (list errstr)))))
       (if (not (eof-object? curr))
	   (loop (read-line fh)
		 (append result (list curr)))
	   (begin
	     (close-input-port fh)
	     (close-input-port fhe)
	     (close-output-port fho)
	     result))))) ;; )

(define (process:cmd-run-with-stderr-and-exitcode->list cmd . params)







   (let-values (((fh fho pid fhe) (if (null? params)
				      (process* cmd)
				      (process* cmd params))))
       (let loop ((curr (read-line fh))
		  (result  '()))
	 (let ((errstr (process:conservative-read fhe)))
	   (if (not (string=? errstr ""))
	       (set! result (append result (list errstr)))))
       (if (not (eof-object? curr))
	   (loop (read-line fh)
		 (append result (list curr)))
	   (begin
             (let-values (((anotherpid normalexit? exitstatus)  (process-wait pid)))
	     (close-input-port fh)
	     (close-input-port fhe)
	     (close-output-port fho)
               (list result (if normalexit? exitstatus -1))))))))

(define (process:cmd-run-proc-each-line cmd proc . params)

  (handle-exceptions
   exn
   (begin
     (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
     (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
     (debug:print 5 *default-log-port* "exn=" (condition->list exn))
     #f)

Deleted records-vs-vectors-vs-coops.scm version [a207631458].

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
;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;; (include "vg.scm")

;; (declare (uses vg))

(use foof-loop defstruct coops)

(defstruct obj     type fill-color angle)

(define (make-vg:obj)(make-vector 3))
(define-inline (vg:obj-get-type         vec)    (vector-ref  vec 0))
(define-inline (vg:obj-get-fill-color   vec)    (vector-ref  vec 1))
(define-inline (vg:obj-get-angle        vec)    (vector-ref  vec 2))
(define-inline (vg:obj-set-type!        vec val)(vector-set! vec 0 val))
(define-inline (vg:obj-set-fill-color!  vec val)(vector-set! vec 1 val))
(define-inline (vg:obj-set-angle!       vec val)(vector-set! vec 2 val))

(use simple-exceptions)
(define vgs:obj-exn (make-exception "wrong record type, expected vgs:obj." 'assert))
(define (make-vgs:obj)(let ((v (make-vector 4)))(vector-set! v 0 'vgs:obj) v))
(define-inline (vgs:obj-type             vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref  vec 1)(raise (vgs:obj-exn 'vgs:obj-type 'xpr))))
(define-inline (vgs:obj-fill-color       vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref  vec 2)(raise (vgs:obj-exn 'vgs:obj-fill-color 'xpr))))
(define-inline (vgs:obj-angle            vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref  vec 3)(raise (vgs:obj-exn 'vgs:obj-angle 'xpr))))
(define-inline (vgs:obj-type-set!        vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 1 val)(raise (vgs:obj-exn 'type))))
(define-inline (vgs:obj-fill-color-set!  vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 2 val)(raise (vgs:obj-exn 'fill-color))))
(define-inline (vgs:obj-angle-set!       vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 3 val)(raise (vgs:obj-exn 'angle))))

(define-class <vgc> ()
  ((type)
   (fill-color)
   (angle)))


;; first use raw vectors
(print "Using vectors")
(time
 (loop ((for r (up-from 0 (to 255))))
       (loop ((for g (up-from 0 (to 255))))
	     (loop ((for b (up-from 0 (to 255))))
		   (let ((obj (make-vg:obj)))
		     (vg:obj-set-type! obj 'abc)
		     (vg:obj-set-fill-color! obj "green")
		     (vg:obj-set-angle! obj 135)
		     (let ((a (vg:obj-get-type obj))
			   (b (vg:obj-get-fill-color obj))
			   (c (vg:obj-get-angle obj)))
		       obj))))))

;; first use raw vectors with safe mode
(print "Using vectors (safe mode)")
(time
 (loop ((for r (up-from 0 (to 255))))
       (loop ((for g (up-from 0 (to 255))))
	     (loop ((for b (up-from 0 (to 255))))
		   (let ((obj (make-vgs:obj)))
		     ;; (badobj (make-vector 20)))
		     (vgs:obj-type-set! obj 'abc)
		     (vgs:obj-fill-color-set! obj "green")
		     (vgs:obj-angle-set! obj 135)
		     (let ((a (vgs:obj-type obj))
			   (b (vgs:obj-fill-color obj))
			   (c (vgs:obj-angle obj)))
		       obj))))))

;; first use defstruct
(print "Using defstruct")
(time
 (loop ((for r (up-from 0 (to 255))))
       (loop ((for g (up-from 0 (to 255))))
	     (loop ((for b (up-from 0 (to 255))))
		   (let ((obj (make-obj)))
		     (obj-type-set! obj 'abc)
		     (obj-fill-color-set! obj "green")
		     (obj-angle-set! obj 135)
		     (let ((a (obj-type obj))
			   (b (obj-fill-color obj))
			   (c (obj-angle obj)))
		       obj))))))
		   

;; first use defstruct
(print "Using coops")
(time
 (loop ((for r (up-from 0 (to 255))))
       (loop ((for g (up-from 0 (to 255))))
	     (loop ((for b (up-from 0 (to 255))))
		   (let ((obj (make <vgc>)))
		     (set! (slot-value obj 'type) 'abc)
		     (set! (slot-value obj 'fill-color) "green")
		     (set! (slot-value obj 'angle) 135)
		     (let ((a (slot-value obj 'type))
			   (b (slot-value obj 'fill-color))
			   (c (slot-value obj 'angle)))
		       obj))))))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































Modified rmt.scm from [39d97c528a] to [46b655b2eb].

656
657
658
659
660
661
662

663
664
665
666
667
668
669
670
(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
  (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)))
    (apply append 
	   (map (lambda (run-id)
		  (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
	   run-ids))))


(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
  (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))

(define (rmt:get-count-tests-running-for-run-id run-id fastmode)
  (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id fastmode)))

(define (rmt:get-not-completed-cnt run-id)
  (rmt:send-receive 'get-not-completed-cnt run-id (list run-id)))







>
|







656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
  (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)))
    (apply append 
	   (map (lambda (run-id)
		  (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
	   run-ids))))

;; NOTE: rmt functions can NEVER have key params as they might be called as local
(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmaps #f))
  (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))

(define (rmt:get-count-tests-running-for-run-id run-id fastmode)
  (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id fastmode)))

(define (rmt:get-not-completed-cnt run-id)
  (rmt:send-receive 'get-not-completed-cnt run-id (list run-id)))

Deleted rmtdb.scm version [62ddf7898c].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
;;======================================================================
;; Copyright 2006-2013, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

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








































Modified run_records.scm from [737eaad866] to [dea8813cfd].

36
37
38
39
40
41
42
43
44
45
46
47
48
(define-inline (test:get-id vec)       (vector-ref vec 0))
(define-inline (test:get-run_id vec)   (vector-ref vec 1))
(define-inline (test:get-test-name vec)(vector-ref vec 2))
(define-inline (test:get-state vec)    (vector-ref vec 3))
(define-inline (test:get-status vec)   (vector-ref vec 4))
(define-inline (test:get-item-path vec)(vector-ref vec 5))

(define-inline (test:test-get-fullname test)
   (conc (db:test-get-testname test)
	 (if (equal? (db:test-get-item-path test) "")
	     ""
	     (conc "(" (db:test-get-item-path test) ")"))))








<
<
<
<
<
<
36
37
38
39
40
41
42






(define-inline (test:get-id vec)       (vector-ref vec 0))
(define-inline (test:get-run_id vec)   (vector-ref vec 1))
(define-inline (test:get-test-name vec)(vector-ref vec 2))
(define-inline (test:get-state vec)    (vector-ref vec 3))
(define-inline (test:get-status vec)   (vector-ref vec 4))
(define-inline (test:get-item-path vec)(vector-ref vec 5))







Modified runs.scm from [030b929939] to [4de72ed2f2].

58
59
60
61
62
63
64
65




66
67
68
69
70
71
72
  (last-load-check-time    0)
  (last-jobs-check-time    0)
  )

(defstruct runs:testdat
  hed tal reg reruns  test-record
  test-name item-path jobgroup
  waitons testmode  newtal itemmaps prereqs-not-met)




  
;; look in the $MT_RUN_AREA_HOME/.softlocks directory for key-host-pid.softlock files
;;  - remove any that are over 3600 seconds old
;;  - if there are any that are younger than 10 seconds
;;      * sleep 10 seconds
;;      * touch my key-host-pid.softlock file
;;      * return







|
>
>
>
>







58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
  (last-load-check-time    0)
  (last-jobs-check-time    0)
  )

(defstruct runs:testdat
  hed tal reg reruns  test-record
  test-name item-path jobgroup
  waitons testmode  newtal
  itemmaps
  (prereqs-not-met #f)
  (last-update 0) ;; 
  )
  
;; look in the $MT_RUN_AREA_HOME/.softlocks directory for key-host-pid.softlock files
;;  - remove any that are over 3600 seconds old
;;  - if there are any that are younger than 10 seconds
;;      * sleep 10 seconds
;;      * touch my key-host-pid.softlock file
;;      * return
827
828
829
830
831
832
833
















834
835
836
837
838
839
840
841
842
843

844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
;;    => review of a previously seen test is higher priority of never visited test
;; reg - list of previously visited tests
;; tal - list of never visited tests
;;   prefer next hed to be from reg than tal.

(define runs:nothing-left-in-queue-count 0)

















;;======================================================================
;; runs:expand-items is called by runs:run-tests-queue
;;======================================================================
;;
;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature:
;;    (let loop ((hed         (car sorted-test-names))
;;	         (tal         (cdr sorted-test-names))
;;	         (reg         '()) ;; registered, put these at the head of tal 
;;	         (reruns      '()))
(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps)

  (let* ((loop-list       (list hed tal reg reruns))
	 (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)))
			    (if (list? res)
				res
				(begin
				  (debug:print 0 *default-log-port*
					       "ERROR: rmt:get-prereqs-not-met returned non-list!\n"
					       "  res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps)
				  '()))))
         (have-itemized (not (null? (lset-intersection eq? testmode '(itemmatch itemwait)))))
	 ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
	 (fails           (runs:calc-fails prereqs-not-met))
	 (prereq-fails    (runs:calc-prereq-fail prereqs-not-met))
	 (non-completed   (runs:calc-not-completed prereqs-not-met))
	 (runnables       (runs:calc-runnable prereqs-not-met))
         (unexpanded-prereqs
          (filter (lambda (testname)
                    (let* ((test-rec (hash-table-ref test-records testname))







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









|
>

|
<
<
<
<
<
<
<
|
<







831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866







867

868
869
870
871
872
873
874
;;    => review of a previously seen test is higher priority of never visited test
;; reg - list of previously visited tests
;; tal - list of never visited tests
;;   prefer next hed to be from reg than tal.

(define runs:nothing-left-in-queue-count 0)

(define (runs:lazy-get-prereqs-not-met  testdat run-id waitons hed item-path #!key (mode '(normal))(itemmaps #f)) ;; mode: testmode itemmaps: itemmaps)
  (if (and (runs:testdat-prereqs-not-met testdat)
	   (< (- (current-seconds) (runs:testdat-last-update testdat)) 10)) ;; only refresh for this test if it has been at least 10 seconds
      (runs:testdat-prereqs-not-met testdat)
      (let* ((res (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode itemmaps)))
		    (if (list? res)
			res
			(begin
			  (debug:print 0 *default-log-port*
				       "ERROR: rmt:get-prereqs-not-met returned non-list!\n"
				       "  res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" mode " itemmaps=" itemmaps)
			  '())))))
	(runs:testdat-prereqs-not-met-set! testdat res)
	(runs:testdat-last-update-set! testdat (current-seconds))
	res)))
	   
;;======================================================================
;; runs:expand-items is called by runs:run-tests-queue
;;======================================================================
;;
;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature:
;;    (let loop ((hed         (car sorted-test-names))
;;	         (tal         (cdr sorted-test-names))
;;	         (reg         '()) ;; registered, put these at the head of tal 
;;	         (reruns      '()))
(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record
			   can-run-more items runname tconfig reglen test-registry test-records itemmaps testdat)
  (let* ((loop-list       (list hed tal reg reruns))
	 (prereqs-not-met (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path mode: testmode itemmaps: itemmaps))







	 (have-itemized   (not (null? (lset-intersection eq? testmode '(itemmatch itemwait)))))

	 (fails           (runs:calc-fails prereqs-not-met))
	 (prereq-fails    (runs:calc-prereq-fail prereqs-not-met))
	 (non-completed   (runs:calc-not-completed prereqs-not-met))
	 (runnables       (runs:calc-runnable prereqs-not-met))
         (unexpanded-prereqs
          (filter (lambda (testname)
                    (let* ((test-rec (hash-table-ref test-records testname))
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
	 (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) ;; TODO: rename fails to failed-prereqs
				      (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)))







<
<







1106
1107
1108
1109
1110
1111
1112


1113
1114
1115
1116
1117
1118
1119
	 (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))


	 (fails                  (if (list? prereqs-not-met) ;; TODO: rename fails to failed-prereqs
				      (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)))
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
                   registry-mutex: registry-mutex
                   flags: flags
                   keyvals: keyvals
                   run-info: run-info
                   ;; newtal: newtal
                   all-tests-registry: all-tests-registry
                   ;; itemmaps: itemmaps
                   ;; prereqs-not-met: (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)
                   ;; can-run-more-tests: (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) ;; look at the test jobgroup and tot jobs running
                   )))

    ;; Initialize the test-registery hash with tests that already have a record
    ;; convert state to symbol and use that as the hash value
    (for-each (lambda (trec)
		(let ((id (db:test-get-id        trec))







<







1505
1506
1507
1508
1509
1510
1511

1512
1513
1514
1515
1516
1517
1518
                   registry-mutex: registry-mutex
                   flags: flags
                   keyvals: keyvals
                   run-info: run-info
                   ;; newtal: newtal
                   all-tests-registry: all-tests-registry
                   ;; itemmaps: itemmaps

                   ;; can-run-more-tests: (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) ;; look at the test jobgroup and tot jobs running
                   )))

    ;; Initialize the test-registery hash with tests that already have a record
    ;; convert state to symbol and use that as the hash value
    (for-each (lambda (trec)
		(let ((id (db:test-get-id        trec))
1713
1714
1715
1716
1717
1718
1719


1720
1721
1722
1723
1724
1725
1726
1727
				  ;; wait for load here
				  (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
				  (loop-can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)
						     (- remtries 1)))))))
		       )))))

	  ;; I'm not clear on why prereqs are gathered here TODO: verfiy this is needed


	  (runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))

	  ;; I'm not clear on why we'd capture running job counts here TODO: verify this is needed
	  (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs))

	  (let ((loop-list (runs:process-expanded-tests runsdat testdat))) ;; in process-expanded-tests ultimately run:test -> launch-test -> test actually running
            (if loop-list (apply loop loop-list))))








>
>
|







1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
				  ;; wait for load here
				  (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
				  (loop-can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)
						     (- remtries 1)))))))
		       )))))

	  ;; I'm not clear on why prereqs are gathered here TODO: verfiy this is needed
	  (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path
					 mode: testmode
					 itemmaps: itemmaps)

	  ;; I'm not clear on why we'd capture running job counts here TODO: verify this is needed
	  (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs))

	  (let ((loop-list (runs:process-expanded-tests runsdat testdat))) ;; in process-expanded-tests ultimately run:test -> launch-test -> test actually running
            (if loop-list (apply loop loop-list))))

1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
	 ;;    - but only do that if resources exist to kick off the job
	 ;; EXPAND ITEMS
	 ((or (procedure? items)(eq? items 'have-procedure))
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-4")
	  (let ((can-run-more    #f)) ;; (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)))
	    (if (not can-run-more) #;(and (list? can-run-more)
		(car can-run-more))
		(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps))) ;; itemized test expanded here
		  (if loop-list
		      (apply loop loop-list)
                      (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed)
                      )
                  )
		;; if can't run more just loop with next possible test
		(loop (car newtal)(cdr newtal) reg reruns))))







|







1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
	 ;;    - but only do that if resources exist to kick off the job
	 ;; EXPAND ITEMS
	 ((or (procedure? items)(eq? items 'have-procedure))
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-4")
	  (let ((can-run-more    #f)) ;; (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)))
	    (if (not can-run-more) #;(and (list? can-run-more)
		(car can-run-more))
		(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps testdat))) ;; itemized test expanded here
		  (if loop-list
		      (apply loop loop-list)
                      (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed)
                      )
                  )
		;; if can't run more just loop with next possible test
		(loop (car newtal)(cdr newtal) reg reruns))))

Deleted sauth-common.scm version [28ffd8e69e].

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
;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.


;; Create the sqlite db
(define (sauthorize:db-do proc) 
      (if (or (not *db-path*)
              (not (file-exists? *db-path*))) 
	(begin
	  (print 0 "[database]\nlocation " *db-path* " \n\n Is missing from the config file!")
	  (exit 1)))
    (if (and *db-path*
	     (directory? *db-path*)
	     (file-read-access? *db-path*))
	(let* ((dbpath    (conc *db-path* "/sauthorize.db"))
	       (writeable (file-write-access? dbpath))
	       (dbexists  (file-exists? dbpath)))
	  (handle-exceptions
	   exn
	   (begin
	     (print 2 "ERROR: problem accessing db " dbpath
			  ((condition-property-accessor 'exn 'message) exn))
	     (exit 1))
            ;(print  "calling proc " proc "db path " dbpath )
	   (call-with-database
            dbpath
	    (lambda (db)
	       ;(print 0 "calling proc " proc " on db " db)
	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
	      (if (not dbexists)(sauthorize:initialize-db db))
	      (proc db)))))
	(print 0 "ERROR: invalid path for storing database: " *db-path*)))

;;execute a query
(define (sauthorize:db-qry db qry)
  ;(print qry)
  (exec (sql db  qry)))


(define (sauthorize: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))
     ;(print 0 "cid " cid " eid:" eid)
    (proc)
    (if (not (eq? eid cid))
        (set! (current-effective-user-id) eid))))


(define (run-cmd cmd arg-list)
  ; (print (current-effective-user-id))
   ;(handle-exceptions
;	     exn
;	     (print 0 "ERROR: failed to run script " cmd " with params " arg-list " " (exn assert))
	     (let ((pid (process-run cmd arg-list)))
	       (process-wait pid))
)
;)


(define (regster-log inl usr-id  area-id  cmd)
  (sauth-common:shell-do-as-adm
        (lambda ()
         (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sretrieve " inl "'," usr-id ","  area-id ", 'cat' )")))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Check user types
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;check if a user is an admin
(define (is-admin username)
   (let* ((admin #f))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM  users where users.username = '" username "'")))))
        (if (not (null? data-row))
             (let ((col  (car data-row)))
             (if (equal? col "yes")
                   (set! admin #t)))))))  	        
admin))


;;check if a user is an read-admin
(define (is-read-admin username)
   (let* ((admin #f))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM  users where users.username = '" username "'")))))
        (if (not (null? data-row))
             (let ((col  (car data-row)))
             (if (equal? col "read-admin")
                   (set! admin #t)))))))  	        
admin))


;;check if user has specifc role for a area
(define (is-user role username area)
  (let* ((has-access #f))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  permissions.access_type, permissions.expiration FROM  users ,  areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "' and areas.code = '" area "'")))))
        (if (not (null? data-row))
           (begin
               (let* ((access-type  (car data-row))
                    (exdate (cadr data-row)))
               (if (not (null? exdate)) 
               (begin 
                  (let ((valid (is-access-valid  exdate)))
                   ;(print valid) 
                  (if (and (equal? access-type role)
                        (equal? valid #t))
                   (set! has-access #t))))
                (print "Access expired"))))))))
 ;(print has-access)
has-access))

(define (is-access-valid exp-str)
    (let* ((ret-val #f )
           (date-parts  (string-split exp-str "/"))
           (yr (string->number (car date-parts)))
           (month (string->number(car (cdr date-parts)))) 
           (day (string->number(caddr date-parts)))
           (exp-date (make-date 0 0 0 0 day month yr )))
             ;(print  exp-date)
             ;(print (current-date))   
            (if (> (date-compare exp-date  (current-date)) 0)
             (set! ret-val #t))
   ;(print ret-val)
   ret-val))


;check if area exists
(define (area-exists area)
   (let* ((area-defined #f))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  areas where areas.code = '" area "'")))))
           (if (not (null? data-row))
                 (set! area-defined #t)))))
area-defined))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Get Record from database
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;gets area id by code 
(define (get-area area)
   (let* ((area-defined '()))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  areas where areas.code = '" area "'")))))
          (set!  area-defined data-row))))
area-defined))

;get id of users table by user name 
(define (get-user user)
  (let* ((user-defined '()))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  users where users.username = '" user "'")))))
          (set!  user-defined data-row))))
user-defined))

;get permissions id by userid and area id 
(define (get-perm userid areaid)
  (let* ((user-defined '()))
    (sauthorize:db-do  (lambda (db)
          (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  permissions where user_id = " userid " and area_id = " areaid)))))
         (set!  user-defined data-row))))

user-defined))

(define (get-restrictions base-path usr)
(let* ((user-defined '()))
    (sauthorize:db-do  (lambda (db)
          (let* ((data-row (query fetch (sql db (conc "SELECT  restriction FROM areas, users, permissions where  areas.id = permissions.area_id and users.id =  permissions.user_id and  users.username = '" usr "' and areas.basepath = '" base-path "'")))))
         ;(print data-row) 
         (set!  user-defined data-row))))
    ;   (print user-defined)
  (if (null? user-defined)
      ""
      (car user-defined))))


(define (get-obj-by-path path)
   (let* ((obj '()))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  code,exe_name, id, basepath FROM  areas where areas.basepath = '" path "'")))))
         (set!  obj data-row))))
obj))

(define (get-obj-by-code code )
  (let* ((obj '()))
    (sauthorize:db-do  (lambda (db)
        ;(print (conc "SELECT  code, exe_name,  id, basepath, required_grps  FROM  areas where areas.code = '" code "'"))
        (let* ((data-row (query fetch (sql db (conc "SELECT  code, exe_name,  id, basepath, required_grps  FROM  areas where areas.code = '" code "'")))))
         ;(print data-row)
         (set!  obj data-row)
         ;(print obj) 
        )))
    (if (not (null? obj))
          (begin
          (let* ((req-grp (caddr (cddr obj))))
            (sauthorize:do-as-calling-user
             (lambda ()
 (sauth-common:check-user-groups req-grp))))))
obj))

(define (sauth-common:check-user-groups req-grp)
(let* ((current-groups  (get-groups) )
        (req-grp-list (string-split req-grp ",")))
        ;(print req-grp-list)
        (for-each (lambda (grp)
	  (let ((grp-info (group-information grp)))
               ;(print grp-info " " grp)
               (if (not (equal? grp-info #f))
               (begin
                 (if (not (member  (caddr grp-info) current-groups))
                  (begin 
                    (sauth:print-error (conc "Please wash " grp " group in your xterm!! " ))
                     (exit 1)))))))
	     req-grp-list)))

(define (get-obj-by-code-no-grp-validation code )
  (let* ((obj '()))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  code, exe_name,  id, basepath  FROM  areas where areas.code = '" code "'")))))
         (set!  obj data-row))))
;(print obj)
obj))




;; function to validate the users input for target path and resolve the path
;; TODO: Check for restriction in subpath 
(define (sauth-common:resolve-path  new current allowed-sheets)
   (let* ((target-path (append  current (string-split new "/")))
          (target-path-string (string-join target-path "/"))
          (normal-path (normalize-pathname target-path-string))
          (normal-list (string-split normal-path "/"))
           (ret '()))
   (if (string-contains   normal-path "..")
    (begin
      (print "ERROR: Path  " new " resolved outside target area ")
      #f)
    (if(equal? normal-path ".")
      ret  
    (if (not (member  (car normal-list) allowed-sheets))
      (begin
      (print "ERROR: Permision denied to  " new )
       #f)
    normal-list)))))

(define (sauth-common:get-target-path base-path-list ext-path top-areas base-path)
  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))
          (usr (current-user-name) ) )
          (if (not (equal? resolved-path #f))
           (if (null? resolved-path) 
             #f
           (let* ((sheet (car resolved-path))
                   (restricted-areas (get-restrictions base-path usr))
                   (restrictions (conc ".*" (string-join (string-split restricted-areas ",") ".*|.*") ".*"))
           	   (target-path (if (null? (cdr resolved-path)) 
                                     base-path 
                                     (conc base-path "/" (string-join (cdr resolved-path) "/")))))
                    
	              
                           (if (and (not (equal? restricted-areas "" ))
                             (string-match (regexp  restrictions) target-path)) 
                           (begin
                              (sauth:print-error "Access denied to " (string-join resolved-path "/"))
                              ;(exit 1)   
                            #f)
                             target-path)
                            
))
             #f)))

(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
    (if (and (null? base-path-list) (equal? ext-path "") )
      (print (string-intersperse top-areas " "))
  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
           ;(print resolved-path)
           (if (not (equal? resolved-path #f))
           (if (null? resolved-path) 
             (print (string-intersperse top-areas " "))
           (let* ((target-path (sauth-common:get-target-path  base-path-list  ext-path top-areas base-path)))
                (print target-path)
                (if (not (equal? target-path #f))
                (begin 
                (cond
		  ((null? tail-cmd-list)
		     (run (pipe
      	      	      (ls "-lrt" ,target-path))))
		  ((not (equal? (car tail-cmd-list) "|"))
                         (print "ls cmd cannot accept " (string-join tail-cmd-list) " as an argument!!"))
                  (else  
                    (run (pipe
      	      	      (ls "-lrt" ,target-path)
                      (begin (system (string-join (cdr tail-cmd-list))))))))))))))))

(define (sauth:print-error msg)
  (with-output-to-port (current-error-port)
	(lambda ()
	       (print (conc "ERROR: " msg)))))

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






























































































































































































































































































































































































































































































































































































































































Added sauth-src/sauth-common.scm version [28ffd8e69e].































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.


;; Create the sqlite db
(define (sauthorize:db-do proc) 
      (if (or (not *db-path*)
              (not (file-exists? *db-path*))) 
	(begin
	  (print 0 "[database]\nlocation " *db-path* " \n\n Is missing from the config file!")
	  (exit 1)))
    (if (and *db-path*
	     (directory? *db-path*)
	     (file-read-access? *db-path*))
	(let* ((dbpath    (conc *db-path* "/sauthorize.db"))
	       (writeable (file-write-access? dbpath))
	       (dbexists  (file-exists? dbpath)))
	  (handle-exceptions
	   exn
	   (begin
	     (print 2 "ERROR: problem accessing db " dbpath
			  ((condition-property-accessor 'exn 'message) exn))
	     (exit 1))
            ;(print  "calling proc " proc "db path " dbpath )
	   (call-with-database
            dbpath
	    (lambda (db)
	       ;(print 0 "calling proc " proc " on db " db)
	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
	      (if (not dbexists)(sauthorize:initialize-db db))
	      (proc db)))))
	(print 0 "ERROR: invalid path for storing database: " *db-path*)))

;;execute a query
(define (sauthorize:db-qry db qry)
  ;(print qry)
  (exec (sql db  qry)))


(define (sauthorize: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))
     ;(print 0 "cid " cid " eid:" eid)
    (proc)
    (if (not (eq? eid cid))
        (set! (current-effective-user-id) eid))))


(define (run-cmd cmd arg-list)
  ; (print (current-effective-user-id))
   ;(handle-exceptions
;	     exn
;	     (print 0 "ERROR: failed to run script " cmd " with params " arg-list " " (exn assert))
	     (let ((pid (process-run cmd arg-list)))
	       (process-wait pid))
)
;)


(define (regster-log inl usr-id  area-id  cmd)
  (sauth-common:shell-do-as-adm
        (lambda ()
         (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sretrieve " inl "'," usr-id ","  area-id ", 'cat' )")))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Check user types
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;check if a user is an admin
(define (is-admin username)
   (let* ((admin #f))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM  users where users.username = '" username "'")))))
        (if (not (null? data-row))
             (let ((col  (car data-row)))
             (if (equal? col "yes")
                   (set! admin #t)))))))  	        
admin))


;;check if a user is an read-admin
(define (is-read-admin username)
   (let* ((admin #f))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM  users where users.username = '" username "'")))))
        (if (not (null? data-row))
             (let ((col  (car data-row)))
             (if (equal? col "read-admin")
                   (set! admin #t)))))))  	        
admin))


;;check if user has specifc role for a area
(define (is-user role username area)
  (let* ((has-access #f))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  permissions.access_type, permissions.expiration FROM  users ,  areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "' and areas.code = '" area "'")))))
        (if (not (null? data-row))
           (begin
               (let* ((access-type  (car data-row))
                    (exdate (cadr data-row)))
               (if (not (null? exdate)) 
               (begin 
                  (let ((valid (is-access-valid  exdate)))
                   ;(print valid) 
                  (if (and (equal? access-type role)
                        (equal? valid #t))
                   (set! has-access #t))))
                (print "Access expired"))))))))
 ;(print has-access)
has-access))

(define (is-access-valid exp-str)
    (let* ((ret-val #f )
           (date-parts  (string-split exp-str "/"))
           (yr (string->number (car date-parts)))
           (month (string->number(car (cdr date-parts)))) 
           (day (string->number(caddr date-parts)))
           (exp-date (make-date 0 0 0 0 day month yr )))
             ;(print  exp-date)
             ;(print (current-date))   
            (if (> (date-compare exp-date  (current-date)) 0)
             (set! ret-val #t))
   ;(print ret-val)
   ret-val))


;check if area exists
(define (area-exists area)
   (let* ((area-defined #f))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  areas where areas.code = '" area "'")))))
           (if (not (null? data-row))
                 (set! area-defined #t)))))
area-defined))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Get Record from database
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;gets area id by code 
(define (get-area area)
   (let* ((area-defined '()))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  areas where areas.code = '" area "'")))))
          (set!  area-defined data-row))))
area-defined))

;get id of users table by user name 
(define (get-user user)
  (let* ((user-defined '()))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  users where users.username = '" user "'")))))
          (set!  user-defined data-row))))
user-defined))

;get permissions id by userid and area id 
(define (get-perm userid areaid)
  (let* ((user-defined '()))
    (sauthorize:db-do  (lambda (db)
          (let* ((data-row (query fetch (sql db (conc "SELECT  id FROM  permissions where user_id = " userid " and area_id = " areaid)))))
         (set!  user-defined data-row))))

user-defined))

(define (get-restrictions base-path usr)
(let* ((user-defined '()))
    (sauthorize:db-do  (lambda (db)
          (let* ((data-row (query fetch (sql db (conc "SELECT  restriction FROM areas, users, permissions where  areas.id = permissions.area_id and users.id =  permissions.user_id and  users.username = '" usr "' and areas.basepath = '" base-path "'")))))
         ;(print data-row) 
         (set!  user-defined data-row))))
    ;   (print user-defined)
  (if (null? user-defined)
      ""
      (car user-defined))))


(define (get-obj-by-path path)
   (let* ((obj '()))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  code,exe_name, id, basepath FROM  areas where areas.basepath = '" path "'")))))
         (set!  obj data-row))))
obj))

(define (get-obj-by-code code )
  (let* ((obj '()))
    (sauthorize:db-do  (lambda (db)
        ;(print (conc "SELECT  code, exe_name,  id, basepath, required_grps  FROM  areas where areas.code = '" code "'"))
        (let* ((data-row (query fetch (sql db (conc "SELECT  code, exe_name,  id, basepath, required_grps  FROM  areas where areas.code = '" code "'")))))
         ;(print data-row)
         (set!  obj data-row)
         ;(print obj) 
        )))
    (if (not (null? obj))
          (begin
          (let* ((req-grp (caddr (cddr obj))))
            (sauthorize:do-as-calling-user
             (lambda ()
 (sauth-common:check-user-groups req-grp))))))
obj))

(define (sauth-common:check-user-groups req-grp)
(let* ((current-groups  (get-groups) )
        (req-grp-list (string-split req-grp ",")))
        ;(print req-grp-list)
        (for-each (lambda (grp)
	  (let ((grp-info (group-information grp)))
               ;(print grp-info " " grp)
               (if (not (equal? grp-info #f))
               (begin
                 (if (not (member  (caddr grp-info) current-groups))
                  (begin 
                    (sauth:print-error (conc "Please wash " grp " group in your xterm!! " ))
                     (exit 1)))))))
	     req-grp-list)))

(define (get-obj-by-code-no-grp-validation code )
  (let* ((obj '()))
    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  code, exe_name,  id, basepath  FROM  areas where areas.code = '" code "'")))))
         (set!  obj data-row))))
;(print obj)
obj))




;; function to validate the users input for target path and resolve the path
;; TODO: Check for restriction in subpath 
(define (sauth-common:resolve-path  new current allowed-sheets)
   (let* ((target-path (append  current (string-split new "/")))
          (target-path-string (string-join target-path "/"))
          (normal-path (normalize-pathname target-path-string))
          (normal-list (string-split normal-path "/"))
           (ret '()))
   (if (string-contains   normal-path "..")
    (begin
      (print "ERROR: Path  " new " resolved outside target area ")
      #f)
    (if(equal? normal-path ".")
      ret  
    (if (not (member  (car normal-list) allowed-sheets))
      (begin
      (print "ERROR: Permision denied to  " new )
       #f)
    normal-list)))))

(define (sauth-common:get-target-path base-path-list ext-path top-areas base-path)
  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))
          (usr (current-user-name) ) )
          (if (not (equal? resolved-path #f))
           (if (null? resolved-path) 
             #f
           (let* ((sheet (car resolved-path))
                   (restricted-areas (get-restrictions base-path usr))
                   (restrictions (conc ".*" (string-join (string-split restricted-areas ",") ".*|.*") ".*"))
           	   (target-path (if (null? (cdr resolved-path)) 
                                     base-path 
                                     (conc base-path "/" (string-join (cdr resolved-path) "/")))))
                    
	              
                           (if (and (not (equal? restricted-areas "" ))
                             (string-match (regexp  restrictions) target-path)) 
                           (begin
                              (sauth:print-error "Access denied to " (string-join resolved-path "/"))
                              ;(exit 1)   
                            #f)
                             target-path)
                            
))
             #f)))

(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
    (if (and (null? base-path-list) (equal? ext-path "") )
      (print (string-intersperse top-areas " "))
  (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
           ;(print resolved-path)
           (if (not (equal? resolved-path #f))
           (if (null? resolved-path) 
             (print (string-intersperse top-areas " "))
           (let* ((target-path (sauth-common:get-target-path  base-path-list  ext-path top-areas base-path)))
                (print target-path)
                (if (not (equal? target-path #f))
                (begin 
                (cond
		  ((null? tail-cmd-list)
		     (run (pipe
      	      	      (ls "-lrt" ,target-path))))
		  ((not (equal? (car tail-cmd-list) "|"))
                         (print "ls cmd cannot accept " (string-join tail-cmd-list) " as an argument!!"))
                  (else  
                    (run (pipe
      	      	      (ls "-lrt" ,target-path)
                      (begin (system (string-join (cdr tail-cmd-list))))))))))))))))

(define (sauth:print-error msg)
  (with-output-to-port (current-error-port)
	(lambda ()
	       (print (conc "ERROR: " msg)))))

Added sauth-src/sauthorize.scm version [b4d2f08e65].























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































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

;; Copyright 2006-2013, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

(use defstruct)
(use scsh-process)

(use srfi-18)
(use srfi-19)
(use refdb)

(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
;(declare (uses common))
;(declare (uses configf))
(declare (uses margs))

(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. 
(include "sauth-paths.scm")
(include "sauth-common.scm")

;;
;; GLOBALS
;;
(define *verbosity* 1)
(define *logging* #f)
(define *exe-name* (pathname-file (car (argv))))
(define *sretrieve:current-tab-number* 0)
(define *args-hash* (make-hash-table))
(define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]]

  list                   		 			: list areas $USER's can access
  log                    		 			: get listing of recent activity.
  sauth  list-area-user <area code> 			: list the users that can access the area.
  sauth open <path> --group <grpname>                      : Open up an area. User needs to be the owner of the area to open it. 
              --code <unique short identifier for an area> 
              --retrieve|--publish [--additional-grps <comma separated unix grps requierd to get to the path>]
  sauth update <area code>  --retrieve|--publish             : update the binaries with the lates changes
  sauth grant <username> --area <area identifier>          : Grant permission to read or write to a area that is alrady opend up.    
             --expiration yyyy/mm/dd --retrieve|--publish 
             [--restrict <comma separated directory names> ]  
  sauth read-shell <area identifier>                       :  Open sretrieve shell for reading.  
  sauth write-shell <area identifier>                      :  Open spublish shell for writing.
   
Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash)) ;; "

;;======================================================================
;; RECORDS
;;======================================================================

;;======================================================================
;; DB
;;======================================================================

;; replace (strftime('%s','now')), with datetime('now'))
(define (sauthorize:initialize-db db)
  (for-each
   (lambda (qry)
     (exec (sql db qry)))
   (list 
    "CREATE TABLE IF NOT EXISTS actions
         (id           INTEGER PRIMARY KEY,
          cmd       TEXT NOT NULL,
          user_id      INTEGER NOT NULL,
          datetime     TIMESTAMP DEFAULT (datetime('now','localtime')),
          area_id      INTEGER NOT NULL,
          comment      TEXT DEFAULT '' NOT NULL,
          action_type  TEXT NOT NULL);"
        "CREATE TABLE IF NOT EXISTS users
         (id           INTEGER PRIMARY KEY,
          username     TEXT NOT NULL,
          is_admin     TEXT NOT NULL,
          datetime     TIMESTAMP DEFAULT (datetime('now','localtime'))
          );" 
          "CREATE TABLE IF NOT EXISTS areas
         (id           INTEGER PRIMARY KEY,
          basepath     TEXT NOT NULL,
          code         TEXT NOT NULL,
          exe_name     TEXT NOT NULL,
          required_grps TEXT DEFAULT '' NOT NULL,
          datetime     TIMESTAMP DEFAULT (datetime('now','localtime'))
          );" 
         "CREATE TABLE IF NOT EXISTS permissions
         (id              INTEGER PRIMARY KEY,
          access_type     TEXT NOT NULL,
          user_id         INTEGER NOT NULL,
          datetime        TIMESTAMP DEFAULT (datetime('now','localtime')),
          area_id         INTEGER NOT NULL,
          restriction     TEXT DEFAULT '' NOT NULL,
          expiration       TIMESTAMP DEFAULT NULL);"
    )))




(define (get-access-type args)
   (let loop ((hed (car args))
		 (tal (cdr args)))
                   (cond
                   ((equal? hed "--retrieve")
                      "retrieve") 
                   ((equal? hed "--publish")
                      "publish") 
                   ((equal? hed "--area-admin")
                      "area-admin")
                   ((equal? hed "--writer-admin")
                      "writer-admin")
                   ((equal? hed "--read-admin")
                      "read-admin")

                   ((null? tal)
                      #f) 
                   (else 
		  	(loop (car tal)(cdr tal))))))



;; check if user can gran access to an area
(define (can-grant-perm username access-type area)
   (let* ((isadmin (is-admin username))
          (is-area-admin (is-user "area-admin" username area ))
          (is-read-admin (is-user "read-admin" username area) )
          (is-writer-admin (is-user "writer-admin" username area) ) )
   (cond
   ((equal? isadmin  #t)
     #t)
   ((equal? is-area-admin #t ) 
     #t)
   ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve"))
     #t)
   ((and (equal? is-read-admin #t ) (equal? access-type "retrieve"))
     #t)

   (else  
    #f))))

(define (sauthorize:list-areausers  area )
  (sauthorize:db-do  (lambda (db)
				     (print "Users having access to " area ":")
				     (query (for-each-row
					     (lambda (row)
                                               (let* ((exp-date (cadr row)))
                                                (if  (is-access-valid  exp-date)   
					        (apply print (intersperse row " | "))))))
					    (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type  FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'"))))))




; check if executable exists
(define (exe-exist exe access-type)
    (let* ((filepath (conc *exe-path* "/" access-type "/" exe)))
    ; (print filepath)
     (if (file-exists? filepath)
       #t
       #f)))

(define (copy-exe access-type exe-name group)
  (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type)))
  (let* ((spath (conc *exe-src*  "/s" access-type))
         (dpath (conc *exe-path* "/" access-type "/" exe-name)))
         (sauthorize:do-as-calling-user
        (lambda ()
            (run-cmd "/bin/cp" (list spath dpath )) 
            (if (equal? access-type "publish")
              (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
              (begin
               (if (equal? group "none")
                 (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
                 (begin   
                     (run-cmd "/bin/chgrp" (list group dpath))
                       (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath))))))))
	(run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type)))))

(define (get-exe-name path group)
   (let ((name ""))
   (sauthorize:do-as-calling-user
        (lambda ()
        (if (equal? (current-effective-user-id) (file-owner path)) 
          (set! name (conc (current-user-name) "_" group))
          (begin
            (print "You cannot open areas that you dont own!!")  
             (exit 1)))))
name))

(define (sauthorize:valid-unix-user username)
    (let* ((ret-val #f))
    (let-values (((inp oup pid)
              (process "/usr/bin/id" (list username))))
        (let loop ((inl (read-line inp)))
          (if (string? inl) 
          (if (string-contains inl  "No such user") 
            (set! ret-val #f)
             (set! ret-val #t)))   
          (if (eof-object? inl)
              (begin
                   (close-input-port inp)
                  (close-output-port oup))
            (loop (read-line inp)))))
            ret-val))


;check if a paths/codes are vaid and if area is alrady open  
(define (open-area group path code access-type other-grps)
   (let* ((exe-name (get-exe-name path group))
           (path-obj (get-obj-by-path path))
           (code-obj (get-obj-by-code-no-grp-validation code)))
           ;(print path-obj)   
          (cond
            ((not (null? path-obj))
                (if (equal? code (car path-obj))
                  (begin
                     (if (equal? exe-name (cadr path-obj))
                        (begin
                            (if (not (exe-exist exe-name  access-type))
                                 (copy-exe access-type exe-name group)
                                 (begin 
                                  (print "Area already open!!")
                                  (exit 1))))   
			(begin
                           (if (not (exe-exist exe-name  access-type))
                                 (copy-exe access-type exe-name group))
                           ;; update exe-name  in db 
                      (sauthorize:db-do   (lambda (db)
                         (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj)))))
                        )))
                   (begin
                       (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n  sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type )
                       (exit 1))))
                      
            ((not (null? code-obj))
                   (print "Code " code " is used for diffrent path. Please try diffrent value of --code" ) 
                   (exit 1))
            (else
               ; (print (exe-exist exe-name  access-type))
                (if (not (exe-exist exe-name  access-type))
                        (copy-exe access-type exe-name group))
                (sauthorize:db-do   (lambda (db)
               (print conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') ") 
             (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') "))))))))

(define (user-has-open-perm user path access)
  (let* ((has-access #f)
         (eid (current-user-id)))
    (cond
     ((is-admin  user)
       (set! has-access #t ))
     ((and (is-read-admin  user) (equal? access "retrieve"))
       (set! has-access #t ))
     (else
        (print "User " user " does not have permission to open areas")))
        has-access))


;;check if user has group access
(define (is-group-washed req_grpid current-grp-list)
  (let loop ((hed (car current-grp-list))
		 (tal (cdr current-grp-list)))
                   (cond
                   ((equal? hed req_grpid)
                    #t)    
                   ((null? tal)
                      #f)
                   (else 
		  	(loop (car tal)(cdr tal))))))

;create executables with appropriate suids
(define (sauthorize:open user path group code access-type other-groups)
   (let* ((gpid (group-information group))
         (req_grpid (if (equal? group "none")
                      group 
                      (if (equal? gpid #f)
                           #f      
                     (caddr gpid))))
         (current-grp-list (get-groups))
         (valid-grp (if (equal? group "none")
                     group
                    (is-group-washed req_grpid current-grp-list))))
   (if (and (not (equal? group "none")) (equal? valid-grp #f ))
       (begin
       (print "Group " group " is not washed in the current xterm!!") 
       (exit 1)))) 
   (if (not (file-write-access? path))
     (begin
       (print "You can open areas owned by yourself. You do not have permissions to open path." path)
        (exit 1)))
   (if (user-has-open-perm user path access-type)
      (begin 
       ;(print "here")   
       (open-area group path code access-type other-groups)
       (sauthorize:grant user user code "2017/12/25"  "read-admin" "") 
       (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )"))))
         (print "Area has " path "  been opened for " access-type ))))

(define (sauthorize:update username exe area access-type)
  (let* ((parts (string-split exe "_"))
         (owner (car parts))
         (group (cadr parts))
         (gpid (group-information group))
         (req_grpid (if (equal? group "none")
                      group 
                      (if (equal? gpid #f)
                           #f      
                     (caddr gpid))))
 
         (current-grp-list (get-groups))
         (valid-grp (if (equal? group "none")
                     group
                    (is-group-washed req_grpid current-grp-list))))
         (if (not (equal? username owner))
            (begin
              (print "You cannot update " area ". Only " owner " can update this area!!") 
               (exit 1)))
          (copy-exe access-type exe group)
           (print "recording action..")    
          (sauthorize:db-do   (lambda (db)
             
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize update " area " --" access-type "'," (car (get-user username)) "," (car (get-area area)) ", 'update' )"))))
         (print "Area has " area "  been update!!" )))

(define (sauthorize:grant auser guser area exp-date access-type restrict)
    ; check if user exist in db
    (let* ((area-obj (get-area area))
           (auser-obj (get-user auser)) 
           (user-obj (get-user guser)))
          
        (if (null? user-obj)
           (begin
            ;; is guser a valid unix user
            (if (not (sauthorize:valid-unix-user guser))
               (begin  
                (print "User " guser " is Invalid unix user!!")
                 (exit 1)))
            (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') "))))
             (set! user-obj (get-user guser))))
        (let* ((perm-obj (get-perm (car user-obj) (car area-obj))))
          (if(null? perm-obj)
          (begin   
            ;; insert permissions
            (sauthorize:db-do   (lambda (db)
            (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')")))))
          (begin 
             ;update permissions
             (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration =  '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj)))))))
             (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )"))))  
             (print "Permission has been sucessfully granted to user " guser))))

(define (sauthorize:process-action  username action . args)
   (case (string->symbol action)
   ((grant)
      (if (< (length args) 6)
         (begin 
	     (print  "ERROR: Missing arguments; " (string-intersperse args ", "))
	     (exit 1)))
       (let* ((remargs     (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0))
              (guser     (car args))
	      (restrict         (or (args:get-arg "--restrict") ""))
              (area         (or (args:get-arg "--area") ""))  
              (exp-date        (or (args:get-arg "--expiration") ""))
              (access-type (get-access-type remargs)))
	; (print  "version " guser " restrict " restrict )
        ; (print "area " area " exp-date " exp-date " access-type " access-type)
        (cond
           ((equal? guser "")
              (print "Username not found!! Try \"sauthorize help\" for useage ")
               (exit 1))   
           ((equal? area "")
              (print "Area not found!! Try \"sauthorize help\" for useage ")
              (exit 1)) 
           ((equal? access-type #f)
              (print "Access type not found!! Try \"sauthorize help\" for useage ")
               (exit 1)) 
           ((equal? exp-date "")
              (print "Date of expiration not found!! Try \"sauthorize help\" for useage ")
              (exit 1)))
           (if (not (area-exists area))
              (begin
              (print "Area does not exisit!!")
              (exit 1)))   
           (if (can-grant-perm username access-type area)
	   (begin
             (print "calling sauthorize:grant ") 
              (sauthorize:grant username guser area exp-date access-type restrict))   
           (begin
              (print "User " username " does not have permission to grant permissions to area " area "!!")
              (exit 1)))))
       ((list-area-user)
          (if (not (equal? (length args) 1))
              (begin
              (print "Missing argument area code to list-area-user ") 
              (exit 1)))
           (let* ((area (car args)))
           (if (not (area-exists area))
              (begin
              (print "Area does not exisit!!")
              (exit 1))) 
                                
                (sauthorize:list-areausers  area )
              ))
      ((read-shell)
          (if (not (equal? (length args) 1))
              (begin
              (print "Missing argument area code to read-shell ") 
              (exit 1)))
           (let* ((area (car args))
                  (code-obj (get-obj-by-code area)))
           (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  "retrieve")))
              (begin
              (print "Area " area " is not open for reading!!")
              (exit 1))) 
              (sauthorize:do-as-calling-user
             (lambda ()
                (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area ))))))
      ((write-shell)
          (if (not (equal? (length args) 1))
              (begin
              (print "Missing argument area code to read-shell ") 
              (exit 1)))
           (let* ((area (car args))
                  (code-obj (get-obj-by-code area)))
           (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  "publish")))
              (begin
              (print "Area " area " is not open for Writing!!")
              (exit 1))) 
              (sauthorize:do-as-calling-user
             (lambda ()
                (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area))))))
      ((publish)
          (if (< (length args) 2)
              (begin
              (print "Missing argument to publish. \n publish <action> <area> [opts] ") 
              (exit 1)))
            
           (let* ((action (car args))
                  (area (cadr args))
                  (cmd-args (cddr args)) 
                  (code-obj (get-obj-by-code area)))
           ;(print "area " area)
           ;(print "code: " code-obj)  
           ;(print (exe-exist (cadr code-obj)  "publish")) 
           (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  "publish")))
              (begin
              (print "Area " area " is not open for writing!!")
              (exit 1)))
              ;(print "hear") 
              (sauthorize:do-as-calling-user
             (lambda ()
               ; (print  *exe-path* "/publish/" (cadr code-obj) action area cmd-args  )
                (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
      
     ((retrieve)
          (if (< (length args) 2)
              (begin
              (print "Missing argument to publish. \n publish <action> <area> [opts] ") 
              (exit 1)))
           (let* ((action (car args))
                  (area (cadr args))
                  (cmd-args (cddr args)) 
                  (code-obj (get-obj-by-code area)))
           (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  "retrieve")))
              (begin
              (print "Area " area " is not open for reading!!")
              (exit 1))) 
               ;(print (conc *exe-path* "/retrieve/" (cadr code-obj) " " action " " area " " (string-join cmd-args)))
              (sauthorize:do-as-calling-user
             (lambda ()
                (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args))))))

 
 
      ((open)
         (if (< (length args) 6)
              (begin
              (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open <path> --group <grpname> --code <unique short identifier for an area> --retrieve|--publish") 
              (exit 1)))
         (let* ((remargs     (args:get-args args '("--group" "--code" "--additional-grps") '() args:arg-hash 0))
              (path     (car args))
	      (group         (or (args:get-arg "--group") ""))
              (area         (or (args:get-arg "--code") ""))
              (other-grps          (or (args:get-arg "--additional-grps") ""))     
              (access-type (get-access-type remargs)))
                
              (cond
                ((equal? path "")
                  (print "path not found!! Try \"sauthorize help\" for useage ")
                  (exit 1))   
                ((equal? area "")
                  (print "--code not found!! Try \"sauthorize help\" for useage ")
                  (exit 1)) 
                ((equal? access-type #f)
                  (print "Access type not found!! Try \"sauthorize help\" for useage ")
                  (exit 1)) 
                ((and (not (equal? access-type "publish")) 
                  (not (equal? access-type "retrieve")))
                  (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ")
                  (exit 1)))
                ; (print other-grps) 
                (sauthorize:open username path group area access-type other-grps)))
         ((update)
            (if (< (length args) 2)
              (begin
              (print "sauthorize update cmd takes 2 arguments!! \n Useage: sauthorize update <area-code> --retrieve|--publish") 
              (exit 1)))
              (let* ((area (car args))
                     (code-obj (get-obj-by-code area))
                    (access-type (get-access-type (cdr args))))
               (if  (and (not (equal? access-type "publish")) (not (equal? access-type "retrieve")))
                  (begin 
                  (print "Access type can be --retrieve|--publish ")
                  (exit 1)))
              (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  access-type)))
              (begin
              (print "Area " area " is not open for reading!!")
              (exit 1))) 
              (sauthorize:update username (cadr code-obj) area access-type ))) 
         ((area-admin)
           (let* ((usr (car args))
                  (usr-obj (get-user usr))
                  (user-id (car (get-user username))))
           
                (if (is-admin  username)
                (begin
                  ; (print usr-obj) 
                  (if (null? usr-obj)
                    (begin
                        (sauthorize:db-do   (lambda (db)
              ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))
             (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")))))
               (begin
                ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) ))
                 (sauthorize:db-do   (lambda (db)
                (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj)))))))
                (print "User " usr " is updated with area-admin access!"))
                (print "Admin only function"))
                (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" )))))) 
          ((mk-admin)
           (let* ((usr (car args))
                  (usr-obj (get-user usr))
                  (user-id (car (get-user username))))
                (if (not (sauthorize:valid-unix-user usr))
               (begin  
                (print "User " usr " is Invalid unix user!!")
                 (exit 1)))

                (if (member  username  *super-users*)
                (begin
                  (if (null? usr-obj)
                    (begin
                        (sauthorize:db-do   (lambda (db)
                           (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'yes' )")))))
               (begin
                 (sauthorize:db-do   (lambda (db)
                (sauthorize:db-qry db (conc "update users set is_admin = 'yes' where id = " (car usr-obj)))))))
                (print "User " usr " is updated with admin access!"))
                (print "Super-Admin only function"))
                (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('mk-admin " usr " ', " user-id ",0, 'mk-admin ')" )))))) 

         ((register-log)
            (if (< (length args) 4)
                (print "Invalid arguments"))
             ;(print args)
             (let* ((cmd-line (car args))
                     (user-id (cadr args))
                     (area-id (caddr args))
                     (user-obj (get-user username))
                      (cmd (cadddr args)))
                
               (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj))))
                (begin 
                (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" )))))
                (print "You ar not authorised to run this cmd")

)))     

       
      (else (print 0 "Unrecognised command " action))))
  
(define (main)
  (let* ((args      (argv))
	 (prog      (car args))
	 (rema      (cdr args))
         (username     (current-user-name)))
    ;; preserve the exe data in the config file
    (cond
     ;; one-word commands
     ((eq? (length rema) 1)
      (case (string->symbol (car rema))
	((help -h -help --h --help)
	 (print sauthorize:help))
	((list)
            
          (sauthorize:db-do  (lambda (db)
				     (print "My Area accesses: ")
				     (query (for-each-row
					     (lambda (row)
                                               (let* ((exp-date (car row)))
                                                (if  (is-access-valid  exp-date)     
					           (apply print (intersperse (cdr row) " | "))))))
					    (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type  FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'"))))))
         
	((log)
	 (sauthorize:db-do  (lambda (db)
				     (print "Logs : ")
				     (query (for-each-row
					     (lambda (row)
                                                   
					       (apply print (intersperse row " | "))))
					    (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code  FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id ")))))
	(else
	 (print "ERROR: Unrecognised command. Try \"sauthorize help\""))))
     ;; multi-word commands
     ((null? rema)(print sauthorize:help))
     ((>= (length rema) 2)
      (apply sauthorize:process-action username (car rema)(cdr rema)))
     (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\"")))))

(main)


      

Deleted sauthorize.scm version [b4d2f08e65].

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

;; Copyright 2006-2013, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

(use defstruct)
(use scsh-process)

(use srfi-18)
(use srfi-19)
(use refdb)

(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
;(declare (uses common))
;(declare (uses configf))
(declare (uses margs))

(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. 
(include "sauth-paths.scm")
(include "sauth-common.scm")

;;
;; GLOBALS
;;
(define *verbosity* 1)
(define *logging* #f)
(define *exe-name* (pathname-file (car (argv))))
(define *sretrieve:current-tab-number* 0)
(define *args-hash* (make-hash-table))
(define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]]

  list                   		 			: list areas $USER's can access
  log                    		 			: get listing of recent activity.
  sauth  list-area-user <area code> 			: list the users that can access the area.
  sauth open <path> --group <grpname>                      : Open up an area. User needs to be the owner of the area to open it. 
              --code <unique short identifier for an area> 
              --retrieve|--publish [--additional-grps <comma separated unix grps requierd to get to the path>]
  sauth update <area code>  --retrieve|--publish             : update the binaries with the lates changes
  sauth grant <username> --area <area identifier>          : Grant permission to read or write to a area that is alrady opend up.    
             --expiration yyyy/mm/dd --retrieve|--publish 
             [--restrict <comma separated directory names> ]  
  sauth read-shell <area identifier>                       :  Open sretrieve shell for reading.  
  sauth write-shell <area identifier>                      :  Open spublish shell for writing.
   
Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest

Version: " megatest-fossil-hash)) ;; "

;;======================================================================
;; RECORDS
;;======================================================================

;;======================================================================
;; DB
;;======================================================================

;; replace (strftime('%s','now')), with datetime('now'))
(define (sauthorize:initialize-db db)
  (for-each
   (lambda (qry)
     (exec (sql db qry)))
   (list 
    "CREATE TABLE IF NOT EXISTS actions
         (id           INTEGER PRIMARY KEY,
          cmd       TEXT NOT NULL,
          user_id      INTEGER NOT NULL,
          datetime     TIMESTAMP DEFAULT (datetime('now','localtime')),
          area_id      INTEGER NOT NULL,
          comment      TEXT DEFAULT '' NOT NULL,
          action_type  TEXT NOT NULL);"
        "CREATE TABLE IF NOT EXISTS users
         (id           INTEGER PRIMARY KEY,
          username     TEXT NOT NULL,
          is_admin     TEXT NOT NULL,
          datetime     TIMESTAMP DEFAULT (datetime('now','localtime'))
          );" 
          "CREATE TABLE IF NOT EXISTS areas
         (id           INTEGER PRIMARY KEY,
          basepath     TEXT NOT NULL,
          code         TEXT NOT NULL,
          exe_name     TEXT NOT NULL,
          required_grps TEXT DEFAULT '' NOT NULL,
          datetime     TIMESTAMP DEFAULT (datetime('now','localtime'))
          );" 
         "CREATE TABLE IF NOT EXISTS permissions
         (id              INTEGER PRIMARY KEY,
          access_type     TEXT NOT NULL,
          user_id         INTEGER NOT NULL,
          datetime        TIMESTAMP DEFAULT (datetime('now','localtime')),
          area_id         INTEGER NOT NULL,
          restriction     TEXT DEFAULT '' NOT NULL,
          expiration       TIMESTAMP DEFAULT NULL);"
    )))




(define (get-access-type args)
   (let loop ((hed (car args))
		 (tal (cdr args)))
                   (cond
                   ((equal? hed "--retrieve")
                      "retrieve") 
                   ((equal? hed "--publish")
                      "publish") 
                   ((equal? hed "--area-admin")
                      "area-admin")
                   ((equal? hed "--writer-admin")
                      "writer-admin")
                   ((equal? hed "--read-admin")
                      "read-admin")

                   ((null? tal)
                      #f) 
                   (else 
		  	(loop (car tal)(cdr tal))))))



;; check if user can gran access to an area
(define (can-grant-perm username access-type area)
   (let* ((isadmin (is-admin username))
          (is-area-admin (is-user "area-admin" username area ))
          (is-read-admin (is-user "read-admin" username area) )
          (is-writer-admin (is-user "writer-admin" username area) ) )
   (cond
   ((equal? isadmin  #t)
     #t)
   ((equal? is-area-admin #t ) 
     #t)
   ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve"))
     #t)
   ((and (equal? is-read-admin #t ) (equal? access-type "retrieve"))
     #t)

   (else  
    #f))))

(define (sauthorize:list-areausers  area )
  (sauthorize:db-do  (lambda (db)
				     (print "Users having access to " area ":")
				     (query (for-each-row
					     (lambda (row)
                                               (let* ((exp-date (cadr row)))
                                                (if  (is-access-valid  exp-date)   
					        (apply print (intersperse row " | "))))))
					    (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type  FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'"))))))




; check if executable exists
(define (exe-exist exe access-type)
    (let* ((filepath (conc *exe-path* "/" access-type "/" exe)))
    ; (print filepath)
     (if (file-exists? filepath)
       #t
       #f)))

(define (copy-exe access-type exe-name group)
  (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type)))
  (let* ((spath (conc *exe-src*  "/s" access-type))
         (dpath (conc *exe-path* "/" access-type "/" exe-name)))
         (sauthorize:do-as-calling-user
        (lambda ()
            (run-cmd "/bin/cp" (list spath dpath )) 
            (if (equal? access-type "publish")
              (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
              (begin
               (if (equal? group "none")
                 (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
                 (begin   
                     (run-cmd "/bin/chgrp" (list group dpath))
                       (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath))))))))
	(run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type)))))

(define (get-exe-name path group)
   (let ((name ""))
   (sauthorize:do-as-calling-user
        (lambda ()
        (if (equal? (current-effective-user-id) (file-owner path)) 
          (set! name (conc (current-user-name) "_" group))
          (begin
            (print "You cannot open areas that you dont own!!")  
             (exit 1)))))
name))

(define (sauthorize:valid-unix-user username)
    (let* ((ret-val #f))
    (let-values (((inp oup pid)
              (process "/usr/bin/id" (list username))))
        (let loop ((inl (read-line inp)))
          (if (string? inl) 
          (if (string-contains inl  "No such user") 
            (set! ret-val #f)
             (set! ret-val #t)))   
          (if (eof-object? inl)
              (begin
                   (close-input-port inp)
                  (close-output-port oup))
            (loop (read-line inp)))))
            ret-val))


;check if a paths/codes are vaid and if area is alrady open  
(define (open-area group path code access-type other-grps)
   (let* ((exe-name (get-exe-name path group))
           (path-obj (get-obj-by-path path))
           (code-obj (get-obj-by-code-no-grp-validation code)))
           ;(print path-obj)   
          (cond
            ((not (null? path-obj))
                (if (equal? code (car path-obj))
                  (begin
                     (if (equal? exe-name (cadr path-obj))
                        (begin
                            (if (not (exe-exist exe-name  access-type))
                                 (copy-exe access-type exe-name group)
                                 (begin 
                                  (print "Area already open!!")
                                  (exit 1))))   
			(begin
                           (if (not (exe-exist exe-name  access-type))
                                 (copy-exe access-type exe-name group))
                           ;; update exe-name  in db 
                      (sauthorize:db-do   (lambda (db)
                         (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj)))))
                        )))
                   (begin
                       (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n  sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type )
                       (exit 1))))
                      
            ((not (null? code-obj))
                   (print "Code " code " is used for diffrent path. Please try diffrent value of --code" ) 
                   (exit 1))
            (else
               ; (print (exe-exist exe-name  access-type))
                (if (not (exe-exist exe-name  access-type))
                        (copy-exe access-type exe-name group))
                (sauthorize:db-do   (lambda (db)
               (print conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') ") 
             (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name, required_grps) values ('" code "', '" path "', '" exe-name "', '" other-grps "') "))))))))

(define (user-has-open-perm user path access)
  (let* ((has-access #f)
         (eid (current-user-id)))
    (cond
     ((is-admin  user)
       (set! has-access #t ))
     ((and (is-read-admin  user) (equal? access "retrieve"))
       (set! has-access #t ))
     (else
        (print "User " user " does not have permission to open areas")))
        has-access))


;;check if user has group access
(define (is-group-washed req_grpid current-grp-list)
  (let loop ((hed (car current-grp-list))
		 (tal (cdr current-grp-list)))
                   (cond
                   ((equal? hed req_grpid)
                    #t)    
                   ((null? tal)
                      #f)
                   (else 
		  	(loop (car tal)(cdr tal))))))

;create executables with appropriate suids
(define (sauthorize:open user path group code access-type other-groups)
   (let* ((gpid (group-information group))
         (req_grpid (if (equal? group "none")
                      group 
                      (if (equal? gpid #f)
                           #f      
                     (caddr gpid))))
         (current-grp-list (get-groups))
         (valid-grp (if (equal? group "none")
                     group
                    (is-group-washed req_grpid current-grp-list))))
   (if (and (not (equal? group "none")) (equal? valid-grp #f ))
       (begin
       (print "Group " group " is not washed in the current xterm!!") 
       (exit 1)))) 
   (if (not (file-write-access? path))
     (begin
       (print "You can open areas owned by yourself. You do not have permissions to open path." path)
        (exit 1)))
   (if (user-has-open-perm user path access-type)
      (begin 
       ;(print "here")   
       (open-area group path code access-type other-groups)
       (sauthorize:grant user user code "2017/12/25"  "read-admin" "") 
       (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )"))))
         (print "Area has " path "  been opened for " access-type ))))

(define (sauthorize:update username exe area access-type)
  (let* ((parts (string-split exe "_"))
         (owner (car parts))
         (group (cadr parts))
         (gpid (group-information group))
         (req_grpid (if (equal? group "none")
                      group 
                      (if (equal? gpid #f)
                           #f      
                     (caddr gpid))))
 
         (current-grp-list (get-groups))
         (valid-grp (if (equal? group "none")
                     group
                    (is-group-washed req_grpid current-grp-list))))
         (if (not (equal? username owner))
            (begin
              (print "You cannot update " area ". Only " owner " can update this area!!") 
               (exit 1)))
          (copy-exe access-type exe group)
           (print "recording action..")    
          (sauthorize:db-do   (lambda (db)
             
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize update " area " --" access-type "'," (car (get-user username)) "," (car (get-area area)) ", 'update' )"))))
         (print "Area has " area "  been update!!" )))

(define (sauthorize:grant auser guser area exp-date access-type restrict)
    ; check if user exist in db
    (let* ((area-obj (get-area area))
           (auser-obj (get-user auser)) 
           (user-obj (get-user guser)))
          
        (if (null? user-obj)
           (begin
            ;; is guser a valid unix user
            (if (not (sauthorize:valid-unix-user guser))
               (begin  
                (print "User " guser " is Invalid unix user!!")
                 (exit 1)))
            (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') "))))
             (set! user-obj (get-user guser))))
        (let* ((perm-obj (get-perm (car user-obj) (car area-obj))))
          (if(null? perm-obj)
          (begin   
            ;; insert permissions
            (sauthorize:db-do   (lambda (db)
            (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')")))))
          (begin 
             ;update permissions
             (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration =  '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj)))))))
             (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )"))))  
             (print "Permission has been sucessfully granted to user " guser))))

(define (sauthorize:process-action  username action . args)
   (case (string->symbol action)
   ((grant)
      (if (< (length args) 6)
         (begin 
	     (print  "ERROR: Missing arguments; " (string-intersperse args ", "))
	     (exit 1)))
       (let* ((remargs     (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0))
              (guser     (car args))
	      (restrict         (or (args:get-arg "--restrict") ""))
              (area         (or (args:get-arg "--area") ""))  
              (exp-date        (or (args:get-arg "--expiration") ""))
              (access-type (get-access-type remargs)))
	; (print  "version " guser " restrict " restrict )
        ; (print "area " area " exp-date " exp-date " access-type " access-type)
        (cond
           ((equal? guser "")
              (print "Username not found!! Try \"sauthorize help\" for useage ")
               (exit 1))   
           ((equal? area "")
              (print "Area not found!! Try \"sauthorize help\" for useage ")
              (exit 1)) 
           ((equal? access-type #f)
              (print "Access type not found!! Try \"sauthorize help\" for useage ")
               (exit 1)) 
           ((equal? exp-date "")
              (print "Date of expiration not found!! Try \"sauthorize help\" for useage ")
              (exit 1)))
           (if (not (area-exists area))
              (begin
              (print "Area does not exisit!!")
              (exit 1)))   
           (if (can-grant-perm username access-type area)
	   (begin
             (print "calling sauthorize:grant ") 
              (sauthorize:grant username guser area exp-date access-type restrict))   
           (begin
              (print "User " username " does not have permission to grant permissions to area " area "!!")
              (exit 1)))))
       ((list-area-user)
          (if (not (equal? (length args) 1))
              (begin
              (print "Missing argument area code to list-area-user ") 
              (exit 1)))
           (let* ((area (car args)))
           (if (not (area-exists area))
              (begin
              (print "Area does not exisit!!")
              (exit 1))) 
                                
                (sauthorize:list-areausers  area )
              ))
      ((read-shell)
          (if (not (equal? (length args) 1))
              (begin
              (print "Missing argument area code to read-shell ") 
              (exit 1)))
           (let* ((area (car args))
                  (code-obj (get-obj-by-code area)))
           (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  "retrieve")))
              (begin
              (print "Area " area " is not open for reading!!")
              (exit 1))) 
              (sauthorize:do-as-calling-user
             (lambda ()
                (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area ))))))
      ((write-shell)
          (if (not (equal? (length args) 1))
              (begin
              (print "Missing argument area code to read-shell ") 
              (exit 1)))
           (let* ((area (car args))
                  (code-obj (get-obj-by-code area)))
           (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  "publish")))
              (begin
              (print "Area " area " is not open for Writing!!")
              (exit 1))) 
              (sauthorize:do-as-calling-user
             (lambda ()
                (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area))))))
      ((publish)
          (if (< (length args) 2)
              (begin
              (print "Missing argument to publish. \n publish <action> <area> [opts] ") 
              (exit 1)))
            
           (let* ((action (car args))
                  (area (cadr args))
                  (cmd-args (cddr args)) 
                  (code-obj (get-obj-by-code area)))
           ;(print "area " area)
           ;(print "code: " code-obj)  
           ;(print (exe-exist (cadr code-obj)  "publish")) 
           (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  "publish")))
              (begin
              (print "Area " area " is not open for writing!!")
              (exit 1)))
              ;(print "hear") 
              (sauthorize:do-as-calling-user
             (lambda ()
               ; (print  *exe-path* "/publish/" (cadr code-obj) action area cmd-args  )
                (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
      
     ((retrieve)
          (if (< (length args) 2)
              (begin
              (print "Missing argument to publish. \n publish <action> <area> [opts] ") 
              (exit 1)))
           (let* ((action (car args))
                  (area (cadr args))
                  (cmd-args (cddr args)) 
                  (code-obj (get-obj-by-code area)))
           (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  "retrieve")))
              (begin
              (print "Area " area " is not open for reading!!")
              (exit 1))) 
               ;(print (conc *exe-path* "/retrieve/" (cadr code-obj) " " action " " area " " (string-join cmd-args)))
              (sauthorize:do-as-calling-user
             (lambda ()
                (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args))))))

 
 
      ((open)
         (if (< (length args) 6)
              (begin
              (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open <path> --group <grpname> --code <unique short identifier for an area> --retrieve|--publish") 
              (exit 1)))
         (let* ((remargs     (args:get-args args '("--group" "--code" "--additional-grps") '() args:arg-hash 0))
              (path     (car args))
	      (group         (or (args:get-arg "--group") ""))
              (area         (or (args:get-arg "--code") ""))
              (other-grps          (or (args:get-arg "--additional-grps") ""))     
              (access-type (get-access-type remargs)))
                
              (cond
                ((equal? path "")
                  (print "path not found!! Try \"sauthorize help\" for useage ")
                  (exit 1))   
                ((equal? area "")
                  (print "--code not found!! Try \"sauthorize help\" for useage ")
                  (exit 1)) 
                ((equal? access-type #f)
                  (print "Access type not found!! Try \"sauthorize help\" for useage ")
                  (exit 1)) 
                ((and (not (equal? access-type "publish")) 
                  (not (equal? access-type "retrieve")))
                  (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ")
                  (exit 1)))
                ; (print other-grps) 
                (sauthorize:open username path group area access-type other-grps)))
         ((update)
            (if (< (length args) 2)
              (begin
              (print "sauthorize update cmd takes 2 arguments!! \n Useage: sauthorize update <area-code> --retrieve|--publish") 
              (exit 1)))
              (let* ((area (car args))
                     (code-obj (get-obj-by-code area))
                    (access-type (get-access-type (cdr args))))
               (if  (and (not (equal? access-type "publish")) (not (equal? access-type "retrieve")))
                  (begin 
                  (print "Access type can be --retrieve|--publish ")
                  (exit 1)))
              (if (or (null? code-obj)
                   (not (exe-exist (cadr code-obj)  access-type)))
              (begin
              (print "Area " area " is not open for reading!!")
              (exit 1))) 
              (sauthorize:update username (cadr code-obj) area access-type ))) 
         ((area-admin)
           (let* ((usr (car args))
                  (usr-obj (get-user usr))
                  (user-id (car (get-user username))))
           
                (if (is-admin  username)
                (begin
                  ; (print usr-obj) 
                  (if (null? usr-obj)
                    (begin
                        (sauthorize:db-do   (lambda (db)
              ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))
             (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")))))
               (begin
                ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) ))
                 (sauthorize:db-do   (lambda (db)
                (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj)))))))
                (print "User " usr " is updated with area-admin access!"))
                (print "Admin only function"))
                (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" )))))) 
          ((mk-admin)
           (let* ((usr (car args))
                  (usr-obj (get-user usr))
                  (user-id (car (get-user username))))
                (if (not (sauthorize:valid-unix-user usr))
               (begin  
                (print "User " usr " is Invalid unix user!!")
                 (exit 1)))

                (if (member  username  *super-users*)
                (begin
                  (if (null? usr-obj)
                    (begin
                        (sauthorize:db-do   (lambda (db)
                           (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'yes' )")))))
               (begin
                 (sauthorize:db-do   (lambda (db)
                (sauthorize:db-qry db (conc "update users set is_admin = 'yes' where id = " (car usr-obj)))))))
                (print "User " usr " is updated with admin access!"))
                (print "Super-Admin only function"))
                (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('mk-admin " usr " ', " user-id ",0, 'mk-admin ')" )))))) 

         ((register-log)
            (if (< (length args) 4)
                (print "Invalid arguments"))
             ;(print args)
             (let* ((cmd-line (car args))
                     (user-id (cadr args))
                     (area-id (caddr args))
                     (user-obj (get-user username))
                      (cmd (cadddr args)))
                
               (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj))))
                (begin 
                (sauthorize:db-do   (lambda (db)
             (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" )))))
                (print "You ar not authorised to run this cmd")

)))     

       
      (else (print 0 "Unrecognised command " action))))
  
(define (main)
  (let* ((args      (argv))
	 (prog      (car args))
	 (rema      (cdr args))
         (username     (current-user-name)))
    ;; preserve the exe data in the config file
    (cond
     ;; one-word commands
     ((eq? (length rema) 1)
      (case (string->symbol (car rema))
	((help -h -help --h --help)
	 (print sauthorize:help))
	((list)
            
          (sauthorize:db-do  (lambda (db)
				     (print "My Area accesses: ")
				     (query (for-each-row
					     (lambda (row)
                                               (let* ((exp-date (car row)))
                                                (if  (is-access-valid  exp-date)     
					           (apply print (intersperse (cdr row) " | "))))))
					    (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type  FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'"))))))
         
	((log)
	 (sauthorize:db-do  (lambda (db)
				     (print "Logs : ")
				     (query (for-each-row
					     (lambda (row)
                                                   
					       (apply print (intersperse row " | "))))
					    (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code  FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id ")))))
	(else
	 (print "ERROR: Unrecognised command. Try \"sauthorize help\""))))
     ;; multi-word commands
     ((null? rema)(print sauthorize:help))
     ((>= (length rema) 2)
      (apply sauthorize:process-action username (car rema)(cdr rema)))
     (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\"")))))

(main)


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






















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Modified server.scm from [7b2af2dc7e] to [c89e2532fc].

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
;;(declare (uses rpc-transport))
(declare (uses launch))
;; (declare (uses daemon))

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

(define (server:make-server-url hostport)
  (if (not hostport)
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

(define  *server-loop-heart-beat* (current-seconds))

;;======================================================================
;; P K T S   S T U F F 
;;======================================================================

;; ???

;;======================================================================
;; P K T S   S T U F F 
;;======================================================================

;; ???

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

;; Call this to start the actual server
;;








|






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







33
34
35
36
37
38
39
40
41
42
43
44
45
46












47
48
49
50
51
52
53
;;(declare (uses rpc-transport))
(declare (uses launch))
;; (declare (uses daemon))

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

#;(define (server:make-server-url hostport)
  (if (not hostport)
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

(define  *server-loop-heart-beat* (current-seconds))













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

;; Call this to start the actual server
;;

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
    (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type))))

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

;; Get the transport
(define (server:get-transport)
  (if *transport-type*
      *transport-type*
      (let ((ttype (string->symbol
		    (or (args:get-arg "-transport")
			(configf:lookup *configdat* "server" "transport")
			"rpc"))))
	(set! *transport-type* ttype)
	ttype)))
	    
;; Generate a unique signature for this server
(define (server:mk-signature)
  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list (current-directory)
					  (argv)))))))

;; When using zmq this would send the message back (two step process)
;; with spiffy or rpc this simply returns the return data to be returned
;; 
(define (server:reply return-addr query-sig success/fail result)
  (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
  ;; (send-message pubsock target send-more: #t)
  ;; (send-message pubsock 
  (case (server:get-transport)
    ((rpc)  (db:obj->string (vector success/fail query-sig result)))
    ((http) (db:obj->string (vector success/fail query-sig result)))
    ((fs)   result)
    (else 
     (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
     result)))

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







|

















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







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
    (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type))))

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

;; Get the transport
#;(define (server:get-transport)
  (if *transport-type*
      *transport-type*
      (let ((ttype (string->symbol
		    (or (args:get-arg "-transport")
			(configf:lookup *configdat* "server" "transport")
			"rpc"))))
	(set! *transport-type* ttype)
	ttype)))
	    
;; Generate a unique signature for this server
(define (server:mk-signature)
  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list (current-directory)
					  (argv)))))))
















;; 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))
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
(define (server:record->url servr)
  (match-let (((mod-time host port start-time pid)
	       servr))
    (if (and host port)
	(conc host ":" port)
	#f)))

(define (server:get-client-signature) ;; BB> why is this proc named "get-"?  it returns nothing -- set! has not return value.
  (if *my-client-signature* *my-client-signature*
      (let ((sig (server:mk-signature)))
        (set! *my-client-signature* sig)
        *my-client-signature*)))

;; wait for server=start-last to be three seconds old
;;







|







284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
(define (server:record->url servr)
  (match-let (((mod-time host port start-time pid)
	       servr))
    (if (and host port)
	(conc host ":" port)
	#f)))

#;(define (server:get-client-signature) ;; BB> why is this proc named "get-"?  it returns nothing -- set! has not return value.
  (if *my-client-signature* *my-client-signature*
      (let ((sig (server:mk-signature)))
        (set! *my-client-signature* sig)
        *my-client-signature*)))

;; wait for server=start-last to be three seconds old
;;
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
	    (if (and (> try-num 0)  ;; first time through simply wait a little while then try again
		     (< num-ok 1))  ;; if there are no decent candidates for servers then try starting a new one
		(server:kind-run areapath))
	    (thread-sleep! 5)
	    (loop (server:check-if-running areapath)
		  (+ try-num 1)))))))

(define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG.

(define (server:get-num-servers #!key (numservers 2))
  (let ((ns (string->number
	     (or (configf:lookup *configdat* "server" "numservers") "notanumber"))))
    (or ns numservers)))

;; no longer care if multiple servers are started by accident. older servers will drop off in time.
;;







<
<







362
363
364
365
366
367
368


369
370
371
372
373
374
375
	    (if (and (> try-num 0)  ;; first time through simply wait a little while then try again
		     (< num-ok 1))  ;; if there are no decent candidates for servers then try starting a new one
		(server:kind-run areapath))
	    (thread-sleep! 5)
	    (loop (server:check-if-running areapath)
		  (+ try-num 1)))))))



(define (server:get-num-servers #!key (numservers 2))
  (let ((ns (string->number
	     (or (configf:lookup *configdat* "server" "numservers") "notanumber"))))
    (or ns numservers)))

;; no longer care if multiple servers are started by accident. older servers will drop off in time.
;;
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
;;
;; NOTE: This is NOT called directly from clients as not all transports support a client running
;;       in the same process as the server.
;;
(define (server:ping host-port-in #!key (do-exit #f))
  (let ((host:port (if (not host-port-in) ;; use read-dotserver to find
		       #f ;; (server:check-if-running *toppath*)
		;; (if (number? host-port-in) ;; we were handed a server-id
		;; 	   (let ((srec (tasks:get-server-by-id (db:delay-if-busy (tasks:open-db)) host-port-in)))
		;; 	     ;; (print "srec: " srec " host-port-in: " host-port-in)
		;; 	     (if srec
		;; 		 (conc (vector-ref srec 3) ":" (vector-ref srec 4))
		;; 		 (conc "no such server-id " host-port-in)))
		       host-port-in))) ;; )
    (let* ((host-port (if host:port
			  (let ((slst (string-split   host:port ":")))
			    (if (eq? (length slst) 2)
				(list (car slst)(string->number (cadr slst)))
				#f))
			  #f)))
;;	   (toppath       (launch:setup)))
      ;; (print "host-port=" host-port)
      (if (not host-port)
	  (begin
	    (if host-port-in
		(debug:print 0 *default-log-port*  "ERROR: bad host:port"))
	    (if do-exit (exit 1))
	    #f)
	  (let* ((iface      (car host-port))







<
<
<
<
<
<
|






<
<







413
414
415
416
417
418
419






420
421
422
423
424
425
426


427
428
429
430
431
432
433
;;
;; NOTE: This is NOT called directly from clients as not all transports support a client running
;;       in the same process as the server.
;;
(define (server:ping host-port-in #!key (do-exit #f))
  (let ((host:port (if (not host-port-in) ;; use read-dotserver to find
		       #f ;; (server:check-if-running *toppath*)






		       host-port-in)))
    (let* ((host-port (if host:port
			  (let ((slst (string-split   host:port ":")))
			    (if (eq? (length slst) 2)
				(list (car slst)(string->number (cadr slst)))
				#f))
			  #f)))


      (if (not host-port)
	  (begin
	    (if host-port-in
		(debug:print 0 *default-log-port*  "ERROR: bad host:port"))
	    (if do-exit (exit 1))
	    #f)
	  (let* ((iface      (car host-port))
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
       (if (eof-object? inl)
	   (case (string->symbol res)
	     ((NOREPLY)  #f)
	     ((LOGIN_OK) #t)
	     (else       #f))
	   (loop (read-line) inl))))))

;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).
;;
(define (server:login toppath)
  (lambda (toppath)
    (set! *db-last-access* (current-seconds)) ;; might not be needed.
    (if (equal? *toppath* toppath)
	#t
	#f)))

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







<
<
<
<
<
<
<
<
<







456
457
458
459
460
461
462









463
464
465
466
467
468
469
       (if (eof-object? inl)
	   (case (string->symbol res)
	     ((NOREPLY)  #f)
	     ((LOGIN_OK) #t)
	     (else       #f))
	   (loop (read-line) inl))))))










;; timeout is hms string: 1h 5m 3s, default is 1 minute
;;
(define (server:expiration-timeout)
  (let ((tmo (configf:lookup *configdat* "server" "timeout")))
    (if (and (string? tmo)
	     (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
        (* 3600 (string->number tmo))
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
     ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
    (string-intersperse 
     (map number->string
	  (u8vector->list
	   (if res res (hostname->ip hostname)))) ".")))

;; (define server:sync-lock-token "SERVER_SYNC_LOCK")
;; (define (server:release-sync-lock)
;;   (db:no-sync-del! *no-sync-db* server:sync-lock-token))
;; (define (server:have-sync-lock?)
;;   (let* ((have-lock-pair (db:no-sync-get-lock *no-sync-db* server:sync-lock-token))
;;          (have-lock?     (car have-lock-pair))
;;          (lock-time      (cdr have-lock-pair))
;;          (lock-age       (- (current-seconds) lock-time)))
;;     (cond
;;      (have-lock? #t)
;;      ((>lock-age
;;        (* 3 (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 180)))
;;       (server:release-sync-lock)
;;       (server:have-sync-lock?))
;;      (else #f))))

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

(define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
  (let* ((sqlite-exe   (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
         (sync-log     (or (args:get-arg "-sync-log") (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log")))
	 (tmp-area     (common:get-db-tmp-area))







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







478
479
480
481
482
483
484
















485
486
487
488
489
490
491
     ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
    (string-intersperse 
     (map number->string
	  (u8vector->list
	   (if res res (hostname->ip hostname)))) ".")))

















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

(define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
  (let* ((sqlite-exe   (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
         (sync-log     (or (args:get-arg "-sync-log") (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log")))
	 (tmp-area     (common:get-db-tmp-area))
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
         (duty-cycle   (configf:lookup-number *configdat* "server" "sync-duty-cycle" default: default-duty-cycle))
         (last-sync-seconds 10) ;; we will adjust this to a measurement and delay last-sync-seconds * (1 - duty-cycle)
         (calculate-off-time (lambda (work-duration duty-cycle)
                                  (* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds)))
         (off-time min-intersync-delay) ;; adjusted in closure below.
         (do-a-sync
          (lambda ()
            (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
            (let* ((finalres
                    (let retry-loop ((num-tries 0))
                         (if (common:simple-file-lock lockfile)
	                     (begin
                               (cond
                                ((not (or fork-to-background persist-until-sync))
                                 (debug:print 0 *default-log-port* "INFO: syncer thread sleeping for max of (server.minimum-intersync-delay="min-intersync-delay







|







503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
         (duty-cycle   (configf:lookup-number *configdat* "server" "sync-duty-cycle" default: default-duty-cycle))
         (last-sync-seconds 10) ;; we will adjust this to a measurement and delay last-sync-seconds * (1 - duty-cycle)
         (calculate-off-time (lambda (work-duration duty-cycle)
                                  (* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds)))
         (off-time min-intersync-delay) ;; adjusted in closure below.
         (do-a-sync
          (lambda ()
            ;; (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
            (let* ((finalres
                    (let retry-loop ((num-tries 0))
                         (if (common:simple-file-lock lockfile)
	                     (begin
                               (cond
                                ((not (or fork-to-background persist-until-sync))
                                 (debug:print 0 *default-log-port* "INFO: syncer thread sleeping for max of (server.minimum-intersync-delay="min-intersync-delay
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
                                        (else
                                         (system (conc "/bin/cp "sync-log" "sync-log".fail"))
                                         (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail")
                                         (if (file-exists? (conc mtdbfile ".backup"))
                                             (system (conc "/bin/cp "mtdbfile ".backup " mtdbfile)))
                                         #f))))
                                 (common:simple-file-release-lock lockfile)
                                 (BB> "released lockfile: " lockfile)
                                 (when (common:file-exists? lockfile)
                                   (BB> "DID NOT ACTUALLY RELEASE LOCKFILE"))
                                 res2) ;; end let
                               );; end begin
                             ;; else
                             (cond
                              (persist-until-sync
                               (thread-sleep! 1)
                               (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; we're in a fork-to-background so we need to succeed.  Let's wait a jiffy and and try again. num-tries="num-tries" (waiting for lockfile="lockfile" to disappear)")
                               (retry-loop (add1 num-tries)))
                              (else
                               (thread-sleep! (max off-time (+ last-sync-seconds min-intersync-delay)))
                               (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.")
                               'parallel-sync-in-progress))
                             ) ;; end if got lockfile
                         )
                    ))
              (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres)
              finalres)
            ) ;; end lambda
          ))
    do-a-sync))

(define (server:writable-watchdog-bruteforce dbstruct)
  (thread-sleep! 1) ;; delay for startup







<
<
<















<







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
                                        (else
                                         (system (conc "/bin/cp "sync-log" "sync-log".fail"))
                                         (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail")
                                         (if (file-exists? (conc mtdbfile ".backup"))
                                             (system (conc "/bin/cp "mtdbfile ".backup " mtdbfile)))
                                         #f))))
                                 (common:simple-file-release-lock lockfile)



                                 res2) ;; end let
                               );; end begin
                             ;; else
                             (cond
                              (persist-until-sync
                               (thread-sleep! 1)
                               (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; we're in a fork-to-background so we need to succeed.  Let's wait a jiffy and and try again. num-tries="num-tries" (waiting for lockfile="lockfile" to disappear)")
                               (retry-loop (add1 num-tries)))
                              (else
                               (thread-sleep! (max off-time (+ last-sync-seconds min-intersync-delay)))
                               (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.")
                               'parallel-sync-in-progress))
                             ) ;; end if got lockfile
                         )
                    ))

              finalres)
            ) ;; end lambda
          ))
    do-a-sync))

(define (server:writable-watchdog-bruteforce dbstruct)
  (thread-sleep! 1) ;; delay for startup
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
                          (if (> res 0) ;; some records were transferred, keep the db alive
                              (begin
                                (mutex-lock! *heartbeat-mutex*)
                                (set! *db-last-access* (current-seconds))
                                (mutex-unlock! *heartbeat-mutex*)
                                (debug:print-info 0 *default-log-port* "sync called, " res " records transferred."))
                              (debug:print-info 2 *default-log-port* "sync called but zero records transferred")))))
;;                         ;; TODO: factor this next routine out into a function
;;                         (with-input-from-pipe ;; this should not block other threads but need to verify this
;;                          (conc "megatest -sync-to-megatest.db -m testsuite:" (common:get-area-name) ":" *toppath*)
;;                          (lambda ()
;;                            (let loop ((inl (read-line))
;;                                       (res #f))
;;                              (if (eof-object? inl)
;;                                  (begin
;;                                    (set! sync-duration (- (current-milliseconds) sync-start))
;;                                    (cond
;;                                     ((not res)
;;                                      (debug:print 0 *default-log-port* "ERROR: sync from /tmp db to megatest.db appears to have failed. Recommended that you stop your runs and run \"megatest -cleanup-db\""))
;;                                     ((> res 0)
;;                                      (mutex-lock! *heartbeat-mutex*)
;;                                      (set! *db-last-access* (current-seconds))
;;                                      (mutex-unlock! *heartbeat-mutex*))))
;;                                  (let ((num-synced (let ((matches (string-match "^Synced (\\d+).*$" inl)))
;;                                                      (if matches
;;                                                          (string->number (cadr matches))
;;                                                          #f))))
;;                                    (loop (read-line)
;;                                          (or num-synced res))))))))))
	      (if will-sync
		  (begin
		    (mutex-lock! *db-multi-sync-mutex*)
		    (set! *db-sync-in-progress* #f)
		    (set! *db-last-sync* start-time)
		    (with-output-to-file end-file (lambda ()(print (current-process-id))))

		    ;; release lock here

		    (mutex-unlock! *db-multi-sync-mutex*)))
	      (if (and debug-mode
		       (> (- start-time last-time) 60))
		  (begin
		    (set! last-time start-time)
		    (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
	    
	    ;; keep going unless time to exit
	    ;;
	    (if (not *time-to-exit*)
		(let delay-loop ((count 0))
                  ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
                                                            
		  (if (and (not *time-to-exit*)
			   (< count 6)) ;; was 11, changing to 4. 
		      (begin
			(thread-sleep! 1)
			(delay-loop (+ count 1))))
		  (if (not *time-to-exit*) (loop))))
	    ;; time to exit, close the no-sync db here
	    (db:no-sync-close-db no-sync-db stmt-cache)
	    (if (common:low-noise-print 30)
		(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))))) ;;" this-wd-num="this-wd-num)))))))








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




















<
<











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
                          (if (> res 0) ;; some records were transferred, keep the db alive
                              (begin
                                (mutex-lock! *heartbeat-mutex*)
                                (set! *db-last-access* (current-seconds))
                                (mutex-unlock! *heartbeat-mutex*)
                                (debug:print-info 0 *default-log-port* "sync called, " res " records transferred."))
                              (debug:print-info 2 *default-log-port* "sync called but zero records transferred")))))






















	      (if will-sync
		  (begin
		    (mutex-lock! *db-multi-sync-mutex*)
		    (set! *db-sync-in-progress* #f)
		    (set! *db-last-sync* start-time)
		    (with-output-to-file end-file (lambda ()(print (current-process-id))))

		    ;; release lock here

		    (mutex-unlock! *db-multi-sync-mutex*)))
	      (if (and debug-mode
		       (> (- start-time last-time) 60))
		  (begin
		    (set! last-time start-time)
		    (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
	    
	    ;; keep going unless time to exit
	    ;;
	    (if (not *time-to-exit*)
		(let delay-loop ((count 0))


		  (if (and (not *time-to-exit*)
			   (< count 6)) ;; was 11, changing to 4. 
		      (begin
			(thread-sleep! 1)
			(delay-loop (+ count 1))))
		  (if (not *time-to-exit*) (loop))))
	    ;; time to exit, close the no-sync db here
	    (db:no-sync-close-db no-sync-db stmt-cache)
	    (if (common:low-noise-print 30)
		(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))))) ;;" this-wd-num="this-wd-num)))))))

Deleted show-uncalled-procedures.scm version [0afd5cabda].

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
;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;
(include "codescanlib.scm")

(define (show-danglers)
  (let* ((all-scm-files (glob "*.scm"))
         (xref (get-xref all-scm-files))
         (dangling-procs
          (map car (filter (lambda (x) (equal? 1 (length x))) xref))))
    (for-each print dangling-procs) ;; our product.
    ))

(show-danglers)

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




























































Modified subrun.scm from [bd1952a98c] to [afe052ef94].

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

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) 
     posix-extras directory-utils pathname-expand typed-records format
     call-with-environment-variables)
(declare (unit subrun))
;;(declare (uses runs))
(declare (uses db))
(declare (uses common))
;;(declare (uses items))
;;(declare (uses runconfig))
;;(declare (uses tests))
;;(declare (uses server))
(declare (uses mt))
;;(declare (uses archive))
;; (declare (uses filedb))

;(include "common_records.scm")
;;(include "key_records.scm")
(include "db_records.scm") ;; provides db:test-get-id
;;(include "run_records.scm")
;;(include "test_records.scm")

(define (subrun:subrun-test-initialized? test-run-dir)
  (if (and (common:file-exists? (conc test-run-dir "/subrun-area") )
           (common:file-exists? (conc test-run-dir "/testconfig.subrun") ))
      #t
      #f))








<


<
<
<
<

<
<
<
<
<

<
<







18
19
20
21
22
23
24

25
26




27





28


29
30
31
32
33
34
35

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) 
     posix-extras directory-utils pathname-expand typed-records format
     call-with-environment-variables)
(declare (unit subrun))

(declare (uses db))
(declare (uses common))




(declare (uses mt))





(include "db_records.scm") ;; provides db:test-get-id



(define (subrun:subrun-test-initialized? test-run-dir)
  (if (and (common:file-exists? (conc test-run-dir "/subrun-area") )
           (common:file-exists? (conc test-run-dir "/testconfig.subrun") ))
      #t
      #f))

Modified tasks.scm from [b621e9649f] to [49aab45cc7].

177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
;; Server and client management
;;======================================================================

;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname
(define (tasks:hostinfo-get-id          vec)    (vector-ref  vec 0))
(define (tasks:hostinfo-get-interface   vec)    (vector-ref  vec 1))
(define (tasks:hostinfo-get-port        vec)    (vector-ref  vec 2))
(define (tasks:hostinfo-get-pubport     vec)    (vector-ref  vec 3))
(define (tasks:hostinfo-get-transport   vec)    (vector-ref  vec 4))
(define (tasks:hostinfo-get-pid         vec)    (vector-ref  vec 5))
(define (tasks:hostinfo-get-hostname    vec)    (vector-ref  vec 6))

(define (tasks:need-server run-id)
  (equal? (configf:lookup *configdat* "server" "required") "yes"))

;; no elegance here ...
;;







|

|







177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
;; Server and client management
;;======================================================================

;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname
(define (tasks:hostinfo-get-id          vec)    (vector-ref  vec 0))
(define (tasks:hostinfo-get-interface   vec)    (vector-ref  vec 1))
(define (tasks:hostinfo-get-port        vec)    (vector-ref  vec 2))
;; (define (tasks:hostinfo-get-pubport     vec)    (vector-ref  vec 3))
(define (tasks:hostinfo-get-transport   vec)    (vector-ref  vec 4))
;; (define (tasks:hostinfo-get-pid         vec)    (vector-ref  vec 5))
(define (tasks:hostinfo-get-hostname    vec)    (vector-ref  vec 6))

(define (tasks:need-server run-id)
  (equal? (configf:lookup *configdat* "server" "required") "yes"))

;; no elegance here ...
;;

Modified tdb.scm from [6edff6262d] to [107bd93069].

373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
		     (<   (tdb:step-get-id a)        (tdb:step-get-id b)))
		    (else #f)))))
    res))

;;
;; Move to steps.scm
;;
(define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table
  (map (lambda (x)
	 ;; take advantage of the \n on time->string
	 (vector
	  (vector-ref x 0)
	  (let ((s (vector-ref x 1)))
	    (if (number? s)(seconds->time-string s) s))
	  (let ((s (vector-ref x 2)))







|







373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
		     (<   (tdb:step-get-id a)        (tdb:step-get-id b)))
		    (else #f)))))
    res))

;;
;; Move to steps.scm
;;
#;(define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table
  (map (lambda (x)
	 ;; take advantage of the \n on time->string
	 (vector
	  (vector-ref x 0)
	  (let ((s (vector-ref x 1)))
	    (if (number? s)(seconds->time-string s) s))
	  (let ((s (vector-ref x 2)))

Modified tests.scm from [0094b671e6] to [bf94920f7d].

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

;;======================================================================
;; Tests
;;======================================================================

(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))
(declare (uses tdb))
(declare (uses common))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))







|







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

;;======================================================================
;; Tests
;;======================================================================

(declare (unit tests))
;; (declare (uses lock-queue))
(declare (uses db))
(declare (uses tdb))
(declare (uses common))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))

Deleted trackback.scm version [b547b4460b].

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
;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

(include "codescanlib.scm")

;; show call paths for named procedure
(define (traceback-proc in-procname)
  (letrec* ((all-scm-files (glob "*.scm"))
            (xref (get-xref all-scm-files))
            (have (alist-ref (string->symbol in-procname) xref eq? #f))
            (lookup (lambda (path procname depth)
                      (let* ((upcone-temp (filter (lambda (x)
                                                    (eq? procname (car x)))
                                                  xref))
                             (upcone-temp2 (cond
                                            ((null? upcone-temp) '())
                                            (else (cdar upcone-temp))))
                             (upcone (filter
                                      (lambda (x) (not (eq? x procname)))
                                      upcone-temp2))
                             (uppath (cons procname path))
                             (updepth (add1 depth)))
                        (if (null? upcone)
                            (print  uppath)
                            (for-each (lambda (x)
                                        (if (not (member procname path))
                                            (lookup uppath x updepth) ))
                                      upcone))))))
           (if have
               (lookup '() (string->symbol in-procname) 0)
               (print "no such func - "in-procname))))


(if (eq? 1 (length (command-line-arguments)))
    (traceback-proc (car (command-line-arguments)))
    (print "Usage: trackback <procedure name>"))

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










































































































Added utils/Makefile.utils version [df13f8bb7e].















>
>
>
>
>
>
>
1
2
3
4
5
6
7
all : show-uncalled-procedures trackback

show-uncalled-procedures : show-uncalled-procedures.scm codescanlib.scm
	csc show-uncalled-procedures.scm

trackback : trackback.scm codescanlib.scm
	csc trackback.scm

Added utils/codescanlib.scm version [6e625610ce].

































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

;; gotta compile with csc, doesn't work with csi -s for whatever reason

(use srfi-69)
(use matchable)
(use utils)
(use ports)
(use extras)
(use srfi-1)
(use posix)
(use srfi-12)

;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )
(define (load-scm-file scm-file)
  ;;(print "load "scm-file)
  (handle-exceptions
   exn
   '()
   (with-input-from-string
       (conc "("
             (with-input-from-file scm-file read-all)
             ")" )
     read)))

;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
;;   -- be advised:
;;      * this may be fooled by macros, since this code does not take them into account.
;;      * this code does only checks for form (define (<procname> ... ) <body>)
;;           so it excludes from reckoning
;;               - generated functions, as in things like foo-set! from defstructs,
;;               - define-inline, (
;;               - define procname (lambda ..
;;               - etc...
(define (get-toplevel-procs+file+args+body filename)
  (let* ((scm-tree (load-scm-file filename))
         (procs
          (filter identity
                  (map
                   (match-lambda 
                    [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
                    [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
                    [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
                    [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>)
                     (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
                         (list defname filename args body)
                         #f)]
                    [else #f] ) scm-tree))))
    procs))


;; given a sexp, return a flat list of atoms in that sexp
(define (get-atoms-in-body body)
  (cond
   ((null? body) '())
   ((atom? body) (list body))
   (else
    (apply append (map get-atoms-in-body body)))))

;;  given a file, return a list of procname, file, list of atoms in said procname
(define (get-procs+file+atoms file)
  (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
         (res
          (map
           (lambda (item)
             (let* ((proc (car item))
                    (file (cadr item))
                    (args (caddr item))
                    (body (cadddr item))
                    (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
               (list proc file atoms)))
           toplevel-proc-items)))
    res))

;; uniquify a list of atoms 
(define (unique-atoms lst)
  (let loop ((lst (flatten lst)) (res '()))
    (if (null? lst)
        (reverse res)
        (let ((c (car lst)))
          (loop (cdr lst) (if (member c res) res (cons c res)))))))

;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
;; returning alist mapping procname to procname that calls said procname
(define (get-callers-alist all-procs+file+calls)
  (let* ((all-procs (map car all-procs+file+calls))
         (caller-ht (make-hash-table))) 
    ;; let's cross reference with a hash table
    (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
    (for-each (lambda (item)
               (let* ((proc (car item))
                      (file (cadr item))
                      (calls (caddr item)))
                 (for-each (lambda (callee)
                             (hash-table-set! caller-ht callee
                                              (cons proc
                                                    (hash-table-ref caller-ht callee))))
                           calls)))
              all-procs+file+calls)
    (map (lambda (x)
           (let ((k (car x))
                 (r (unique-atoms (cdr x))))
             (cons k r)))                    
         (hash-table->alist caller-ht))))

;; create a handy cross-reference of callees to callers in the form of an alist.
(define (get-xref all-scm-files)
  (let* ((all-procs+file+atoms
          (apply append (map get-procs+file+atoms all-scm-files)))
         (all-procs (map car all-procs+file+atoms))
         (all-procs+file+calls  ; proc calls things in calls list
          (map (lambda (item)
                 (let* ((proc (car item))
                        (file (cadr item))
                        (atoms (caddr item))
                        (calls
                         (filter identity
                                 (map
                                  (lambda (x)
                                    (if (and ;; (not (equal? x proc))  ;; uncomment to prevent listing self
                                         (member x all-procs))
                                        x
                                        #f))
                                  atoms))))
                   (list proc file calls)))
               all-procs+file+atoms))
         (callers (get-callers-alist all-procs+file+calls))) 
    callers))

Added utils/show-uncalled-procedures.scm version [7cf01ad99d].



































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

;; gotta compile with csc, doesn't work with csi -s for whatever reason

(use srfi-69)
(use matchable)
(use utils)
(use ports)
(use extras)
(use srfi-1)
(use posix)
(use srfi-12)

;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )

(define (load-scm-file scm-file)
  ;;(print "load "scm-file)
  (handle-exceptions
   exn
   '()
   (with-input-from-string
       (conc "("
             (with-input-from-file scm-file read-all)
             ")" )
     read)))

;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
;;   -- be advised:
;;      * this may be fooled by macros, since this code does not take them into account.
;;      * this code does only checks for form (define (<procname> ... ) <body>)
;;           so it excludes from reckoning
;;               - generated functions, as in things like foo-set! from defstructs,
;;               - define-inline, (
;;               - define procname (lambda ..
;;               - etc...
(define (get-toplevel-procs+file+args+body filename)
  (let* ((scm-tree (load-scm-file filename))
         (procs
          (filter identity
                  (map
                   (match-lambda 
                    [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
                    [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
                    [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
                    [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>)
                     (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
                         (list defname filename args body)
                         #f)]
                    [else #f] ) scm-tree))))
    procs))


;; given a sexp, return a flat list of atoms in that sexp
(define (get-atoms-in-body body)
  (cond
   ((null? body) '())
   ((atom? body) (list body))
   (else
    (apply append (map get-atoms-in-body body)))))

;;  given a file, return a list of procname, file, list of atoms in said procname
(define (get-procs+file+atoms file)
  (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
         (res
          (map
           (lambda (item)
             (let* ((proc (car item))
                    (file (cadr item))
                    (args (caddr item))
                    (body (cadddr item))
                    (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
               (list proc file atoms)))
           toplevel-proc-items)))
    res))

;; uniquify a list of atoms 
(define (unique-atoms lst)
  (let loop ((lst (flatten lst)) (res '()))
    (if (null? lst)
        (reverse res)
        (let ((c (car lst)))
          (loop (cdr lst) (if (member c res) res (cons c res)))))))

;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
;; returning alist mapping procname to procname that calls said procname
(define (get-callers-alist all-procs+file+calls)
  (let* ((all-procs (map car all-procs+file+calls))
         (caller-ht (make-hash-table))) 
    ;; let's cross reference with a hash table
    (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
    (for-each (lambda (item)
               (let* ((proc (car item))
                      (file (cadr item))
                      (calls (caddr item)))
                 (for-each (lambda (callee)
                             (hash-table-set! caller-ht callee
                                              (cons proc
                                                    (hash-table-ref caller-ht callee))))
                           calls)))
              all-procs+file+calls)
    (map (lambda (x)
           (let ((k (car x))
                 (r (unique-atoms (cdr x))))
             (cons k r)))                    
         (hash-table->alist caller-ht))))

;; create a handy cross-reference of callees to callers in the form of an alist.
(define (get-xref all-scm-files)
  (let* ((all-procs+file+atoms
          (apply append (map get-procs+file+atoms all-scm-files)))
         (all-procs (map car all-procs+file+atoms))
         (all-procs+file+calls  ; proc calls things in calls list
          (map (lambda (item)
                 (let* ((proc (car item))
                        (file (cadr item))
                        (atoms (caddr item))
                        (calls
                         (filter identity
                                 (map
                                  (lambda (x)
                                    (if (and ;; (not (equal? x proc))  ;; uncomment to prevent listing self
                                         (member x all-procs))
                                        x
                                        #f))
                                  atoms))))
                   (list proc file calls)))
               all-procs+file+atoms))
         (callers (get-callers-alist all-procs+file+calls))) 
    callers))

(define (get-danglers)
  (let* ((all-scm-files (glob "*.scm"))
         (xref (get-xref all-scm-files))
         (dangling-procs
          (map car (filter (lambda (x) (equal? 1 (length x))) xref))))
    dangling-procs))

(define (read-ignore-file fname)
  (let ((ht (make-hash-table)))
    (if (file-exists? fname)
	(for-each
	 (lambda (x)
	   (hash-table-set! ht x #t))
	 (with-input-from-file fname
	   read-lines)))
    ht))

(define (show-danglers)
  (let ((ignores     (read-ignore-file "danglers-to-ignore.txt"))
	(danglers    (map get-stats (get-danglers))))
    ;; (print "ignores: " (hash-table->alist ignores))
    (for-each (lambda (dangler)
		(let* ((fnname (conc (cadr dangler))))
		  ;; (print "fnname="fnname" member: "(member fnname ignore-list))
		  (if (not (hash-table-exists? ignores fnname))
		      (apply print (intersperse  dangler "\t"))
		      #;(print "skipping "fnname))))
	      (sort danglers (lambda (a b)
			       (let ((ca (car a))
				     (cb (car b)))
				 (if (equal? ca cb)
				     (string<=? (conc (cadr a))(conc (cadr b)))
				     (< ca cb))))))))

    ;; (for-each print dangling-procs) ;; our product.

(define (get-stats fn)
  (let* ((data  (with-input-from-pipe (conc "grep '"fn"' *.scm") read-lines))
	 (files (delete-duplicates
		 (map (lambda (entry)
			(car (string-split entry ":")))
		      data))))
    (list (length data) fn files)))

(show-danglers)

    

Added utils/trackback.scm version [b547b4460b].











































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

(include "codescanlib.scm")

;; show call paths for named procedure
(define (traceback-proc in-procname)
  (letrec* ((all-scm-files (glob "*.scm"))
            (xref (get-xref all-scm-files))
            (have (alist-ref (string->symbol in-procname) xref eq? #f))
            (lookup (lambda (path procname depth)
                      (let* ((upcone-temp (filter (lambda (x)
                                                    (eq? procname (car x)))
                                                  xref))
                             (upcone-temp2 (cond
                                            ((null? upcone-temp) '())
                                            (else (cdar upcone-temp))))
                             (upcone (filter
                                      (lambda (x) (not (eq? x procname)))
                                      upcone-temp2))
                             (uppath (cons procname path))
                             (updepth (add1 depth)))
                        (if (null? upcone)
                            (print  uppath)
                            (for-each (lambda (x)
                                        (if (not (member procname path))
                                            (lookup uppath x updepth) ))
                                      upcone))))))
           (if have
               (lookup '() (string->symbol in-procname) 0)
               (print "no such func - "in-procname))))


(if (eq? 1 (length (command-line-arguments)))
    (traceback-proc (car (command-line-arguments)))
    (print "Usage: trackback <procedure name>"))

(exit 0)