Megatest

mtest-reaper.scm at [023e88f071]
Login

File eggs/ducttape-lib/mtest-reaper.scm artifact 3df09dc432 part of check-in 023e88f071


;;(use general-lib)
;;(import scheme chicken extras ports data-structures)
;;(use directory-utils filepath)
(use typed-records)
;;(use regex-literals)
;;(use regex)

(import scheme chicken extras ports data-structures )
(use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339 scsh-process directory-utils uuid-lib filepath srfi-19 posix-extras hostinfo)
(use pathname-expand)
(use sql-de-lite)

(define (safe-file-exists? path-string)
  (false-on-exception (lambda () (file-exists? path-string))))

;; assumes this compiled binary lives in <isoenv core root>/bin
(define (find-dir-on-path-holding-binary binary)
  (let ((filter-result
         (filter (lambda (dir)
                   (safe-file-exists? (conc dir "/" binary)))
                 (string-split (get-environment-variable "PATH") ":"))))
    (if (> (length filter-result) 0)
        (car filter-result)
        (abort (conc "Error: Cannot resolve path to binary '"binary"'. ")))))

(define (get-dir-holding-self)
  (let ((binname (car (argv))))
    (cond
     ((safe-file-exists?  binname) (pathname-expand binname))
     (else  (find-dir-on-path-holding-binary binname)))))

(define (self-exe-fullpath)
  (let ((binname (car (argv))))
    (cond
     ((safe-file-exists?  binname) (pathname-expand binname))
     (else  (conc (find-dir-on-path-holding-binary binname) "/" binname)))))

(let* ((lib-path (conc (get-dir-holding-self) "/lib/ducttape-lib.so")))
  (print "loading "lib-path)
  (load lib-path))
(import ducttape-lib)



(define (get-my-mtest-server-procs)
  (let* ((procs (linux-get-process-info-records))
        (my-mtest-procs
         (filter
          (lambda (a-proc)
            (and
             (equal? (get-environment-variable "USER") (proc-USER a-proc))
             (string-match (regexp "^.*\\/mtest\\s+.*-server.*") (proc-COMMAND a-proc))))
          procs)))
    my-mtest-procs))



(define (pid->mtest-monitor-db-file pid)
  (let* ((env   (pid->environ-hash pid))
         (ltdir (hash-table-ref/default env "MT_LINKTREE" #f))
         (radir (hash-table-ref/default env "MT_RUN_AREA_HOME" #f))
         (cwd   (pid->cwd pid)))
    (let ((res
           (cond
            (ltdir (conc ltdir "/.db/monitor.db"))
            (radir (conc
                    (do-or-die
                     (conc "megatest -start-dir "radir" -show-config -section setup -var linktree"))
                    "/.db/monitor.db"))
            (cwd  (conc
                   (do-or-die
                    (conc "megatest -start-dir "cwd" -show-config -section setup -var linktree"))
                   "/.db/monitor.db"))
            
            (else #f))))
      res)))
      
(define (get-mdb-status mdb-file pid)
    ;; select state from servers where pid='4465';
  
  (cond
   ((not (string? mdb-file)) (conc "mdb-file could not be determined for pid " pid ">>"mdb-file ))
   ((not (file-exists? mdb-file)) (conc "mdb-file does not exist for pid "pid" : "mdb-file))
   (else
    (let ((dbh (open-database mdb-file)))
      
      (set-busy-handler! dbh 10000)
      (let* ((sql-str "select state from servers where pid=?;")
             (stm (sql dbh sql-str))
             (alists (query fetch-alists stm (->string pid))))
        (if (null? alists)
            "server pid not in monitor.db"
            (cdr (car (car alists)))))))))

    
(define (mtest-server-pid->status pid)
  (let* ((mdb-file (pid->mtest-monitor-db-file pid)))
    (if mdb-file
        (get-mdb-status mdb-file pid)
        "no monitor.db file could be found"
        )))


(define (kill pid)
  (print "KILL "pid)
  (do-or-die (conc "kill -9 "pid)))

(define (reap-defunct-mtest-server-pid pid)
  (let ((status (mtest-server-pid->status pid)))
    (print pid"->"(mtest-server-pid->status pid))
    (if (member status (list "running" "dbprep" "available" "collision"))
        (print "pid="pid" in status "status" -- not killing")
        (kill pid))))

(define (make-it-so)
  (let* ((procs (get-my-mtest-server-procs))
         (pids (map proc-PID procs)))
    (for-each reap-defunct-mtest-server-pid pids)))


(define (run-self-on-remote-host) #t)

(if (file-exists? ".homehost")
    (let* ((homehost (with-input-from-file ".homehost" (lambda () (read)) ))
           (thishost (current-ip-string))
          (me-exe   (self-exe-fullpath))
          (sshcmd      (conc "ssh "homehost" 'cd "(get-environment-variable "PWD")" && "me-exe"'")))
      (print ">>"homehost"<<")
      (print ">>"me-exe"<<")
      (print ">>"thishost"<<")
      (print ">>"sshcmd"<<")
      (if (equal? thishost homehost)
          (print "makeitso")
          (do-or-die sshcmd))
      
      ))