Megatest

;; 1. Look at test records either deleted or part of deleted run:
;;    a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
;;    b. If test dir gone, delete the test record
;; 2. Look at run records
;;    a. If have tests that are not deleted, set state='unknown'
;;    b. ....
;;
(define (db:clean-up dbstruct)

(define (db:clean-up db)
  (debug:print 0 "WARNING: db clean up not ported to v1.60, cleanup action will be on megatest.db")
  (debug:print 0 "ERROR: db clean up not ported yet")

  (let* ((db         (db:get-db dbstruct #f))
  (let* (;; (db         (db:get-db dbstruct #f))
	 (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);"))
	(statements
	 (map (lambda (stmt)
		(sqlite3:prepare db stmt))
	      (list
	       ;; delete all tests that belong to runs that are 'deleted'
	       "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted');"

			     count-stmt)
       (map sqlite3:execute statements)
       (sqlite3:for-each-row (lambda (tot)
			       (debug:print-info 0 "Records count after  clean: " tot))
			     count-stmt)))
    (map sqlite3:finalize! statements)
    (sqlite3:finalize! count-stmt)
    (db:find-and-mark-incomplete db)
    ;; (db:find-and-mark-incomplete db)
    (sqlite3:execute db "VACUUM;")))

;;======================================================================
;; M E T A   G E T   A N D   S E T   V A R S
;;======================================================================

;; returns number if string->number is successful, string otherwise

(define (db:replace-test-records dbstruct run-id testrecs)
  (db:with-db dbstruct run-id #t 
	      (lambda (db)
		(let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ","))
		       (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ");"))
		       (qry    (sqlite3:prepare db qrystr)))
		  (debug:print 0 "INFO: migrating test records for run with id " run-id)
		  (sqlite3:with-transaction
		   db
		   (lambda ()
		  (for-each 
		   (lambda (rec)
		     ;; (debug:print 0 "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n")
		     (apply sqlite3:execute qry (vector->list rec)))
		   testrecs)
		     (for-each 
		      (lambda (rec)
			;; (debug:print 0 "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n")
			(apply sqlite3:execute qry (vector->list rec)))
		      testrecs)))
		  (sqlite3:finalize! qry)))))

;; map a test-id into the proper range
;;
(define (db:adj-test-id mtdb min-test-id test-id)
  (if (>= test-id min-test-id)
      test-id

;; ;; ;; redo me        (list "uname" "rundir" "final_logf" "comment"))
;; ;; ;; redo me       (set! *didsomething* #t)))

(if (args:get-arg "-import-megatest.db")
    (let* ((toppath  (launch:setup-for-run))
	   (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f))
	   (mtdb     (if toppath (db:open-megatest-db)))
	   (run-ids  (if toppath (db:get-all-run-ids mtdb))))
	   (run-ids  (if toppath (db:get-all-run-ids mtdb)))
	   (mdb     (tasks:open-db))
	   (servers (tasks:get-all-servers mdb)))
      
      ;; kill servers
      (for-each
       (lambda (server)
	 (tasks:server-delete-record mdb (vector-ref server 0) "dbmigration")
	 (tasks:kill-server (vector-ref server 2)(vector-ref server 1)))
       servers)
      (sqlite3:finalize! mdb)

      ;; clear out junk records
      ;;
      (db:clean-up mtdb)

      ;; adjust test-ids to fit into proper range
      ;;
      (db:prep-megatest.db-for-migration mtdb)

      ;; sync runs, test_meta etc.
      ;;

     "SELECT id FROM servers WHERE run_id=? AND (state = 'running' OR (state = 'dbprep' AND  (strftime('%s','now') - start_time) < 60));" run-id)
    res))

(define (tasks:get-all-servers mdb)
  (let ((res '()))
    (sqlite3:for-each-row
     (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id)
       ;;                       0   1        2         3    4       5          6        7     8          9          10        11     12
       ;;                       0  1     2         3      4     5          6        7     8          9          10        11     12
       (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res)))
     mdb
     "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id FROM servers WHERE state NOT LIKE 'defunct%' ORDER BY start_time DESC;")
    res))

;; no elegance here ...
;;
(define (tasks:kill-server status hostname port pid)
  (debug:print-info 1 "Removing defunct server record for " hostname ":" port)
(define (tasks:kill-server hostname pid)
  (debug:print-info 0 "Attempting to kill server process " pid " on host " hostname)
  (if port
      (open-run-close tasks:server-deregister tasks:open-db hostname port: port)
      (open-run-close tasks:server-deregister tasks:open-db hostname pid:  pid))
  (if status ;; #t means alive
      (begin
	(if (equal? hostname (get-host-name))
	    (handle-exceptions
	     exn
	     (debug:print-info 0 "server may or may not be dead, check for megatest -server running as pid " pid "\n"
			       "  EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
	     (debug:print 1 "Sending signal/term to " pid " on " hostname)
	     (process-signal pid signal/term)
	     (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill
	     ;;(process-signal pid signal/kill)
	     ) ;; local machine, send sig term
	    (begin
	      ;;(debug:print-info 1 "Stopping remote servers not yet supported."))))
	      (debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide")
	      (let ((serverdat (list hostname port)))
		(hash-table-set! *runremote* run-id (http-transport:client-connect hostname port))
	      	(cdb:kill-server serverdat pid)))))    ;; remote machine, try telling server to commit suicide
      (begin
	(if status 
	    (if (equal? hostname (get-host-name))
		(begin
		  (debug:print-info 1 "Sending signal/term to " pid " on " hostname)
		  (process-signal pid signal/term)  ;; local machine, send sig term
		  (thread-sleep! 5)                 ;; give it five seconds to die peacefully then do a brutal kill
		  (process-signal pid signal/kill)) 
		(debug:print 0 "WARNING: Can't kill frozen server on remote host " hostname))))))
  (setenv "TARGETHOST" hostname)
  (system (conc "nbfake kill " pid)))
 
;;   (if status ;; #t means alive
;;       (begin
;; 	(if (equal? hostname (get-host-name))
;; 	    (handle-exceptions
;; 	     exn
;; 	     (debug:print-info 0 "server may or may not be dead, check for megatest -server running as pid " pid "\n"
;; 			       "  EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
;; 	     (debug:print 1 "Sending signal/term to " pid " on " hostname)
;; 	     (process-signal pid signal/term)
;; 	     (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill
;; 	     ;;(process-signal pid signal/kill)
;; 	     ) ;; local machine, send sig term
;; 	    (begin
;; 	      ;;(debug:print-info 1 "Stopping remote servers not yet supported."))))
;; 	      (debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide")
;; 	      (let ((serverdat (list hostname port)))
;; 		(hash-table-set! *runremote* run-id (http-transport:client-connect hostname port))
;; 	      	(cdb:kill-server serverdat pid)))))    ;; remote machine, try telling server to commit suicide
;;       (begin
;; 	(if status 
;; 	    (if (equal? hostname (get-host-name))
;; 		(begin
;; 		  (debug:print-info 1 "Sending signal/term to " pid " on " hostname)
;; 		  (process-signal pid signal/term)  ;; local machine, send sig term
;; 		  (thread-sleep! 5)                 ;; give it five seconds to die peacefully then do a brutal kill
;; 		  (process-signal pid signal/kill)) 
;; 		(debug:print 0 "WARNING: Can't kill frozen server on remote host " hostname))))))


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