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,23 +2319,26 @@ ;;====================================================================== ;; 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")))) @@ -2341,10 +2345,31 @@ (pktsdirs (if pktsdirs-str (string-split pktsdirs-str " ") #f))) pktsdirs)) +(define (common:save-pkt pktalist-in mtconf use-lt) + (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)) 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: 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 ;;======================================================================