Megatest

mtcommon.scm at [3200899a59]
Login

File src/mtcommon.scm artifact a31207d0a5 part of check-in 3200899a59


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

;; NOTE: This is the db module, long term it will replace db.scm.
;; WARN: This module conflicts with db.scm as it uses sql-de-lite

(declare (unit mtcommon))

(module mtcommon
        (
         get-create-writeable-dir
         print-error
         print-info
         log-event
         debug-setup
         debug-mode
         check-verbosity
         calc-verbosity
	 ;; pkts stuff
	 load-pkts-to-db	 
	 get-pkt-alists
	 with-queue-db
	 ;; unix stuff
	 get-cached-info
	 write-cached-info
	 get-normalized-cpu-load
         )

(import scheme chicken data-structures extras posix ports)
(use (prefix sql-de-lite sql:) posix typed-records format srfi-1 srfi-69 pkts regex (prefix dbi dbi:) regex-case)

(defstruct ctrldat
  (port      (current-error-port))
  (verbosity 1)
  (vcache    (make-hash-table))
  (logging   #f) ;; keep the flag and the db handle separate to enable overriding
  (logdb     #f) ;; might need to make this a stack of handles for threaded access
  (toppath   #f) ;; 
  )

(define *log* (make-ctrldat))

;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (calc-verbosity vstr args)
  (or (hash-table-ref/default (ctrldat-vcache *log*) vstr #f)
      (let ((res (cond
                  ((number? vstr) vstr)
                  ((not (string?  vstr))   1)
                  ;; ((string-match  "^\\s*$" vstr) 1)
                  (vstr           (let ((debugvals  (filter number? (map string->number (string-split vstr ",")))))
                                    (cond
                                     ((> (length debugvals) 1) debugvals)
                                     ((> (length debugvals) 0)(car debugvals))
                                     (else 1))))
                  ((hash-table-exists? args "-v")   2)
                  ((hash-table-exists? args "-q")    0)
                  (else                   1))))
        (hash-table-set! (ctrldat-vcache *log*) vstr res)
        res)))

;; check verbosity, #t is ok
(define (check-verbosity verbosity vstr)
  (if (not (or (number? verbosity)
	       (list?   verbosity)))
      (begin
	(print "ERROR: Invalid debug value \"" vstr "\"")
	#f)
      #t))

(define (debug-mode n)
  (let* ((verbosity (ctrldat-verbosity *log*)))
    (cond
     ((and (number? verbosity)   ;; number number
           (number? n))
      (<= n verbosity))
     ((and (list? verbosity)     ;; list   number
           (number? n))
      (member n verbosity))
     ((and (list? verbosity)     ;; list   list
           (list? n))
      (not (null? (lset-intersection! eq? verbosity n))))
     ((and (number? verbosity)
           (list? n))
      (member verbosity n)))))

(define (debug-setup args)
  (let* ((debugstr  (or (hash-table-ref/default args "-debug" #f)
                        (get-environment-variable "MT_DEBUG_MODE")))
         (verbosity (calc-verbosity debugstr args)))
    ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
    (if (not (check-verbosity verbosity debugstr))
        (set! verbosity 1))
    (ctrldat-verbosity-set! *log* verbosity)
    (if (or (hash-table-exists? args "-debug")
	    (not (get-environment-variable "MT_DEBUG_MODE")))
	(setenv "MT_DEBUG_MODE" (if (list? verbosity)
				    (string-intersperse (map conc verbosity) ",")
				    (conc verbosity))))))
  
(define (debug-print n e . params)
  (if (debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  (if (ctrldat-logging *log*)
	      (log-event (apply conc params))
	      (apply print params)
	      )))))

;; more betterer implementation above?
;; (define (print-info n e . params)
;;   (apply debug-print n e "INFO: " params))

;; ;; Brandon's debug printer shortcut (indulge me :)
;; (define *BB-process-starttime* (current-milliseconds))
;; (define (BB> . in-args)
;;   (let* ((stack (get-call-chain))
;;          (location "??"))
;;     (for-each
;;      (lambda (frame)
;;        (let* ((this-loc (vector-ref frame 0))
;;               (temp     (string-split (->string this-loc) " "))
;;               (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
;;          (if (equal? this-func "BB>")
;;              (set! location this-loc))))
;;      stack)
;;     (let* ((color-on "\x1b[1m")
;;            (color-off "\x1b[0m")
;;            (dp-args
;;             (append
;;              (list 0 *default-log-port*
;;                    (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off "   ")  )
;;              in-args)))
;;       (apply debug:print dp-args))))
;; 
;; (define *BBpp_custom_expanders_list* (make-hash-table))
;; 
;; 
;; 
;; ;; register hash tables with BBpp.
;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
;;                  (cons hash-table? hash-table->alist))
;; 
;; ;; test name converter
;; (define (BBpp_custom_converter arg)
;;   (let ((res #f))
;;     (for-each
;;      (lambda (custom-type-name)
;;        (let* ((custom-type-info      (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
;;               (custom-type-test      (car custom-type-info))
;;               (custom-type-converter (cdr custom-type-info)))
;;          (when (and (not res) (custom-type-test arg))
;;            (set! res (custom-type-converter arg)))))
;;      (hash-table-keys *BBpp_custom_expanders_list*))
;;     (if res (BBpp_ res) arg)))
;; 
;; (define (BBpp_ arg)
;;   (cond
;;    ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
;;    ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
;;    ((hash-table? arg)
;;     (let ((al (hash-table->alist arg)))
;;       (BBpp_ (cons HASH_TABLE: al))))
;;    ((null? arg) '())
;;    ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;;    ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;;    (else (BBpp_custom_converter arg))))
;; 
;; ;; Brandon's pretty printer.  It expands hashes and custom types in addition to regular pp
;; (define (BBpp arg)
;;   (pp (BBpp_ arg)))
;; 
;; ;(use define-macro)
;; (define-syntax inspect
;;   (syntax-rules ()
;;     [(_ x)
;;     ;; (with-output-to-port (current-error-port)
;;        (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
;;      ;;  )
;;      ]
;;     [(_ x y ...) (begin (inspect x) (inspect y ...))]))

(define (print-error n e . params)
  ;; normal print
  (if (debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (if (ctrldat-logging *log*)
	      (log-event (apply conc params))
	      ;; (apply print "pid:" (current-process-id) " " params)
	      (apply print "ERROR: " params)
	      ))))
  ;; pass important messages to stderr
  (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
      (with-output-to-port (current-error-port)
	(lambda ()
	  (apply print "ERROR: " params)
	  ))))

(define (print-info n e . params)
  (if (debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (if (ctrldat-logging *log*)
	      (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
		(log-event res))
	      (apply print "INFO: (" n ") " params) ;; res)
	      )))))

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

;;======================================================================
;; Unix stuff
;;======================================================================

;; get values from cached info from dropping file in logs dir
;;  e.g. key is host and dtype is normalized-load
;;
(define (get-cached-info logdir key dtype #!key (age 5)(log-port (current-error-port)))
  (let* ((fullpath (conc logdir "/" key "-" dtype ".log")))
    (if (and (file-exists? fullpath)
	     (file-read-access? fullpath))
	(handle-exceptions
	 exn
	 #f
	 (debug-print 2 log-port "reading file " fullpath)
	 (let ((real-age (- (current-seconds)(file-change-time fullpath)))) 
	   (if (< real-age age)
	       (with-input-from-file fullpath read)
	       (begin
		 (debug-print 2 log-port "file " fullpath " is too old (" real-age" seconds)to trust, skipping reading it")
		 #f))))
	(begin
	  (debug-print 2 log-port "not reading file " fullpath)
	  #f))))

(define (write-cached-info logdir key dtype dat)
  (let* ((fullpath (conc logdir "/" key "-" dtype ".log")))
    (handle-exceptions
     exn
     #f
     (with-output-to-file fullpath (lambda ()(pp dat))))))


;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads
;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc.
;;  keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load
;;
(define (get-normalized-cpu-load logdir remote-host)
  (let ((actual-host (or remote-host (get-host-name)))) ;; #f is localhost
    (or (get-cached-info logdir actual-host "normalized-load")
	(let ((data (if remote-host
			(with-input-from-pipe 
			    (conc "ssh " remote-host " cat /proc/loadavg;cat /proc/cpuinfo;echo end")
			  read-lines)
			(append 
			 (with-input-from-file "/proc/loadavg" 
			   read-lines)
			 (with-input-from-file "/proc/cpuinfo"
			   read-lines)
			 (list "end"))))
	      (load-rx  (regexp "^([\\d\\.]+)\\s+([\\d\\.]+)\\s+([\\d\\.]+)\\s+.*$"))
	      (proc-rx  (regexp "^processor\\s+:\\s+(\\d+)\\s*$"))
	      (core-rx  (regexp "^core id\\s+:\\s+(\\d+)\\s*$"))
	      (phys-rx  (regexp "^physical id\\s+:\\s+(\\d+)\\s*$"))
	      (max-num  (lambda (p n)(max (string->number p) n))))
	  ;; (print "data=" data)
	  (if (null? data) ;; something went wrong
	      #f
	      (let loop ((hed      (car data))
			 (tal      (cdr data))
			 (loads    #f)
			 (proc-num 0)  ;; processor includes threads
			 (phys-num 0)  ;; physical chip on motherboard
			 (core-num 0)) ;; core
		;; (print hed ", " loads ", " proc-num ", " phys-num ", " core-num)
		(if (null? tal) ;; have all our data, calculate normalized load and return result
		    (let* ((act-proc (+ proc-num 1))
			   (act-phys (+ phys-num 1))
			   (act-core (+ core-num 1))
			   (adj-proc-load (/ (car loads) act-proc))
			   (adj-core-load (/ (car loads) act-core))
			   (result
			    (append (list (cons 'adj-proc-load adj-proc-load)
					  (cons 'adj-core-load adj-core-load))
				    (list (cons '1m-load (car loads))
					  (cons '5m-load (cadr loads))
					  (cons '15m-load (caddr loads)))
				    (list (cons 'proc act-proc)
					  (cons 'core act-core)
					  (cons 'phys act-phys)))))
		      (write-cached-info logdir actual-host "normalized-load" result)
		      result)
		  (regex-case
		   hed
		   (load-rx  ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num))
		   (proc-rx  ( x p         ) (loop (car tal)(cdr tal) loads           (max-num p proc-num) phys-num core-num))
		   (phys-rx  ( x p         ) (loop (car tal)(cdr tal) loads           proc-num (max-num p phys-num) core-num))
		   (core-rx  ( x c         ) (loop (car tal)(cdr tal) loads           proc-num phys-num (max-num c core-num)))
		   (else 
		    (begin
		      ;; (print "NO MATCH: " hed)
		      (loop (car tal)(cdr tal) loads proc-num phys-num core-num)))))))))))

;;======================================================================
;; L O G G I N G    D B 
;;======================================================================

(define (open-logging-db toppath)
  (let* ((dbpath    (conc (if toppath (conc toppath "/") "") "logging.db")) ;; fname)
	 (dbexists  (file-exists? dbpath))
	 (db        (sql:open-database dbpath))
	 (handler   (sql:busy-timeout 136000))) ;; remove argument to override
    (sql:set-busy-handler! db handler)
    (if (not dbexists)
        (sql:exec (sql:sql db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);")))
    (sql:exec (sql:sql db "PRAGMA synchronous = 0;"))
    db))

(define (log-local-event toppath . loglst)
  (let ((logline (apply conc loglst)))
    (log-event logline)))

(define (log-event toppath logline)
  (let ((db (open-logging-db toppath)))
    (sql:exec
     (sql:sql db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);")
     logline
     (current-directory)
     (string-intersperse (argv) " ")
     (current-process-id))
    logline))

;;======================================================================
;; paths and directories
;;======================================================================

;; return first path that can be created or already exists and is writable
;;
(define (get-create-writeable-dir dirs)
  (if (null? dirs)
      #f
      (let loop ((hed (car dirs))
		 (tal (cdr dirs)))
	(let ((res (or (and (directory? hed)
			    (file-write-access? hed)
			    hed)
		       (handle-exceptions
			   exn
			   (begin
			     ;; (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.")
                             (print "INFO: could not create " hed ", this might cause problems down the road.")
			     #f)
			(create-directory hed #t)))))
	  (if (and (string? res)
		   (directory? res))
	      res
	      (if (null? tal)
		  #f
		  (loop (car tal)(cdr tal))))))))

(define old-file-exists? file-exists?)

(define (file-exists? path-string)
  ;; this avoids stack dumps. NOTE: The issues that triggered this approach might have been fixed TODO: test and remove if possible
  ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg:  system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
  (handle-exceptions
   exn
   #f
   (old-file-exists? path-string)))

;;======================================================================
;; pkts stuff
;;======================================================================

(define (load-pkts-to-db pktsdir-str setup-pdbpath #!key (use-lt #f)(log-port (current-error-port)))
  (with-queue-db
     pktsdir-str
     setup-pdbpath
     (lambda (pktsdirs pktsdir pdb)
       (for-each
	(lambda (pktsdir) ;; look at all
	  (cond
	   ((not (file-exists? pktsdir))
	    (debug-print 0 log-port "ERROR: packets directory " pktsdir " does not exist."))
	   ((not (directory? pktsdir))
	    (debug-print 0 log-port "ERROR: packets directory path " pktsdir " is not a directory."))
	   ((not (file-read-access? pktsdir))
	    (debug-print 0 log-port "ERROR: packets directory path " pktsdir " is not readable."))
	   (else
	    (print-info 0 log-port "Loading packets found in " pktsdir)
	    (let ((pkts (glob (conc pktsdir "/*.pkt"))))
	      (for-each
	       (lambda (pkt)
		 (let* ((uuid    (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
			(exists  (lookup-by-uuid pdb uuid #f)))
		   (if (not exists)
		       (let* ((pktdat (string-intersperse
				       (with-input-from-file pkt read-lines)
				       "\n"))
			      (apkt   (pkt->alist pktdat))
			      (ptype  (alist-ref 'T apkt)))
			 (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0)
			 (debug-print 4 log-port "Added " uuid " of type " ptype " to queue"))
		       (debug-print 4 log-port "pkt: " uuid " exists, skipping...")
		       )))
	       pkts)))))
	pktsdirs))
     use-lt: use-lt))
  
(define (get-pkt-alists pkts)
  (map (lambda (x)
	 (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt
       pkts))

(define (with-queue-db pktsdir-str setup-pdbpath proc #!key (use-lt #f)(toppath-in #f)(log-port (current-error-port)))
  (let* ((pktsdirs (get-pkts-dirs use-lt pktsdir-str))
	 (pktsdir  (if pktsdirs (car pktsdirs) #f))
	 (toppath  toppath-in) ;; (or (configf:lookup mtconf "scratchdat" "toppath") toppath-in))
	 (pdbpath  (or setup-pdbpath pktsdir))) ;; (configf:lookup mtconf "setup"  "pdbpath")
    (cond
     ((not (and  pktsdir toppath pdbpath))
      (debug-print 0 log-port "ERROR: settings are missing in your megatest.config for area management.")
      (debug-print 0 log-port "  you need to have pktsdir in the [setup] section."))
     ((not (file-exists? pktsdir))
      (debug-print 0 log-port "ERROR: pkts directory not found " pktsdir))
     ((not (equal? (file-owner pktsdir)(current-effective-user-id)))
      (debug-print 0 log-port "ERROR: directory " pktsdir " is not owned by " (current-effective-user-name)))
     (else
	(let* ((pdb  (open-queue-db pdbpath "pkts.db"
				    schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
	  (proc pktsdirs pktsdir pdb)
	  (dbi:close pdb))))))

;; (configf:lookup mtconf "setup"  "pktsdirs")
(define (get-pkts-dirs use-lt #!key (top-path #f)(pktsdirs #f))
  (let* ((pktsdirs-str (or pktsdirs
			   (and use-lt
				(conc (or top-path
					  (current-directory))
				      "/lt/.pkts"))))
	 (pktsdirs  (if pktsdirs-str
			(string-split pktsdirs-str " ")
			#f)))
    pktsdirs))

)