Megatest

#     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/>.

# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
# rm <files>.o ; make install CSCOPTS='-profile' ; ... ;  chicken-profile | less

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

recent-commits.csv : .fslckout
	fossil timeline -n 350 -t ci -F "%h,%a,%b,%t,\"%c\"" > recent-commits.csv


SHELL=/bin/bash
PREFIX=$(PWD)
# CSCOPTS=-lfa2 -specialize -inline-global
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm	\
           server.scm configf.scm db.scm keys.scm margs.scm		\
           server.scm configf.scm db.scm keys.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		\
           tdb.scm mt.scm	\
           ezsteps.scm rmt.scm api.scm		\
           subrun.scm archive.scm env.scm		\
           diff-report.scm cgisetup/models/pgdb.scm

# module source files
MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm adjutant.scm mutils.scm mttop.scm tcp-transportmod.scm rmtmod.scm portlogger.scm
MSRCFILES = adjutant.scm mutils.scm mttop.scm

transport-mode.scm : transport-mode.scm.template
	cp transport-mode.scm.template transport-mode.scm

dashboard-transport-mode.scm : dashboard-transport-mode.scm.template
	cp dashboard-transport-mode.scm.template dashboard-transport-mode.scm

mtest : transport-mode.scm
dboard : dashboard-transport-mode.scm

# dbmod.import.o is just a hack here
mofiles/portlogger.o : mofiles/dbmod.o

mofiles/dbfile.o     : \
       mofiles/debugprint.o mofiles/commonmod.o 

mofiles/dbmod.o : mofiles/dbfile.o

mofiles/commonmod.o : mofiles/debugprint.o
configf.o : commonmod.import.o
mofiles/dbfile.o : mofiles/debugprint.o
mofiles/rmtmod.o mofiles/dbmod.o : mofiles/dbfile.o mofiles/commonmod.o mofiles/debugprint.o
db.o : mofiles/dbmod.o mofiles/dbfile.o
mofiles/debugprint.o : mofiles/mtargs.o
mofiles/tcp-transportmod.o : mofiles/portlogger.o

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

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

# I'm not sure the cp is a good idea, changed a lot of things and it may not have been necessary...
# mofiles/%.o  %.import.scm : %.scm megatest-fossil-hash.scm
#	@[ -e mofiles ] || mkdir -p mofiles
#	csc $(CSCOPTS) -I mofiles -I $* -J -c $< -o $*.o
#	cp $*.o mofiles/$*.o
#	@touch $*.import.scm # ensure it is touched after the .o is made

mofiles/%.o : %.scm
	mkdir -p mofiles
%.import.scm mofiles/%.o : %.scm
	@mkdir -p mofiles
	csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
	@if [[ -e $*.import.scm ]];then touch $*.import.scm;fi # ensure it is touched after the .o is made

ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')
MTESTHASH=$(shell if [[ -e .fslckout ]];then fossil info|grep checkout:| awk '{print $$2}';else echo "na";fi)

ifeq ($(MTESTHASH),)
$(error MTESTHASH is broken!)
endif

# CSIPATH=$(shell which csi)
# CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
# ARCHSTR=$(shell uname -m)_$(shell uname -r)
# BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE")
# ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr)
ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi)
# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE")

PNGFILES = $(shell cd docs/manual;ls *png)

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

mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES)  megatest-version.scm
mtest: $(OFILES) readline-fix.scm $(MOFILES) $(MOIMPFILES) megatest.o  megatest-version.scm
	csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest

showmtesthash:
	@echo $(MTESTHASH)

dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm
	csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard

mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm
	csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut
