Megatest

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

(define-inline (debug:print n . params)
  (if (<= n *verbosity*)
      (apply print params)))

;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)

	                        expected REAL,
	                        tol REAL,
                                units TEXT,
                                comment TEXT DEFAULT '',
                                status TEXT DEFAULT 'n/a',
                                type TEXT DEFAULT '',
                              CONSTRAINT test_data UNIQUE (test_id,category,variable));")
	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS task_queue (id INTEGER PRIMARY KEY,
                                action TEXT DEFAULT '',
                                owner TEXT,
                                state TEXT DEFAULT 'new',
                                target TEXT DEFAULT '',
                                name TEXT DEFAULT '',
                                test TEXT DEFAULT '',
                                item TEXT DEFAULT '',
                                creation_time TIMESTAMP,
                                execution_time TIMESTAMP;")
	  (sqlite3:execute db "CREATE monitors (id INTEGER PRIMARY KEY,
                                pid INTEGER,
                                start_time TIMESTAMP,
                                last_update TIMESTAMP,
                                hostname TEXT,
                                username TEXT);")
	  ;; Must do this *after* running patch db !! No more. 
	  (db:set-var db "MEGATEST_VERSION" megatest-version)
	  ))
    db))

;;======================================================================
;; TODO:

\begin_layout Standard
A flow specifies the tests to run, the order and dependencies and is managed
 by a running megatest process.
\end_layout

\begin_layout Section
Flow Specification and Running (Not released yet)
\end_layout

\begin_layout Subsection
Write your flow file
\end_layout

\begin_layout Standard

status open

\begin_layout Plain Layout

megatest -runflow <flowname> :FIELD1 val1 :FIELD2 val2 :runname wk32.4
\end_layout

\end_inset


\end_layout

\begin_layout Section
Monitor based running
\end_layout

\begin_layout Subsection
Monitor logic
\end_layout

\begin_layout Standard
\begin_inset Graphics
	filename monitor-state-diagram.svg

\end_inset


\end_layout

\begin_layout Section
Reference

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

(define-inline (key:get-fieldname key)(vector-ref key 0))
(define-inline (key:get-fieldtype key)(vector-ref key 1))

(define-inline (keys->valslots keys) ;; => ?,?,? ....
  (string-intersperse (map (lambda (x) "?") keys) ","))

(define-inline (keys->key/field keys . additional)

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

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

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

;; make-vector-record tasks task id action owner state target name test item creation_time execution_time 
(define (make-tasks:task)(make-vector 10))
(define-inline (tasks:task-get-id               vec)    (vector-ref  vec 0))
(define-inline (tasks:task-get-action           vec)    (vector-ref  vec 1))
(define-inline (tasks:task-get-owner            vec)    (vector-ref  vec 2))
(define-inline (tasks:task-get-state            vec)    (vector-ref  vec 3))
(define-inline (tasks:task-get-target           vec)    (vector-ref  vec 4))
(define-inline (tasks:task-get-name             vec)    (vector-ref  vec 5))
(define-inline (tasks:task-get-test             vec)    (vector-ref  vec 6))
(define-inline (tasks:task-get-item             vec)    (vector-ref  vec 7))
(define-inline (tasks:task-get-creation_time    vec)    (vector-ref  vec 8))
(define-inline (tasks:task-get-execution_time   vec)    (vector-ref  vec 9))


;; make-vector-record tasks monitor pid start_time last_update hostname username
(define (make-tasks:monitor)(make-vector 5))
(define-inline (tasks:monitor-get-pid           vec)    (vector-ref  vec 0))
(define-inline (tasks:monitor-get-start_time    vec)    (vector-ref  vec 1))
(define-inline (tasks:monitor-get-last_update   vec)    (vector-ref  vec 2))
(define-inline (tasks:monitor-get-hostname      vec)    (vector-ref  vec 3))
(define-inline (tasks:monitor-get-username      vec)    (vector-ref  vec 4))

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

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

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

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

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

;;======================================================================
;; Tasks and Task monitors
;;======================================================================


;;======================================================================
;; Tasks
;;======================================================================



;;======================================================================
;; Task Monitors
;;======================================================================

(define (tasks:register-monitor db)
  (let* ((pid (current-process-id))
	 (hostname (get-host-name))
	 (userinfo (user-information (current-user-id)))
	 (username (car userinfo)))
    (sqlite3:execute db "INSERT INTO monitors (pid,start_time,last_update,hostname,username) VALUES (?,strftime('%s','now'),strftime('%s','now'),?,?);"
		     pid hostname username)))

(define (tasks:get-num-alive-monitors db)
  (let ((res 0))
    (sqlite3:for-each-row 
     (lambda (count)
       (set! res count))
     db
     "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;"
     (car (user-information (current-user-id))))
    res))

;; return one task from those who are 'new' OR 'waiting' AND more than 10sec old
;;
(define (tasks:snag-a-task db)
  (let ((res #f))
    (with-transaction 
     db
     (lambda ()
       (sqlite3:for-each-row
	(lambda (id . rem)
	  (set! res (apply vector id rem)))
	db
	"SELECT id,action,owner,state,target,name,test,item,creation_time,exectution_time 
           FROM tasks_queue
             WHERE 
                state='new' OR (state='waiting' AND 
                                last_update+10 > strftime('%s','now'))
             LIMIT 1;")
       (if res ;; yep, have work to be done
	   (begin
	     (sqlite3:execute db "UPDATE tasks_queue SET state='inprogress' WHERE id=?;"
			      (tasks:task-get-id res))
	     res))))))

(define (tasks:start-monitor db)
  (if (> (tasks:get-num-alive-monitors db) 2) ;; have two running, no need for more
      (debug:print 1 "INFO: Not starting monitor, already have more than two running")
      (let* ((megatestdb     (conc *toppath* "/megatest.db"))
	     (last-db-update 0)) ;; (file-modification-time megatestdb)))
	(task:register-monitor db)
	(let loop ((count 0))
	  ;; if the db has been modified we'd best look at the task queue
	  (let ((modtime (file-modification-time megatestdb)))
	    (if (> modtime last-db-update)
		(let* ((task   (tasks:snag-a-task db))
		       (action (if task (tasks:task-get-action task) #f)))
		  (if action
		      (case (string->symbol action)
			((run)       (tasks:start-run   db task))
			((remove)    (tasks:remove-runs db task))
			((lock)      (tasks:lock-runs   db task))
			((monitor)   (tasks:start-monitor db task))
			((rollup)    (tasks:rollup-runs db task))
			((updatemeta)(tasks:update-meta db task))
			((kill)      (tasks:kill-monitors db task))))
		  ;; WARNING: Possible race conditon here!!
		  ;; should this update be immediately after the task-get-action call above?
		  (set! modtime (file-modification-time megatestdb)))))
	  (loop (+ count 1))))))