Megatest

;======================================================================
;; Copyright 2006-2016, 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

  (let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
    (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) 

;; open an sql database inside a file lock
;; returns: db existed-prior-to-opening
;; RA => Returns a db handler; sets the lock if opened in writable mode
;;
;; (define *db-open-mutex* (make-mutex))

(define (db:lock-create-open fname initproc)
  (let* ((parent-dir   (or (pathname-directory fname)(current-directory))) ;; no parent? go local
         (raw-fname    (pathname-file fname))
	 (dir-writable (file-write-access? parent-dir))
	 (file-exists  (common:file-exists? fname))
	 (file-write   (if file-exists
			   (file-write-access? fname)
			   dir-writable )))
    ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped.
    (if file-write ;; dir-writable
	(condition-case
         (let* ((lockfname   (conc fname ".lock"))
                (readyfname  (conc parent-dir "/.ready-" raw-fname))
                (readyexists (common:file-exists? readyfname)))
           (if (not readyexists)
               (common:simple-file-lock-and-wait lockfname))

         (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
         (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
        
	(condition-case
         (begin
           (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname)
           (let ((db (sqlite3:open-database fname)))
             ;; (mutex-unlock! *db-open-mutex*)
             db))
         (exn (io-error)  (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
         (exn (corrupt)   (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
         (exn (busy)      (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
         (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
         (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
	)))

;;
;; (define (db:launch-delay-left dbstruct run-id launch-delay)
  

;;  select end_time-now from
;;      (select testname,item_path,event_time+run_duration as
;;                          end_time,strftime('%s','now') as now from tests where state in
;;      ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));

(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)
  (let* ((incompleted '())
	 (oldlaunched '())
	 (toplevels   '())
	 (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) ;; FIXME suspect test run time & deadtime are not well matched; resulting in COMPLETED/DEAD status of an a-ok running test
	 (deadtime     (if (and deadtime-str
				(string->number deadtime-str))
			   (string->number deadtime-str)
			   7200))) ;; two hours
    (db:with-db 
     dbstruct #f #f
     (lambda (db)

              (min-incompleted-ids (map car incompleted)) ;; do 'em all
              (all-ids             (append min-incompleted-ids (map car oldlaunched))))
         (if (> (length all-ids) 0)
             (begin
               (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE")
               (for-each
                (lambda (test-id)
                  (db:test-set-state-status dbstruct run-id test-id "COMPLETED" "DEAD" "Test failed to complete")) ;; fix for one aspect of Randy's ticket 1405717332 ;; TODO - fix problem where test goes to COMPLETED/DEAD while in progress, only later to go to COMPLETED/PASS.  ref ticket 220546828

                all-ids))))))))

;; ALL REPLACED BY THE BLOCK ABOVE
;;
;; 	    (sqlite3:execute 
;; 	     db
;; 	     (conc "UPDATE tests SET state='INCOMPLETE' WHERE run_id=? AND id IN (" 

                                                    (if (not (equal? state "DELETED"))
                                                        (cons status (map dbr:counts-status state-status-counts))
                                                        (map dbr:counts-status state-status-counts)))
                                                   *common:std-statuses* >))
			    (non-completes     (filter (lambda (x)
							 (not (equal? x "COMPLETED")))
						       all-curr-states))
			    (preq-fails        (filter (lambda (x)
							 (equal? x "PREQ_FAIL"))
						       all-curr-statuses))
                            (num-non-completes (length non-completes))

                            (newstate          (cond

						((> running 0)           "RUNNING")            ;; anything running, call the situation running
                                                ((> (length preq-fails) 0)
                                                 "NOT_STARTED")
						((> bad-not-started 0)   "COMPLETED")          ;; we have an ugly situation, it is completed in the sense we cannot do more.


						((> num-non-completes 0) (car non-completes))  ;;  (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED


						(else                    (car all-curr-states))))
			                       ;; (if (> running 0)
                                               ;;     "RUNNING"
                                               ;;     (if (> bad-not-started 0)
                                               ;;         "COMPLETED"
                                               ;;         (car all-curr-states))))
                            (newstatus         (cond
                                                ((> (length preq-fails) 0)
                                                 "PREQ_FAIL")
                                                ((or (> bad-not-started 0)
                                                     (and (equal? newstate "NOT_STARTED")
                                                          (> num-non-completes 0)))
                                                 "STARTED")
                                                (else
                                                 (car all-curr-statuses)))))

                       ;; (print "bad-not-supported: " bad-not-support " all-curr-states: " all-curr-states " all-curr-statuses: " all-curr-states)
                       ;;      " newstate: " newstate " newstatus: " newstatus)
                       ;; NB// Pass the db so it is part of the transaction
                       (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path"> bad-not-started="bad-not-started" newstate="newstate" newstatus="newstatus" num-non-completes="num-non-completes" non-completes="non-completes "len(sscs)="(length state-status-counts)  " state-status-counts: "
                                    (apply conc
                                           (map (lambda (x)
                                                  (conc
                                                   (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
                                                state-status-counts))
                                    
                                    ); end debug:print
                       (if tl-test-id
			   (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
		       ))))))
         (mutex-unlock! *db-transaction-mutex*)
         (if (and test-id state status (equal? status "AUTO")) 
             (db:test-data-rollup dbstruct run-id test-id status))
         tr-res)))))
;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path)
  (db:with-db

;;
;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
;;       mode 'toplevel means that tests must be COMPLETED only
;;       mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
;;       mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING
;; 
;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode)


(define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f))
  ;; BBnote - rollup of an itemized test's overall state/status done in db:set-state-status-and-roll-up-items
  (let* ((ok-statuses '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))
         (have-itemized (not (null? (lset-intersection eq? mode '(itemmatch itemwait))))))
    (append
     (if (member 'exclusive mode)
         (let ((running-tests (db:get-tests-for-run dbstruct
                                                    #f  ;; run-id of #f means for all runs. 
                                                    (if (string=? ref-item-path "")   ;; testpatt
                                                        ref-test-name
                                                        (conc ref-test-name "/" ref-item-path))
                                                    '("LAUNCHED" "REMOTEHOSTSTART" "RUNNING") ;; states
                                                    '()          ;; statuses
                                                    #f           ;; offset
                                                    #f           ;; limit
                                                    #f           ;; not-in
                                                    #f           ;; sort by
                                                    #f           ;; sort order
                                                    'shortlist   ;; query type
                                                    0            ;; last update, beginning of time ....
                                                    #f           ;; mode
                                                    )))
           ;;(map (lambda (testdat)
           ;;	(if (equal? (db:test-get-item-path testdat) "")
           ;;	    (db:test-get-testname testdat)
           ;;	    (conc (db:test-get-testname testdat)
           ;;		  "/"
           ;;		  (db:test-get-item-path testdat))))
           running-tests) ;; calling functions want the entire data
         '())
     (if (or (not waitons)
             (null? waitons))
         '()
         (let* ((unmet-pre-reqs '())
                (result         '()))
           (for-each 
            (lambda (waitontest-name)
              ;; by getting the tests with matching name we are looking only at the matching test 
              ;; and related sub items
              ;; next should be using mt:get-tests-for-run?
              (let ((tests             (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
                    (ever-seen         #f)
                    (parent-waiton-met #f)
                    (item-waiton-met   #f))
                (for-each 
                 (lambda (test) ;; BB- this is the upstream test
                   ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ...
                   (let* ((state             (db:test-get-state test))
                          (status            (db:test-get-status test))
                          (item-path         (db:test-get-item-path test)) ;; BB- this is the upstream itempath
                          (is-completed      (equal? state "COMPLETED"))
                          (is-running        (equal? state "RUNNING"))
                          (is-killed         (equal? state "KILLED"))
                          (is-ok             (member status ok-statuses))
                          ;;                                       testname-b    path-a    path-b
                          (same-itempath     (db:compare-itempaths ref-test-name item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path)))
                     (set! ever-seen #t)
                     (cond
                      ;; case 1, non-item (parent test) is 
                      ((and (equal? item-path "") ;; this is the parent test of the waiton being examined
                            is-completed
                            (or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;;  itemmatch itemwait))))))
                       (set! parent-waiton-met #t))
                      ;; Special case for toplevel and KILLED
                      ((and (equal? item-path "") ;; this is the parent test
                            is-killed
                            (member 'toplevel mode))
                       (set! parent-waiton-met #t))
                      ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met
                      ((and have-itemized ;; how is that different from (member mode '(itemmatch itemwait)) ?????
                            ;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items
                            same-itempath)
                       (if (and is-completed is-ok)
                           (set! item-waiton-met #t))
                       (if (and (equal? item-path "") ;; if upstream rollup test is completed, parent-waiton-met is set
                                (or is-completed is-running));; this is the parent, set it to run if completed or running ;; BB1
                           (set! parent-waiton-met #t)))
                      ;; normal checking of parent items, any parent or parent item not ok blocks running
                      ((and is-completed
                            (or is-ok 
                                (member 'toplevel mode))              ;; toplevel does not block on FAIL
                            (and is-ok (member 'itemmatch mode))) ;; itemmatch blocks on not ok
                       (set! item-waiton-met #t)))))
                 tests)
                ;; both requirements, parent and item-waiton must be met to NOT add item to
                ;; prereq's not met list
                (if (not (or parent-waiton-met item-waiton-met))
                    (set! result (append (if (null? tests) (list waitontest-name) tests) result))) ;; appends the string if the full record is not available
                ;; if the test is not found then clearly the waiton is not met...
                ;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
                (if (not ever-seen)
                    (set! result (append (if (null? tests)(list waitontest-name) tests) result)))))
            waitons)

           ;; TODO: for itemwait and itemmatch mode, filter out failed toplevel prereq test if any items passed.
           
           ;; a rewrite might help understanding, but quick fix is just remove tests from result which are completed/pass. -BB
           ;;(pp result)
           ;; (let ((prereq-tests-some-items-passed-list '(ref-test-name))) ;; seed with ref-test-name; do not wait on self.

           ;;   (for-each (lambda (test)
           ;;               (if (vector? test)
           ;;                   (if (and
           ;;                        (equal? (db:test-get-state test) "COMPLETED")
           ;;                        (member (db:test-get-status test) ok-statuses)
           ;;                        (not (equal? (db:test-get-item-path test) "")))
           ;;                       (set! prereq-tests-some-items-passed-list (cons (db:test-get-testname test) prereq-tests-some-items-passed-list)))))
           ;;             result)
           ;;   (set! prereq-tests-some-items-passed-list (delete-duplicates prereq-tests-some-items-passed-list))
                                               

           (delete-duplicates result)
           )))))
  
;;======================================================================
;; Just for sync, procedures to make sync easy
;;======================================================================

;; get an alist of record ids changed since time since-time
;;   '((runs . (1 2 3 ...))(steps . (5 6 7 ...) ...))
;;