;;======================================================================
;; Copyright 2017, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit rmtmod))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses dbfile)) ;; needed for records
;; (declare (uses apimod))
;; (declare (uses apimod.import))
;; (declare (uses ulex))
;; (include "ulex/ulex.scm")
(module rmtmod
*
(import scheme chicken data-structures extras matchable srfi-69)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import commonmod dbfile debugprint) ;; (prefix commonmod cmod:))
;; (import apimod)
;; (import (prefix ulex ulex:))
(include "db_records.scm")
(defstruct alldat
(areapath #f)
(ulexdat #f)
)
;; hold the send-receive proc in this parameter
(define rmtmod:send-receive #f) ;; (make-parameter #f))
;;======================================================================
;; M I S C
;;======================================================================
;; hand off a call to one of the db:queries statements
;; added run-id to make looking up the correct db possible
;;
(define (rmt:general-call stmtname run-id . params)
(rmtmod:send-receive 'general-call run-id (append (list stmtname run-id) params)))
;;======================================================================
;; import an sexpr file into the db
;;======================================================================
(define (rmt:import-sexpr sexpr-file)
(if (file-exists? sexpr-file)
(let* ((data (with-input-from-file sexpr-file read)))
(for-each
(lambda (targ-dat)
(rmt:import-target targ-dat)) ;; ("target" ("run1" ("data" (1 ("field" . "value") ...
data))
(let* ((msg (conc "ERROR: file "sexpr-file" not found")))
(debug:print 0 *default-log-port* msg)
(cons #f msg))))
(define (rmt:import-target targ-dat)
(let* ((target (car targ-dat))
(data (cdr targ-dat)))
(for-each
(lambda (run-dat)
(rmt:import-run target run-dat)) ;; ("runname" ("data" ("testid" ("field" . "value") ...
data)))
(define (rmt:import-run target run-dat)
(let* ((runname (car run-dat))
(all-dat (cdr run-dat))
(tests-data (alist-ref "data" all-dat equal?))
(run-meta (alist-ref "meta" all-dat equal?))
(run-id (rmt:insert-run target runname run-meta)))
(for-each
(lambda (test-dat)
(let* ((test-id (car test-dat))
(test-rec (cdr test-dat)))
(rmt:insert-test run-id test-rec)))
tests-data)))
;; insert run if not there, return id either way
(define (rmt:insert-run target runname run-meta)
;; look for id, return if found
(debug:print 0 *default-log-port* "Insert run: "target"/"runname)
(let* ((runs (rmtmod:send-receive 'simple-get-runs #f
;; runpatt count offset target last-update)
(list runname #f #f target #f))))
(if (null? runs)
(rmtmod:send-receive 'insert-run #f (list target runname run-meta))
(simple-run-id (car runs)))))
(define (rmt:insert-test run-id test-rec)
(let* ((testname (alist-ref "testname" test-rec equal?))
(item-path (alist-ref "item_path" test-rec equal?)))
(debug:print 0 *default-log-port* " Insert test in run "run-id": "testname"/"item-path)
(rmtmod:send-receive 'insert-test run-id test-rec)))
;;======================================================================
;; T E S T S
;;======================================================================
;; Just some syntatic sugar
(define (rmt:register-test run-id test-name item-path)
(assert (number? run-id) "FATAL: Run id required.")
(rmt:general-call 'register-test run-id run-id test-name item-path))
(define (rmt:get-test-id run-id testname item-path)
(assert (number? run-id) "FATAL: Run id required.")
(rmtmod:send-receive 'get-test-id run-id (list run-id testname item-path)))
(define (rmt:get-test-info-by-id run-id test-id)
(if (number? test-id)
(rmtmod:send-receive 'get-test-info-by-id run-id (list run-id test-id))
(begin
(debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
(print-call-chain (current-error-port))
#f)))
(define (rmt:get-test-state-status-by-id run-id test-id)
(rmtmod:send-receive 'get-test-state-status-by-id run-id (list run-id test-id)))
(define (rmt:test-get-rundir-from-test-id run-id test-id)
(rmtmod:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))
;; (define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
;; (assert (number? run-id) "FATAL: Run id required.")
;; (let* ((test-path (if (string? work-area)
;; work-area
;; (rmt:test-get-rundir-from-test-id run-id test-id))))
;; (debug:print 3 *default-log-port* "TEST PATH: " test-path)
;; (open-test-db test-path)))
;; WARNING: This currently bypasses the transaction wrapped writes system
(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
(assert (number? run-id) "FATAL: Run id required.")
(rmtmod:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment)))
;; (define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus)
;; (assert (number? run-id) "FATAL: Run id required.")
;; (rmtmod:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus)))
(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
(assert (number? run-id) "FATAL: Run id required.")
;; (if (number? run-id)
(rmtmod:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)))
;; (begin
;; (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id)
;; (print-call-chain (current-error-port))
;; '())))
(define (rmt:get-tests-for-run-state-status run-id testpatt last-update)
(assert (number? run-id) "FATAL: Run id required.")
(rmtmod:send-receive 'get-tests-for-run-state-status run-id (list run-id testpatt last-update)))
;; get stuff via synchash
(define (rmt:synchash-get run-id proc synckey keynum params)
(assert (number? run-id) "FATAL: Run id required.")
(rmtmod:send-receive 'synchash-get run-id (list run-id proc synckey keynum params)))
(define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in)
(assert (number? run-id) "FATAL: Run id required.")
(rmtmod:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in)))
;;======================================================================
;; Maintenance
;;======================================================================
(define (rmt:get-toplevels-and-incompletes run-id running-deadtime remotehoststart-deadtime)
(rmtmod:send-receive 'get-toplevels-and-incompletes run-id (list run-id running-deadtime remotehoststart-deadtime)))
(define (rmt:get-status-from-final-status-file run-dir)
(let ((infile (conc run-dir "/.final-status")))
;; first verify we are able to write the output file
(if (not (file-read-access? infile))
(begin
(debug:print 2 *default-log-port* "ERROR: cannot read " infile)
(debug:print 2 *default-log-port* "ERROR: run-dir is " run-dir)
#f
)
(with-input-from-file infile read-lines)
)))
(define (rmt:set-state-status-by-state-status run-id testname currstate currstatus newstate newstatus)
(rmtmod:send-receive 'set-state-status-by-state-status run-id (list run-id testname currstate currstatus newstate newstatus)))
)