mtut: $(OFILES) $(MOFILES) $(MOIMPFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm 
	csc $(CSCOPTS) $(OFILES) $(MOFILES)  $(MOIMPFILES) mtut.scm -o mtut

include makefile.inc
# include makefile.inc
include chicken.makefile

TCMTOBJS = \
	api.o \
	archive.o \
	cgisetup/models/pgdb.o \
# TCMTOBJS = \
# 	api.o \
# 	archive.o \
# 	cgisetup/models/pgdb.o \
	client.o \
	common.o \
	configf.o \
	db.o \
	env.o \
# 	common.o \
# 	configf.o \
# 	db.o \
# 	env.o \
	http-transport.o \
	items.o \
	keys.o \
	launch.o \
# 	items.o \
# 	keys.o \
# 	launch.o \
	lock-queue.o \
	margs.o \
	mt.o \
	ods.o \
# 	margs.o \
# 	mt.o \
# 	ods.o \
	portlogger.o \
	process.o \
	rmt.o \
	runconfig.o \
	runs.o \
	server.o \
	tasks.o \
	tdb.o \
	tests.o \
	subrun.o \
        ezsteps.o

#        mofiles/rmtmod.o \
#        mofiles/commonmod.o \

tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm
	csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt
# 	process.o \
# 	rmt.o \
# 	runconfig.o \
# 	runs.o \
# 	server.o \
# 	tasks.o \
# 	tdb.o \
# 	tests.o \
# 	subrun.o \
#         ezsteps.o
# 
# #        mofiles/rmtmod.o \
# #        mofiles/commonmod.o \
# 
# tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm $(MOFILES) $(MOIMPFILES)
# 	csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt

# install documentation to $(PREFIX)/docs
# DOES NOT REBUILD DOCS
#
$(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html
	mkdir -p $(PREFIX)/share/docs
	$(INSTALL) docs/manual/megatest_manual.html $(PREFIX)/share/docs/megatest_manual.html
	for png in $(PNGFILES);do $(INSTALL) docs/manual/$$png $(PREFIX)/share/docs/$$png;done

# add a fake dependency so this doens't copy everytime
$(PREFIX)/share/js/jquery-3.1.0.slim.min.js : # .fslckout
	mkdir -p $(PREFIX)/share/js
	fossil wiki export java-script-lib > $(PREFIX)/share/js/jquery-3.1.0.slim.min.js
	cp utils/java-script-lib $(PREFIX)/share/js/jquery-3.1.0.slim.min.js

$(PREFIX)/share/db/mt-pg.sql : mt-pg.sql
	mkdir -p $(PREFIX)/share/db
	$(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql

# Special dependencies for the includes
$(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm

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

# mofiles/dbmod.o : mofiles/configfmod.o

# 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
db.o api.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/debugprint.o mofiles/commonmod.o dbmod.import.o

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

runs.o : test_records.scm

# mofiles-made : $(MOFILES)
# 	make $(MOIMPFILES)
# 	touch mofiles-made

megatest.o : megatest-fossil-hash.scm megatest-version.scm
megatest.o : megatest-fossil-hash.scm megatest-version.scm $(MOFILES) $(MOIMPFILES)

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
rmt.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.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/dbfile.o : mofiles/commonmod.o

# 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

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

# tcmt

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

$(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/tcmt utils/mk_wrapper
	utils/mk_wrapper $(PREFIX) tcmt $(PREFIX)/bin/tcmt
	chmod a+x $(PREFIX)/bin/tcmt
# $(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt
# 	$(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt
# 
# $(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/tcmt utils/mk_wrapper
# 	utils/mk_wrapper $(PREFIX) tcmt $(PREFIX)/bin/tcmt
# 	chmod a+x $(PREFIX)/bin/tcmt

$(PREFIX)/bin/mt_laststep : utils/mt_laststep
	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/mt_runstep : utils/mt_runstep
	$(INSTALL) $< $@

$(PREFIX)/bin/nbfind : utils/nbfind
	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/mtrunner : utils/mtrunner
	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/mt-old-to-new.sh : utils/mt-old-to-new.sh
	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/mt-new-to-old.sh : utils/mt-new-to-old.sh
	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/convert-db.sh : utils/convert-db.sh
	$(INSTALL) $< $@
	chmod a+x $@

deploytarg/nbfake : utils/nbfake
	$(INSTALL) $< $@
	chmod a+x $@

deploytarg/viewscreen : utils/viewscreen
	$(INSTALL) $< $@

# install dashboard as dboard so wrapper script can be called dashboard
$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper
	utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard
	chmod a+x $(PREFIX)/bin/dashboard
	$(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard

# Work around missing libraries on crappy corporate compute farm (hearafter known as CCCF)
ifeq ($(ARCHSTR),12.5)
EXTRALIBS_HACK=$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0
else
EXTRALIBS_HACK=
endif

$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so : lib/libpangox-1.0.so
	if [[ $(ARCHSTR) == 12.5 ]]; then \
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib
	$(INSTALL) lib/libpangox-1.0.so $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib; \
	$(INSTALL) lib/libpangox-1.0.so $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so; \
	fi

$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 : lib/libpangox-1.0.so.0
	if [[ $(ARCHSTR) == 12.5 ]]; then \
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib
	$(INSTALL) lib/libpangox-1.0.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib; \
	$(INSTALL) lib/libpangox-1.0.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0; \
        fi

$(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0 : lib/libxcb-xlib.so.0
	if [[ $(ARCHSTR) == 12.5 ]]; then \
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib
	$(INSTALL) lib/libxcb-xlib.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib; \
	$(INSTALL) lib/libxcb-xlib.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0; \
        fi

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

#         $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/tcmt 
#         $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \
# $(PREFIX)/bin/newdashboard

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

test: tests/tests.scm

	else \
	   echo "(define *use-new-readline* #t)" > readline-fix.scm;\
	fi

altdb.scm :
	echo ";; optional alternate db setup" > altdb.scm
	echo "(define *available-db* (make-hash-table))" >> altdb.scm
	if  csi -ne '(use mysql-client)';then \
	if  csi -ne '(use mysql-client)' &> /dev/null;then \
           echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
	fi
	if csi -ne '(use postgresql)';then \
	if csi -ne '(use postgresql)'&> /dev/null;then \
	   echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
	fi
	if  csi -ne '(import mysql-client)'&> /dev/null;then \
           echo "(import mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
	fi
	if csi -ne '(import postgresql)'&> /dev/null;then \
	   echo "(import 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
# portlogger-example : portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.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 server.o synchash.o tasks.o tdb.o tests.o tree.o
#	csc $(CSCOPTS) portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.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 server.o sync-hash.o tasks.o tdb.o tests.o tree.o

unitdeps.dot : *scm ./utils/plot-uses Makefile
	./utils/plot-uses todot commonmod.import,mtargs.import,mtargs,debugprint *.scm > unitdeps.dot

unitdeps.pdf : unitdeps.dot
	dot unitdeps.dot -Tpdf -o unitdeps.pdf

./utils/plot-uses : utils/plot-uses.scm
	csc utils/plot-uses.scm

# 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

wikipage=plan
editwiki:
	cd docs/manual && ../../utils/editwiki $(wikipage)

viewmanual:
	arora docs/manual/megatest_manual.html

targets:
	@grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"'


unit :
	cd tests;make unit

#     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/>.

(server:writable-watchdog-bruteforce dbstruct)

(server:writable-watchdog-deltasync dbstruct)


=====================================================================
NOTES from looking at branch v1.62-rpc
=====================================================================

*last-db-access* or *db-last-access* ==> which is it to be?
seen in singletest: ERROR: Unrecognised arguments: :first_err This is the first error

# 
#     You should have received a copy of the GNU General Public License
#     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

TODO
====

WW38
. Add test_rundat to no-sync ==> correction, put in <testdir>/.meta/test-run.dat
. Add STATE/STATUS transitions to .meta/test-run.dat or similar
. Swizzle update-test-rundat to operate on no-sync
. Swizzle update-run-duration, -uname-host and cpuload-diskfree to no-sync
. On state/status change update tests table with duration
23WW48
. Add calls-per-minute to db access stats
. Find out why start-server calls are taking 250ms and fix
. Allow two or three servers to run for any given db
. Update avg call count/sec every 30 sec in no-sync
. get server uses no-sync process info to decide which server to suggest
. Use process table to decide who will do sync back
. Fix metadat being synced over and over

23WW47
. Finding server
.. look at .servinfo for likely prime main
.. ask the .servinfo prime main for real prime main
.. save prime main (for how long, 10 seconds or 10 minutes?)

. Starting prime main
.. get servinfo files - START
.. no files? create my servinfo file, goto START
.. have files? am I the prime main according to servinfo files?
.. no, I'm not the prime main, ping prime main
.. ping is good, prime main exists, register self as server if on same host as prime main DONE
.. no pirng response, remove the .servinfo file - goto START
.. if I am prime main according to .servinfo files, register directly in no-sync

. Starting non-main
.. get servinfo files
.. no files? launch server for main.db
.. have files? pick out prime main
.. register self as server with prime main

23WW46 - v1.80 branch
. Use file semaphore to kill tests, eliminate db load of the KILLREQ query
. Merge this change to revolution branch
23WW45 - the revolution branch
. Add "fast" db start option (no handshaking over NFS)
. Add server-ro to server types (just "server" is fine for read/write).
. [DONE] Create pause-server and resume-server calls
. Create rsync or cp sync to MTRAH function
. Change rmt:send-receive to divert calls to read-only server when possible
. [DONE] Change start server to call main.db server for 1..N.db servers, block until server is read for use.

23WW21
. Dashboard needs its own cache db in /tmp

23WW07
. Remove use of *dbstruct-dbs*

WW15
. fill newview matrix with data, filter pipeline gui elements
. improve [script], especially indent handling

WW16
. split db into megatest.db (runs etc.) db/<something>.db
. release basic newview implementation

WW18
. release split db implementation
. mtutil calls from dashboard (for remote control)
. logs browser (esp. for surfacing mtutil related activities)

WW19
. break command line into sections; all, run control, queries, utilities etc.
. pull in ftfplan (not integrated, just code pulled in)

WW20
. ./configure => ubuntu, sles11, sles12, rh7
. Jenkins junit XML support
. Add output flushing in teamcity support
. Switch to using simple runs query everywhere
. Add end_time to runs and add a rollup call that sets state, status and end_time

Future
. Switch to scsh-process pipeline management for job execution/control
. Use call-with-environment-variables more.

;;     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 api))
(use srfi-69 posix)

(declare (unit api))
(declare (uses rmt))
(declare (uses db))
(declare (uses db))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tasks))
(declare (uses tcp-transportmod))

(import commonmod)
(import dbmod)
(import dbfile)
(import debugprint)
(import tcp-transportmod)

(use srfi-69
     srfi-18
     posix
     matchable
     s11n
     typed-records)

;; allow these queries through without starting a server
;;
(define api:read-only-queries
  '(get-key-val-pairs
    get-var
    get-keys
    get-key-vals
    test-toplevel-num-items
    get-test-info-by-id
    get-test-state-status-by-id
    get-steps-info-by-id
    get-data-info-by-id
    test-get-rundir-from-test-id
    get-count-tests-running-for-testname
    get-count-tests-running
    get-count-tests-running-in-jobgroup
    get-previous-test-run-record
    get-matching-previous-test-run-records
    test-get-logfile-info
    test-get-records-for-index-file
    get-testinfo-state-status
    test-get-top-process-pid
    test-get-paths-matching-keynames-target-new
    get-prereqs-not-met
    get-count-tests-running-for-run-id
    get-run-info
    get-run-status
    get-run-state
    get-run-stats
    get-run-times
    get-targets
    get-target
    get-target
    get-targets
    ;; register-run
    get-tests-tags
    get-test-times
    get-tests-for-run
    get-tests-for-run-state-status
    get-test-id
    get-tests-for-runs-mindata
    get-tests-for-run-mindata
    get-run-name-from-id
    get-runs
    simple-get-runs
    get-num-runs
    get-runs-cnt-by-patt
    get-all-run-ids
    get-prev-run-ids
    get-run-ids-matching-target
    get-runs-by-patt
    get-steps-data
    get-steps-for-test
    read-test-data
    read-test-data*
    read-test-data-varpatt
    login
    tasks-get-last
    testmeta-get-record
    have-incompletes?
    get-changed-record-ids
    ;; synchash-get
    get-changed-record-ids
    get-all-runids
    get-changed-record-test-ids
    get-changed-record-run-ids
    get-run-record-ids 
    get-not-completed-cnt))

(define api:write-queries
  '(
    get-keys-write ;; dummy "write" query to force server start

    ;; SERVERS
    start-server
    kill-server
    ;; start-server
    ;; kill-server

    ;; TESTS
    test-set-state-status-by-id
    delete-test-records
    delete-old-deleted-test-records
    test-set-state-status
    test-set-top-process-pid

    teststep-set-status!
    delete-steps-for-test
    ;; TEST DATA
    test-data-rollup
    csv->test-data

    ;; MISC
    sync-inmem->db
    sync-cachedb->db
    drop-all-triggers
    create-all-triggers
    update-tesdata-on-repilcate-db 

    ;; TESTMETA
    testmeta-add-record
    testmeta-update-field

    ;; TASKS
    tasks-add
    tasks-set-state-given-param-key
    ))

(define *db-write-mutexes* (make-hash-table))
;; These are called by the server on recipt of /api calls
;;    - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;;    - returns #( flag result )
;;
(define (api:execute-requests dbstruct dat)
  (handle-exceptions
   exn
   (let ((call-chain (get-call-chain)))
     (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn)
     (print-call-chain (current-error-port))
     (debug:print 0 *default-log-port* " message: "  ((condition-property-accessor 'exn 'message) exn))       
(define *server-signature* #f)

(define *api-threads* '())
(define (api:register-thread th-in command)
  (set! *api-threads* (cons (list th-in (current-seconds) command) *api-threads*)))

(define (api:get-thread-command th-in)
  (let ((thread-data (assoc th-in *api-threads*)))
    (if thread-data
        (third thread-data) ; Assuming the command is the third element in the list
        #f))) ; Return #f if the thread is not found

(define (api:unregister-thread th-in)
  (set! *api-threads* (filter (lambda (thdat)
				(not (eq? th-in (car thdat))))
			      *api-threads*)))

(define (api:remove-dead-or-terminated)
  (set! *api-threads* (filter (lambda (thdat)
				(not (member (thread-state (car thdat)) '(terminated dead))))
			      *api-threads*)))

(define (api:get-count-threads-alive)
  (length *api-threads*))

(define (api:get-threads)
  (map (lambda (thdat)
         (let ((thread (first thdat))
               (timestamp (second thdat))
               (command (third thdat)))
           (format "\nThread: ~a, age: ~a, Command: ~a" thread (- (current-seconds) timestamp) command)))
       *api-threads*))


(define *api:last-stats-print* 0)
(define *api-print-db-stats-mutex* (make-mutex))
(define (api:print-db-stats)
  (debug:print-info 0 *default-log-port* "Started periodic db stats printer")
     (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
   (cond
    ((not (vector? dat))                    ;; it is an error to not receive a vector
     (vector #f (vector #f "remote must be called with a vector")))
    ((> *api-process-request-count* 20) ;; 20)
     (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.")
     (set! *server-overloaded* #t)
     (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor!
    (else  
  (let loop ()
    (mutex-lock! *api-print-db-stats-mutex*)
    (if (> (- (current-seconds) *api:last-stats-print*) 15)
	(begin
	  (rmt:print-db-stats)
	  (set! *api:last-stats-print* (current-seconds))))
    (mutex-unlock! *api-print-db-stats-mutex*)
    (thread-sleep! 5)
    (loop)))


;; indat is (cmd run-id params meta)
;;
;; WARNING: Do not print anything in the lambda of this function as it
;;          reads/writes to current in/out port
;;
(define (api:tcp-dispatch-request-make-handler dbstruct) ;; cmd run-id params)
  (assert *toppath* "FATAL: api:tcp-dispatch-request-make-handler called but *toppath* not set.")
  (if (not *server-signature*)
      (set! *server-signature* (tt:mk-signature *toppath*)))
  (lambda (indat)
    (api:register-thread (current-thread) (car indat))
    (let* ((result 
	    (let* ((numthreads (api:get-count-threads-alive))
		   (delay-wait (if (> numthreads 10)
				   (- numthreads 10)
				   0))
		   (normal-proc (lambda (cmd run-id params)
				  (case cmd
				    ((ping) *server-signature*)
				    (else
				     (api:dispatch-request dbstruct cmd run-id params))))))
	      (set! *api-process-request-count* numthreads)
	      (set! *db-last-access* (current-seconds))
;; 	      (if (not (eq? numthreads numthreads))
;; 	      (begin
;; 	      (api:remove-dead-or-terminated)
;; 	      (let ((threads-now (api:get-count-threads-alive)))
;; 	      (debug:print 0 *default-log-port* "WARNING: numthreads="numthreads", numthreads="numthreads", remaining="threads-now)
;; 	      (set! numthreads threads-now))))
	      (match indat
		     ((cmd run-id params meta)
		      (let* ((start-t (current-milliseconds))
			     (db-ok  (let* ((dbfname (dbmod:run-id->dbfname run-id))
					    (ok      (equal? dbfname (dbr:dbstruct-dbfname dbstruct))))
				       (case cmd
					 ((ping) #t) ;; we are fine
					 (else
     (let* ((cmd-in            (common:safe-vector-ref dat 0 'nocmd))
            (cmd               (if (symbol? cmd-in)
				   cmd-in
				   (string->symbol cmd-in)))
            (params            (common:safe-vector-ref dat 1 '()))
            (start-t           (current-milliseconds))
					  (assert ok "FATAL: database file and run-id not aligned.")))))
			     (ttdat   *server-info*)
			     (server-state (tt-state ttdat))
			     (maxthreads   20) ;; make this a parameter?
			     (status  (cond
                                       ((> numthreads maxthreads)
					(let* ((testsuite (common:get-testsuite-name))
					       (mtexe     (common:find-local-megatest))
            (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")
                 (case cmd
                   ;;===============================================
                   ;; READ/WRITE QUERIES
                   ;;===============================================
					       (proc      (lambda ()
							    ;; we are overloaded, try to start another server
							    (debug:print 0 *default-log-port* "Too many threads running, starting another server")
							    (tt:server-process-run *toppath* testsuite mtexe run-id))))
					  (set! *server-start-requests* (cons proc *server-start-requests*)))
					;; 'busy
					'loaded ;; not ideal since the client will not backoff
					)
				       (else 'ok)))
			     (errmsg  (case status
					((busy)   (conc "Server overloaded, "numthreads" threads in flight, current cmd: " cmd "\n current threads: " (api:get-threads)))
					((loaded) (conc "Server loaded, "numthreads" threads in flight"))
					(else     #f)))
			     (result  (case status
					((busy)
					 (if (eq? cmd 'ping)
					     (normal-proc cmd run-id params)
					     ;; numthreads must be greater than 5 for busy
					     (* 0.1 (- numthreads maxthreads)) ;; was 15
					     )) ;; (- numthreads 29)) ;; call back in as many seconds
					((loaded)
					 ;; 			    (if (eq? (rmt:transport-mode) 'tcp)
					 ;; 				(thread-sleep! 0.5))
					 (normal-proc cmd run-id params))
					(else
					 (normal-proc cmd run-id params))))
			     (meta   (case cmd
				       ((ping) `((sstate . ,server-state)(sload . ,numthreads)))
				       (else   `((wait . ,delay-wait)))))
			     (payload (list status errmsg result meta)))
			;; (cmd run-id params meta)
			(db:add-stats cmd run-id params (- (current-milliseconds) start-t))
			payload))
		     (else
		      (assert #f "FATAL: failed to deserialize indat "indat))))))
      ;; (set! *api-process-request-count* (- *api-process-request-count* 1))
      ;; (serialize payload)
     
      (api:unregister-thread (current-thread))
      result)))

(define *api-halt-writes* #f)

(define (api:dispatch-request dbstruct cmd run-id params)
  (if (not *no-sync-db*)
      (db:open-no-sync-db))
  (let* ((start-time (current-milliseconds)))
    (if (member cmd api:write-queries)
	(let loop ()
	  (if *api-halt-writes*
	      (begin
		(thread-sleep! 0.2)
		(if (< (- (current-milliseconds) start-time)
		       5000) ;; hope it don't take more than five seconds to sync
		    (loop-time)
		    #;(debug:print 0 *default-log-port* "ERROR: writes halted for more than 5 seconds, sync might be taking too long"))))))
    (db:add-stats 'api-write-blocking-for-sync run-id params (- (current-milliseconds) start-time)))
  (case cmd
    ;;===============================================
    ;; READ/WRITE QUERIES
    ;;===============================================

		   ((nocmd)                         '(#f "All broken!"))

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

                   ;; TESTS
    ;; TESTS

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

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

    ((insert-test)                      (db:insert-test dbstruct run-id params))

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

    ((insert-run)                   (apply db:insert-run dbstruct params))

                   ;; STEPS
                   ((teststep-set-status!)         (apply db:teststep-set-status! dbstruct params))
                   ((delete-steps-for-test!)        (apply db:delete-steps-for-test! dbstruct params))
                   
                   ;; TEST DATA
                   ((test-data-rollup)             (apply db:test-data-rollup dbstruct params))
                   ((csv->test-data)               (apply db:csv->test-data dbstruct params))
    ;; STEPS
    ((teststep-set-status!)         (apply db:teststep-set-status! dbstruct params))
    ((delete-steps-for-test!)       (apply db:delete-steps-for-test! dbstruct params))
    
    ;; TEST DATA
    ((test-data-rollup)             (apply db:test-data-rollup dbstruct params))
    ((csv->test-data)               (apply db:csv->test-data dbstruct params))

                   ;; MISC
                   ((sync-inmem->db)               (let ((run-id (car params)))
                                                     (db:sync-touched dbstruct run-id force-sync: #t)))
                   ((mark-incomplete)              (apply db:find-and-mark-incomplete dbstruct params))
                   ((create-all-triggers)          (db:create-all-triggers dbstruct))
                   ((drop-all-triggers)            (db:drop-all-triggers dbstruct)) 
    ;; MISC
    ((sync-cachedb->db)               (let ((run-id (car params)))
                                      (db:sync-touched dbstruct run-id db:initialize-main-db force-sync: #t)))
    ((get-toplevels-and-incompletes) (apply db:get-toplevels-and-incompletes dbstruct params))
    ((mark-incomplete)              #f);;(thread-start! (make-thread (lambda () ;; no need to block on this one
					;;			  (apply db:find-and-mark-incomplete dbstruct params)
					;;			  #t)))) 
    ((create-all-triggers)          (db:create-all-triggers dbstruct))
    ((drop-all-triggers)            (db:drop-all-triggers dbstruct)) 

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

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

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

    ;; NO SYNC DB PROCESSES
    ((register-process)          (apply dbfile:register-process *no-sync-db* params))
    ((set-process-done)          (apply dbfile:set-process-done *no-sync-db* params))
    ((set-process-status)        (apply dbfile:set-process-status *no-sync-db* params))
    ((get-process-options)       (apply dbfile:get-process-options *no-sync-db* params))
    
    ;; ARCHIVES
    ;; ((archive-get-allocations)   
    ((archive-register-disk)     (apply db:archive-register-disk dbstruct params))
    ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
    ;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
		   
                   ;;======================================================================
                   ;; READ ONLY QUERIES
                   ;;======================================================================
    ;;======================================================================
    ;; READ ONLY QUERIES
    ;;======================================================================

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

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

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

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

                   ;; TEST DATA
                   ((read-test-data)               (apply db:read-test-data dbstruct params))
                   ((read-test-data*)              (apply db:read-test-data* dbstruct params))
                   ((get-data-info-by-id)          (apply db:get-data-info-by-id dbstruct params)) 
    ;; TEST DATA
    ((read-test-data)               (apply db:read-test-data dbstruct params))
    ((read-test-data-varpatt)       (apply db:read-test-data-varpatt dbstruct params))
    ((get-data-info-by-id)          (apply db:get-data-info-by-id dbstruct params)) 

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

                   ;; TASKS 
                   ((find-task-queue-records)   (apply tasks:find-task-queue-records dbstruct params))
		   (else
		    (debug:print 0 *default-log-port* "ERROR: bad api call " cmd)
		    (conc "ERROR: BAD api call " cmd))))))
    ;; TASKS 
    ((find-task-queue-records)   (apply tasks:find-task-queue-records dbstruct params))
    (else
     (debug:print 0 *default-log-port* "ERROR: bad api call " cmd)
     (conc "ERROR: BAD api call " cmd))))

       
       ;; save all stats
       (let ((delta-t (- (current-milliseconds)
			 start-t)))
	 (hash-table-set! *db-api-call-time* cmd
			  (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '()))))
       (if writecmd-in-readonly-mode
           (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:*
;;
;; NB// Runs on the server as part of the server loop
;;
(define (api:process-request dbstruct $) ;; the $ is the request vars proc
  (set! *api-process-request-count* (+ *api-process-request-count* 1))
  (let* ((cmd     ($ 'cmd))
	 (paramsj ($ 'params))
	 (params  (db:string->obj paramsj transport: 'http)) ;; incoming data from the POST (or is it a GET?)
	 (resdat  (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result )
	 (success (common:safe-vector-ref resdat 0 #f))
	 (res     (common:safe-vector-ref resdat 1 #f))) ;; (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)))

;;     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 apimod))
(declare (uses commonmod))
(declare (uses ulex))

(module apimod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import commonmod)
(import (prefix ulex ulex:))


(define (api:execute-requests params)
  #f)

)

;; 
;;     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 (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)

(declare (unit archive))
(declare (uses db))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses common))
(declare (uses commonmod))
(declare (uses rmtmod))

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

(import commonmod
	debugprint
	rmtmod
	(prefix mtargs args:))

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

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

        (archiver       (let ((s (configf:lookup *configdat* "archive" "archiver")))
			   (if s (string->symbol s) 'bup)))
        (rsync-exe (or (configf:lookup *configdat* "archive" "rsync") "rsync"))   
        (print-prefix      "Running: ") 
        (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target-patt run-patt "megatest-db"))
	(archive-dir  (if archive-info (cdr archive-info) #f))
	(archive-id   (if archive-info (car archive-info) -1))
        (home-host (common:get-homehost))
        (home-host    (server:choose-server *toppath* 'homehost))
        (archive-time (seconds->std-time-str (current-seconds)))
        (archive-staging-db (conc *toppath* "/.db-snapshot/archive_" archive-time))
        (tmp-db-path (conc (common:get-db-tmp-area) "/megatest.db"))
        (tmp-db-path (conc (dbfile:make-tmpdir-name *toppath* "") "/megatest.db"))
        (dbfile             (conc  archive-staging-db "/megatest.db"))) 
        (create-directory archive-staging-db #t)
        (let-values (((pid-val exit-status exit-code) (run-n-wait rsync-exe params: (list "-v" (conc (car home-host) ":"tmp-db-path) archive-staging-db) print-cmd: print-prefix)))
            (if (eq? exit-code 0)   
              (case archiver
	        ((bup) ;; Archive using bup
	          (let* ((bup-init-params  (list "-d" archive-dir "init"))

                              (exit 1))))
		     (debug:print-info 2 *default-log-port* "Archiving data with bup")
		     (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
                         (if (not (eq? exit-code 0))
                              (begin    
                              (debug:print-error 0 *default-log-port* "There was an error archiving data with bup. Archive failed.")
                              (exit 1))
                             (debug:print-info 2 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp <ts>. Current timestamp: " (seconds->std-time-str (current-seconds))))))) 
                             (debug:print-info 0 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp <ts>. Current timestamp: " (seconds->std-time-str (current-seconds))))))) 
               (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))
		 (debug:print-info 2 *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: "Running:"))
      (sleep 2)
      (db:multi-db-sync 
       (db:setup #f)
       (db:setup) ;; (db:setup-db *dbstruct-dbs* *toppath* #f)
       'killservers
       ;'dejunk
       ;'adj-testids
       'old2new
       )
      (debug:print-info 1 *default-log-port* "dropping trigerrs to update linktree")   
      (debug:print-info 1 *default-log-port* "dropping triggers to update linktree") 
      (rmt:drop-all-triggers)
  
    (let* ((linktree       (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
	  (src-archive-linktree (rmt:get-var "src-archive-linktree")))
        (if (not (equal? src-archive-linktree linktree))
           (rmt:update-tesdata-on-repilcate-db src-archive-linktree linktree))
              (debug:print-info 1 *default-log-port* "creating triggers after updating linktree")   
       (rmt:create-all-triggers)
))  

(define (archive:ls->list  bup-exe archive-dir internal-path)
  (let ((cmd (conc bup-exe " -d " archive-dir  " ls -l " internal-path "| awk '{print $6}' | sort"))
        (res '()))
    (debug:print-info 0 *default-log-port* cmd)
    (handle-exceptions
     exn
     #f ;; anything goes wrong - assume the process in NOT running.
     (with-input-from-pipe 
      cmd
      (lambda ()
	(let* ((inl (read-lines)))

(define (seconds->std-time-str sec)
  (time->string 
   (seconds->local-time sec)
   "%Y-%m-%d-%H%M%S"))
 

(define (archive:get-timestamp-dir bup-exe archive-dir testsuite-name target test-partial-path test-last-update)
    (print (seconds->std-time-str test-last-update)) 
    (debug:print-info 0 *default-log-port* "Test last update time:" (seconds->std-time-str test-last-update)) 
    (let* ((internal-path (conc testsuite-name "-" target))
           (archive-update-delay (string->number (or (configf:lookup *configdat* "archive" "test-update-delay") "900" )))  
           (ts-list (archive:ls->list  bup-exe archive-dir internal-path))
           (ds-flag (vector-ref (seconds->local-time) 8)))
           (let loop ((hed (car ts-list))
                       (tail (cdr ts-list)))
                   (if (and (null? tail) (equal? hed "latest"))
                        #f
                    (if (and (not (null? tail)) (equal? hed "latest"))
                        (loop (car tail) (cdr tail))
                  (let* ((archive-seconds (time-string->seconds hed ds-flag)))
                    (if (< (abs (- archive-seconds test-last-update)) 120)
                    (if (< (abs (- archive-seconds test-last-update)) archive-update-delay)
                    (let* ((test-list (archive:ls->list  bup-exe archive-dir (conc internal-path "/" hed "/" test-partial-path))))
                           (if (> (length test-list) 0)
                               hed
                               (if (not (null? tail)) 
                                 (loop (car tail) (cdr tail))
                                 #f)))
                       (if (null? tail)

	      (include-paths           (args:get-arg "-include"))
	      (exclude-pattern         (args:get-arg "-exclude-rx"))
	      (exclude-file            (args:get-arg "-exclude-rx-from")))
	 (if (not archive-timestamp-dir)
               (debug:print-error 0 *default-log-port* "Archive not found for testsuite" (common:get-testsuite-name) " run/test/itempath" test-partial-path)
         (begin    
	 ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children
         (debug:print-info 0 *default-log-port* "Archive time: " archive-timestamp-dir)
	 (if (and (not toplevel/children)  ;; special handling needed for toplevel with children
		  prev-test-physical-path
		  (common:file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in?
	     (let* ((base (pathname-directory prev-test-physical-path))
		    (dirn (pathname-file      prev-test-physical-path))
		    (newn (conc base "/." dirn)))
	       (debug:print-error 0 *default-log-port* "the old directory " prev-test-physical-path ", still exists! Moving it to " newn)

;;======================================================================
;; Copyright 2019, 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 artifacts))

(include "artifacts/artifacts.scm")

NOTE: keep megatest/artifacts/ in sync with datastore/artifacts

;; -*- scheme -*-
(
; Your egg's license:
(license "BSD")

; Pick one from the list of categories (see below) for your egg and enter it
; here.
(category db)

; A list of eggs pkts depends on.  If none, you can omit this declaration
; altogether. If you are making an egg for chicken 3 and you need to use
; procedures from the `files' unit, be sure to include the `files' egg in the
; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
; `depends' is an alias to `needs'.
;; (needs (autoload "3.0"))

; A list of eggs required for TESTING ONLY.  See the `Tests' section.
(test-depends test)

(author "Matt Welland")
(synopsis "A sha1-chain based datastore similar to the data format in fossil scm, consisting of artifacts of single line cards."))

(repo fossil "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}")
(uri zip "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}/zip/{egg-name}.zip?uuid={egg-release}")
(release "1.0")

;; Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of artifacts
;; 
;;     Pkts 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.
;; 
;;     Pkts 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 Pkts.  If not, see <http://www.gnu.org/licenses/>.
;;

;; CARDS:
;;
;; A card is a line of text, the first two characters are a letter followed by a
;;   space. The letter is the card type.
;;
;; artifact:
;;
;; An artifact is a sorted list of cards with a final card Z that contains the shar1 hash
;;   of all of the preceding cards.
;;
;; AARTIFACT:
;;
;;  An alist mapping card types to card data
;;      '((T . "artifacttype")
;;        (a . "some content"))
;;
;; EARTIFACT:
;;
;;  Extended packet using friendly keys. Must use a artifactspec to convert to/from eartifacts
;;    '((ptype . "artifacttype")
;;      (adata . "some content))
;;
;; DARTIFACT:
;;
;; artifacts pulled from the database have this format:
;;
;;((aartifact (Z . "7de89c09ac024b3832c93e16cd78d11e2e28733b")     <= this is a the alist
;;       (t . "v1.63/tip/dev")
;;       (c . "QUICKPATT")
;;       (T . "runstart")
;;       (P . "354eeb67120a921e3e33155ecab1b522ac10b6bd")
;;       (D . "1488995096.0"))
;;  (id . 8)
;;  (group-id . 0)
;;  (uuid . "7de89c09ac024b3832c93e16cd78d11e2e28733b")
;;  (parent . "")
;;  (artifact-type . "runstart")
;;  (artifact . "D 1488995096.0\nP 354eeb67120a921e3e33155ecab1b522ac10b6bd\nT runstart\nc QUICKPATT\nt v1.63/tip/dev\nZ 7de89c09ac024b3832c93e16cd78d11e2e28733b"))
;;
;; artifactspec is alist of alists mapping types and nicekeys to keys
;;
;; '((posting . ((title . t)
;;               (url   . u)
;;               (blurb . b)))
;;   (comment . ((comment . c)
;;               (score   . s))))

;; Reserved cards:
;;   P      : artifact parent
;;   R      : reference artifact containing mapping of short string -> sha1sum strings
;;   T      : artifact type
;;   D      : current time from (current-time), unless provided
;;   Z      : shar1 hash of the packet

;; Example usage:
;;
;; Create a artifact:
;;
;; (use artifacts)
;; (define-values (uuid artifact)
;;     (alist->artifact
;;       '((fruit . "apple") (meat . "beef"))  ;; this is the data to convert
;;       '((foods (fruit . f) (meat . m)))     ;; this is the artifact spec
;;       ptype:
;;       'foods))
;;
;; Add to artifact queue:
;;
;; (define db (open-queue-db "/tmp/artifacts" "artifacts.db"))
;; (add-to-queue db artifact uuid 'foods #f 0) ;; no parent and use group_id of 0
;;
;; Retrieve the packet from the db and extract a value:
;;
;; (alist-ref
;;    'meat
;;    (dartifact->alist
;;         (car (get-dartifacts db #f 0 #f))
;;        '((foods (fruit . f)
;;                 (meat . m)))))
;; => "beef"
;;

(module artifacts
(
;; cards, util and misc
;; sort-cards
;; calc-sha1
;;
;; low-level constructor procs, exposed only for development/testing, will be removed
construct-sdat
construct-artifact     
card->type/value  
add-z-card

;; queue database procs
open-queue-db
add-to-queue
create-and-queue
;; lookup-by-uuid
lookup-by-id
get-dartifacts
get-not-processed-artifacts
get-related
find-artifacts
process-artifacts
get-descendents
get-ancestors
get-artifacts
;; get-last-descendent
;; with-queue-db
;; load-artifacts-to-db

;; procs that operate directly on artifacts, sdat, aartifacts, dartifacts etc.
artifact->alist    ;; artifact -> aartifact (i.e. alist)
artifact->sdat     ;; artifact -> '("a aval" "b bval" ...)
sdat->alist   ;; '("a aval" "b bval"...) -> ((a . "aval")(b . "bval") ...)
dblst->dartifacts  ;; convert list of tuples from queue db into dartifacts
dartifact->alist   ;; flatten a dartifact into an alist containing all db fields and the artifact alist
dartifacts->alists ;; apply dartifact->alist to a list of alists using a artifact-spec
alist->artifact    ;; returns two values uuid, artifact
get-value     ;; looks up a value given a key in a dartifact
flatten-all   ;; merge the list of values from a query which includes a artifact into a flat alist <== really useful!
check-artifact

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

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

;; artifactsdb
artifactdb-conn     ;; useful
artifactdb-fname
artifactsdb-open
artifactsdb-close
artifactsdb-add-record
;; temporary
artifactdb-artifactspec

;; utility procs
increment-string ;; used to get indexes for strings in ref artifacts
make-report      ;; make a .dot file
calc-sha1
uuid-first-two-letters
uuid-remaining-letters

;; file and directory utils
multi-glob
capture-dir
file-get-sha1
check-same
link-or-copy
same-partition?
link-if-same-partition
archive-copy
write-to-archive
artifact-rollup
read-artifacts-into-hash
hash-of-artifacts->bundle
archive-dest

;; pathname-full-filename

;; minimal artifact functions
minimal-artifact-read
minimal-artifact->alist
afact-get-D
afact-get-Z
afact-get-T
afact-get
afact-get-number/default


;; bundles
write-bundle
read-bundle

;; new artifacts db
with-todays-adb
get-all-artifacts
refresh-artifacts-db

)

(import (chicken base) scheme (chicken process) (chicken time posix)
	(chicken io) (chicken file) (chicken pathname)
        chicken.process-context.posix (chicken string)
	(chicken time) (chicken sort) (chicken file posix) (chicken condition) srfi-1
	regex srfi-13 srfi-69 (chicken port) (chicken process-context)
	crypt sha1 matchable message-digest sqlite3 typed-records
	directory-utils
	scsh-process)

;;======================================================================
;; DATA MANIPULATION UTILS
;;======================================================================

(define-inline (unescape-data data)
  (string-translate* data '(("\\n" . "\n") ("\\\\" . "\\"))))

(define-inline (escape-data data)
  (string-translate* data '(("\n" . "\\n") ("\\" . "\\\\"))))

(define-inline (make-card type data)
  (conc type " " (escape-data (->string data))))

;; reverse an alist for doing artifactkey -> external key conversions
;;
(define-inline (reverse-aspec aspec)
  (map (lambda (dat)
	 (cons (cdr dat)(car dat)))
       aspec))

;; add a card to the list of cards, sdat
;; if type is #f return only sdat
;; if data is #f return only sdat
;;
(define-inline (add-card sdat type data)
  (if (and type data)
      (cons (make-card type data) sdat)
      sdat))

;;======================================================================
;; STRING AS FUNKY NUMBER
;;======================================================================

;; NOTE: PTDZ are removed as they are reserved. NB// the R card is not used in a
;;       ref, instead the P parent card is used.
;;       Question: Why does it matter to remove PTDZ?
;;                 To make the ref easier to use the ref strings will be the keys
;;                 so we cannot have overlap with any actual keys. But this is a
;;                 bit silly. What we need to do instead is reject keys of length
;;                 one where the char is in PTDZ
;;
;; This is basically base92
;;
(define string-num-chars (string->list "!#$%&'()*+,-./0123456789:;<=>?@ABCEFGHIJKLMNOQRSUVWXY[\\]^_abcdefghijklmnopqrstuvwxyz{|}~"))
;; "0123456789abcdefghijklmnopqrstuvwxyzABCEFGHIJKLMNOQSUVWXY!#$%&'()*+,-./[]:;<=>?\\^_{}|"))

(define (char-incr inchar)
  (let* ((carry     #f)
	 (next-char (let ((rem (member inchar string-num-chars)))
		      (if (eq? (length rem) 1) ;; we are at the last character in our string-num-chars list
			  (begin
			    (set! carry #t)
			    (car string-num-chars))
			  (cadr rem)))))
    (values next-char carry)))
    
(define (increment-string str)
  (if (string-null? str)
      "0"
      (let ((strlst (reverse (string->list str)))) ;; need to process the string from the lsd
	(list->string
	 (let loop ((hed (car strlst))
		    (tal (cdr strlst))
		    (res '()))
	   (let-values (((newhed carry)(char-incr hed)))
	     ;; (print "newhed: " newhed " carry: " carry " tal: " tal)
	     (let ((newres (cons newhed res)))
	       (if carry ;; we'll have to propagate the carry
		   (if (null? tal) ;; at the end, tack on "0" (which is really a "1")
		       (cons (car string-num-chars) newres)
		       (loop (car tal)(cdr tal) newres))
		   (append (reverse tal) newres)))))))))
    
;;======================================================================
;; P K T S D B   I N T E R F A C E
;;
;; INTEGER, REAL, TEXT
;;======================================================================
;;
;; spec
;;  ( (tablename1 . (field1name L1 TYPE)
;;                  (field2name L2 TYPE) ... )
;;    (tablename2 ... ))
;;
;;  Example: (tests (testname n TEXT)
;;                  (rundir   r TEXT)
;;                   ... )
;;
;; artifact keys are taken from the first letter, if that is not unique
;; then look at the next letter and so on
;;

;; simplify frequent need to get one result with default
;;
(define (get-one db default qry . params)
  (apply fold-row
   car
   default
   db
   qry
   params))

(define (get-rows db qry . params)
  (apply fold-row
   cons
   db
   qry
   params))
  
;; use this struct to hold the artifactspec and the db handle
;;
(defstruct artifactdb
  (fname       #f)
  (artifactsdb-spec #f)
  (artifactspec     #f)  ;; cache the artifactspec
  (field-keys  #f)  ;; cache the field->key mapping (field1 . k1) ...
  (key-fields  #f)  ;; cache the key->field mapping
  (conn        #f)
  )

;; WARNING: There is a simplification in the artifactsdb spec w.r.t. artifactspec.
;;          The field specs are the cdr of the table list - not a full
;;          list. The extra list level in artifactspec is gratuitous and should
;;          be removed.
;;
(define (artifactsdb-spec->artifactspec tables-spec)
  (map (lambda (tablespec)
	 (list (car tablespec)
	       (map (lambda (field-spec)
		      (cons (car field-spec)(cadr field-spec)))
		    (cdr tablespec))))
       tables-spec))

(define (artifactsdb-open dbfname artifactsdb-spec)
  (let* ((pdb      (make-artifactdb))
	 (dbexists (file-exists? dbfname))
	 (db       (open-database dbfname)))
    (artifactdb-artifactsdb-spec-set! pdb artifactsdb-spec)
    (artifactdb-artifactspec-set!     pdb (artifactsdb-spec->artifactspec artifactsdb-spec))
    (artifactdb-fname-set!       pdb dbfname)
    (artifactdb-conn-set!        pdb db)
    (if (not dbexists)
	(artifactsdb-init pdb))
    pdb))

(define (artifactsdb-init artifactsdb)
  (let* ((db          (artifactdb-conn artifactsdb))
	 (artifactsdb-spec (artifactdb-artifactsdb-spec artifactsdb)))
    ;; create a table for the artifacts themselves
    (execute db "CREATE TABLE IF NOT EXISTS artifacts (id INTEGER PRIMARY KEY, zkey TEXT, record_id INTEGER, artifact TEXT);")
    (for-each
     (lambda (table)
       (let* ((table-name (car table))
	      (fields     (cdr table))
	      (stmt (conc "CREATE TABLE IF NOT EXISTS "
			  table-name
			  " (id INTEGER PRIMARY KEY,"
			  (string-intersperse
			   (map (lambda (fieldspec)
				  (conc (car fieldspec) " "
					(caddr fieldspec)))
				fields)
			   ",")
			  ");")))
	 (execute db stmt)))
     artifactsdb-spec)))

;; create artifact from the data and insert into artifacts table
;; 
;; data is assoc list of (field . value) ...
;; tablename is a symbol matching the table name
;;
(define (artifactsdb-add-record artifactsdb tablename data #!optional (parent #f))
  (let*-values (((zkey artifact) (alist->artifact data (artifactdb-artifactspec artifactsdb) ptype: tablename)))
    ;; have the data as alist so insert it into appropriate table also
    (let* ((db        (artifactdb-conn artifactsdb)))
      ;; TODO: Address collisions
      (execute db "INSERT INTO artifacts (zkey,artifact,record_id) VALUES (?,?,?);"
		zkey artifact -1)
      (let* (;; (artifactid     (artifactsdb-artifactkey->artifactid artifactsdb artifactkey))
	     (record-id (artifactsdb-insert artifactsdb tablename data)))
	(execute db "UPDATE artifacts SET record_id=? WHERE zkey=?;"
		  record-id zkey)
      ))))

;; 
(define (artifactsdb-insert artifactsdb tablename data)
  (let* ((db (artifactdb-conn artifactsdb))
	 (stmt (conc "INSERT INTO " tablename
		     " (" (string-intersperse (map conc (map car data)) ",")
		     ") VALUES ('"
		     ;; TODO: Add lookup of data type and do not
		     ;;       wrap integers with quotes
		     (string-intersperse (map conc (map cdr data)) "','")
		     "');")))
    (print "stmt: " stmt)
    (execute db stmt)
    ;; lookup the record-id and return it
    
    ))
    
(define (artifactsdb-close artifactsdb)
  (finalize! (artifactdb-conn artifactsdb)))

;; (let loop ((s "0")(n 0))(print s)(if (< n 5000)(loop (increment-string s)(+ n 1))))

;;======================================================================
;; CARDS, MISC and UTIL
;;======================================================================

;; given string (likely multi-line) "dat" return shar1 hash
;;
(define (calc-sha1 instr)
  (message-digest-string
   (sha1-primitive)
   instr))

;; given a single card return its type and value
;;
(define (card->type/value card)
  (let ((ctype (substring card 0 1))
	(cval  (substring card 2 (string-length card))))
    (values (string->symbol ctype) cval)))

;;======================================================================
;; SDAT procs
;;  sdat is legacy/internal usage. Intention is to remove sdat calls from
;;  the exposed calls.
;;======================================================================

;; sort list of cards
;;
(define-inline (sort-cards sdat)
  (sort sdat string<=?))

;; artifact rules
;; 1. one card per line
;; 2. at least one card
;; 3. no blank lines

;; given sdat, a list of cards return uuid, packet (as sdat)
;;
(define (add-z-card sdat)
  (let* ((sorted-sdat (sort-cards sdat))
	 (dat         (string-intersperse sorted-sdat "\n"))
	 (uuid        (calc-sha1 dat)))
    (values
     uuid
     (conc
      dat
      "\nZ "
      uuid))))

(define (check-artifact artifact)
  (handle-exceptions
      exn
      #f ;; anything goes wrong - call it a crappy artifact
    (let* ((sdat (string-split artifact "\n"))
	   (rdat (reverse sdat)) ;; reversed
	   (zdat (car rdat))
	   (Z    (cadr (string-split zdat)))
	   (cdat (string-intersperse (reverse (cdr rdat)) "\n")))
      (equal? Z (calc-sha1 cdat)))))

;;======================================================================
;; AARTIFACTs
;;======================================================================

;; convert a sdat (list of cards) to an alist
;;
(define (sdat->alist sdat)
  (let loop ((hed (car sdat))
	     (tal (cdr sdat))
	     (res '()))
    (let-values (( (ctype cval)(card->type/value hed) ))
      ;; if this card is not one of the common ones tack it on to rem
      (let* ((oldval (alist-ref ctype res))
	     (newres (cons (cons ctype
				 (if oldval ;; list or string
				     (if (list? oldval)
					 (cons cval oldval)
					 (cons cval (list oldval)))
				     cval))
			   res)))
	(if (null? tal)
	    newres
	    (loop (car tal)(cdr tal) newres))))))

;;((aartifact (Z . "7de89c09ac024b3832c93e16cd78d11e2e28733b")     <= this is a the alist
;;       (t . "v1.63/tip/dev")
;;       (c . "QUICKPATT")
;;       (T . "runstart")
;;       (P . "354eeb67120a921e3e33155ecab1b522ac10b6bd")
;;       (D . "1488995096.0"))
;;  (id . 8)
;;  (group-id . 0)
;;  (uuid . "7de89c09ac024b3832c93e16cd78d11e2e28733b")
;;  (parent . "")
;;  (artifact-type . "runstart")
;;  (artifact . "D 1488995096.0\nP 354eeb67120a921e3e33155ecab1b522ac10b6bd\nT runstart\nc QUICKPATT\nt v1.63/tip/dev\nZ 7de89c09ac024b3832c93e16cd78d11e2e28733b"))
;;
;; artifactspec is alist of alists mapping types and nicekeys to keys
;;
;; '((posting . ((title . t)
;;               (url   . u)
;;               (blurb . b)))
;;   (comment . ((comment . c)
;;               (score   . s))))

;; DON'T USE? 
;;
(define (get-value field dartifact . spec-in)
  (if (null? spec-in)
      (alist-ref field dartifact)
      (let* ((spec  (car spec-in))
	     (aartifact  (alist-ref 'aartifact dartifact))) ;; get the artifact alist
	(if (and aartifact spec)
	    (let* ((ptype (alist-ref 'artifact-type dartifact))
		   (pspec (alist-ref (string->symbol ptype) spec))) ;; do we have a spec for this type of artifact
	      (and pspec
		  (let* ((key (alist-ref field pspec)))
		    (and key (alist-ref key aartifact)))))
	    #f))))

;; convert a dartifact to a pure alist given a artifactspec
;; this flattens out the alist to include the data from
;; the queue database record
;;
(define (dartifact->alist dartifact artifactspec)
  (let* ((aartifact       (alist-ref 'aartifact dartifact))
	 (artifact-type   (or (alist-ref 'artifact-type dartifact) ;; artifact-type is from the database field artifact_type
			 (alist-ref 'T aartifact)))
	 (artifact-fields (alist-ref (string->symbol artifact-type) artifactspec))
	 (rev-fields (if artifact-fields
			 (reverse-aspec artifact-fields)
			 '())))
    (append (map (lambda (entry)
		   (let* ((artifact-key (car entry))
			  (new-key (or (alist-ref artifact-key rev-fields) artifact-key)))
		     `(,new-key . ,(cdr entry))))
		 aartifact)
	    dartifact)))

;; convert a list of dartifacts into a list of alists using artifact-spec
;;
(define (dartifacts->alists dartifacts artifact-spec)
   (map (lambda (x)
	  (dartifact->alist x artifact-spec))
	dartifacts))

;; Generic flattener, make the tuple and artifact into a single flat alist
;;
;; qry-result-spec is a list of symbols corresponding to each field
;;
(define (flatten-all inlst artifactspec . qry-result-spec)
  (map
   (lambda (tuple)
     (dartifact->alist
      (apply dblst->dartifacts tuple qry-result-spec)
      artifactspec))
   inlst))

;; call like this:
;;  (construct-sdat 'a "a data" 'S "S data" ...)
;; returns list of cards
;;  ( "A a value" "D 12345678900" ...)
;;
(define (construct-sdat . alldat)
  (let ((have-D-card #f)) ;; flag
    (if (even? (length alldat))
	(let loop ((type (car alldat))
		   (data (cadr alldat))
		   (tail (cddr alldat))
		   (res  '()))
	  (if (eq? type 'D)(set! have-D-card #t))
	  (if (null? tail)
	      (if have-D-card ;; return the constructed artifact, add a D card if none found
		  (add-card res type data)
		  (add-card 
		   (add-card res 'D (current-seconds))
		   type data))
	      (loop (car tail)
		    (cadr tail)
		    (cddr tail)
		    (add-card res type data))))
	#f))) ;; #f means it failed to create the sdat

(define (construct-artifact . alldat)
  (add-z-card
   (apply construct-sdat alldat)))

;;======================================================================
;; CONVERTERS
;;======================================================================

(define (artifact->sdat artifact)
  (map unescape-data (string-split artifact "\n")))

;; given a pure artifact return an alist
;;
(define (artifact->alist artifact #!key (artifactspec #f))
  (let ((sdat (cond
	       ((string? artifact)  (artifact->sdat artifact))
	       ((list? artifact)    artifact)
	       (else #f))))
    (if artifact
	(if artifactspec
	    (dartifact->alist (list (cons 'aartifact (sdat->alist sdat))) artifactspec)
	    (sdat->alist sdat))
	#f)))

;; convert an alist to an sdat
;;  in: '((a . "blah")(b . "foo"))
;; out: '("a blah" "b foo")
;;
(define (alist->sdat adat)
  (map (lambda (dat)
	 (conc (car dat) " " (cdr dat)))
       adat))

;; adat is the incoming alist, aspec is the mapping
;; from incoming key to the artifact key (usually one
;; letter to keep data tight) see the artifactspec at the
;; top of this file
;;
;; NOTE: alists can contain multiple instances of the same key (supported fine by artifacts)
;;       but you (obviously I suppose) cannot use alist-ref to access those entries.
;;
(define (alist->artifact adat aspec #!key (ptype #f)(no-d #f))
  (let* ((artifact-type (or ptype
			    (alist-ref 'T adat) ;; can provide in the incoming alist
			    #f))
	 (artifact-spec (if artifact-type            ;; alist of external-key -> key
			    (or (alist-ref artifact-type aspec) '())
			    (if (null? aspec)
				'()
				(cdar aspec)))) ;; default to first one if nothing specified
	 (new-alist (map (lambda (dat)
			   (let* ((key    (car dat))
				  (val    (cdr dat))
				  (newkey (or (alist-ref key artifact-spec)
					      key)))
			     (cons newkey (escape-data (conc val))))) ;; convert all incoming data (symbols, numbers etc.) to a string and then escape newlines.
			 adat))
	 (new-with-type (if (alist-ref 'T new-alist)
			    new-alist
			    (cons `(T . ,artifact-type) new-alist)))
	 (with-d-card   (if (or no-d ;; no timestamp wanted
				(alist-ref 'D new-with-type))
			    new-with-type
			    (cons `(D . ,(current-seconds))
				  new-with-type))))
    (add-z-card
     (alist->sdat with-d-card))))

;;======================================================================
;;  D B   Q U E U E   I N T E R F A C E
;;======================================================================

;; artifacts (
;;   id SERIAL PRIMARY KEY,
;;   uuid TEXT NOT NULL,
;;   parent_uuid TEXT default '',
;;   artifact_type INTEGER DEFAULT 0,
;;   group_id INTEGER NOT NULL,
;;   artifact TEXT NOT NULL

;; schema is list of SQL statements - can be used to extend db with more tables
;;
(define (open-queue-db dbpath dbfile #!key (schema '()))
  (let* ((dbfname  (conc dbpath "/" dbfile))
	 (dbexists (if (file-exists? dbfname) #t (begin (create-directory dbpath #t) #f)))
	 (db       (open-database dbfname)))
    ;; (set-busy-handler! (dbi:db-conn db) (busy-timeout 10000))
    (if (not dbexists) ;; NOTE: In the archive we allow duplicates and other messiness. 
	(for-each
	 (lambda (stmt)
	   (execute db stmt))
	 (cons "CREATE TABLE IF NOT EXISTS artifacts
                          (id           INTEGER PRIMARY KEY,
                           group_id     INTEGER NOT NULL,
                           uuid         TEXT NOT NULL,
                           parent_uuid  TEXT TEXT DEFAULT '',
                           artifact_type     TEXT NOT NULL,
                           artifact          TEXT NOT NULL,
                           processed    INTEGER DEFAULT 0)"
		   schema))) ;; 0=not processed, 1=processed, 2... for expansion
    db))

(define (add-to-queue db artifact uuid artifact-type parent-uuid group-id)
  (execute db "INSERT INTO artifacts (uuid,parent_uuid,artifact_type,artifact,group_id)
                   VALUES(?,?,?,?,?);" ;; $1,$2,$3,$4,$5);"
	    uuid
	    (if parent-uuid parent-uuid "");; use null string as placeholder for no parent uuid.
	    (if artifact-type (conc artifact-type) "") 
	    artifact
	    group-id))

;; given all needed parameters create a artifact and store it in the queue
;;  procs is an alist that maps artifact-type to a function that takes a list of artifact params
;;  in data and returns the uuid and artifact
;;
(define (create-and-queue conn procs artifact-type parent-uuid group-id data)
  (let ((proc (alist-ref artifact-type procs)))
    (if proc
	(let-values (( (uuid artifact) (proc data) ))
	  (add-to-queue conn artifact uuid artifact-type parent-uuid group-id)
	  uuid)
	#f)))

;; given uuid get artifact, if group-id is specified use it (reduces probablity of
;;     being messed up by a uuid collision)
;;
(define (lookup-by-uuid db artifact-uuid group-id)
  (if group-id
      (get-one db "SELECT artifact FROM artifacts WHERE group_id=? AND uuid=?;" group-id artifact-uuid)
      (get-one db "SELECT artifact FROM artifacts WHERE uuid=?;" artifact-uuid)))
      
;; find a packet by its id
;;
(define (lookup-by-id db id)
  (get-one db "SELECT artifact FROM artifacts WHERE id=?;" id))


;;======================================================================
;;  P R O C E S S   P K T S
;;======================================================================

;; given a list of field values pulled from the queue db generate a list
;; of dartifact's
;;
(define (dblst->dartifacts lst . altmap)
  (let* ((maplst (if (null? altmap)
		     '(id group-id uuid parent artifact-type artifact processed)
		     altmap))
	 (res (map cons maplst lst))) ;; produces list of pairs, i.e an alist
    (cons `(aartifact . ,(artifact->alist (alist-ref 'artifact res)))
	  res)))

;; NB// ptypes is a list of symbols, '() or #f find all types
;;
(define (get-dartifacts db ptypes group-id parent-uuid #!key (uuid #f))
  (let* ((ptype-qry (if (and ptypes
			     (not (null? ptypes)))
			(conc " IN ('" (string-intersperse (map conc ptypes) "','") "')")
			(conc " LIKE '%' ")))
	 (rows      (get-rows
		     db
		     (conc
		      "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed FROM artifacts
                         WHERE artifact_type " ptype-qry " AND group_id=?
                         AND processed=0 "
			 (if parent-uuid (conc "AND parent_uuid='" parent-uuid "' ") "")
			 (if uuid        (conc "AND        uuid='"        uuid "' ") "")
			 "ORDER BY id DESC;")
		     group-id)))
    (map dblst->dartifacts (map vector->list rows))))

;; get N artifacts not yet processed for group-id
;;
(define (get-not-processed-artifacts db group-id artifact-type limit offset)
  (map dblst->dartifacts
       (map vector->list
	    (get-rows
	     db
	     "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed FROM artifacts
                WHERE artifact_type = ? AND group_id = ? AND processed=0
                LIMIT ? OFFSET ?;"
	     (conc artifact-type) ;; convert symbols to string
	     group-id
	     limit
	     offset
	     ))))

;; given a uuid, get not processed child artifacts 
;;
(define (get-related db group-id uuid)
  (map dblst->dartifacts
       (get-rows
	db
	"SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed FROM artifacts
           WHERE parent_uuid=? AND group_id=? AND processed=0;"
	uuid group-id)))

;; generic artifact processor
;;
;; find all packets in group-id of type in ptypes and apply proc to artifactdat
;;
(define (process-artifacts conn group-id ptypes parent-uuid proc)
  (let* ((artifacts (get-dartifacts conn ptypes group-id parent-uuid)))
    (map proc artifacts)))

;; criteria is an alist ((k . valpatt) ...)
;;   - valpatt is a regex
;;   - ptypes is a list of types (symbols expected)
;;   match-type: 'any or 'all
;;
(define (find-artifacts db ptypes criteria #!key (processed #f)(match-type 'any)(artifact-spec #f)) ;; processed=#f, don't use, else use
  (let* ((artifacts (get-dartifacts db ptypes 0 #f))
	 (match-rules (lambda (artifactdat) ;; returns a list of matching rules
			(filter (lambda (c)
				  ;; (print "c: " c)
				  (let* ((ctype (car c)) ;; card type
					 (rx    (cdr c)) ;; card pattern
					 ;; (t     (alist-ref 'artifact-type artifactdat))
					 (artifact   (alist-ref 'artifact artifactdat))
					 (aartifact  (artifact->alist artifact))
					 (cdat  (alist-ref ctype aartifact)))
				    ;; (print "cdat: " cdat) ;; " aartifact: " aartifact)
				    (if cdat
					(string-match rx cdat)
					#f)))
				criteria)))
	 (res         (filter (lambda (artifactdat)
				(if (null? criteria) ;; looking for all artifacts
				    #t
				    (case match-type
				      ((any)(not (null? (match-rules artifactdat))))
				      ((all)(eq? (length (match-rules artifactdat))(length criteria)))
				      (else
				       (print "ERROR: bad match type " match-type ", expecting any or all.")))))
			      artifacts)))
    (if artifact-spec
	(dartifacts->alists res artifact-spec)
	res)))

;; get descendents of parent-uuid
;;
;; NOTE: Should be doing something like the following:
;;
;; given a uuid, get not processed child artifacts 
;; processed:
;;    #f => get all
;;     0 => get not processed
;;     1 => get processed
;;
(define (get-ancestors db group-id uuid #!key (processed #f))
  (map dblst->dartifacts
       (map vector->list
	    (get-rows
	     db
	     (conc
	      "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed 
                FROM artifacts
                 WHERE uuid IN 
                     (WITH RECURSIVE
                       tree(uuid,parent_uuid)
                        AS
                        (
                           SELECT uuid, parent_uuid
                           FROM artifacts
                           WHERE uuid = ?
                           UNION ALL
                           SELECT t.uuid, t.parent_uuid
                           FROM artifacts t
                           JOIN tree ON t.uuid = tree.parent_uuid
                        )
	              SELECT uuid FROM tree)
	    AND group_id=?" (if processed (conc " AND processed=" processed) "") ";")
	     uuid group-id))))

;; Untested
;;
(define (get-descendents db group-id uuid #!key (processed #f))
  (map dblst->dartifacts
       (map vector->list
	    (get-rows
	     db
	     (conc
	      "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed 
                FROM artifacts
                 WHERE uuid IN 
                     (WITH RECURSIVE
                       tree(uuid,parent_uuid)
                        AS
                        (
                           SELECT uuid, parent_uuid
                           FROM artifacts
                           WHERE uuid = ?
                           UNION ALL
                           SELECT t.uuid, t.parent_uuid
                           FROM artifacts t
                           JOIN tree ON t.parent_uuid = tree.uuid
                        )
	              SELECT uuid FROM tree)
	    AND group_id=?" (if processed (conc " AND processed=" processed) "") ";")
	     uuid group-id))))

;; look up descendents based on given info unless passed in a list via inlst
;;
;; (define (get-last-descendent db group-id uuid #!key (processed #f)(inlst #f))
;;   (let ((descendents (or inlst (get-descendents db group-id uuid processed: processed))))
;;     (if (null? descendents)
;; 	#f
;; 	(last descendents))))

;;======================================================================
;;  A R C H I V E S - always to a sqlite3 db 
;;======================================================================

;; open an archive db
;; path: archive-dir/<year>/month.db
;;
#;(define (archive-open-db archive-dir)
  (let* ((curr-time (seconds->local-time (current-seconds)))
	 (dbpath    (conc archive-dir "/" (time->string curr-time "%Y")))
	 (dbfile    (conc dbpath "/" (time->string curr-time "%m") ".db"))
	 (dbexists (if (file-exists? dbfile) #t (begin (create-directory dbpath #t) #f))))
    (let ((db (open-database dbfile)))
      ;; (set-busy-handler! db (busy-timeout 10000))
      (if (not dbexists) ;; NOTE: In the archive we allow duplicates and other messiness. 
	  (execute db "CREATE TABLE IF NOT EXISTS artifacts
                          (id           INTEGER,
                           group_id     INTEGER,
                           uuid         TEXT,
                           parent_uuid  TEXT,
                           artifact_type     TEXT,
                           artifact          TEXT,
                           processed    INTEGER DEFAULT 0)"))
      db)))

;; turn on transactions! otherwise this will be painfully slow
;;
#;(define (write-archive-artifacts src-db db artifact-ids)
  (let ((artifacts (get-rows
	       src-db
	       (conc "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact FROM artifacts WHERE id IN ("
		     (string-intersperse (map conc artifact-ids) ",") ")"))))
    ;; (dbi:with-transaction
    ;;  db
     (lambda ()
       (for-each
	(lambda (artifact)
	  (apply execute  db "INSERT INTO artifacts (id,group_id,uuid,parent_uuid,artifact_type,artifact)
                               VALUES (?,?,?,?,?,?)"
		 artifact))
	artifacts)))) ;; )

;; given a list of uuids and lists of uuids move all to
;; the sqlite3 db for the current archive period
;;
#;(define (archive-artifacts conn artifact-ids archive-dir)
  (let ((db (archive-open-db archive-dir)))
    (write-archive-artifacts conn db artifact-ids)
    (finalize! db))
  ;; (pg:with-transaction
  ;;  conn
  ;; (lambda ()
     (for-each
      (lambda (id)
	(get-one
	 conn
	 "DELETE FROM artifacts WHERE id=?" id))
      artifact-ids)) ;; ))

;; given a list of ids mark all as processed
;;
(define (mark-processed conn artifact-ids)
  ;; (pg:with-transaction
   ;; conn
   ;; (lambda ()
     (for-each
      (lambda (id)
	(get-one
	 conn
	 "UPDATE artifacts SET processed=1 WHERE id=?;" id))
      artifact-ids)) ;; x))

;; a generic artifact getter, gets from the artifacts db
;;
(define (get-artifacts conn ptypes)
  (let* ((ptypes-str    (if (null? ptypes)
			    ""
			    (conc " WHERE artifact_type IN ('" (string-intersperse ptypes ",") "') ")))
	 (qry-str       (conc "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed FROM artifacts" ptypes-str)))
    (map vector->list (get-rows conn qry-str))))

;; make a report of the artifacts in the db
;; ptypes of '() gets all artifacts
;; display-fields
;;
(define (make-report dest conn artifactspec display-fields . ptypes)
  (let* (;; (conn          (dbi:db-conn (s:db)))
	 (all-rows      (get-artifacts conn ptypes))
	 (all-artifacts      (flatten-all
			 all-rows
			 artifactspec
			 'id 'group-id 'uuid 'parent 'artifact-type 'artifact 'processed))
	 (by-uuid       (let ((ht (make-hash-table)))
			  (for-each
			   (lambda (artifact)
			     (let ((uuid (alist-ref 'uuid artifact)))
			       (hash-table-set! ht uuid artifact)))
			   all-artifacts)
			  ht))
	 (by-parent     (let ((ht (make-hash-table)))
			  (for-each
			   (lambda (artifact)
			     (let ((parent (alist-ref 'parent artifact)))
			       (hash-table-set! ht parent (cons artifact (hash-table-ref/default ht parent '())))))
			   all-artifacts)
			    ht))
	 (oup           (if dest (open-output-file dest) (current-output-port))))
    
    (with-output-to-port
	oup
      (lambda ()
	(print "digraph megatest_state_status {
  // ranksep=0.05
  rankdir=LR;
  node [shape=\"box\"];
")
	;; first all the names
	(for-each
	 (lambda (artifact)
	   (let* ((uuid        (alist-ref 'uuid artifact))
		  (shortuuid   (substring uuid 0 4))
		  (type        (alist-ref 'artifact-type artifact))
		  (processed   (alist-ref 'processed artifact)))
	     
	     (print "\"" uuid "\" [label=\"" shortuuid ", ("
		    type ", "
		    (if processed "processed" "not processed") ")")
	     (for-each
	      (lambda (key-field)
		(let ((val (alist-ref key-field artifact)))
		  (if val
		      (print key-field "=" val))))
	      display-fields)
	     (print "\" ];")))
	 all-artifacts)
	;; now for parent-child relationships
	(for-each
	 (lambda (artifact)
	   (let ((uuid   (alist-ref 'uuid artifact))
		 (parent (alist-ref 'parent artifact)))
	     (if (not (equal? parent ""))
		 (print "\"" parent "\" -> \"" uuid"\";"))))
	 all-artifacts)

	(print "}")
	))
    (if dest
	(begin
	  (close-output-port oup)
	  (system "dot -Tpdf out.dot -o out.pdf")))
    
    ))

;;======================================================================
;; Read ref artifacts into a vector < laststr hash table > 
;;======================================================================



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

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

;; read artifact into alist
;;
(define (read-artifact->alist artifact-file #!key (artifactspec #f))
  (artifact->alist (with-input-from-file
		  artifact-file
		read-string)
	      artifactspec: artifactspec))

;;======================================================================
;; File utils, stuff useful for file management
;;======================================================================

(define (file-get-sha1 fname)
  (let* ((sha1-res (run/strings (sha1sum ,fname))))
    (car (string-split (car sha1-res)))))

(define (link-or-copy srcf destf)
  (or (handle-exceptions
       exn
       #f
       (file-link srcf destf))
      (if (file-exists? destf)
	  (print "NOTE: destination already exists, skipping copy.")
	  (copy-file srcf destf))))

;; (define (files-diff file1 file2)
;;   (let* ((diff-res (with-input-from-port
;; 		       (run/port (diff "-q" ,file1 ,file2))
;; 		     (lambda ()
;; 		       (let* ((res (read-line)))
;; 			 (read-lines)
;; 			 res)))))
;;     (car (string-split sha1-res))))
;; 


(define (check-same file1 file2)
  (cond
   ((not (and (file-exists? file1)(file-exists? file2))) #f)
   ((not (equal? (file-size file1)(file-size file2))) #f)
   (else
    (let-values (((status run-ok process-id)
		  (run (diff "-q" ,file1 ,file2))))
      status))))

(define *pcache* (make-hash-table))
(define (get-device dir)
  (let ((indat (or (hash-table-ref/default *pcache* dir #f)
		   (let* ((inp (open-input-pipe (conc "df --output=source \""dir"\"")))
			  (res (read-lines inp)))
		     (close-input-port inp)
		     (hash-table-set! *pcache* dir res)
		     res))))
    (cadr indat)))

(define (same-partition? dir1 dir2)
  (equal? (get-device dir1)(get-device dir2)))

(define (link-if-same-partition file1 file2)
  (let* ((dir1 (pathname-directory file1))
	 (dir2 (pathname-directory file2))
	 (f1   (pathname-file file1))
	 (f2   (pathname-file file2)))
    (if (same-partition? dir1 dir2)
	(let* ((tmpname (conc "."f2"-"(current-seconds))))
	  ;; this steps needs to be executed as actual user    
	  (move-file file2 (conc dir1 "/" tmpname))
	  (file-link file1 file2)
	  (delete-file (conc dir1 "/" tmpname))))))

(define (uuid-first-two-letters sha1sum)
  (substring sha1sum 0 2))

(define (uuid-remaining-letters sha1sum)
  (let ((slen (string-length sha1sum)))
    (substring sha1sum 2 slen)))

(define (archive-dest destd sha1sum)
  (let* ((subdir         (uuid-first-two-letters sha1sum)) ;; (substring sha1sum 0 2))
	 ;; (slen           (string-length sha1sum))
	 (rem            sha1sum #;(uuid-remaining-letters sha1sum)) ;; (substring sha1sum 3 slen))
	 (full-dest-dir  (conc destd"/"subdir))
	 (full-dest-file (conc full-dest-dir"/"rem)))
    (if (not (directory-exists? full-dest-dir))
	(create-directory full-dest-dir #t))
    full-dest-file))

(define (write-to-archive data destd #!optional (nextnum #f))
  (let* ((sha1sum    (calc-sha1 data))
	 (full-dest  (conc (archive-dest destd sha1sum)
			   (if nextnum (conc "."nextnum) ""))))
    (if (file-exists? full-dest)
	(if (equal? (string-intersperse (with-input-from-file full-dest read-lines) "\n")
		    data)
	    (begin
	      ;; (print "INFO: data already exists in "full-dest" and is identical")
	      sha1sum)
	    (let ((nextnum (if nextnum (+ nextnum 1) 0)))
	      (print "WARN: data already exists in "full-dest" but is different! Trying again...")
	      (write-to-archive data destd nextnum)))
	(begin
	  (with-output-to-file
	      full-dest
	    (lambda ()
	      (print data)))
	  sha1sum)))) ;; BUG? Does print munge data?

;; copy srcf with sha1sum aabc... to aa/bc...
;;
(define (archive-copy srcf destd sha1sum)
  (let* ((full-dest-file (archive-dest destd sha1sum)))
    (let loop ((trynum 0))
      (let ((dest-name (if (> trynum 0)
			   (conc full-dest-file"-"trynum)
			   full-dest-file)))
	(cond
	 ((not (file-exists? srcf)) #f) ;; this should be an error?
	 ((and (file-exists? srcf)
	       (file-exists? dest-name))
	  (if (check-same srcf dest-name)
	      (link-if-same-partition dest-name srcf)
	      (loop (+ trynum 1)))) ;; collisions are rare, this protects against them
	 ((not (file-exists? dest-name))
	  (link-or-copy srcf dest-name))
	 (else #f))))))

;; multi-glob
(define (multi-glob globstrs inpath)
  ;; (print "multi-glob: "globstrs", "inpath)
  (if (equal? inpath "")
      globstrs
      (let* ((parts     (string-split inpath "/" #t))
	     (nextpart  (car parts))
	     (remaining (string-intersperse (cdr parts) "/")))
	(if (and (equal? nextpart "") ;; this must be a leading / meaning root directory
	         (null? globstrs))
	    (multi-glob '("/") remaining)
	    (begin
	      ;; (print "nextpart="nextpart", remaining="remaining)
	      (apply append
              (map (lambda (gstr)
                      (let* ((pathstr  (conc gstr"/"nextpart))
		   	     (pathstrs (glob pathstr)))
		          ;; (print "pathstr="pathstr)
		          (multi-glob pathstrs remaining)))
	               globstrs)))))))
	     

;; perm[/user:group]:
;;   DDD - octal perm (future expansion)
;;   -   - use umask/defacto perms (i.e. don't actively do anything)
;;   x   - mark as executable
;;
;; Cards:
;;   file:      f perm fname
;;   directory: d perm fname artifactid
;;   link:      l perm lname destpath
;;
;;   NOTE: cards are kept as (C . "value")
;;
;; given a directory path, ignore list and artifact store (hash-table):
;;  1. create sha1 tree at dest (e.g. aa/b3a7 ...)
;;  2. create artifact for each dir
;;    - cards for all files
;;    - cards for files that are symlinks or executables
;;  3. return (artifactid . artifact)
;;
;; NOTES:
;;   Use destdir of #f to not create sha1 tree
;;   Hard links will be used if srcdir and destdir appear to be same partion
;;
;; (alist->artifact adat aspec #!key (ptype #f))
;;
;;
;; (load "../../artifacts/artifacts.scm")(import big-chicken srfi-69 artifacts)(define dirdat (make-hash-table))
;; (capture-dir ".." ".." "/tmp/junk" '() dirdat)
;;
;; [procedure] (file-type FILE [LINK [ERROR]])
;; Returns the file-type for FILE, which should be a filename, a file-descriptor or a port object. If LINK is given and true, symbolic-links are not followed:
;; 
;;  regular-file
;;  directory
;;  fifo
;;  socket
;;  symbolic-link
;;  character-device
;;  block-device
;; Note that not all types are supported on every platform. If ERROR is given and false, then file-type returns #f if the file does not exist; otherwise, it signals an error.
;; 
;; 
(define (capture-dir curr-dir src-dir dest-dir ignore-list artifacts all-seen)
  (let* ((dir-dat (directory-fold
		   (lambda (fname res) ;; res is a list of artifact cards
		     (let* ((fullname   (conc curr-dir"/"fname)))
		       ;; (print "INFO: processing "fullname)
		       (if (hash-table-ref/default all-seen fullname #f) ;; something circular going on
			   (begin
			     (print "WARNING: possible circular link(s) "fullname)
			     res)
			   (let* ((ftype (file-type fullname #t #f)))
			     (hash-table-set! all-seen fullname ftype)
			     (cons
			      (case ftype ;; get the card
			       ((directory) ;; (directory? fullname)
				(let* ((new-curr-dir (conc curr-dir"/"fname))
				       (new-src-dir  (conc src-dir"/"fname)))
				  (let* ((dir-dat (capture-dir new-curr-dir new-src-dir
							       dest-dir ignore-list artifacts all-seen))
					 (a-id (car dir-dat))
					 (artf (cdr dir-dat)))
				    (hash-table-set! artifacts a-id artf)
				    (cons 'd (conc "- "a-id" "fname))))) ;; the card
			       ((symbolic-link) ;; (symbolic-link? fullname)
				(let ((ldest (read-symbolic-link fullname)))
				  (cons 'l (conc "- "fname"/"ldest)))) ;; delimit link name from dest with /
			       ((regular-file) ;; must be a file
				(let* ((start      (current-seconds))
				       (sha1sum    (file-get-sha1 fullname))
				       (perms      (if (file-executable? fullname) "x" "-")))
				  (let ((runtime (- (current-seconds) start)))
				    (if (> runtime 1)
					(print "INFO: file "fullname" took "runtime" seconds to calculate sha1.")))
				  (if dest-dir
				      (archive-copy fullname dest-dir sha1sum))
				  (cons 'f (conc perms " "sha1sum" "fname))))
			       (else
				(print "WARNING: file "fullname" of type "ftype" is NOT supported and will converted to empty file.")
				(let* ((sha1sum (write-to-archive "" dest-dir)))
				  (cons 'f (conc "- "sha1sum" "fname)))))
			      res)))))
		       '() src-dir #:dotfiles? #t))) ;; => (values srcdir_artifact sub_artifacts_list)
    ;; (print "dir-dat: " dir-dat)
    (let-values (((a-id artf)
		  (alist->artifact dir-dat '() ptype: 'd no-d: #t)))
      (hash-table-set! artifacts a-id artf)
      (cons a-id artf))))

;; maybe move this into artifacts?
;;
;; currently moves *.artifact into a bundle and moves the artifacts into attic
;; future: move artifacts under 1 meg in size into bundle up to 10 meg in size
;;
(define (artifact-rollup bundle-dir) ;; cfg storepath)
  ;; (let* ((bundle-dir (calc-bundle-dir cfg storepath)))
    (let* ((bundles   (glob (conc bundle-dir"/*.bundle")))
	   (artifacts (glob (conc bundle-dir"/*.artifact"))))
      (if (> (length artifacts) 30) ;; rollup only if > 30 artifacts
	  ;; if we have unbundled artifacts, bundle them
	  (let* ((ht     (read-artifacts-into-hash #f artifacts: artifacts))
		 (bundle (hash-of-artifacts->bundle ht)))
	    (write-bundle bundle bundle-dir)
	    (create-directory (conc bundle-dir"/attic") #t)
	    (for-each
	     (lambda (full-fname)
	       (let* ((fname   (pathname-strip-directory full-fname))
		      (newname (conc bundle-dir"/attic/"fname)))
		 (move-file full-fname newname #t)))
	     artifacts)
	    (conc "bundled "(length artifacts)))
	  "not enough artifacts to bundle")))

;; if destfile is a directory then calculate the sha1sum of the bundle and store it
;; by <sha1sum>.bundle
;;
;; incoming dat is pure text (bundle already sorted and appended:
;;
(define (write-bundle bdl-data destdir)
  (let* ((bdl-uuid  (calc-sha1 bdl-data)))
    (with-output-to-file
	(conc destdir"/"bdl-uuid".bundle")
      (lambda ()
	(print bdl-data)))))

;; minimal (and hopefully fast) artifact reader
;; TODO: Add check of shar sum.
;;
(define (minimal-artifact-read fname)
  (let* ((indat (with-input-from-file fname read-lines)))
    (if (null? indat)
	(values #f (conc "did not find an artifact in "fname))
	(let* ((zcard (last indat))
	       (cardk (substring zcard 0 1))
	       (cardv (substring zcard 2 (string-length zcard))))
	  (if (equal? cardk "Z")
	      (values cardv (string-intersperse indat "\n"))
	      (values #f (conc fname" is not a valid artifact")))))))

;; read artifacts from directory into hash
;; NOTE: support for max-count not implemented yet
;;
(define (read-artifacts-into-hash dir #!key (artifacts #f) (max-count #f)(ht #f))
  (let* ((artifacts (or artifacts
			(glob (conc dir"/*.artifact"))))
	 (ht        (or ht (make-hash-table))))
    (for-each
     (lambda (fname)
       (let-values (((uuid afct)
		     (minimal-artifact-read fname)))
	 (hash-table-set! ht uuid afct)))
     artifacts)
    ht))

;; ht is:
;;   uuid => artifact text
;; use write-bundle to put result into a bundle file
;;
(define (hash-of-artifacts->bundle ht)    
  (fold (lambda (k res)
	  (let* ((v (hash-table-ref ht k)))
	    (if res
		(conc res"\n"v)
		v)))
	#f
	(sort (hash-table-keys ht) string<=?)))

;; minimal artifact to alist
;;
(define (minimal-artifact->alist afact)
  (let* ((lines   (string-split afact "\n")))
    (map (lambda (a)
	   (let* ((key (string->symbol (substring a 0 1)))
		  (sl  (string-length a))
		  (val (if (> sl 2)
			   (substring a 2 sl)
			   "")))
	     (cons key val)))
	 lines)))

;; some accessors for common cards
(define (afact-get-D afact)
  (let ((dval (alist-ref 'D afact)))
    (if dval
	(string->number dval)
	#f)))

(define (afact-get-T afact) ;; get the artifact type as a symbol
  (let ((val (alist-ref 'T afact)))
    (if val
	(string->symbol val)
	val)))

(define (afact-get-Z afact)
  (alist-ref 'Z afact))

(define (afact-get afact key default)
  (or (alist-ref key afact)
      default))

(define (afact-get-number/default afact key default)
  (let ((val (alist-ref key afact)))
    (if val
	(or (string->number val) default) ;; seems wrong
	default)))

;; bundles are never big and reading into memory for processing is fine
;;
(define (read-bundle srcfile #!optional (mode 'uuid-raw))
  (let* ((indat (with-input-from-file srcfile read-lines)))
    (let loop ((tail indat)
	       (dat '())  ;; artifact being extracted
	       (res '())) ;; list of artifacts
      (if (null? tail)
	  (reverse res) ;; last dat should be empty list
	  (let* ((curr-line (car tail)))
	    (let-values (((ctype cdata)
			  (card->type/value curr-line)))
	      (let* ((is-z-card (eq? 'Z ctype))
		     (new-dat   (cons (case mode
					((uuid-raw) curr-line)
					(else       (cons ctype cdata)))
				      dat)))
		(if is-z-card
		    (loop (cdr tail) ;; done with this artifact
			  '()
			  (cons (case mode
				  ((uuid-raw) (cons cdata (string-intersperse (reverse new-dat) "\n")))
				  (else       (reverse new-dat)))
				res))
		    (loop (cdr tail)
			  new-dat
			  res)))))))))


;; find all .bundle and .artifacts files in bundle-dir
;; and inport them into sqlite handle adb
;; 
(define (refresh-artifacts-db adb bundle-dir)
  (let* ((bundles   (glob (conc bundle-dir"/*.bundle")))
	 (artifacts (glob (conc bundle-dir"/*.artifact")))
	 (uuids     (get-all-uuids adb 'hash)))
    (with-transaction
     adb
     (lambda ()
       (for-each
	(lambda (bundle-file)
	  ;; (print "Importing artifacts from "bundle-file)
	  (let* ((bdat (read-bundle bundle-file 'uuid-raw))
		 (count 0)
		 (inc   (lambda ()(set! count (+ count 1)))))
	    (for-each
	     (lambda (adat)
	       (match
		adat
		((zval . artifact)
		 (if (not (hash-table-exists? uuids zval))
		     (begin
		       ;; (print "INFO: importing new artifact "zval" from bundle "bundle-file)
		       (inc)
		       (execute adb "INSERT INTO artifacts (uuid, artifact) VALUES (?,?);"
				zval artifact)
		       (hash-table-set! uuids zval #t))))
		(else
		 (print "ERROR: Bad artifact data "adat))))
	     bdat)
	    (print "INFO: imported "count" artifacts from "bundle-file)))
	bundles)
       (for-each
	(lambda (artifact-file)
	  ;; (print "Importing artifact from "artifact-file)
	  (let-values (((uuid artifact) (minimal-artifact-read artifact-file)))
	    (if uuid
		(if (not (hash-table-exists? uuids uuid))
		    (begin
		      ;; (print "INFO: importing new artifact "uuid" from "artifact-file)
		      (execute adb "INSERT INTO artifacts (uuid, artifact) VALUES (?,?);"
			       uuid artifact)
		      (hash-table-set! uuids uuid #t)))
		(print "Bad artifact in "artifact-file))))
	artifacts)))))

;;======================================================================
;;  Artifacts db cache
;;======================================================================

;; artifacts
;;   id SERIAL PRIMARY KEY,
;;   uuid TEXT NOT NULL,
;;   artifact TEXT NOT NULL
;;
;; parents
;;   id INTEGER REFERENCES artids.id,  -- 
;;   parent_id  REFERENCES artids.id
;;
;; schema is list of SQL statements - can be used to extend db with more tables
;;
(define (open-artifacts-db dbpath dbfile #!key (schema '()))
  (let* ((dbfname  (conc dbpath "/" dbfile))
	 (dbexists (if (file-exists? dbfname) #t (begin (create-directory dbpath #t) #f)))
	 (adb      (open-database dbfname)))
    (set-busy-handler! adb (make-busy-timeout 10000))
    (execute adb "PRAGMA synchronous = 0;")
    (if (not dbexists)
	(with-transaction
	 adb
	 (lambda ()
	   (for-each
	    (lambda (stmt)
	      (execute adb stmt))
	    (append `("CREATE TABLE IF NOT EXISTS artifacts
                          (id           INTEGER PRIMARY KEY,
                           uuid         TEXT NOT NULL,
                           artifact     TEXT NOT NULL)"
		      
		      "CREATE TABLE IF NOT EXISTS parents
                          (id INTEGER REFERENCES artifacts(id) NOT NULL,
                           parent_id INTEGER REFERENCES artifacts(id) NOT NULL)")
		    schema)))))
    adb))

(define (generate-year-month-name #!optional (seconds #f))
  (let* ((curr-time (seconds->local-time (or seconds (current-seconds)))))
    (time->string curr-time "%Y%m")))

;; I don't like this function. TODO: remove the
;; mode and option to return ht. Use instead the
;; get-all-artifacts below
;;
(define (get-all-uuids adb #!optional (mode #f))
  (let* ((res (fold-row
	       (lambda (res uuid)
		 (cons uuid res))
	       '()
	       adb
	       "SELECT uuid FROM artifacts;")))
    (case mode
      ((hash)
       (let* ((ht (make-hash-table)))
	 (for-each
	  (lambda (uuid)
	    (hash-table-set! ht uuid #t))
	  res)
	 ht))
      (else res))))

;; returns raw artifacts (i.e. NOT alists but instead plain text)
(define (get-all-artifacts adb)
  (let* ((ht  (make-hash-table)))
    (for-each-row
     (lambda (id uuid artifact)
       (hash-table-set! ht uuid `(,id ,uuid ,artifact)))
     adb
     "SELECT id,uuid,artifact FROM artifacts;")
    ht))

;; given a bundle-dir copy or create to /tmp and open
;; the YYMM.db file and hand the handle to the given proc
;; NOTE: we operate in /tmp/ to accomodate users on NFS
;; where slamming Unix locks at an NFS filer can cause
;; locking fails. Eventually this /tmp behavior will be
;; configurable.
;;
(define (with-todays-adb bundle-dir proc)
  (let* ((dbname   (conc (generate-year-month-name) ".db"))
	 (destname (conc bundle-dir"/"dbname))
	 (tmparea  (conc "/tmp/"(current-user-name)"-"(calc-sha1 bundle-dir)))
	 (tmpname  (conc tmparea"/"dbname))
	 (lockfile (conc destname".update-in-progress")))
    ;; (print "with-todays-adb, bundle-dir: "bundle-dir", dbname: "dbname", destname: "destname",\n    tmparea: " tmparea", lockfile: "lockfile)
    (if (not (file-exists? tmparea))(create-directory tmparea #t))
    (let loop ((count 0))
      (if (file-exists? lockfile)
	  (if (< count 30) ;; aproximately 30 seconds
	      (begin
		(sleep 1)
		(loop (+ 1 count)))
	      (print "ERROR: "lockfile" exists, proceeding anyway"))
	  (if (file-exists? destname)
	      (begin
		(copy-file destname tmpname #t)
		(copy-file destname lockfile #t)))))
    (let* ((adb  (open-artifacts-db tmparea dbname))
	   (res  (proc adb)))
      (finalize! adb)
      (copy-file tmpname destname #t)
      (delete-file* lockfile)
      res)))

) ;; module artifacts

;; ATTIC