;======================================================================
;; 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))
)