Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -8,12 +8,12 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack - matchable regex posix srfi-18 extras - pkts (prefix dbi dbi:)) + matchable pkts (prefix dbi dbi:) + regex) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit common)) @@ -73,10 +73,11 @@ ;; (define *user-hash-data* (make-hash-table)) (define *db-keys* #f) +(define *pkts-info* (make-hash-table)) ;; store stuff like the last parent here (define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config (define *runconfigdat* #f) ;; run configs data (define *configdat* #f) ;; megatest.config data (define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done (define *toppath* #f) @@ -2318,33 +2319,61 @@ ;;====================================================================== ;; Manage pkts, used in servers, tests and likely other contexts so put ;; in common ;;====================================================================== -(define common:pkt-spec - '((server . ((action . a) - (pid . d) - (ipaddr . i) - (port . p))) - - (test . ((cpuuse . c) - (diskuse . d) - (item-path . i) - (runname . r) - (state . s) - (target . t) - (status . u))))) +(define common:pkts-spec + '((default . ((parent . P))) + (server . ((action . a) + (pid . d) + (ipaddr . i) + (port . p) + (parent . P))) + + (test . ((cpuuse . c) + (diskuse . d) + (item-path . i) + (runname . r) + (state . s) + (target . t) + (status . u) + (parent . P))))) (define (common:get-pkts-dirs mtconf use-lt) (let* ((pktsdirs-str (or (configf:lookup mtconf "setup" "pktsdirs") (and use-lt - (conc *toppath* "/lt/.pkts")))) + (conc (or *toppath* + (current-directory)) + "/lt/.pkts")))) (pktsdirs (if pktsdirs-str (string-split pktsdirs-str " ") #f))) pktsdirs)) +(define (common:save-pkt pktalist-in mtconf use-lt #!key (add-only #f)) ;; add-only saves the pkt only if there is a parent already + (if (or (not add-only) + (hash-table-exists? *pkts-info* 'last-parent)) + (let* ((parent (hash-table-ref/default *pkts-info* 'last-parent #f)) + (pktalist (if parent + (cons `(parent . ,parent) + pktalist-in) + pktalist-in))) + (let-values (((uuid pkt) + (alist->pkt pktalist common:pkts-spec))) + (hash-table-set! *pkts-info* 'last-parent uuid) + (let ((pktsdir (or (hash-table-ref/default *pkts-info* 'pkts-dir #f) + (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt)) + (pktsdir (car pktsdirs))) ;; assume it is there + (hash-table-set! *pkts-info* 'pkts-dir pktsdir) + pktsdir)))) + (if (not (file-exists? pktsdir)) + (create-directory pktsdir #t)) + (with-output-to-file + (conc pktsdir "/" uuid ".pkt") + (lambda () + (print pkt)))))))) + (define (common:with-queue-db mtconf proc #!key (use-lt #f)(toppath-in #f)) (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt)) (pktsdir (if pktsdirs (car pktsdirs) #f)) (toppath (or (configf:lookup mtconf "scratchdat" "toppath") toppath-in)) @@ -2356,11 +2385,11 @@ (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))))) -(define (common:load-pkts-to-db mtconf) +(define (common:load-pkts-to-db mtconf #!key (use-lt #f)) (common:with-queue-db mtconf (lambda (pktsdirs pktsdir pdb) (for-each (lambda (pktsdir) ;; look at all @@ -2381,11 +2410,12 @@ (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0) (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue")) (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...") ))) pkts)))) - pktsdirs)))) + pktsdirs)) + use-lt: use-lt)) (define (common:get-pkt-alists pkts) (map (lambda (x) (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt pkts)) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -227,10 +227,14 @@ ;; (define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f) (sections #f) (settings (make-hash-table)) (keep-filenames #f) (post-section-procs '()) (apply-wildcards #t)) (debug:print 9 *default-log-port* "START: " path) + (if *configdat* + (common:save-pkt `((action . read-config) + (f . path)) + *configdat* #t add-only: #t)) (if (and (not (port? path)) (not (file-exists? path))) ;; for case where we are handed a port (begin (debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory)) ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read? Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -357,17 +357,30 @@ (if (and sdat (not changed) (> (- (current-seconds) start-time) 2)) (begin (debug:print-info 0 *default-log-port* "Received server alive signature") + (common:save-pkt `((action . alive) + (T . server) + (pid . ,(current-process-id)) + (ipaddr . ,(car sdat)) + (port . ,(cadr sdat))) + *configdat* #t) sdat) (begin (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat) (sleep 4) (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes (begin (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server") + (common:save-pkt `((action . died) + (T . server) + (pid . ,(current-process-id)) + (ipaddr . ,(car sdat)) + (port . ,(cadr sdat)) + (msg . "Transport died?")) + *configdat* #t) (exit)) (loop start-time (equal? sdat last-sdat) sdat))))))) (iface (car server-info)) @@ -476,26 +489,26 @@ ;; (/ *total-non-write-delay* ;; *number-non-write-queries*)) ;; " ms") (db:print-current-query-stats) - + (common:save-pkt `((action . exit) + (T . server) + (pid . ,(current-process-id))) + *configdat* #t) (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") (exit))) ;; all routes though here end in exit ... ;; ;; start_server? ;; (define (http-transport:launch) - ;; (if (args:get-arg "-daemonize") - ;; (begin - ;; (daemon:ize) - ;; (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it - ;; (begin - ;; (current-error-port *alt-log-file*) - ;; (current-output-port *alt-log-file*))))) + (common:save-pkt `((action . start) + (T . server) + (pid . ,(current-process-id))) + *configdat* #t) (let* ((th2 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server run thread started") (http-transport:run (if (args:get-arg "-server") (args:get-arg "-server") Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -114,10 +114,11 @@ set-ss : set state/status archive : compress and move test data to archive disk kill : stop tests or entire runs db : database utilities areas, contours, setup : show areas, contours or setup section from megatest.config + gendot : generate a graphviz dot file from pkts. Contour actions: process : runs import, rungen and dispatch Selectors @@ -996,14 +997,16 @@ (print "No section \"" (car remargs) "\" found"))) (print "ERROR: list requires section parameter; areas, setup or contours"))) ((gendot) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat))) - (with-queue-db + (common:load-pkts-to-db mtconf use-lt: #t) ;; need to NOT do this by default ... + (common:with-queue-db mtconf (lambda (pktsdirs pktsdir conn) - (make-report "out.dot" conn '()))))) + (make-report "out.dot" conn common:pkts-spec '(action ipaddr port) )) + use-lt: #t))) ((db) (if (null? remargs) (print "ERROR: missing sub command for db command") (let ((subcmd (car remargs))) (case (string->symbol subcmd) @@ -1043,8 +1046,8 @@ (repl) (load (args:get-arg "-load"))))) #| (define mtconf (car (simple-setup #f))) -(define dat (with-queue-db mtconf (lambda (conn)(get-pkts conn '())))) +(define dat (common:with-queue-db mtconf (lambda (conn)(get-pkts conn '())))) (pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed)) |# Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -111,10 +111,11 @@ (< (http-transport:server-dat-get-last-access (remote-conndat runremote)) expire-time))) (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.") (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection. (mutex-unlock! *rmt-mutex*) (rmt:send-receive cmd rid params attemptnum: attemptnum)) + ;; on homehost and this is a read ((and (not (remote-force-server runremote)) ;; honor forced use of server (cdr (remote-hh-dat runremote)) ;; on homehost (member cmd api:read-only-queries)) ;; this is a read (mutex-unlock! *rmt-mutex*) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -8,12 +8,12 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils posix-extras matchable - ) +(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest + directory-utils posix-extras matchable) (use spiffy uri-common intarweb http-client spiffy-request-vars) (declare (unit server)) @@ -32,10 +32,16 @@ (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) (define *server-loop-heart-beat* (current-seconds)) + +;;====================================================================== +;; P K T S S T U F F +;;====================================================================== + +;; ??? ;;====================================================================== ;; P K T S S T U F F ;;======================================================================