Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -10,11 +10,11 @@
process.scm runs.scm tasks.scm tests.scm genexample.scm \
http-transport.scm filedb.scm \
client.scm synchash.scm daemon.scm mt.scm \
ezsteps.scm lock-queue.scm sdb.scm \
rmt.scm api.scm tdb.scm rpc-transport.scm \
- portlogger.scm archive.scm env.scm
+ portlogger.scm archive.scm env.scm diff-report.scm
# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -12,11 +12,11 @@
;; C L I E N T S
;;======================================================================
(require-extension (srfi 18) extras tcp s11n)
-(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
+(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest matchable)
;; (use zmq)
(use (prefix sqlite3 sqlite3:))
(use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb directory-utils)
@@ -48,101 +48,15 @@
((rpc) (rpc:client-connect iface port))
((http) (http:client-connect iface port))
((zmq) (zmq:client-connect iface port))
(else (rpc:client-connect iface port))))
-(define (client:setup run-id #!key (remaining-tries 10) (failed-connects 0))
+(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0))
(case (server:get-transport)
- ((rpc) (rpc-transport:client-setup run-id remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id))
- ((http)(client:setup-http run-id remaining-tries: remaining-tries failed-connects: failed-connects))
- (else (rpc-transport:client-setup run-id remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id))))
-
-;; (define (client:login-no-auto-setup server-info run-id)
-;; (case (server:get-transport)
-;; ((rpc) (rpc:login-no-auto-client-setup server-info run-id))
-;; ((http) (rmt:login-no-auto-client-setup server-info run-id))
-;; (else (rpc:login-no-auto-client-setup server-info run-id))))
-;;
-;; (define (client:setup-rpc run-id)
-;; (debug:print 0 *default-log-port* "INFO: client:setup remaining-tries=" remaining-tries)
-;; (if (<= remaining-tries 0)
-;; (begin
-;; (debug:print-error 0 *default-log-port* "failed to start or connect to server for run-id " run-id)
-;; (exit 1))
-;; (let ((host-info (hash-table-ref/default *runremote* run-id #f)))
-;; (debug:print-info 0 *default-log-port* "client:setup host-info=" host-info ", remaining-tries=" remaining-tries)
-;; (if host-info
-;; (let* ((iface (car host-info))
-;; (port (cadr host-info))
-;; (start-res (client:connect iface port))
-;; ;; (ping-res (server:ping-server run-id iface port))
-;; (ping-res (client:login-no-auto-setup start-res run-id)))
-;; (if ping-res ;; sucessful login?
-;; (begin
-;; (hash-table-set! *runremote* run-id start-res)
-;; start-res) ;; return the server info
-;; (if (member remaining-tries '(3 4 6))
-;; (begin ;; login failed
-;; (debug:print 25 *default-log-port* "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" host-info)
-;; (hash-table-delete! *runremote* run-id)
-;; (open-run-close tasks:server-force-clean-run-record
-;; tasks:open-db
-;; run-id
-;; (car host-info)
-;; (cadr host-info)
-;; " client:setup (host-info=#t)")
-;; (thread-sleep! 5)
-;; (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1)))
-;; (begin
-;; (debug:print 25 *default-log-port* "INFO: client:setup failed to connect, start-res=" start-res ", run-id=" run-id ", host-info=" host-info)
-;; (thread-sleep! 5)
-;; (client:setup run-id remaining-tries: (- remaining-tries 1))))))
-;; ;; YUK: rename server-dat here
-;; (let* ((server-dat (open-run-close tasks:get-server tasks:open-db run-id)))
-;; (debug:print-info 0 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
-;; (if server-dat
-;; (let* ((iface (tasks:hostinfo-get-interface server-dat))
-;; (port (tasks:hostinfo-get-port server-dat))
-;; (start-res (http-transport:client-connect iface port))
-;; ;; (ping-res (server:ping-server run-id iface port))
-;; (ping-res (rmt:login-no-auto-client-setup start-res run-id)))
-;; (if start-res
-;; (begin
-;; (hash-table-set! *runremote* run-id start-res)
-;; start-res)
-;; (if (member remaining-tries '(2 5))
-;; (begin ;; login failed
-;; (debug:print 25 *default-log-port* "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
-;; (hash-table-delete! *runremote* run-id)
-;; (open-run-close tasks:server-force-clean-run-record
-;; tasks:open-db
-;; run-id
-;; (tasks:hostinfo-get-interface server-dat)
-;; (tasks:hostinfo-get-port server-dat)
-;; " client:setup (server-dat = #t)")
-;; (thread-sleep! 2)
-;; (server:try-running run-id)
-;; (thread-sleep! 10) ;; give server a little time to start up
-;; (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1)))
-;; (begin
-;; (debug:print 25 *default-log-port* "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
-;; (thread-sleep! 5)
-;; (client:setup run-id remaining-tries: (- remaining-tries 1))))))
-;; (begin ;; no server registered
-;; (if (eq? remaining-tries 2)
-;; (begin
-;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)")
-;; (client:setup run-id remaining-tries: 10))
-;; (begin
-;; (thread-sleep! 2)
-;; (debug:print 25 *default-log-port* "INFO: client:setup start-res (not defined here), run-id=" run-id ", server-dat=" server-dat)
-;; (if (< (open-run-close tasks:num-in-available-state tasks:open-db run-id) 3)
-;; (begin
-;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)")
-;; (server:try-running run-id)))
-;; (thread-sleep! 10) ;; give server a little time to start up
-;; (client:setup run-id remaining-tries: (- remaining-tries 1)))))))))))
+ ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id))
+ ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects))
+ (else (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id))))
;; Do all the connection work, look up the transport type and set up the
;; connection if required.
;;
;; There are two scenarios.
@@ -152,100 +66,50 @@
;;
;; client:setup
;;
;; lookup_server, need to remove *runremote* stuff
;;
-(define (client:setup-http run-id #!key (remaining-tries 10) (failed-connects 0))
+
+(define (client:setup-http areapath #!key (remaining-tries 100) (failed-connects 0))
(debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries)
- (let* ((tdbdat (tasks:open-db)))
- (if (<= remaining-tries 0)
- (begin
- (debug:print-error 0 *default-log-port* "failed to start or connect to server for run-id " run-id)
- (exit 1))
- (let* ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id)))
- (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
- (if server-dat
- (let* ((iface (tasks:hostinfo-get-interface server-dat))
- (hostname (tasks:hostinfo-get-hostname server-dat))
- (port (tasks:hostinfo-get-port server-dat))
- (start-res (case *transport-type*
- ((http)(http-transport:client-connect iface port))
- ;;((nmsg)(nmsg-transport:client-connect hostname port))
- ))
- (ping-res (case *transport-type*
- ((http)(rmt:login-no-auto-client-setup start-res))
- ;; ((nmsg)(let ((logininfo (rmt:login-no-auto-client-setup start-res run-id)))
- ;; (if logininfo
- ;; (car (vector-ref logininfo 1))
- ;; #f)))
-
- )))
- (if (and start-res
- ping-res)
- (begin
- (remote-conndat-set! *runremote* start-res) ;; (hash-table-set! *runremote* run-id start-res)
- (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))
- start-res)
- (begin ;; login failed but have a server record, clean out the record and try again
- (debug:print-info 0 *default-log-port* "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
- (case *transport-type*
- ((http)(http-transport:close-connections run-id)))
- (remote-conndat-set! *runremote* #f) ;; (hash-table-delete! *runremote* run-id)
- (tasks:kill-server-run-id run-id)
- (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat)
- run-id
- (tasks:hostinfo-get-interface server-dat)
- (tasks:hostinfo-get-port server-dat)
- " client:setup (server-dat = #t)")
- (if (> remaining-tries 8)
- (thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little
- (thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time
- (server:try-running *toppath*)
- (thread-sleep! 5) ;; give server a little time to start up
- (client:setup run-id remaining-tries: (- remaining-tries 1))
- )))
- (begin ;; no server registered
- (let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id)))
- (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available)
- (if (< num-available 2)
- (server:try-running *toppath*))
- (thread-sleep! (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms.
- (client:setup run-id remaining-tries: (- remaining-tries 1)))))))))
-
-;; keep this as a function to ease future
-(define (client:start run-id server-info)
- (http-transport:client-connect (tasks:hostinfo-get-interface server-info)
- (tasks:hostinfo-get-port server-info)))
-
-;; ;; client:signal-handler
-;; (define (client:signal-handler signum)
-;; (signal-mask! signum)
-;; (set! *time-to-exit* #t)
-;; (handle-exceptions
-;; exn
-;; (debug:print 0 *default-log-port* " ... exiting ...")
-;; (let ((th1 (make-thread (lambda ()
-;; "") ;; do nothing for now (was flush out last call if applicable)
-;; "eat response"))
-;; (th2 (make-thread (lambda ()
-;; (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
-;; (thread-sleep! 1) ;; give the flush one second to do it's stuff
-;; (debug:print 0 *default-log-port* " Done.")
-;; (exit 4))
-;; "exit on ^C timer")))
-;; (thread-start! th2)
-;; (thread-start! th1)
-;; (thread-join! th2))))
-;;
-;; ;; client:launch
-;; ;; Need to set the signal handler somewhere other than here as this
-;; ;; routine will go away.
-;; ;;
-;; (define (client:launch run-id)
-;; (set-signal-handler! signal/int client:signal-handler)
-;; (set-signal-handler! signal/term client:signal-handler)
-;; (if (client:setup run-id)
-;; (debug:print-info 2 *default-log-port* "connected as client")
-;; (begin
-;; (debug:print-error 0 *default-log-port* "Failed to connect as client")
-;; (exit))))
-;;
+ (server:start-and-wait areapath)
+ (if (<= remaining-tries 0)
+ (begin
+ (debug:print-error 0 *default-log-port* "failed to start or connect to server")
+ (exit 1))
+ ;;
+ ;; Alternatively here, we can get the list of candidate servers and work our way
+ ;; through them searching for a good one.
+ ;;
+ (let* ((server-dat (server:get-first-best areapath)))
+ (if (not server-dat) ;; no server found
+ (client:setup-http areapath remaining-tries: (- remaining-tries 1))
+ (let ((host (cadr server-dat))
+ (port (caddr server-dat)))
+ (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
+ (if (not *runremote*)(set! *runremote* (make-remote)))
+ (if (and host port)
+ (let* ((start-res (case *transport-type*
+ ((http)(http-transport:client-connect host port))))
+ (ping-res (case *transport-type*
+ ((http)(rmt:login-no-auto-client-setup start-res)))))
+ (if (and start-res
+ ping-res)
+ (begin
+ (remote-conndat-set! *runremote* start-res) ;; (hash-table-set! *runremote* run-id start-res)
+ (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))
+ start-res)
+ (begin ;; login failed but have a server record, clean out the record and try again
+ (debug:print-info 0 *default-log-port* "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
+ (case *transport-type*
+ ((http)(http-transport:close-connections)))
+ (remote-conndat-set! *runremote* #f) ;; (hash-table-delete! *runremote* run-id)
+ (thread-sleep! 1)
+ (client:setup-http areapath remaining-tries: (- remaining-tries 1))
+ )))
+ (begin ;; no server registered
+ (server:kind-run areapath)
+ (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries)
+ (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms.
+ (server:start-and-wait areapath)
+ (client:setup-http areapath remaining-tries: (- remaining-tries 1)))))))))
+
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -141,11 +141,11 @@
(define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set
(define *homehost-mutex* (make-mutex))
(defstruct remote
(hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag )
- (server-url (if *toppath* (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*) #f))
+ (server-url (if *toppath* (server:check-if-running *toppath*))) ;; (server:check-if-running *toppath*) #f))
(last-server-check 0) ;; last time we checked to see if the server was alive
(conndat #f)
(transport *transport-type*)
(server-timeout (or (server:get-timeout) 100))) ;; default to 100 seconds
@@ -242,19 +242,32 @@
;;
(define (common:rotate-logs)
(if (not (directory-exists? "logs"))(create-directory "logs"))
(directory-fold
(lambda (file rem)
- (if (and (string-match "^.*.log" file)
- (> (file-size (conc "logs/" file)) 200000))
- (let ((gzfile (conc "logs/" file ".gz")))
- (if (file-exists? gzfile)
- (begin
- (debug:print-info 0 *default-log-port* "removing " gzfile)
- (delete-file gzfile)))
- (debug:print-info 0 *default-log-port* "compressing " file)
- (system (conc "gzip logs/" file)))))
+ (handle-exceptions
+ exn
+ (debug:print-info 0 *default-log-port* "failed to rotate log " file ", probably handled by another process.")
+ (let* ((fullname (conc "logs/" file))
+ (file-age (- (current-seconds)(file-modification-time fullname))))
+ (if (or (and (string-match "^.*.log" file)
+ (> (file-size fullname) 200000))
+ (and (string-match "^server-.*.log" file)
+ (> (- (current-seconds) (file-modification-time fullname))
+ (* 8 60 60))))
+ (let ((gzfile (conc fullname ".gz")))
+ (if (file-exists? gzfile)
+ (begin
+ (debug:print-info 0 *default-log-port* "removing " gzfile)
+ (delete-file gzfile)))
+ (debug:print-info 0 *default-log-port* "compressing " file)
+ (system (conc "gzip " fullname)))
+ (if (> file-age (* (string->number (or (configf:lookup *configdat* "setup" "log-expire-days") "30")) 24 3600))
+ (handle-exceptions
+ exn
+ #f
+ (delete-file fullname)))))))
'()
"logs"))
;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;;
@@ -572,33 +585,36 @@
(define *wdnum*mutex (make-mutex))
;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp
;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server)
;;
(define (common:watchdog)
-
(thread-sleep! 0.05) ;; delay for startup
(let ((legacy-sync (common:run-sync?))
(debug-mode (debug:debug-mode 1))
(last-time (current-seconds))
- (this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x)))
- )
+ (this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x))))
(debug:print-info 0 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num)
(if (and legacy-sync (not *time-to-exit*))
- (let ((dbstruct (db:setup)))
+ (let* ((dbstruct (db:setup))
+ (mtdb (dbr:dbstruct-mtdb dbstruct))
+ (mtpath (db:dbdat-get-path mtdb)))
(debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
(let loop ()
- ;;(BB> "watchdog loop. pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
;; sync for filesystem local db writes
;;
(mutex-lock! *db-multi-sync-mutex*)
(let* ((need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write
(sync-in-progress *db-sync-in-progress*)
(should-sync (and (not *time-to-exit*)
(> (- (current-seconds) *db-last-sync*) 5))) ;; sync every five seconds minimum
+ (start-time (current-seconds))
+ (mt-mod-time (file-modification-time mtpath))
+ (recently-synced (> (- start-time mt-mod-time) 4))
(will-sync (and (or need-sync should-sync)
- (not sync-in-progress)))
- (start-time (current-seconds)))
+ (not sync-in-progress)
+ (not recently-synced))))
+ ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced))
;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync)
(if will-sync (set! *db-sync-in-progress* #t))
(mutex-unlock! *db-multi-sync-mutex*)
(if will-sync
(let ((res (common:sync-to-megatest.db dbstruct))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -99,10 +99,14 @@
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
+(if (not (common:on-homehost?))
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: Current policy requires running dashboard on homehost: " (common:get-homehost))))
+
;; TODO: Move this inside (main)
;;
(if (not (launch:setup))
(begin
(print "Failed to find megatest.config, exiting")
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -13,14 +13,14 @@
;; Database access
;;======================================================================
;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc
-(use (srfi 18) extras tcp stack) ;; RADT => use of require-extension?
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records sql-null)
+(use (srfi 18) extras tcp stack)
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records sql-null matchable)
(import (prefix sqlite3 sqlite3:))
-(import (prefix base64 base64:)) ;; RADT => prefix??
+(import (prefix base64 base64:))
(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm")
(import (prefix dbi dbi:))
(declare (unit db))
(declare (uses common))
@@ -146,11 +146,11 @@
(use-mutex (> *api-process-request-count* 25)))
(if (and use-mutex
(common:low-noise-print 120 "over-50-parallel-api-requests"))
(debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access"))
(if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*))
- (debug:print-info 0 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*))
+ (debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*))
(handle-exceptions
exn
(begin
(print-call-chain (current-error-port))
(debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn))
@@ -487,13 +487,14 @@
'("pass_count" "INTEGER"))
(list "test_meta"
'("id" "INTEGER" 'key)
'("testname" "TEXT")
+ '("author" "TEXT")
'("owner" "TEXT")
'("description" "TEXT")
- '("reviewed" "INTEGER")
+ '("reviewed" "TEXT")
'("iterated" "TEXT")
'("avg_runtime" "REAL")
'("avg_disk" "REAL")
'("tags" "TEXT")
'("jobgroup" "TEXT")))))
@@ -563,21 +564,21 @@
)
;; test read/write access to the database
(let ((db (dbi:open 'sqlite3 (cons (cons ('dbname dbpath) '())))))
(cond
((equal? fname "megatest.db")
- (sqlite3:executeute db "DELETE FROM tests WHERE state='DELETED';"))
+ (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';"))
((equal? fname "main.db")
- (sqlite3:executeute db "DELETE FROM runs WHERE state='deleted';"))
+ (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';"))
((string-match "\\d.db" fname)
- (sqlite3:executeute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';"))
+ (sqlite3:execute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';"))
((equal? fname "monitor.db")
- (sqlite3:executeute "DELETE FROM servers WHERE state LIKE 'defunct%';"))
+ (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';"))
(else
- (sqlite3:executeute db "vacuum;")))
+ (sqlite3:execute db "vacuum;")))
- (dbi:close db)
+ (sqlite3:finalize! db)
#t))))))
;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
;; db's are dbdat's
;;
@@ -910,20 +911,21 @@
(let* ((mtdb (dbr:dbstruct-mtdb dbstruct))
(tmpdb (db:get-db dbstruct))
(refndb (dbr:dbstruct-refndb dbstruct))
(slave-dbs (dbr:dbstruct-slave-dbs dbstruct))
(allow-cleanup #t) ;; (if run-ids #f #t))
- (tdbdat (tasks:open-db))
- (servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))
+ ;; (tdbdat (tasks:open-db))
+ (servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat)))
(data-synced 0)) ;; count of changed records (I hope)
;; kill servers
(if (member 'killservers options)
(for-each
(lambda (server)
- (tasks:server-delete-record (db:delay-if-busy tdbdat) (vector-ref server 0) "dbmigration")
- (tasks:kill-server (vector-ref server 2)(vector-ref server 1)))
+ (match-let (((mod-time host port start-time pid) server))
+ (if (and host pid)
+ (tasks:kill-server host pid))))
servers))
;; clear out junk records
;;
(if (member 'dejunk options)
@@ -2157,13 +2159,16 @@
db
"SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;")
(reverse run-ids)))))
;; get some basic run stats
+;;
+;; data structure:
;;
;; ( (runname (( state count ) ... ))
-;; ( ...
+;; ( ...
+;;
(define (db:get-run-stats dbstruct)
(let* ((totals (make-hash-table))
(curr (make-hash-table))
(res '())
(runs-info '()))
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -12,11 +12,11 @@
(use format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw-iup)
-(use regex typed-records)
+(use regex typed-records matchable)
(declare (unit dcommon))
(declare (uses megatest-version))
(declare (uses gutils))
@@ -620,11 +620,12 @@
#:numlin-visible 5
))
(colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId"))
(updater (lambda ()
(if (dashboard:monitor-changed? commondat tabdat)
- (let ((servers (tasks:get-all-servers (db:delay-if-busy tdbdat))))
+ (let ((servers (server:get-list *toppath* limit: 10)))
+ ;; (tasks:get-all-servers (db:delay-if-busy tdbdat))))
(iup:attribute-set! servers-matrix "NUMLIN" (length servers))
;; (set! colnum 0)
;; (for-each (lambda (colname)
;; ;; (print "colnum: " colnum " colname: " colname)
;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
@@ -632,36 +633,40 @@
;; colnames)
(set! rownum 1)
(for-each
(lambda (server)
(set! colnum 0)
- (let* ((vals (list (vector-ref server 0) ;; Id
- (vector-ref server 9) ;; MT-Ver
- (vector-ref server 1) ;; Pid
- (vector-ref server 2) ;; Hostname
- (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port
- (seconds->hr-min-sec (- (current-seconds)(vector-ref server 6)))
- ;; (vector-ref server 5) ;; Pubport
- ;; (vector-ref server 10) ;; Last beat
- ;; (vector-ref server 6) ;; Start time
- ;; (vector-ref server 7) ;; Priority
- ;; (vector-ref server 8) ;; State
- (vector-ref server 8) ;; State
- (vector-ref server 12) ;; RunId
- )))
- (for-each (lambda (val)
- (let* ((row-col (conc rownum ":" colnum))
- (curr-val (iup:attribute servers-matrix row-col)))
- (if (not (equal? (conc val) curr-val))
- (begin
- (iup:attribute-set! servers-matrix row-col val)
- (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))))
- (set! colnum (+ 1 colnum))))
- vals)
- (set! rownum (+ rownum 1)))
- (iup:attribute-set! servers-matrix "REDRAW" "ALL"))
- servers))))))
+ (match-let (((mod-time host port start-time pid)
+ server))
+ (let* ((uptime (- (current-seconds) mod-time))
+ (runtime (if start-time
+ (- mod-time start-time)
+ 0))
+ (vals (list "-" ;; (vector-ref server 0) ;; Id
+ "-" ;; (vector-ref server 9) ;; MT-Ver
+ pid ;; (vector-ref server 1) ;; Pid
+ host ;; (vector-ref server 2) ;; Hostname
+ (conc host ":" port) ;; (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port
+ (seconds->hr-min-sec runtime) ;; (- (current-seconds) start-time)) ;; (vector-ref server 6)))
+ (cond
+ ((< uptime 5) "alive")
+ ((< uptime 16) "probably alive");; less than 15 seconds since mod, call it alive (vector-ref server 8) ;; State
+ (else "dead"))
+ "-" ;; (vector-ref server 12) ;; RunId
+ )))
+ (for-each (lambda (val)
+ (let* ((row-col (conc rownum ":" colnum))
+ (curr-val (iup:attribute servers-matrix row-col)))
+ (if (not (equal? (conc val) curr-val))
+ (begin
+ (iup:attribute-set! servers-matrix row-col val)
+ (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))))
+ (set! colnum (+ 1 colnum))))
+ vals)
+ (set! rownum (+ rownum 1)))
+ (iup:attribute-set! servers-matrix "REDRAW" "ALL")))
+ (sort servers (lambda (a b)(> (car a)(car b))))))))))
(set! colnum 0)
(for-each (lambda (colname)
(iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
(iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))
(set! colnum (+ colnum 1)))
ADDED diff-report.scm
Index: diff-report.scm
==================================================================
--- /dev/null
+++ diff-report.scm
@@ -0,0 +1,408 @@
+
+(declare (unit diff-report))
+(declare (uses common))
+(declare (uses rmt))
+
+(include "common_records.scm")
+(use matchable)
+(use fmt)
+(use ducttape-lib)
+(define css "")
+
+(define (diff:tests-mindat->hash tests-mindat)
+ (let* ((res (make-hash-table)))
+ (for-each
+ (lambda (item)
+ (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1)))
+ (value (list-ref item 2)))
+ (hash-table-set! res test-name+item-path value)))
+ tests-mindat)
+ res))
+
+;; return 1 if status1 is better
+;; return 0 if status1 and 2 are equally good
+;; return -1 if status2 is better
+(define (diff:status-compare3 status1 status2)
+ (let*
+ ((status-goodness-ranking (list "PASS" "WARN" "WAIVED" "SKIP" "FAIL" "ABORT" #f))
+ (mem1 (member status1 status-goodness-ranking))
+ (mem2 (member status2 status-goodness-ranking))
+ )
+ (cond
+ ((and (not mem1) (not mem2)) 0)
+ ((not mem1) -1)
+ ((not mem2) 1)
+ ((= (length mem1) (length mem2)) 0)
+ ((> (length mem1) (length mem2)) 1)
+ (else -1))))
+
+
+(define (diff:xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f) (consistent-fail-not-clean #f))
+ (let* ((src-hash (diff:tests-mindat->hash src-tests-mindat))
+ (dest-hash (diff:tests-mindat->hash dest-tests-mindat))
+ (all-keys
+ (reverse (sort
+ (delete-duplicates
+ (append (hash-table-keys src-hash) (hash-table-keys dest-hash)))
+
+ (lambda (a b)
+ (cond
+ ((< 0 (string-compare3 (car a) (car b))) #t)
+ ((> 0 (string-compare3 (car a) (car b))) #f)
+ ((< 0 (string-compare3 (cdr a) (cdr b))) #t)
+ (else #f)))
+
+ ))))
+ (let ((res
+ (map ;; TODO: rename xor to delta globally in dcommon and dashboard
+ (lambda (key)
+ (let* ((test-name (car key))
+ (item-path (cdr key))
+
+ (dest-value (hash-table-ref/default dest-hash key (list 0 "NULL" "NULL"))) ;; (list test-id state status)
+ (dest-test-id (list-ref dest-value 0))
+ (dest-state (list-ref dest-value 1))
+ (dest-status (list-ref dest-value 2))
+
+ (src-value (hash-table-ref/default src-hash key (list 0 "NULL" "NULL"))) ;; (list test-id state status)
+ (src-test-id (list-ref src-value 0))
+ (src-state (list-ref src-value 1))
+ (src-status (list-ref src-value 2))
+
+ (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete
+
+ (dest-complete
+ (and dest-value dest-state dest-status
+ (equal? dest-state "COMPLETED")
+ (not (member dest-status incomplete-statuses))))
+ (src-complete
+ (and src-value src-state src-status
+ (equal? src-state "COMPLETED")
+ (not (member src-status incomplete-statuses))))
+ (status-compare-result (diff:status-compare3 src-status dest-status))
+ (xor-new-item
+ (cond
+ ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a )
+ ;; neither complete -> bad
+
+ ;; src !complete, dest complete -> better
+ ((and (not dest-complete) (not src-complete))
+ (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE") src-value dest-value)
+ ((not dest-complete)
+ (list src-test-id "NOT-IN-DEST" "DEST-INCOMPLETE") src-value dest-value)
+ ((not src-complete)
+ (list dest-test-id "NOT-IN-SRC" "SRC-INCOMPLETE") src-value dest-value)
+ ((and
+ (equal? src-state dest-state)
+ (equal? src-status dest-status))
+ (if (and consistent-fail-not-clean (not (member dest-status '("PASS" "SKIP" "WAIVED" "WARN"))))
+ (list dest-test-id (conc "BOTH-BAD") (conc "CLEAN-" dest-status) src-value dest-value)
+ (list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) src-value dest-value)))
+ ;; better or worse: pass > warn > waived > skip > fail > abort
+ ;; pass > warn > waived > skip > fail > abort
+
+ ((= 1 status-compare-result) ;; src is better, dest is worse
+ (list dest-test-id "WORSE" (conc src-status "->" dest-status) src-value dest-value))
+ (else
+ (list dest-test-id "BETTER" (conc src-status "->" dest-status) src-value dest-value)))))
+ (list test-name item-path xor-new-item)))
+ all-keys)))
+
+ (if hide-clean
+ (filter
+ (lambda (item)
+ (not
+ (equal?
+ "CLEAN"
+ (list-ref (list-ref item 2) 1))))
+ res)
+ res))))
+
+(define (diff:run-name->run-id run-name)
+ (if (number? run-name)
+ run-name
+ (let* ((qry-res (rmt:get-runs run-name 1 0 '())))
+ (if (eq? 2 (vector-length qry-res))
+ (vector-ref (car (vector-ref qry-res 1)) 1)
+ #f))))
+
+(define (diff:target+run-name->run-id target run-name)
+ (let* ((keys (rmt:get-keys))
+ (target-parts (if target (string-split target "/") (map (lambda (x) "%") keys))))
+ (if (not (eq? (length keys) (length keys)))
+ (begin
+ (print "Error: Target ("target") item count does not match fields count target tokens="target-parts" fields="keys)
+ #f)
+ (let* ((target-map (zip keys target-parts))
+ (qry-res (rmt:get-runs run-name 1 0 target-map)))
+
+ (if (eq? 2 (vector-length qry-res))
+ (let ((first-ent (vector-ref qry-res 1)))
+ (if (> (length first-ent) 0)
+ (vector-ref (car first-ent) 1)
+ #f))
+ #f)))))
+
+(define (diff:run-id->tests-mindat run-id #!key (testpatt "%/%"))
+ (let* ((states '())
+ (statuses '())
+ (offset #f)
+ (limit #f)
+ (not-in #t)
+ (sort-by #f)
+ (sort-order #f)
+ (qryvals "id,testname,item_path,state,status")
+ (qryvals "id,testname,item_path,state,status")
+ (last-update 0)
+ (mode #f)
+ )
+ (map
+ ;; (lambda (row)
+ ;; (match row
+ ;; ((#(id test-name item-path state status)
+ ;; (list test-name item-path (list id state status))))
+ ;; (else #f)))
+ (lambda (row)
+ (let* ((id (vector-ref row 0))
+ (test-name (vector-ref row 1))
+ (item-path (vector-ref row 2))
+ (state (vector-ref row 3))
+ (status (vector-ref row 4)))
+ (list test-name item-path (list id state status))))
+
+ (rmt:get-tests-for-run run-id
+ testpatt states statuses
+ offset limit
+ not-in sort-by sort-order
+ qryvals
+ last-update
+ mode))))
+
+
+(define (diff:diff-runs src-run-id dest-run-id)
+ (let* ((src-tests-mindat (diff:run-id->tests-mindat src-run-id))
+ (dest-tests-mindat (diff:run-id->tests-mindat dest-run-id)))
+ (diff:xor-tests-mindat src-tests-mindat dest-tests-mindat consistent-fail-not-clean: #t)))
+
+
+(define (diff:rundiff-find-by-state run-diff state)
+ (filter
+ (lambda (x)
+ (equal? (list-ref (caddr x) 1) state))
+ run-diff))
+
+(define (diff:rundiff-clean-breakdown run-diff)
+ (map
+ (lambda (run-diff-item)
+ (match run-diff-item
+ ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status)))
+ (list test-name item-path "CLEAN" src-status))
+ (else "")))
+ (diff:rundiff-find-by-state run-diff "CLEAN")))
+
+(define (diff:summarize-run-diff run-diff)
+
+ (let* ((diff-states (list "CLEAN" "BETTER" "WORSE" "BOTH-BAD" "NOT-IN-DEST" "NOT-IN-SRC" )))
+ (map
+ (lambda (state)
+ (list state
+ (length (diff:rundiff-find-by-state run-diff state))))
+ diff-states)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Presentation code below, business logic above ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (diff:stml->string in-stml)
+ (with-output-to-string
+ (lambda ()
+ (s:output-new
+ (current-output-port)
+ in-stml))))
+
+(define (diff:state-status->bgcolor state status)
+ (match (list state status)
+ (("CLEAN" _) "#88ff88")
+ (("BETTER" _) "#33ff33")
+ (("WORSE" _) "#ff3333")
+ (("BOTH-BAD" _) "#ff3333")
+ ((_ "WARN") "#ffff88")
+ ((_ "FAIL") "#ff8888")
+ ((_ "ABORT") "#ff0000")
+ ((_ "PASS") "#88ff88")
+ ((_ "SKIP") "#ffff00")
+ (else "#ffffff")))
+
+(define (diff:test-state-status->diff-report-cell state status)
+ (s:td 'bgcolor (diff:state-status->bgcolor state status) status))
+
+(define (diff:diff-state-status->diff-report-cell state status)
+ (s:td state 'bgcolor (diff:state-status->bgcolor state status)))
+
+
+(define (diff:megatest-html-logo)
+
+ "
+___ ___ _ _
+| \\/ | ___ __ _ __ _| |_ ___ ___| |_
+| |\\/| |/ _ \\/ _` |/ _` | __/ _ \\/ __| __|
+| | | | __/ (_| | (_| | || __/\\__ \\ |_
+|_| |_|\\___|\\__, |\\__,_|\\__\\___||___/\\__|
+ |___/
+
")
+
+(define (diff:megatest-html-diff-logo)
+ "
+___ ___ _ _
+| \\/ | ___ __ _ __ _| |_ ___ ___| |_ | _ \\(_)/ _|/ _|
+| |\\/| |/ _ \\/ _` |/ _` | __/ _ \\/ __| __| | | | | | |_| |_
+| | | | __/ (_| | (_| | || __/\\__ \\ |_ | |_| | | _| _|
+|_| |_|\\___|\\__, |\\__,_|\\__\\___||___/\\__| |____/|_|_| |_|
+ |___/
+
")
+
+
+(define (diff:run-id->target+run-name+starttime run-id)
+ (let* ((target (rmt:get-target run-id))
+ (runinfo (rmt:get-run-info run-id)) ; vector of header (list) and result (vector)
+ (info-hash (alist->hash-table
+ (map (lambda (x) (cons (car x) (cadr x))) ; make it a useful hash
+ (zip (vector-ref runinfo 0) (vector->list (vector-ref runinfo 1))))))
+ (run-name (hash-table-ref/default info-hash "runname" "N/A"))
+ (start-time (hash-table-ref/default info-hash "event_time" 0)))
+ (list target run-name start-time)))
+
+(define (diff:deliver-diff-report src-run-id dest-run-id
+ #!key
+ (html-output-file #f)
+ (email-subject-prefix "[MEGATEST DIFF]")
+ (email-recipients-list '()) )
+ (let* ((src-info (diff:run-id->target+run-name+starttime src-run-id))
+ (src-target (car src-info))
+ (src-run-name (cadr src-info))
+ (src-start (conc (seconds->string (caddr src-info)) " " (local-timezone-abbreviation)))
+ (dest-info (diff:run-id->target+run-name+starttime dest-run-id))
+ (dest-target (car dest-info))
+ (dest-run-name (cadr dest-info))
+ (dest-start (conc (seconds->string (caddr dest-info)) " " (local-timezone-abbreviation)))
+
+
+ (run-diff (diff:diff-runs src-run-id dest-run-id ))
+ (test-count (length run-diff))
+ (summary-table
+ (apply s:table 'cellspacing "0" 'border "1"
+ (s:tr
+ (s:th "Diff type")
+ (s:th "% share")
+ (s:th "Count"))
+
+ (map
+ (lambda (state-count)
+ (s:tr
+ (diff:diff-state-status->diff-report-cell (car state-count) #f)
+ (s:td 'align "right" (fmt #f
+ (decimal-align 3
+ (fix 2
+ (num/fit 6
+ (* 100 (/ (cadr state-count) test-count)))))))
+ (s:td 'align "right" (cadr state-count))))
+ (diff:summarize-run-diff run-diff))))
+ (meta-table
+ (s:table 'cellspacing "0" 'border "1"
+
+ (s:tr
+ (s:td 'colspan "2"
+ (s:table 'cellspacing "0" 'border "1"
+ (s:tr
+ (s:th 'align "LEFT" "") (s:th "SOURCE RUN") (s:th "DESTINATION RUN"))
+ (s:tr
+ (s:th 'align "LEFT" "Started") (s:td src-start) (s:td dest-start))
+ (s:tr
+ (s:th 'align "LEFT" "TARGET") (s:td src-target) (s:td dest-target))
+ (s:tr
+ (s:th 'align "LEFT" "RUN NAME") (s:td src-run-name) (s:td dest-run-name)))))))
+
+ (main-table
+ (apply s:table 'cellspacing "0" 'border "1"
+ (s:tr
+ (s:th "Test name")
+ (s:th "Item Path")
+ (s:th (conc "SOURCE"))
+ (s:th (conc "DEST"))
+ (s:th "Diff"))
+ (map
+ (lambda (run-diff-item)
+ (match run-diff-item
+ ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status)))
+ (s:tr
+ (s:td test-name)
+ (s:td item-path)
+ (diff:test-state-status->diff-report-cell src-state src-status)
+ (diff:test-state-status->diff-report-cell dest-state dest-status)
+ (diff:diff-state-status->diff-report-cell diff-state diff-status)))
+ (else "")))
+ (filter (lambda (run-diff-item)
+ (match run-diff-item
+ ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status)))
+ (not (equal? diff-state "CLEAN")))
+ (else #f)))
+ run-diff))))
+ (email-subject (conc email-subject-prefix " " src-target "/" src-run-name" vs. "dest-target"/"dest-run-name))
+ (html-body (diff:stml->string (s:body
+ (diff:megatest-html-diff-logo)
+ (s:h2 "Summary")
+ (s:table 'border "0"
+ (s:tr
+ (s:td "Diff calculated at")
+ (s:td (conc (seconds->string) " " (local-timezone-abbreviation))))
+ (s:tr
+ (s:td "MT_RUN_AREA_HOME" ) (s:td *toppath*))
+ (s:tr 'valign "TOP"
+ (s:td summary-table)
+ (s:td meta-table)))
+ (s:h2 "Diffs + consistently failing tests")
+ main-table)))
+
+ )
+ (if html-output-file
+ (with-output-to-file html-output-file (lambda () (print html-body))))
+ (when (and email-recipients-list (> (length email-recipients-list) 0))
+ (sendmail (string-join email-recipients-list ",") email-subject html-body use_html: #t))
+ html-body))
+
+
+
+
+
+;; (let* ((src-run-name "all57")
+;; (dest-run-name "all60")
+;; (src-run-id (diff:run-name->run-id src-run-name))
+;; (dest-run-id (diff:run-name->run-id dest-run-name))
+;; (to-list (list "bjbarcla")))
+;; (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: "/tmp/bjbarcla/zippy.html")
+;; )
+
+(define (do-diff-report src-target src-runname dest-target dest-runname html-file to-list-raw)
+ (let* (;;(src-target "nope%")
+ ;;(src-runname "all57")
+ ;;(dest-target "%")
+ ;;(dest-runname "all60")
+ (src-run-id (diff:target+run-name->run-id src-target src-runname))
+ (dest-run-id (diff:target+run-name->run-id dest-target dest-runname))
+ ;(html-file "/tmp/bjbarcla/zippy.html")
+ (to-list (if (string? to-list-raw) (string-split to-list-raw ",:") #f))
+ )
+
+ (cond
+ ((not src-run-id)
+ (print "No match for source target/runname="src-target"/"src-runname)
+ (print "Cannot proceed.")
+ #f)
+ ((not dest-run-id)
+ (print "No match for source target/runname="dest-target"/"dest-runname)
+ (print "Cannot proceed.")
+ #f)
+ (else
+ (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: html-file)))))
+
+
ADDED ducttape/Makefile
Index: ducttape/Makefile
==================================================================
--- /dev/null
+++ ducttape/Makefile
@@ -0,0 +1,33 @@
+help:
+ @echo ""
+ @echo "make targets:"
+ @echo "============="
+ @echo "install - build and install general_lib egg as icfadm"
+ @echo "test - run unit tests on ducttape-lib.scm (tests code, not egg)"
+ @echo "eggs-info - show chicken-install commands to get eggs upon which ducttape-lib depends"
+ @echo "test_example - compile an example scm against installed general_lib egg"
+ @echo "clean - remove binaries and other build artifacts"
+ @echo ""
+
+clean:
+ rm -f *.so *.import.scm test_ducttape test_example foo *.c *.o
+
+install:
+ chicken-install
+
+test:
+ chicken-install -no-install
+ csc test_ducttape.scm
+
+ ./test_ducttape
+ rm -f foo
+
+test_example:
+ @csc test_example.scm
+ @./test_example
+ @rm test_example
+
+eggs-info:
+ @echo chicken-install ansi-escape-sequences
+ @echo chicken-install slice
+ @echo chicken-install rfc3339
ADDED ducttape/README
Index: ducttape/README
==================================================================
--- /dev/null
+++ ducttape/README
@@ -0,0 +1,8 @@
+This directory holds the "ducttape" chicken scheme egg used by megatest.
+
+Run "make test" to ensure this egg works on your system.
+
+Run "make install" as your admin user with chicken on your $PATH to install this egg.
+
+
+
ADDED ducttape/ducttape-lib.meta
Index: ducttape/ducttape-lib.meta
==================================================================
--- /dev/null
+++ ducttape/ducttape-lib.meta
@@ -0,0 +1,13 @@
+;;; ducttape-lib.meta -*- Hen -*-
+
+((egg "ducttape-lib.egg")
+ (synopsis "Miscellaneous tool and standard print routines.")
+ (category env)
+ (author "Brandon Barclay")
+ (doc-from-wiki)
+ (license "GPL-2")
+ ;; srfi-69, posix, srfi-18
+ (depends regex)
+ (test-depends test)
+ ; suspicious - (files "ducttape-lib")
+ )
ADDED ducttape/ducttape-lib.scm
Index: ducttape/ducttape-lib.scm
==================================================================
--- /dev/null
+++ ducttape/ducttape-lib.scm
@@ -0,0 +1,747 @@
+(module ducttape-lib
+ (
+ runs-ok
+ ducttape-debug-level
+ ducttape-debug-regex-filter
+ ducttape-silent-mode
+ ducttape-quiet-mode
+ ducttape-log-file
+ ducttape-color-mode
+ iputs-preamble
+ script-name
+ idbg
+ ierr
+ iwarn
+ inote
+ iputs
+ re-match?
+ ; launch-repl
+ keyword-skim
+ skim-cmdline-opts-noarg-by-regex
+ skim-cmdline-opts-withargs-by-regex
+ concat-lists
+ ducttape-process-command-line
+ ducttape-append-logfile
+ ducttape-activate-logfile
+ isys
+ do-or-die
+ counter-maker
+ dir-is-writable?
+ mktemp
+ get-tmpdir
+ sendmail
+ find-exe
+
+ zeropad
+ string-leftpad
+ string-rightpad
+ seconds->isodate
+ seconds->wwdate
+ seconds->wwdate-values
+ isodate->seconds
+ isodate->wwdate
+ wwdate->seconds
+ wwdate->isodate
+ current-wwdate
+ current-isodate
+
+ )
+
+ (import scheme chicken extras ports data-structures )
+ (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339)
+ ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process*
+ (use directory-utils uuid-lib filepath srfi-19 ) ; linenoise
+
+ (include "mimetypes.scm") ; provides ext->mimetype
+ (include "workweekdate.scm")
+ (define ducttape-lib-version 1.00)
+ (define (toplevel-command sym proc) (lambda () #f))
+;;;; utility procedures
+
+ ;; begin credit: megatest's process.scm
+ (define (port->list fh )
+ (if (eof-object? fh) #f
+ (let loop ((curr (read-line fh))
+ (result '()))
+ (if (not (eof-object? curr))
+ (loop (read-line fh)
+ (append result (list curr)))
+ result))))
+
+ (define (conservative-read port)
+ (let loop ((res ""))
+ (if (not (eof-object? (peek-char port)))
+ (loop (conc res (read-char port)))
+ res)))
+ ;; end credit: megatest's process.scm
+
+ (define (counter-maker)
+ (let ((acc 0))
+ (lambda ( #!optional (increment 1) )
+ (set! acc (+ increment acc))
+ acc)))
+
+ (define (port->string port #!optional ) ; todo - add newline
+ (let ((linelist (port->list port)))
+ (if linelist
+ (string-join linelist "\n")
+ "")))
+
+
+ (define (outport->foreach outport foreach-thunk)
+ (let loop ((line (foreach-thunk)))
+ (if line
+ (begin
+ (write-line line outport)
+ (loop (foreach-thunk))
+ )
+ (begin
+ ;;http://bugs.call-cc.org/ticket/766
+ ;;close-[input|output]-port implicitly calling process-wait on process pipe ports. This leads to errors like
+ ;;Error: (process-wait) waiting for child process failed - No child processes: 10872
+ (close-output-port outport)
+ #f))))
+
+ ;; weird - alist-ref arg order changes signature csc vs. csi... explitly defining.
+ (define (my-alist-ref key alist)
+ (let ((res (assoc key alist)))
+ (if res (cdr res) #f)))
+
+ (define (keyword-skim-alist args alist)
+ (let loop ((result-alist '()) (result-args args) (rest-alist alist))
+ (cond
+ ((null? rest-alist) (values result-alist result-args))
+ (else
+ (let ((keyword (caar rest-alist))
+ (defval (cdar rest-alist)))
+ (let-values (((kwval result-args2)
+ (keyword-skim
+ keyword
+ defval
+ result-args)))
+ (loop
+ (cons (cons keyword kwval) result-alist)
+ result-args2
+ (cdr rest-alist))))))))
+
+ (define (isys command . rest-args)
+ (let-values
+ (((opt-alist args)
+ (keyword-skim-alist
+ rest-args
+ '( ( foreach-stdout-thunk: . #f )
+ ( foreach-stdin-thunk: . #f )
+ ( stdin-proc: . #f ) ) )))
+ (let* ((foreach-stdout-thunk
+ (my-alist-ref foreach-stdout-thunk: opt-alist))
+ (foreach-stdin-thunk
+ (my-alist-ref foreach-stdin-thunk: opt-alist))
+ (stdin-proc
+ (if foreach-stdin-thunk
+ (lambda (port)
+ (outport->foreach port foreach-stdin-thunk))
+ (my-alist-ref stdin-proc: opt-alist))))
+
+ ;; TODO: support command is list.
+
+ (let-values (((stdout stdin pid stderr)
+ (if (null? args)
+ (process* command)
+ (process* command args))))
+
+ ;(if foreach-stdin-thunk
+ ; (set! stdin-proc
+ ; (lambda (port)
+ ; (outport->foreach port foreach-stdin-thunk))))
+
+ (if stdin-proc
+ (stdin-proc stdin))
+
+ (let ((stdout-res
+ (if foreach-stdout-thunk ;; don't accumulate stdout if we have a thunk; probably doing this because stdout is BIG so lets not waste memory
+ (begin
+ (port-for-each foreach-stdout-thunk (lambda () (read-line stdout)))
+ "foreach-stdout-thunk ate stdout"
+ )
+ (if stdin-proc
+ "foreach-stdin-thunk/stdin-proc blocks stdout"
+ (port->string stdout))))
+ (stderr-res
+ (if stdin-proc
+ "foreach-stdin-thunk/stdin-proc blocks stdout"
+ (port->string stderr))))
+
+ ;; if we've used a stdin-proc, we've closed stdin port, which unfortunately causes a wait-pid internally, causing stdout and stderr ports to auto-close. don't close them again. (so sad - we lost stdout and stderr contents when we write to stdin)
+ ;; see - http://bugs.call-cc.org/ticket/766
+ (if (not stdin-proc)
+ (close-input-port stdout)
+ (close-input-port stderr))
+
+ (let-values (((anotherpid normalexit? exitstatus) (process-wait pid)))
+ (values exitstatus stdout-res stderr-res)))))))
+
+ (define (do-or-die command #!key nodie (foreach-stdout #f) (stdin-proc #f))
+ (let-values (((exit-code stdout-str stderr-str) (isys command foreach-stdout-thunk: foreach-stdout stdin-proc: stdin-proc )))
+ (if (equal? 0 exit-code)
+ stdout-str
+ (begin
+ (ierr (conc "Command > " command " " "< failed with " exit-code " because: \n" stderr-str) )
+ (if nodie #f (exit exit-code))))))
+
+
+ ;; runs-ok: evaluate expression while suppressing exceptions.
+ ; on caught exception, returns #f
+ ; otherwise, returns expression value
+ (define (runs-ok thunk)
+ (handle-exceptions exn #f (begin (thunk) #t)))
+
+ ;; concat-lists: result list = lista + listb
+ (define (concat-lists lista listb) ;; ok, I just reimplemented append...
+ (foldr cons listb lista))
+
+
+;;; setup general_lib env var parameters
+
+ ;; show warning/note/error/debug prefixes using ansi colors
+ (define ducttape-color-mode
+ (make-parameter (get-environment-variable "DUCTTAPE_COLORIZE")))
+
+ ;; if defined, has number value. if number value > 0, show debug messages
+ ;; value should be decremented in subshells -- idea is raising debug level will show debug messages deeper and deeper in process call stack
+ (define ducttape-debug-level
+ (make-parameter
+ (let ( (raw-debug-level (get-environment-variable "DUCTTAPE_DEBUG_LEVEL")) )
+ (if raw-debug-level
+ (let ((num-debug-level (runs-ok (string->number raw-debug-level))))
+ (if (integer? num-debug-level)
+ (begin
+ (let ((new-num-debug-level (- num-debug-level 1)))
+ (if (> new-num-debug-level 0) ;; decrement
+ (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level))
+ (unsetenv "DUCTTAPE_DEBUG_LEVEL")))
+ num-debug-level) ; it was set and > 0, mode is value
+ (begin
+ (unsetenv "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it
+ #f))) ; value was invalid, mode is f
+ #f)))) ; var not set, mode is f
+
+
+ (define ducttape-debug-mode (if (ducttape-debug-level) #t #f))
+
+ ;; ducttape-debug-regex-filter suppresses non-matching debug messages
+ (define ducttape-debug-regex-filter
+ (make-parameter
+ (let ((raw-debug-pattern (get-environment-variable "DUCTTAPE_DEBUG_PATTERN")))
+ (if raw-debug-pattern
+ raw-debug-pattern
+ "."))))
+
+ ;; silent mode suppresses Note and Warning type messages
+ (define ducttape-silent-mode
+ (make-parameter (get-environment-variable "DUCTTAPE_SILENT_MODE")))
+
+ ;; quiet mode suppresses Note type messages
+ (define ducttape-quiet-mode
+ (make-parameter (get-environment-variable "DUCTTAPE_QUIET_MODE")))
+
+ ;; if log file is defined, warning/note/error/debug messages are appended
+ ;; to named logfile.
+ (define ducttape-log-file
+ (make-parameter (get-environment-variable "DUCTTAPE_LOG_FILE")))
+
+
+
+
+
+
+;;; standard messages printing implementation
+
+ ; get the name of the current script/binary being run
+ (define (script-name)
+ (car (reverse (string-split (car (argv)) "/"))))
+
+ (define (ducttape-timestamp)
+ (rfc3339->string (time->rfc3339 (seconds->local-time))))
+
+
+ (define (iputs-preamble msg-type #!optional (suppress-color #f))
+ (let ((do-color (and
+ (not suppress-color)
+ (ducttape-color-mode)
+ (terminal-port? (current-error-port)))))
+ (case msg-type
+ ((note)
+ (if do-color
+ (set-text (list 'fg-green 'bg-black 'bold) "Note:")
+ "Note:"
+ ))
+ ((warn)
+ (if do-color
+ (set-text (list 'fg-yellow 'bg-black 'bold) "Warning:")
+ "Warning:"
+ ))
+ ((err)
+ (if do-color
+ (set-text (list 'fg-red 'bg-black 'bold) "Error:")
+ "Error:"
+ ))
+ ((dbg)
+ (if do-color
+ (set-text (list 'fg-blue 'bg-magenta) "Debug:")
+ "Debug:"
+ )))))
+
+ (define (ducttape-append-logfile msg-type message #!optional (suppress-preamble #f))
+ (let
+ ((txt
+ (string-join
+ (list
+ (ducttape-timestamp)
+ (script-name)
+ (if suppress-preamble
+ message
+ (string-join (list (iputs-preamble msg-type #t) message) " ")))
+ " | ")))
+
+ (if (ducttape-log-file)
+ (runs-ok
+ (call-with-output-file (ducttape-log-file)
+ (lambda (output-port)
+ (format output-port "~A ~%" txt)
+ )
+ #:append))
+ #t)))
+
+ (define (ducttape-activate-logfile #!optional (logfile #f))
+ ;; from python ducttape-lib.py
+ ; message = "START - pid=%d ppid=%d argv=(%s) pwd=%s user=%s host=%s"%(pid,ppid," ".join("'"+x+"'" for x in sys.argv),os.environ['PWD'],os.getenv('USER','nouser'),os.getenv('HOST','nohost') )
+ (let ((pid (number->string (current-process-id)))
+ (ppid (number->string (parent-process-id)))
+ (argv
+ (string-join
+ (map
+ (lambda (x)
+ (string-join (list "\"" x "\"") "" ))
+ (argv))
+ " "))
+ (pwd (or (get-environment-variable "PWD") "nopwd"))
+ (user (or (get-environment-variable "USER") "nouser"))
+ (host (or (get-environment-variable "HOST") "nohost")))
+ (if logfile
+ (begin
+ (ducttape-log-file logfile)
+ (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file))))
+ (ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t)))
+
+
+ ;; log exit code
+ (define (set-ducttape-log-exit-handler)
+ (let ((orig-exit-handler (exit-handler)))
+ (exit-handler
+ (lambda (exitcode)
+ (ducttape-append-logfile 'note (format #f "Exit ~A by sys.exit" exitcode) #t)
+ (orig-exit-handler exitcode)))))
+
+
+ (define (idbg first-message . rest-args)
+ (let* ((debug-level-threshold
+ (if (> (length rest-args) 0) (car rest-args) 1))
+ (message-list
+ (if (> (length rest-args) 1)
+ (cons first-message (cdr rest-args))
+ (list first-message)) )
+ (message (apply conc
+ (map ->string message-list))))
+
+ (ducttape-append-logfile 'dbg message)
+ (if (ducttape-debug-level)
+ (if (<= debug-level-threshold (ducttape-debug-level))
+ (if (string-search (ducttape-debug-regex-filter) message)
+ (begin
+ (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'dbg) message (script-name))))))))
+
+ (define (ierr message-first . message-rest)
+ (let* ((message
+ (apply conc
+ (map ->string (cons message-first message-rest)))))
+ (ducttape-append-logfile 'err message)
+ (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'err) message (script-name))))
+
+ (define (iwarn message-first . message-rest)
+ (let* ((message
+ (apply conc
+ (map ->string (cons message-first message-rest)))))
+ (ducttape-append-logfile 'warn message)
+ (if (not (ducttape-silent-mode))
+ (begin
+ (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'warn) message (script-name))))))
+
+ (define (inote message-first . message-rest)
+ (let* ((message
+ (apply conc
+ (map ->string (cons message-first message-rest)))))
+ (ducttape-append-logfile 'note message)
+ (if (not (or (ducttape-silent-mode) (ducttape-quiet-mode)))
+ (begin
+ (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'note) message (script-name))))))
+
+
+ (define (iputs kind message #!optional (debug-level-threshold 1))
+ (cond
+ ((member kind (string-split "NOTE/Note/note/n/N" "/")) (inote message))
+ ((member kind (string-split "Error/ERROR/error/Err/ERR/err/E/e" "/")) (ierr message))
+ ((member kind
+ (string-split "Warning/WARNING/warning/Warn/WARN/warn/W/w" "/"))
+ (iwarn message))
+ ((member kind (string-split "Debug/DEBUG/debug/Dbg/DBG/dbg/D/d" "/"))
+ (idbg message debug-level-threshold))))
+
+ (define (mkdir-recursive path-so-far hier-list-to-create)
+ (if (null? hier-list-to-create)
+ path-so-far
+ (let* ((next-hier-item (car hier-list-to-create))
+ (rest-hier-items (cdr hier-list-to-create))
+ (path-to-mkdir (string-concatenate (list path-so-far "/" next-hier-item))))
+ (if (runs-ok (lambda () (create-directory path-to-mkdir)))
+ (mkdir-recursive path-to-mkdir rest-hier-items)
+ #f))))
+
+ ; ::mkdir-if-not-exists::
+ ; make a dir recursively if it does not
+ ; already exist.
+ ; on success - returns path
+ ; on fail - returns #f
+ (define (mkdirp-if-not-exists the-dir)
+ (let ( (path-list (string-split the-dir "/")))
+ (mkdir-recursive "/" path-list)))
+
+ ; ::mkdir-if-not-exists::
+ ; make a dir recursively if it does not
+ ; already exist.
+ ; on success - returns path
+ ; on fail - returns #f
+
+
+ (define (mkdirp-if-not-exists the-dir)
+ (let ( (path-list (string-split the-dir "/")))
+ (mkdir-recursive "/" path-list)))
+
+ (define (dir-is-writable? the-dir)
+ (let ((dummy-file (string-concatenate (list the-dir "/.dummyfile"))))
+ (and
+ (file-exists? the-dir)
+ (cond
+ ((runs-ok (lambda ()(with-output-to-file dummy-file (lambda () (print "foo")))))
+ (begin
+ (runs-ok (lambda () (delete-file dummy-file) ))
+ the-dir))
+ (else #f)))))
+
+
+ (define (get-tmpdir )
+ (let* ((tmproot
+ (dir-is-writable?
+ (or
+ (get-environment-variable "TMPDIR")
+ "/tmp")))
+
+ (user
+ (or
+ (get-environment-variable "USER")
+ "USER_Envvar_not_set"))
+ (tmppath
+ (string-concatenate
+ (list tmproot "/env21-general-" user ))))
+
+ (dir-is-writable?
+ (mkdirp-if-not-exists
+ tmppath))))
+
+ (define (mktemp
+ #!optional
+ (prefix "general_lib_tmpfile")
+ (dir #f))
+ (let-values
+ (((fd path)
+ (file-mkstemp
+ (conc
+ (if dir dir (get-tmpdir))
+ "/" prefix ".XXXXXX"))))
+ (close-output-port (open-output-file* fd))
+ path))
+
+
+
+ ;;http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment
+ ;; write send-email using:
+ ;; - isys-foreach-stdin-line
+ ;; - formatting in http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment
+ (define (sendmail to_addr subject body
+ #!key
+ (from_addr "admin")
+ cc_addr
+ bcc_addr
+ more-headers
+ use_html
+ (attach-files-list '())
+ (images-with-content-id-alist '())
+ )
+
+ (define (sendmail-proc sendmail-port)
+ (define (wl line-str)
+ (write-line line-str sendmail-port))
+
+ (define (get-uuid)
+ (string-upcase (uuid->string (uuid-generate))))
+
+ (let ((mailpart-uuid (get-uuid))
+ (mailpart-body-uuid (get-uuid)))
+
+ (define (boundary)
+ (wl (conc "--" mailpart-uuid)))
+
+ (define (body-boundary)
+ (wl (conc "--" mailpart-body-uuid)))
+
+
+ (define (email-mime-header)
+ (wl (conc "From: " from_addr))
+ (wl (conc "To: " to_addr))
+ (if cc_addr
+ (wl (conc "Cc: " cc_addr)))
+ (if bcc_addr
+ (wl (conc "Bcc: " bcc_addr)))
+ (if more-headers
+ (wl more-headers))
+ (wl (conc "Subject: " subject))
+ (wl "MIME-Version: 1.0")
+ (wl (conc "Content-Type: multipart/mixed; boundary=\"" mailpart-uuid "\""))
+ (wl "")
+ (boundary)
+ (wl (conc "Content-Type: multipart/alternative; boundary=\"" mailpart-body-uuid "\""))
+ (wl "")
+ )
+
+
+ (define (email-text-body)
+ (body-boundary)
+ (wl "Content-Type: text/plain; charset=ISO-8859-1")
+ (wl "Content-Disposition: inline")
+ (wl "")
+ (wl body)
+ (body-boundary))
+
+ (define (email-html-body)
+ (body-boundary)
+ (wl "Content-Type: text/plain; charset=ISO-8859-1")
+ (wl "")
+ (wl "You need to enable HTML option for email")
+ (body-boundary)
+ (wl "Content-Type: text/html; charset=ISO-8859-1")
+ (wl "Content-Disposition: inline")
+ (wl "")
+ (wl body)
+ (body-boundary))
+
+ (define (attach-file file #!key (content-id #f))
+ (let* ((filename
+ (filepath:take-file-name file))
+ (ext-with-dot
+ (filepath:take-extension file))
+ (ext (string-take-right
+ ext-with-dot
+ (- (string-length ext-with-dot) 1)))
+ (mimetype (ext->mimetype ext))
+ (uuencode-command (conc "uuencode " file " " filename)))
+ (boundary)
+ (wl (conc "Content-Type: " mimetype "; name=\"" filename "\""))
+ (wl "Content-Transfer-Encoding: uuencode")
+ (if content-id
+ (wl (conc "Content-Id: " content-id)))
+ (wl (conc "Content-Disposition: attachment; filename=\"" filename "\""))
+ (wl "")
+ (do-or-die
+ uuencode-command
+ foreach-stdout:
+ (lambda (line)
+ (wl line)))))
+
+ (define (embed-image file+content-id)
+ (let ((file (car file+content-id))
+ (content-id (cdr file+content-id)))
+ (attach-file file content-id: content-id)))
+
+ ;; send the email
+ (email-mime-header)
+ (if use_html
+ (email-html-body)
+ (email-text-body))
+ (for-each attach-file attach-files-list)
+ (for-each embed-image images-with-content-id-alist)
+ (boundary)
+ (close-output-port sendmail-port)))
+
+ (do-or-die "/usr/sbin/sendmail -t"
+ stdin-proc: sendmail-proc))
+
+ ;; like shell "which" command
+ (define (find-exe exe)
+ (let* ((path-items
+ (string-split
+ (or
+ (get-environment-variable "PATH") "")
+ ":")))
+
+ (let loop ((rest-path-items path-items))
+ (if (null? rest-path-items)
+ #f
+ (let* ((this-dir (car rest-path-items))
+ (next-rest (cdr rest-path-items))
+ (candidate (conc this-dir "/" exe)))
+ (if (file-execute-access? candidate)
+ candidate
+ (loop next-rest)))))))
+
+
+;;;; process command line options
+
+ ;; get command line switches (have no subsequent arg; eg. [-foo])
+ ;; assumes these are switches without arguments
+ ;; will return list of matches
+ ;; removes matches from command-line-arguments parameter
+ (define (skim-cmdline-opts-noarg-by-regex switch-pattern)
+ (let* (
+ (irr (irregex switch-pattern))
+ (matches (filter
+ (lambda (x)
+ (irregex-match irr x))
+ (command-line-arguments)))
+ (non-matches (filter
+ (lambda (x)
+ (not (member x matches)))
+ (command-line-arguments))))
+
+ (command-line-arguments non-matches)
+ matches))
+
+ (define (keyword-skim keyword default args #!optional (eqpred equal?))
+ (let loop ( (kwval default) (args-remaining args) (args-to-return '()) )
+ (cond
+ ((null? args-remaining)
+ (values
+ (if (list? kwval) (reverse kwval) kwval)
+ (reverse args-to-return)))
+ ((and (> (length args-remaining) 1) (eqpred keyword (car args-remaining)))
+ (if (list? default)
+ (if (equal? default kwval)
+ (loop (list (cadr args-remaining)) (cddr args-remaining) args-to-return)
+ (loop (cons (cadr args-remaining) kwval) (cddr args-remaining) args-to-return))
+ (loop (cadr args-remaining) (cddr args-remaining) args-to-return)))
+ (else (loop kwval (cdr args-remaining) (cons (car args-remaining) args-to-return))))))
+
+
+
+ ;; get command line switches (have a subsequent arg; eg. [-foo bar])
+ ;; assumes these are switches without arguments
+ ;; will return list of arguments to matches
+ ;; removes matches from command-line-arguments parameter
+
+ (define (re-match? re str)
+ (irregex-match re str))
+
+ (define (skim-cmdline-opts-withargs-by-regex switch-pattern)
+ (let-values
+ (((result new-cmdline-args)
+ (keyword-skim switch-pattern
+ '()
+ (command-line-arguments)
+ re-match?
+ )))
+ (command-line-arguments new-cmdline-args)
+ result))
+
+
+
+ ;; recognize ducttape-lib command line switches (--quiet, --silent, --color, -d.., -dp.., -logfile)
+ ;; - reset parameters; reset DUCTTAPE_* env vars to match user specified intent
+ ;; - mutate (command-line-arguments) parameter to subtract these recognized and handled switches
+ ;; * beware -- now (argv) and (command-line-arguments) are inconsistent... cannot mutate (argv) alas. Use (command-line-arguments)
+ ;; WARNING: this defines command line arguments that may clash with your program. Only call this if you
+ ;; are sure they can coexist.
+ (define (ducttape-process-command-line)
+
+ ;; --quiet
+ (let ((quiet-opts (skim-cmdline-opts-noarg-by-regex "--?quiet")))
+ (if (not (null? quiet-opts))
+ (begin
+ (setenv "DUCTTAPE_QUIET_MODE" "1")
+ (ducttape-quiet-mode "1"))))
+
+ ;; --silent
+ (let ((silent-opts (skim-cmdline-opts-noarg-by-regex "--?silent")))
+ (if (not (null? silent-opts))
+ (begin
+ (setenv "DUCTTAPE_SILENT_MODE" "1")
+ (ducttape-silent-mode "1"))))
+
+ ;; -color
+ (let ((color-opts (skim-cmdline-opts-noarg-by-regex "--?colou?r(ize)?")))
+ (if (not (null? color-opts))
+ (begin
+ (setenv "DUCTTAPE_COLORIZE" "1")
+ (ducttape-color-mode "1"))))
+
+ ;; -nocolor
+ (let ((nocolor-opts (skim-cmdline-opts-noarg-by-regex "--?nocolou?r(ize)?")))
+ (if (not (null? nocolor-opts))
+ (begin
+ (unsetenv "DUCTTAPE_COLORIZE" )
+ (ducttape-color-mode #f))))
+
+ ;; -logfile
+ (let ((logfile-opts (skim-cmdline-opts-withargs-by-regex "--?log(-?file)?")))
+ (if (not (null? logfile-opts))
+ (begin
+ (ducttape-log-file (car (reverse logfile-opts)))
+ (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file)))))
+
+ ;; -d -dd -d#
+ (let ((debug-opts (skim-cmdline-opts-noarg-by-regex "-d(d*|\\d+)"))
+ (initial-debuglevel (if (ducttape-debug-level) (ducttape-debug-level) 0) ))
+ (if (not (null? debug-opts))
+ (begin
+ (ducttape-debug-level
+ (let loop ((opts debug-opts) (debuglevel initial-debuglevel))
+ (if (null? opts)
+ debuglevel
+ (let*
+ ( (curopt (car opts))
+ (restopts (cdr opts))
+ (ds (string-match "-(d+)" curopt))
+ (dnum (string-match "-d(\\d+)" curopt)))
+ (cond
+ (ds (loop restopts (+ debuglevel (string-length (cadr ds)))))
+ (dnum (loop restopts (string->number (cadr dnum)))))))))
+ (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level))))))
+
+
+ ;; -dp / --debug-pattern
+ (let ((debugpat-opts (skim-cmdline-opts-withargs-by-regex "--?(debug-pattern|dp)")))
+ (if (not (null? debugpat-opts))
+ (begin
+ (ducttape-debug-regex-filter (string-join debugpat-opts "|"))
+ (setenv "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter))))))
+
+
+ ;;; following code commented out; side effects not wanted on startup
+ ;; immediately activate logfile (will be noop if logfile disabled)
+ ;;(ducttape-activate-logfile)
+ ;;(set-ducttape-log-exit-handler)
+
+ ;; TODO: hook exception handler so we can log exception before we sign off.
+
+ ;; handle command line immediately;
+ ;;(process-command-line)
+
+
+ ) ; end module
ADDED ducttape/ducttape-lib.setup
Index: ducttape/ducttape-lib.setup
==================================================================
--- /dev/null
+++ ducttape/ducttape-lib.setup
@@ -0,0 +1,1 @@
+(standard-extension 'ducttape-lib '1.0.0)
ADDED ducttape/mimetypes.scm
Index: ducttape/mimetypes.scm
==================================================================
--- /dev/null
+++ ducttape/mimetypes.scm
@@ -0,0 +1,782 @@
+;; gathered from macosx:
+;; cat /etc/apache2/mime.types | grep -v '^#' | perl -ne 'print "(\"$2\" . \"$1\")\n" if /(\S+)\s+(\S+)/' > mimetypes.scm
+;; + manual manipulation
+
+(define ducttape_ext2mimetype '(("ez" . "application/andrew-inset")
+("aw" . "application/applixware")
+("atom" . "application/atom+xml")
+("atomcat" . "application/atomcat+xml")
+("atomsvc" . "application/atomsvc+xml")
+("ccxml" . "application/ccxml+xml")
+("cdmia" . "application/cdmi-capability")
+("cdmic" . "application/cdmi-container")
+("cdmid" . "application/cdmi-domain")
+("cdmio" . "application/cdmi-object")
+("cdmiq" . "application/cdmi-queue")
+("cu" . "application/cu-seeme")
+("davmount" . "application/davmount+xml")
+("dbk" . "application/docbook+xml")
+("dssc" . "application/dssc+der")
+("xdssc" . "application/dssc+xml")
+("ecma" . "application/ecmascript")
+("emma" . "application/emma+xml")
+("epub" . "application/epub+zip")
+("exi" . "application/exi")
+("pfr" . "application/font-tdpfr")
+("gml" . "application/gml+xml")
+("gpx" . "application/gpx+xml")
+("gxf" . "application/gxf")
+("stk" . "application/hyperstudio")
+("ink" . "application/inkml+xml")
+("ipfix" . "application/ipfix")
+("jar" . "application/java-archive")
+("ser" . "application/java-serialized-object")
+("class" . "application/java-vm")
+("js" . "application/javascript")
+("json" . "application/json")
+("jsonml" . "application/jsonml+json")
+("lostxml" . "application/lost+xml")
+("hqx" . "application/mac-binhex40")
+("cpt" . "application/mac-compactpro")
+("mads" . "application/mads+xml")
+("mrc" . "application/marc")
+("mrcx" . "application/marcxml+xml")
+("ma" . "application/mathematica")
+("mathml" . "application/mathml+xml")
+("mbox" . "application/mbox")
+("mscml" . "application/mediaservercontrol+xml")
+("metalink" . "application/metalink+xml")
+("meta4" . "application/metalink4+xml")
+("mets" . "application/mets+xml")
+("mods" . "application/mods+xml")
+("m21" . "application/mp21")
+("mp4s" . "application/mp4")
+("doc" . "application/msword")
+("mxf" . "application/mxf")
+("bin" . "application/octet-stream")
+("oda" . "application/oda")
+("opf" . "application/oebps-package+xml")
+("ogx" . "application/ogg")
+("omdoc" . "application/omdoc+xml")
+("onetoc" . "application/onenote")
+("oxps" . "application/oxps")
+("xer" . "application/patch-ops-error+xml")
+("pdf" . "application/pdf")
+("pgp" . "application/pgp-encrypted")
+("asc" . "application/pgp-signature")
+("prf" . "application/pics-rules")
+("p10" . "application/pkcs10")
+("p7m" . "application/pkcs7-mime")
+("p7s" . "application/pkcs7-signature")
+("p8" . "application/pkcs8")
+("ac" . "application/pkix-attr-cert")
+("cer" . "application/pkix-cert")
+("crl" . "application/pkix-crl")
+("pkipath" . "application/pkix-pkipath")
+("pki" . "application/pkixcmp")
+("pls" . "application/pls+xml")
+("ai" . "application/postscript")
+("cww" . "application/prs.cww")
+("pskcxml" . "application/pskc+xml")
+("rdf" . "application/rdf+xml")
+("rif" . "application/reginfo+xml")
+("rnc" . "application/relax-ng-compact-syntax")
+("rl" . "application/resource-lists+xml")
+("rld" . "application/resource-lists-diff+xml")
+("rs" . "application/rls-services+xml")
+("gbr" . "application/rpki-ghostbusters")
+("mft" . "application/rpki-manifest")
+("roa" . "application/rpki-roa")
+("rsd" . "application/rsd+xml")
+("rss" . "application/rss+xml")
+("rtf" . "application/rtf")
+("sbml" . "application/sbml+xml")
+("scq" . "application/scvp-cv-request")
+("scs" . "application/scvp-cv-response")
+("spq" . "application/scvp-vp-request")
+("spp" . "application/scvp-vp-response")
+("sdp" . "application/sdp")
+("setpay" . "application/set-payment-initiation")
+("setreg" . "application/set-registration-initiation")
+("shf" . "application/shf+xml")
+("smi" . "application/smil+xml")
+("rq" . "application/sparql-query")
+("srx" . "application/sparql-results+xml")
+("gram" . "application/srgs")
+("grxml" . "application/srgs+xml")
+("sru" . "application/sru+xml")
+("ssdl" . "application/ssdl+xml")
+("ssml" . "application/ssml+xml")
+("tei" . "application/tei+xml")
+("tfi" . "application/thraud+xml")
+("tsd" . "application/timestamped-data")
+("plb" . "application/vnd.3gpp.pic-bw-large")
+("psb" . "application/vnd.3gpp.pic-bw-small")
+("pvb" . "application/vnd.3gpp.pic-bw-var")
+("tcap" . "application/vnd.3gpp2.tcap")
+("pwn" . "application/vnd.3m.post-it-notes")
+("aso" . "application/vnd.accpac.simply.aso")
+("imp" . "application/vnd.accpac.simply.imp")
+("acu" . "application/vnd.acucobol")
+("atc" . "application/vnd.acucorp")
+("air" . "application/vnd.adobe.air-application-installer-package+zip")
+("fcdt" . "application/vnd.adobe.formscentral.fcdt")
+("fxp" . "application/vnd.adobe.fxp")
+("xdp" . "application/vnd.adobe.xdp+xml")
+("xfdf" . "application/vnd.adobe.xfdf")
+("ahead" . "application/vnd.ahead.space")
+("azf" . "application/vnd.airzip.filesecure.azf")
+("azs" . "application/vnd.airzip.filesecure.azs")
+("azw" . "application/vnd.amazon.ebook")
+("acc" . "application/vnd.americandynamics.acc")
+("ami" . "application/vnd.amiga.ami")
+("apk" . "application/vnd.android.package-archive")
+("cii" . "application/vnd.anser-web-certificate-issue-initiation")
+("fti" . "application/vnd.anser-web-funds-transfer-initiation")
+("atx" . "application/vnd.antix.game-component")
+("mpkg" . "application/vnd.apple.installer+xml")
+("m3u8" . "application/vnd.apple.mpegurl")
+("swi" . "application/vnd.aristanetworks.swi")
+("iota" . "application/vnd.astraea-software.iota")
+("aep" . "application/vnd.audiograph")
+("mpm" . "application/vnd.blueice.multipass")
+("bmi" . "application/vnd.bmi")
+("rep" . "application/vnd.businessobjects")
+("cdxml" . "application/vnd.chemdraw+xml")
+("mmd" . "application/vnd.chipnuts.karaoke-mmd")
+("cdy" . "application/vnd.cinderella")
+("cla" . "application/vnd.claymore")
+("rp9" . "application/vnd.cloanto.rp9")
+("c4g" . "application/vnd.clonk.c4group")
+("c11amc" . "application/vnd.cluetrust.cartomobile-config")
+("c11amz" . "application/vnd.cluetrust.cartomobile-config-pkg")
+("csp" . "application/vnd.commonspace")
+("cdbcmsg" . "application/vnd.contact.cmsg")
+("cmc" . "application/vnd.cosmocaller")
+("clkx" . "application/vnd.crick.clicker")
+("clkk" . "application/vnd.crick.clicker.keyboard")
+("clkp" . "application/vnd.crick.clicker.palette")
+("clkt" . "application/vnd.crick.clicker.template")
+("clkw" . "application/vnd.crick.clicker.wordbank")
+("wbs" . "application/vnd.criticaltools.wbs+xml")
+("pml" . "application/vnd.ctc-posml")
+("ppd" . "application/vnd.cups-ppd")
+("car" . "application/vnd.curl.car")
+("pcurl" . "application/vnd.curl.pcurl")
+("dart" . "application/vnd.dart")
+("rdz" . "application/vnd.data-vision.rdz")
+("uvf" . "application/vnd.dece.data")
+("uvt" . "application/vnd.dece.ttml+xml")
+("uvx" . "application/vnd.dece.unspecified")
+("uvz" . "application/vnd.dece.zip")
+("fe_launch" . "application/vnd.denovo.fcselayout-link")
+("dna" . "application/vnd.dna")
+("mlp" . "application/vnd.dolby.mlp")
+("dpg" . "application/vnd.dpgraph")
+("dfac" . "application/vnd.dreamfactory")
+("kpxx" . "application/vnd.ds-keypoint")
+("ait" . "application/vnd.dvb.ait")
+("svc" . "application/vnd.dvb.service")
+("geo" . "application/vnd.dynageo")
+("mag" . "application/vnd.ecowin.chart")
+("nml" . "application/vnd.enliven")
+("esf" . "application/vnd.epson.esf")
+("msf" . "application/vnd.epson.msf")
+("qam" . "application/vnd.epson.quickanime")
+("slt" . "application/vnd.epson.salt")
+("ssf" . "application/vnd.epson.ssf")
+("es3" . "application/vnd.eszigno3+xml")
+("ez2" . "application/vnd.ezpix-album")
+("ez3" . "application/vnd.ezpix-package")
+("fdf" . "application/vnd.fdf")
+("mseed" . "application/vnd.fdsn.mseed")
+("seed" . "application/vnd.fdsn.seed")
+("gph" . "application/vnd.flographit")
+("ftc" . "application/vnd.fluxtime.clip")
+("fm" . "application/vnd.framemaker")
+("fnc" . "application/vnd.frogans.fnc")
+("ltf" . "application/vnd.frogans.ltf")
+("fsc" . "application/vnd.fsc.weblaunch")
+("oas" . "application/vnd.fujitsu.oasys")
+("oa2" . "application/vnd.fujitsu.oasys2")
+("oa3" . "application/vnd.fujitsu.oasys3")
+("fg5" . "application/vnd.fujitsu.oasysgp")
+("bh2" . "application/vnd.fujitsu.oasysprs")
+("ddd" . "application/vnd.fujixerox.ddd")
+("xdw" . "application/vnd.fujixerox.docuworks")
+("xbd" . "application/vnd.fujixerox.docuworks.binder")
+("fzs" . "application/vnd.fuzzysheet")
+("txd" . "application/vnd.genomatix.tuxedo")
+("ggb" . "application/vnd.geogebra.file")
+("ggt" . "application/vnd.geogebra.tool")
+("gex" . "application/vnd.geometry-explorer")
+("gxt" . "application/vnd.geonext")
+("g2w" . "application/vnd.geoplan")
+("g3w" . "application/vnd.geospace")
+("gmx" . "application/vnd.gmx")
+("kml" . "application/vnd.google-earth.kml+xml")
+("kmz" . "application/vnd.google-earth.kmz")
+("gqf" . "application/vnd.grafeq")
+("gac" . "application/vnd.groove-account")
+("ghf" . "application/vnd.groove-help")
+("gim" . "application/vnd.groove-identity-message")
+("grv" . "application/vnd.groove-injector")
+("gtm" . "application/vnd.groove-tool-message")
+("tpl" . "application/vnd.groove-tool-template")
+("vcg" . "application/vnd.groove-vcard")
+("hal" . "application/vnd.hal+xml")
+("zmm" . "application/vnd.handheld-entertainment+xml")
+("hbci" . "application/vnd.hbci")
+("les" . "application/vnd.hhe.lesson-player")
+("hpgl" . "application/vnd.hp-hpgl")
+("hpid" . "application/vnd.hp-hpid")
+("hps" . "application/vnd.hp-hps")
+("jlt" . "application/vnd.hp-jlyt")
+("pcl" . "application/vnd.hp-pcl")
+("pclxl" . "application/vnd.hp-pclxl")
+("sfd-hdstx" . "application/vnd.hydrostatix.sof-data")
+("mpy" . "application/vnd.ibm.minipay")
+("afp" . "application/vnd.ibm.modcap")
+("irm" . "application/vnd.ibm.rights-management")
+("sc" . "application/vnd.ibm.secure-container")
+("icc" . "application/vnd.iccprofile")
+("igl" . "application/vnd.igloader")
+("ivp" . "application/vnd.immervision-ivp")
+("ivu" . "application/vnd.immervision-ivu")
+("igm" . "application/vnd.insors.igm")
+("xpw" . "application/vnd.intercon.formnet")
+("i2g" . "application/vnd.intergeo")
+("qbo" . "application/vnd.intu.qbo")
+("qfx" . "application/vnd.intu.qfx")
+("rcprofile" . "application/vnd.ipunplugged.rcprofile")
+("irp" . "application/vnd.irepository.package+xml")
+("xpr" . "application/vnd.is-xpr")
+("fcs" . "application/vnd.isac.fcs")
+("jam" . "application/vnd.jam")
+("rms" . "application/vnd.jcp.javame.midlet-rms")
+("jisp" . "application/vnd.jisp")
+("joda" . "application/vnd.joost.joda-archive")
+("ktz" . "application/vnd.kahootz")
+("karbon" . "application/vnd.kde.karbon")
+("chrt" . "application/vnd.kde.kchart")
+("kfo" . "application/vnd.kde.kformula")
+("flw" . "application/vnd.kde.kivio")
+("kon" . "application/vnd.kde.kontour")
+("kpr" . "application/vnd.kde.kpresenter")
+("ksp" . "application/vnd.kde.kspread")
+("kwd" . "application/vnd.kde.kword")
+("htke" . "application/vnd.kenameaapp")
+("kia" . "application/vnd.kidspiration")
+("kne" . "application/vnd.kinar")
+("skp" . "application/vnd.koan")
+("sse" . "application/vnd.kodak-descriptor")
+("lasxml" . "application/vnd.las.las+xml")
+("lbd" . "application/vnd.llamagraphics.life-balance.desktop")
+("lbe" . "application/vnd.llamagraphics.life-balance.exchange+xml")
+("123" . "application/vnd.lotus-1-2-3")
+("apr" . "application/vnd.lotus-approach")
+("pre" . "application/vnd.lotus-freelance")
+("nsf" . "application/vnd.lotus-notes")
+("org" . "application/vnd.lotus-organizer")
+("scm" . "application/vnd.lotus-screencam")
+("lwp" . "application/vnd.lotus-wordpro")
+("portpkg" . "application/vnd.macports.portpkg")
+("mcd" . "application/vnd.mcd")
+("mc1" . "application/vnd.medcalcdata")
+("cdkey" . "application/vnd.mediastation.cdkey")
+("mwf" . "application/vnd.mfer")
+("mfm" . "application/vnd.mfmp")
+("flo" . "application/vnd.micrografx.flo")
+("igx" . "application/vnd.micrografx.igx")
+("mif" . "application/vnd.mif")
+("daf" . "application/vnd.mobius.daf")
+("dis" . "application/vnd.mobius.dis")
+("mbk" . "application/vnd.mobius.mbk")
+("mqy" . "application/vnd.mobius.mqy")
+("msl" . "application/vnd.mobius.msl")
+("plc" . "application/vnd.mobius.plc")
+("txf" . "application/vnd.mobius.txf")
+("mpn" . "application/vnd.mophun.application")
+("mpc" . "application/vnd.mophun.certificate")
+("xul" . "application/vnd.mozilla.xul+xml")
+("cil" . "application/vnd.ms-artgalry")
+("cab" . "application/vnd.ms-cab-compressed")
+("xls" . "application/vnd.ms-excel")
+("xlam" . "application/vnd.ms-excel.addin.macroenabled.12")
+("xlsb" . "application/vnd.ms-excel.sheet.binary.macroenabled.12")
+("xlsm" . "application/vnd.ms-excel.sheet.macroenabled.12")
+("xltm" . "application/vnd.ms-excel.template.macroenabled.12")
+("eot" . "application/vnd.ms-fontobject")
+("chm" . "application/vnd.ms-htmlhelp")
+("ims" . "application/vnd.ms-ims")
+("lrm" . "application/vnd.ms-lrm")
+("thmx" . "application/vnd.ms-officetheme")
+("cat" . "application/vnd.ms-pki.seccat")
+("stl" . "application/vnd.ms-pki.stl")
+("ppt" . "application/vnd.ms-powerpoint")
+("ppam" . "application/vnd.ms-powerpoint.addin.macroenabled.12")
+("pptm" . "application/vnd.ms-powerpoint.presentation.macroenabled.12")
+("sldm" . "application/vnd.ms-powerpoint.slide.macroenabled.12")
+("ppsm" . "application/vnd.ms-powerpoint.slideshow.macroenabled.12")
+("potm" . "application/vnd.ms-powerpoint.template.macroenabled.12")
+("mpp" . "application/vnd.ms-project")
+("docm" . "application/vnd.ms-word.document.macroenabled.12")
+("dotm" . "application/vnd.ms-word.template.macroenabled.12")
+("wps" . "application/vnd.ms-works")
+("wpl" . "application/vnd.ms-wpl")
+("xps" . "application/vnd.ms-xpsdocument")
+("mseq" . "application/vnd.mseq")
+("mus" . "application/vnd.musician")
+("msty" . "application/vnd.muvee.style")
+("taglet" . "application/vnd.mynfc")
+("nlu" . "application/vnd.neurolanguage.nlu")
+("ntf" . "application/vnd.nitf")
+("nnd" . "application/vnd.noblenet-directory")
+("nns" . "application/vnd.noblenet-sealer")
+("nnw" . "application/vnd.noblenet-web")
+("ngdat" . "application/vnd.nokia.n-gage.data")
+("n-gage" . "application/vnd.nokia.n-gage.symbian.install")
+("rpst" . "application/vnd.nokia.radio-preset")
+("rpss" . "application/vnd.nokia.radio-presets")
+("edm" . "application/vnd.novadigm.edm")
+("edx" . "application/vnd.novadigm.edx")
+("ext" . "application/vnd.novadigm.ext")
+("odc" . "application/vnd.oasis.opendocument.chart")
+("otc" . "application/vnd.oasis.opendocument.chart-template")
+("odb" . "application/vnd.oasis.opendocument.database")
+("odf" . "application/vnd.oasis.opendocument.formula")
+("odft" . "application/vnd.oasis.opendocument.formula-template")
+("odg" . "application/vnd.oasis.opendocument.graphics")
+("otg" . "application/vnd.oasis.opendocument.graphics-template")
+("odi" . "application/vnd.oasis.opendocument.image")
+("oti" . "application/vnd.oasis.opendocument.image-template")
+("odp" . "application/vnd.oasis.opendocument.presentation")
+("otp" . "application/vnd.oasis.opendocument.presentation-template")
+("ods" . "application/vnd.oasis.opendocument.spreadsheet")
+("ots" . "application/vnd.oasis.opendocument.spreadsheet-template")
+("odt" . "application/vnd.oasis.opendocument.text")
+("odm" . "application/vnd.oasis.opendocument.text-master")
+("ott" . "application/vnd.oasis.opendocument.text-template")
+("oth" . "application/vnd.oasis.opendocument.text-web")
+("xo" . "application/vnd.olpc-sugar")
+("dd2" . "application/vnd.oma.dd2+xml")
+("oxt" . "application/vnd.openofficeorg.extension")
+("pptx" . "application/vnd.openxmlformats-officedocument.presentationml.presentation")
+("sldx" . "application/vnd.openxmlformats-officedocument.presentationml.slide")
+("ppsx" . "application/vnd.openxmlformats-officedocument.presentationml.slideshow")
+("potx" . "application/vnd.openxmlformats-officedocument.presentationml.template")
+("xlsx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet")
+("xltx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.template")
+("docx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.document")
+("dotx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.template")
+("mgp" . "application/vnd.osgeo.mapguide.package")
+("dp" . "application/vnd.osgi.dp")
+("esa" . "application/vnd.osgi.subsystem")
+("pdb" . "application/vnd.palm")
+("paw" . "application/vnd.pawaafile")
+("str" . "application/vnd.pg.format")
+("ei6" . "application/vnd.pg.osasli")
+("efif" . "application/vnd.picsel")
+("wg" . "application/vnd.pmi.widget")
+("plf" . "application/vnd.pocketlearn")
+("pbd" . "application/vnd.powerbuilder6")
+("box" . "application/vnd.previewsystems.box")
+("mgz" . "application/vnd.proteus.magazine")
+("qps" . "application/vnd.publishare-delta-tree")
+("ptid" . "application/vnd.pvi.ptid1")
+("qxd" . "application/vnd.quark.quarkxpress")
+("bed" . "application/vnd.realvnc.bed")
+("mxl" . "application/vnd.recordare.musicxml")
+("musicxml" . "application/vnd.recordare.musicxml+xml")
+("cryptonote" . "application/vnd.rig.cryptonote")
+("cod" . "application/vnd.rim.cod")
+("rm" . "application/vnd.rn-realmedia")
+("rmvb" . "application/vnd.rn-realmedia-vbr")
+("link66" . "application/vnd.route66.link66+xml")
+("st" . "application/vnd.sailingtracker.track")
+("see" . "application/vnd.seemail")
+("sema" . "application/vnd.sema")
+("semd" . "application/vnd.semd")
+("semf" . "application/vnd.semf")
+("ifm" . "application/vnd.shana.informed.formdata")
+("itp" . "application/vnd.shana.informed.formtemplate")
+("iif" . "application/vnd.shana.informed.interchange")
+("ipk" . "application/vnd.shana.informed.package")
+("twd" . "application/vnd.simtech-mindmapper")
+("mmf" . "application/vnd.smaf")
+("teacher" . "application/vnd.smart.teacher")
+("sdkm" . "application/vnd.solent.sdkm+xml")
+("dxp" . "application/vnd.spotfire.dxp")
+("sfs" . "application/vnd.spotfire.sfs")
+("sdc" . "application/vnd.stardivision.calc")
+("sda" . "application/vnd.stardivision.draw")
+("sdd" . "application/vnd.stardivision.impress")
+("smf" . "application/vnd.stardivision.math")
+("sdw" . "application/vnd.stardivision.writer")
+("sgl" . "application/vnd.stardivision.writer-global")
+("smzip" . "application/vnd.stepmania.package")
+("sm" . "application/vnd.stepmania.stepchart")
+("sxc" . "application/vnd.sun.xml.calc")
+("stc" . "application/vnd.sun.xml.calc.template")
+("sxd" . "application/vnd.sun.xml.draw")
+("std" . "application/vnd.sun.xml.draw.template")
+("sxi" . "application/vnd.sun.xml.impress")
+("sti" . "application/vnd.sun.xml.impress.template")
+("sxm" . "application/vnd.sun.xml.math")
+("sxw" . "application/vnd.sun.xml.writer")
+("sxg" . "application/vnd.sun.xml.writer.global")
+("stw" . "application/vnd.sun.xml.writer.template")
+("sus" . "application/vnd.sus-calendar")
+("svd" . "application/vnd.svd")
+("sis" . "application/vnd.symbian.install")
+("xsm" . "application/vnd.syncml+xml")
+("bdm" . "application/vnd.syncml.dm+wbxml")
+("xdm" . "application/vnd.syncml.dm+xml")
+("tao" . "application/vnd.tao.intent-module-archive")
+("pcap" . "application/vnd.tcpdump.pcap")
+("tmo" . "application/vnd.tmobile-livetv")
+("tpt" . "application/vnd.trid.tpt")
+("mxs" . "application/vnd.triscape.mxs")
+("tra" . "application/vnd.trueapp")
+("ufd" . "application/vnd.ufdl")
+("utz" . "application/vnd.uiq.theme")
+("umj" . "application/vnd.umajin")
+("unityweb" . "application/vnd.unity")
+("uoml" . "application/vnd.uoml+xml")
+("vcx" . "application/vnd.vcx")
+("vsd" . "application/vnd.visio")
+("vis" . "application/vnd.visionary")
+("vsf" . "application/vnd.vsf")
+("wbxml" . "application/vnd.wap.wbxml")
+("wmlc" . "application/vnd.wap.wmlc")
+("wmlsc" . "application/vnd.wap.wmlscriptc")
+("wtb" . "application/vnd.webturbo")
+("nbp" . "application/vnd.wolfram.player")
+("wpd" . "application/vnd.wordperfect")
+("wqd" . "application/vnd.wqd")
+("stf" . "application/vnd.wt.stf")
+("xar" . "application/vnd.xara")
+("xfdl" . "application/vnd.xfdl")
+("hvd" . "application/vnd.yamaha.hv-dic")
+("hvs" . "application/vnd.yamaha.hv-script")
+("hvp" . "application/vnd.yamaha.hv-voice")
+("osf" . "application/vnd.yamaha.openscoreformat")
+("osfpvg" . "application/vnd.yamaha.openscoreformat.osfpvg+xml")
+("saf" . "application/vnd.yamaha.smaf-audio")
+("spf" . "application/vnd.yamaha.smaf-phrase")
+("cmp" . "application/vnd.yellowriver-custom-menu")
+("zir" . "application/vnd.zul")
+("zaz" . "application/vnd.zzazz.deck+xml")
+("vxml" . "application/voicexml+xml")
+("wgt" . "application/widget")
+("hlp" . "application/winhlp")
+("wsdl" . "application/wsdl+xml")
+("wspolicy" . "application/wspolicy+xml")
+("7z" . "application/x-7z-compressed")
+("abw" . "application/x-abiword")
+("ace" . "application/x-ace-compressed")
+("dmg" . "application/x-apple-diskimage")
+("aab" . "application/x-authorware-bin")
+("aam" . "application/x-authorware-map")
+("aas" . "application/x-authorware-seg")
+("bcpio" . "application/x-bcpio")
+("torrent" . "application/x-bittorrent")
+("blb" . "application/x-blorb")
+("bz" . "application/x-bzip")
+("bz2" . "application/x-bzip2")
+("cbr" . "application/x-cbr")
+("vcd" . "application/x-cdlink")
+("cfs" . "application/x-cfs-compressed")
+("chat" . "application/x-chat")
+("pgn" . "application/x-chess-pgn")
+("nsc" . "application/x-conference")
+("cpio" . "application/x-cpio")
+("csh" . "application/x-csh")
+("deb" . "application/x-debian-package")
+("dgc" . "application/x-dgc-compressed")
+("dir" . "application/x-director")
+("wad" . "application/x-doom")
+("ncx" . "application/x-dtbncx+xml")
+("dtb" . "application/x-dtbook+xml")
+("res" . "application/x-dtbresource+xml")
+("dvi" . "application/x-dvi")
+("evy" . "application/x-envoy")
+("eva" . "application/x-eva")
+("bdf" . "application/x-font-bdf")
+("gsf" . "application/x-font-ghostscript")
+("psf" . "application/x-font-linux-psf")
+("otf" . "application/x-font-otf")
+("pcf" . "application/x-font-pcf")
+("snf" . "application/x-font-snf")
+("ttf" . "application/x-font-ttf")
+("pfa" . "application/x-font-type1")
+("woff" . "application/x-font-woff")
+("arc" . "application/x-freearc")
+("spl" . "application/x-futuresplash")
+("gca" . "application/x-gca-compressed")
+("ulx" . "application/x-glulx")
+("gnumeric" . "application/x-gnumeric")
+("gramps" . "application/x-gramps-xml")
+("gtar" . "application/x-gtar")
+("hdf" . "application/x-hdf")
+("install" . "application/x-install-instructions")
+("iso" . "application/x-iso9660-image")
+("jnlp" . "application/x-java-jnlp-file")
+("latex" . "application/x-latex")
+("lzh" . "application/x-lzh-compressed")
+("mie" . "application/x-mie")
+("prc" . "application/x-mobipocket-ebook")
+("m3u8" . "application/x-mpegurl")
+("application" . "application/x-ms-application")
+("lnk" . "application/x-ms-shortcut")
+("wmd" . "application/x-ms-wmd")
+("wmz" . "application/x-ms-wmz")
+("xbap" . "application/x-ms-xbap")
+("mdb" . "application/x-msaccess")
+("obd" . "application/x-msbinder")
+("crd" . "application/x-mscardfile")
+("clp" . "application/x-msclip")
+("exe" . "application/x-msdownload")
+("mvb" . "application/x-msmediaview")
+("wmf" . "application/x-msmetafile")
+("mny" . "application/x-msmoney")
+("pub" . "application/x-mspublisher")
+("scd" . "application/x-msschedule")
+("trm" . "application/x-msterminal")
+("wri" . "application/x-mswrite")
+("nc" . "application/x-netcdf")
+("nzb" . "application/x-nzb")
+("p12" . "application/x-pkcs12")
+("p7b" . "application/x-pkcs7-certificates")
+("p7r" . "application/x-pkcs7-certreqresp")
+("rar" . "application/x-rar-compressed")
+("ris" . "application/x-research-info-systems")
+("sh" . "application/x-sh")
+("shar" . "application/x-shar")
+("swf" . "application/x-shockwave-flash")
+("xap" . "application/x-silverlight-app")
+("sql" . "application/x-sql")
+("sit" . "application/x-stuffit")
+("sitx" . "application/x-stuffitx")
+("srt" . "application/x-subrip")
+("sv4cpio" . "application/x-sv4cpio")
+("sv4crc" . "application/x-sv4crc")
+("t3" . "application/x-t3vm-image")
+("gam" . "application/x-tads")
+("tar" . "application/x-tar")
+("tcl" . "application/x-tcl")
+("tex" . "application/x-tex")
+("tfm" . "application/x-tex-tfm")
+("texinfo" . "application/x-texinfo")
+("obj" . "application/x-tgif")
+("ustar" . "application/x-ustar")
+("src" . "application/x-wais-source")
+("der" . "application/x-x509-ca-cert")
+("fig" . "application/x-xfig")
+("xlf" . "application/x-xliff+xml")
+("xpi" . "application/x-xpinstall")
+("xz" . "application/x-xz")
+("z1" . "application/x-zmachine")
+("xaml" . "application/xaml+xml")
+("xdf" . "application/xcap-diff+xml")
+("xenc" . "application/xenc+xml")
+("xhtml" . "application/xhtml+xml")
+("xml" . "application/xml")
+("dtd" . "application/xml-dtd")
+("xop" . "application/xop+xml")
+("xpl" . "application/xproc+xml")
+("xslt" . "application/xslt+xml")
+("xspf" . "application/xspf+xml")
+("mxml" . "application/xv+xml")
+("yang" . "application/yang")
+("yin" . "application/yin+xml")
+("zip" . "application/zip")
+("adp" . "audio/adpcm")
+("au" . "audio/basic")
+("mid" . "audio/midi")
+("mp4a" . "audio/mp4")
+("m4a" . "audio/mp4a-latm")
+("mpga" . "audio/mpeg")
+("oga" . "audio/ogg")
+("s3m" . "audio/s3m")
+("sil" . "audio/silk")
+("uva" . "audio/vnd.dece.audio")
+("eol" . "audio/vnd.digital-winds")
+("dra" . "audio/vnd.dra")
+("dts" . "audio/vnd.dts")
+("dtshd" . "audio/vnd.dts.hd")
+("lvp" . "audio/vnd.lucent.voice")
+("pya" . "audio/vnd.ms-playready.media.pya")
+("ecelp4800" . "audio/vnd.nuera.ecelp4800")
+("ecelp7470" . "audio/vnd.nuera.ecelp7470")
+("ecelp9600" . "audio/vnd.nuera.ecelp9600")
+("rip" . "audio/vnd.rip")
+("weba" . "audio/webm")
+("aac" . "audio/x-aac")
+("aif" . "audio/x-aiff")
+("caf" . "audio/x-caf")
+("flac" . "audio/x-flac")
+("mka" . "audio/x-matroska")
+("m3u" . "audio/x-mpegurl")
+("wax" . "audio/x-ms-wax")
+("wma" . "audio/x-ms-wma")
+("ram" . "audio/x-pn-realaudio")
+("rmp" . "audio/x-pn-realaudio-plugin")
+("wav" . "audio/x-wav")
+("xm" . "audio/xm")
+("cdx" . "chemical/x-cdx")
+("cif" . "chemical/x-cif")
+("cmdf" . "chemical/x-cmdf")
+("cml" . "chemical/x-cml")
+("csml" . "chemical/x-csml")
+("xyz" . "chemical/x-xyz")
+("bmp" . "image/bmp")
+("cgm" . "image/cgm")
+("g3" . "image/g3fax")
+("gif" . "image/gif")
+("ief" . "image/ief")
+("jp2" . "image/jp2")
+("jpeg" . "image/jpeg")
+("ktx" . "image/ktx")
+("pict" . "image/pict")
+("png" . "image/png")
+("btif" . "image/prs.btif")
+("sgi" . "image/sgi")
+("svg" . "image/svg+xml")
+("tiff" . "image/tiff")
+("psd" . "image/vnd.adobe.photoshop")
+("uvi" . "image/vnd.dece.graphic")
+("sub" . "image/vnd.dvb.subtitle")
+("djvu" . "image/vnd.djvu")
+("dwg" . "image/vnd.dwg")
+("dxf" . "image/vnd.dxf")
+("fbs" . "image/vnd.fastbidsheet")
+("fpx" . "image/vnd.fpx")
+("fst" . "image/vnd.fst")
+("mmr" . "image/vnd.fujixerox.edmics-mmr")
+("rlc" . "image/vnd.fujixerox.edmics-rlc")
+("mdi" . "image/vnd.ms-modi")
+("wdp" . "image/vnd.ms-photo")
+("npx" . "image/vnd.net-fpx")
+("wbmp" . "image/vnd.wap.wbmp")
+("xif" . "image/vnd.xiff")
+("webp" . "image/webp")
+("3ds" . "image/x-3ds")
+("ras" . "image/x-cmu-raster")
+("cmx" . "image/x-cmx")
+("fh" . "image/x-freehand")
+("ico" . "image/x-icon")
+("pntg" . "image/x-macpaint")
+("sid" . "image/x-mrsid-image")
+("pcx" . "image/x-pcx")
+("pic" . "image/x-pict")
+("pnm" . "image/x-portable-anymap")
+("pbm" . "image/x-portable-bitmap")
+("pgm" . "image/x-portable-graymap")
+("ppm" . "image/x-portable-pixmap")
+("qtif" . "image/x-quicktime")
+("rgb" . "image/x-rgb")
+("tga" . "image/x-tga")
+("xbm" . "image/x-xbitmap")
+("xpm" . "image/x-xpixmap")
+("xwd" . "image/x-xwindowdump")
+("eml" . "message/rfc822")
+("igs" . "model/iges")
+("msh" . "model/mesh")
+("dae" . "model/vnd.collada+xml")
+("dwf" . "model/vnd.dwf")
+("gdl" . "model/vnd.gdl")
+("gtw" . "model/vnd.gtw")
+("mts" . "model/vnd.mts")
+("vtu" . "model/vnd.vtu")
+("wrl" . "model/vrml")
+("x3db" . "model/x3d+binary")
+("x3dv" . "model/x3d+vrml")
+("x3d" . "model/x3d+xml")
+("manifest" . "text/cache-manifest")
+("appcache" . "text/cache-manifest")
+("ics" . "text/calendar")
+("css" . "text/css")
+("csv" . "text/csv")
+("html" . "text/html")
+("n3" . "text/n3")
+("txt" . "text/plain")
+("dsc" . "text/prs.lines.tag")
+("rtx" . "text/richtext")
+("sgml" . "text/sgml")
+("tsv" . "text/tab-separated-values")
+("t" . "text/troff")
+("ttl" . "text/turtle")
+("uri" . "text/uri-list")
+("vcard" . "text/vcard")
+("curl" . "text/vnd.curl")
+("dcurl" . "text/vnd.curl.dcurl")
+("scurl" . "text/vnd.curl.scurl")
+("mcurl" . "text/vnd.curl.mcurl")
+("sub" . "text/vnd.dvb.subtitle")
+("fly" . "text/vnd.fly")
+("flx" . "text/vnd.fmi.flexstor")
+("gv" . "text/vnd.graphviz")
+("3dml" . "text/vnd.in3d.3dml")
+("spot" . "text/vnd.in3d.spot")
+("jad" . "text/vnd.sun.j2me.app-descriptor")
+("wml" . "text/vnd.wap.wml")
+("wmls" . "text/vnd.wap.wmlscript")
+("s" . "text/x-asm")
+("c" . "text/x-c")
+("f" . "text/x-fortran")
+("java" . "text/x-java-source")
+("opml" . "text/x-opml")
+("p" . "text/x-pascal")
+("nfo" . "text/x-nfo")
+("etx" . "text/x-setext")
+("sfv" . "text/x-sfv")
+("uu" . "text/x-uuencode")
+("vcs" . "text/x-vcalendar")
+("vcf" . "text/x-vcard")
+("3gp" . "video/3gpp")
+("3g2" . "video/3gpp2")
+("h261" . "video/h261")
+("h263" . "video/h263")
+("h264" . "video/h264")
+("jpgv" . "video/jpeg")
+("jpm" . "video/jpm")
+("mj2" . "video/mj2")
+("ts" . "video/mp2t")
+("mp4" . "video/mp4")
+("mpeg" . "video/mpeg")
+("ogv" . "video/ogg")
+("qt" . "video/quicktime")
+("uvh" . "video/vnd.dece.hd")
+("uvm" . "video/vnd.dece.mobile")
+("uvp" . "video/vnd.dece.pd")
+("uvs" . "video/vnd.dece.sd")
+("uvv" . "video/vnd.dece.video")
+("dvb" . "video/vnd.dvb.file")
+("fvt" . "video/vnd.fvt")
+("mxu" . "video/vnd.mpegurl")
+("pyv" . "video/vnd.ms-playready.media.pyv")
+("uvu" . "video/vnd.uvvu.mp4")
+("viv" . "video/vnd.vivo")
+("dv" . "video/x-dv")
+("webm" . "video/webm")
+("f4v" . "video/x-f4v")
+("fli" . "video/x-fli")
+("flv" . "video/x-flv")
+("m4v" . "video/x-m4v")
+("mkv" . "video/x-matroska")
+("mng" . "video/x-mng")
+("asf" . "video/x-ms-asf")
+("vob" . "video/x-ms-vob")
+("wm" . "video/x-ms-wm")
+("wmv" . "video/x-ms-wmv")
+("wmx" . "video/x-ms-wmx")
+("wvx" . "video/x-ms-wvx")
+("avi" . "video/x-msvideo")
+("movie" . "video/x-sgi-movie")
+("smv" . "video/x-smv")
+("ice" . "x-conference/x-cooltalk")))
+
+(define (ext->mimetype ext)
+ (let ((x (assoc ext ducttape_ext2mimetype)))
+ (if x (cdr x) "text/plain")))
ADDED ducttape/sample_ducttape.scm
Index: ducttape/sample_ducttape.scm
==================================================================
--- /dev/null
+++ ducttape/sample_ducttape.scm
@@ -0,0 +1,4 @@
+(include "ducttape-lib.scm")
+(import ducttape-lib)
+(inote "hello world")
+(exit 0)
ADDED ducttape/test_ducttape.scm
Index: ducttape/test_ducttape.scm
==================================================================
--- /dev/null
+++ ducttape/test_ducttape.scm
@@ -0,0 +1,355 @@
+#!/usr/bin/env csi -script
+(use test)
+(include "ducttape-lib.scm")
+(import ducttape-lib)
+(import ansi-escape-sequences)
+(use trace)
+(set! systype (do-or-die (if (file-exists? "/bin/uname") "/bin/uname" "/usr/bin/uname")))
+;(trace skim-cmdline-opts-withargs-by-regex)
+;(trace keyword-skim)
+;(trace re-match?)
+(define (reset-ducttape)
+ (unsetenv "DUCTTAPE_DEBUG_LEVEL")
+ (ducttape-debug-level #f)
+
+ (unsetenv "DUCTTAPE_DEBUG_PATTERN")
+ (ducttape-debug-regex-filter ".")
+
+ (unsetenv "DUCTTAPE_LOG_FILE")
+ (ducttape-log-file #f)
+
+ (unsetenv "DUCTTAPE_SILENT_MODE")
+ (ducttape-silent-mode #f)
+
+ (unsetenv "DUCTTAPE_QUIET_MODE")
+ (ducttape-quiet-mode #f)
+
+ (unsetenv "DUCTTAPE_COLOR_MODE")
+ (ducttape-color-mode #f)
+)
+
+(define (reset-ducttape-with-cmdline-list cmdline-list)
+ (reset-ducttape)
+
+ (command-line-arguments cmdline-list)
+ (ducttape-process-command-line)
+)
+
+
+(define (direct-iputs-test)
+ (ducttape-color-mode #f)
+ (ierr "I'm an error")
+ (iwarn "I'm a warning")
+ (inote "I'm a note")
+
+ (ducttape-debug-level 1)
+ (idbg "I'm a debug statement")
+ (ducttape-debug-level #f)
+ (idbg "I'm a hidden debug statement")
+
+ (ducttape-silent-mode #t)
+ (iwarn "I shouldn't show up")
+ (inote "I shouldn't show up either")
+ (ierr "I should show up 1")
+ (ducttape-silent-mode #f)
+
+ (ducttape-quiet-mode #t)
+ (iwarn "I should show up 2")
+ (inote "I shouldn't show up though")
+ (ierr "I should show up 3")
+ (ducttape-quiet-mode #f)
+
+ (ducttape-debug-level 1)
+ (idbg "foo")
+ (iputs "dbg" "debug message")
+ (iputs "e" "error message")
+ (iputs "w" "warning message")
+ (iputs "n" "note message")
+
+ (ducttape-color-mode #t)
+ (ierr "I'm an error COLOR")
+ (iwarn "I'm a warning COLOR")
+ (inote "I'm a note COLOR")
+ (idbg "I'm a debug COLOR")
+
+
+ )
+
+(define (test-argprocessor-funcs)
+
+ (test-group
+ "Command line processor utility functions"
+
+ (set! testargs1 '( "-d" "-d" "-d3" "-ddd" "-foo" "fooarg" "-foo" "fooarg2" "-lastArgIsDecoy" "-foo"))
+ (command-line-arguments testargs1)
+ (set! expected_result '("-d" "-d" "-d3" "-ddd"))
+ (set! expected_sideeffect '("-foo" "fooarg" "-foo" "fooarg2" "-lastArgIsDecoy" "-foo"))
+
+ (test "skim-cmdline-opts-noarg-by-regex result" expected_result (skim-cmdline-opts-noarg-by-regex "-d(d+|\\d+)?"))
+ (test "skim-cmdline-opts-noarg-by-regex sideeffect" expected_sideeffect (command-line-arguments))
+
+
+
+ (command-line-arguments testargs1)
+ (set! expected_result '("fooarg" "fooarg2" ))
+ (set! expected_sideeffect '( "-d" "-d" "-d3" "-ddd" "-lastArgIsDecoy" "-foo"))
+ (test
+ "skim-cmdline-opts-withargs-by-regex result"
+ expected_result
+ (skim-cmdline-opts-withargs-by-regex "--?foo"))
+
+ (test
+ "skim-cmdline-opts-withargs-by-regex sideeffect"
+ expected_sideeffect
+ (command-line-arguments))
+
+ ))
+
+(define (test-misc)
+ (test-group
+ "misc"
+ (let ((tmpfile (mktemp)))
+ (test-assert "mktemp: temp file created" (file-exists? tmpfile))
+ (if (file-exists? tmpfile)
+ (delete-file tmpfile))
+
+ )))
+
+
+
+(define (test-systemstuff)
+ (test-group
+ "system commands"
+
+ (let-values (((ec o e) (isys (find-exe "true"))))
+ (test-assert "isys: /bin/true should have exit code 0" (equal? ec 0)))
+ (let-values (((ec o e) (isys (find-exe "false"))))
+ (test-assert "isys: /bin/false should have exit code 1" (equal? ec 1)))
+
+ (let-values (((ec o e) (isys "/bin/echo" "foo" "bar" "baz")))
+ (test-assert "isys: /bin/echo should have exit code 0" (equal? ec 0))
+ (test-assert "isys: /bin/echo should have stdout 'foo bar baz'" (equal? o "foo bar baz")))
+
+ (let-values (((ec o e) (isys "/bin/ls /zzzzz")))
+ (let ((expected-code
+ (if (equal? systype "Darwin") 1 2))
+ (expected-err
+ (if (equal? systype "Darwin")
+ "ls: /zzzzz: No such file or directory"
+ "/bin/ls: cannot access /zzzzz: No such file or directory"))
+
+ )
+ (test "isys: /bin/ls /zzzzz should have exit code 2" expected-code ec)
+ (test "isys: /bin/ls /zzzzz should have empty stdout" "" o)
+ (test
+ "isys: /bin/ls /zzzzz should have stderr"
+ expected-err
+ e))
+ )
+
+ (let-values (((ec o e) (isys "/bin/ls /etc/passwd")))
+ (test "isys: /bin/ls /etc/passwd should have exit code 0" 0 ec)
+ (test "isys: /bin/ls /etc/passwd should have stdout" "/etc/passwd" o)
+ (test
+ "isys: /bin/ls /etc/passwd should have empty stderr"
+ ""
+ e))
+
+ (let ((res (do-or-die "/bin/ls /etc/passwd")))
+ (test
+ "do-or-die: ls /etc/passwd should work"
+ "/etc/passwd" res ))
+
+ (let ((res (do-or-die "/bin/ls /zzzzz" nodie: #t)))
+ (test
+ "do-or-die: ls /zzzzz should die"
+ #f res ))
+
+ ; test reading from process stdout line at a time
+ (let* (
+ (lineno (counter-maker))
+
+ ; print each line with an index
+ (eachline-fn (lambda (line)
+ (print "GOTLINE " (lineno) "> " line)))
+
+ (res
+ (do-or-die "/bin/ls -l /etc | head; true"
+ foreach-stdout: eachline-fn )))
+
+ (test-assert "ls -l /etc should not be empty"
+ (not (equal? res ""))))
+ ;; test writing to process stdout line at a time
+
+ (let* ((tmpfile (mktemp))
+ (cmd (conc "cat > " tmpfile)))
+ (let-values (((c o e)
+ (isys cmd stdin-proc:
+ (lambda (myport)
+ (write-line "hello" myport)
+ (write-line "hello2" myport)
+ (close-output-port myport)))))
+ (test "isys-sp: cat should exit 0" 0 c)
+ (let ((mycmd (conc "cat " tmpfile)))
+ (test "isys-sp: cat output should match input" "hello\nhello2" (do-or-die mycmd)))
+
+ (delete-file tmpfile)
+ ))
+
+ (let* ((tmpfile (mktemp))
+ (cmd (conc "cat > " tmpfile)))
+ (do-or-die cmd stdin-proc:
+ (lambda (myport)
+ (write-line "hello" myport)
+ (write-line "hello2" myport)
+ (close-output-port myport))
+ cmd)
+ (test "dod-sp: cat output should match input" "hello\nhello2" (do-or-die (conc "cat " tmpfile)))
+ (delete-file tmpfile))
+
+
+
+
+
+ (let*
+ ((thefile (conc "/tmp/" (get-environment-variable "USER") "9-lines"))
+ (counter (counter-maker))
+ (stdin-writer
+ (lambda ()
+ (if (< (counter) 10)
+ (number->string (counter 0))
+ #f)))
+ (cmd (conc "cat > " thefile)))
+ (let-values
+ (((c o e)
+ (isys cmd foreach-stdin-thunk: stdin-writer)))
+
+ (test-assert "isys-fsl: cat should return 0" (equal? c 0))
+
+ (test-assert
+ "isys-fsl: cat should have written a file"
+ (file-exists? thefile))
+
+ (if
+ (file-exists? thefile)
+ (begin
+ (test "isys-fsl: cat file should have right contents" "1\n2\n3\n4\n5\n6\n7\n8\n9" (do-or-die (conc "cat " thefile)))
+ (delete-file thefile)))))
+
+ ) ; end test-group
+ ) ; end define
+
+
+(define (test-argprocessor )
+ (test-group
+ "Command line processor parameter settings"
+
+ (reset-ducttape-with-cmdline-list '())
+ (test-assert "(nil) debug mode should be off" (not (ducttape-debug-level)))
+ (test-assert "(nil): debug pattern should be '.'" (equal? "." (ducttape-debug-regex-filter)))
+ (test-assert "(nil): colors should be off" (not (ducttape-color-mode)))
+ (test-assert "(nil): silent mode should be off" (not (ducttape-silent-mode)))
+ (test-assert "(nil): quiet mode should be off" (not (ducttape-quiet-mode)))
+ (test-assert "(nil): logfile should be off" (not (ducttape-log-file)))
+
+ (reset-ducttape-with-cmdline-list '("-d"))
+ (test-assert "-d: debug mode should be on at level 1" (eq? 1 (ducttape-debug-level)))
+
+ (reset-ducttape-with-cmdline-list '("-dd"))
+ (test "-dd: debug level should be 2" 2 (ducttape-debug-level))
+
+ (reset-ducttape-with-cmdline-list '("-ddd"))
+ (test "-ddd: debug level should be 3" 3 (ducttape-debug-level))
+
+ (reset-ducttape-with-cmdline-list '("-d2"))
+ (test "-d2: debug level should be 2" 2 (ducttape-debug-level))
+
+ (reset-ducttape-with-cmdline-list '("-d3"))
+ (test "-d3: debug level should be 3" 3 (ducttape-debug-level))
+
+ (reset-ducttape-with-cmdline-list '("-dp" "foo"))
+ (test "-dp foo: debug pattern should be 'foo'" "foo" (ducttape-debug-regex-filter))
+
+ (reset-ducttape-with-cmdline-list '("--debug-pattern" "foo"))
+ (test "--debug-pattern foo: debug pattern should be 'foo'" "foo" (ducttape-debug-regex-filter))
+
+ (reset-ducttape-with-cmdline-list '("-dp" "foo" "-dp" "bar"))
+ (test "-dp foo -dp bar: debug pattern should be 'foo|bar'" "foo|bar" (ducttape-debug-regex-filter))
+
+ (reset-ducttape-with-cmdline-list '("--quiet"))
+ (test-assert "-quiet: quiet mode should be active" (ducttape-quiet-mode))
+
+ (reset-ducttape-with-cmdline-list '("--silent"))
+ (test-assert "-silent: silent mode should be active" (ducttape-silent-mode))
+
+ (reset-ducttape-with-cmdline-list '("--color"))
+ (test-assert "-color: color mode should be active" (ducttape-color-mode))
+
+ (reset-ducttape-with-cmdline-list '("--log" "foo"))
+ (test "--log foo: logfile should be 'foo'" "foo" (ducttape-log-file))
+
+))
+
+(define (test-wwdate)
+ (test-group
+ "wwdate conversion tests"
+ (let ((test-table
+ '(("16ww01.5" . "2016-01-01")
+ ("16ww18.5" . "2016-04-29")
+ ("1999ww33.5" . "1999-08-13")
+ ("16ww18.4" . "2016-04-28")
+ ("16ww18.3" . "2016-04-27")
+ ("13ww01.0" . "2012-12-30")
+ ("13ww52.6" . "2013-12-28")
+ ("16ww53.3" . "2016-12-28"))))
+ (for-each
+ (lambda (test-pair)
+ (let ((wwdate (car test-pair))
+ (isodate (cdr test-pair)))
+ (test
+ (conc "(isodate->wwdate "isodate ") => "wwdate)
+ wwdate
+ (isodate->wwdate isodate))
+
+ (test
+ (conc "(wwdate->isodate "wwdate ") => "isodate)
+ isodate
+ (wwdate->isodate wwdate))))
+ test-table))))
+
+(define (main)
+ ;; (test )
+
+; (test-group "silly settext group"
+; (test #f "\x1b[1mfoo\x1b[0m" (set-text (list 'bold) "foo"))
+; (test "settext bold" "\x1b[1mfoo\x1b[0m" (set-text (list 'bold) "foo"))
+; )
+
+ ; visually inspect this
+ (direct-iputs-test)
+
+ ; following use unit test test-egg
+ (reset-ducttape)
+ (test-argprocessor-funcs)
+ (reset-ducttape)
+ (test-argprocessor)
+ (test-systemstuff)
+ (test-misc)
+ (test-wwdate)
+ ) ; end main()
+
+(main)
+(sendmail "brandon.j.barclay@intel.com" "6hello subject" "test body" )
+
+;(let* ((image-file "/nfs/site/home/bjbarcla/megatest-logo.png")
+; (cid "mtlogo")
+; (image-alist (list (cons image-file cid)))
+; (body (conc "Hello world
![\"test]()
bye!")))
+
+; (sendmail "brandon.j.barclay@intel.com" "7hello subject" body use_html: #t images-with-content-id-alist: image-alist)
+; (print "sent image mail"))
+;(sendmail "bjbarcla" "2hello subject html" "test bodyhello
italics" use_html: #t)
+;(sendmail "bb" "4hello attach subject html" "hmm
" use_html: #t attach-files-list: '( "/Users/bb/Downloads/wdmycloud-manual-4779-705103.pdf" ) )
+
+;(launch-repl)
+(test-exit)
ADDED ducttape/test_example.scm
Index: ducttape/test_example.scm
==================================================================
--- /dev/null
+++ ducttape/test_example.scm
@@ -0,0 +1,3 @@
+(use ducttape-lib)
+
+(inote "Hello world")
ADDED ducttape/useargs-example.scm
Index: ducttape/useargs-example.scm
==================================================================
--- /dev/null
+++ ducttape/useargs-example.scm
@@ -0,0 +1,19 @@
+(use ducttape-lib)
+
+(let (
+ (customers (skim-cmdline-opts-withargs-by-regex "--cust(omer)?"))
+ (magicmode (skim-cmdline-opts-noarg-by-regex "--magic"))
+ )
+ (print "your customers are " customers)
+ (if (null? magicmode)
+ (print "no unicorns for you")
+ (print "magic!")
+ )
+ )
+
+(idbg "hello")
+(idbg "hello2" 2)
+(idbg "hello2" 3)
+(inote "note")
+(iwarn "warn")
+(ierr "err")
ADDED ducttape/workweekdate.scm
Index: ducttape/workweekdate.scm
==================================================================
--- /dev/null
+++ ducttape/workweekdate.scm
@@ -0,0 +1,193 @@
+(use srfi-19)
+(use test)
+;;(use format)
+(use regex)
+;(declare (unit wwdate))
+;; utility procedures to convert among
+;; different ways to express date (wwdate, seconds since epoch, isodate)
+;;
+;; samples:
+;; isodate -> "2016-01-01"
+;; wwdate -> "16ww01.5"
+;; seconds -> 1451631600
+
+;; procedures provided:
+;; ====================
+;; seconds->isodate
+;; seconds->wwdate
+;;
+;; isodate->seconds
+;; isodate->wwdate
+;;
+;; wwdate->seconds
+;; wwdate->isodate
+
+;; srfi-19 used extensively; this doc is better tha the eggref:
+;; http://srfi.schemers.org/srfi-19/srfi-19.html
+
+;; Author: brandon.j.barclay@intel.com 16ww18.6
+
+(define (date->seconds date)
+ (inexact->exact
+ (string->number
+ (date->string date "~s"))))
+
+(define (seconds->isodate seconds)
+ (let* ((date (seconds->date seconds))
+ (result (date->string date "~Y-~m-~d")))
+ result))
+
+(define (isodate->seconds isodate)
+ "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K"
+ (let* ((numlist (map string->number (string-split isodate "-")))
+ (raw-year (car numlist))
+ (year (if (< raw-year 100) (+ raw-year 2000) raw-year))
+ (month (list-ref numlist 1))
+ (day (list-ref numlist 2))
+ (date (make-date 0 0 0 0 day month year))
+ (seconds (date->seconds date)))
+
+ seconds))
+
+;; adapted from perl Intel::WorkWeek perl module
+;; workweek year consists of numbered weeks starting from week 1
+;; days of week are numbered starting from 0 on sunday
+;; weeks begin on sunday- day number 0 and end saturday- day 6
+;; week 1 is defined as the week containing jan 1 of the year
+;; workweek year does not match calendar year in workweek 1
+;; since workweek 1 contains jan1 and workweek begins sunday,
+;; days prior to jan1 in workweek 1 belong to the next workweek year
+(define (seconds->wwdate-values seconds)
+ (define (date-difference->seconds d1 d2)
+ (- (date->seconds d1) (date->seconds d2)))
+
+ (let* ((thisdate (seconds->date seconds))
+ (thisdow (string->number (date->string thisdate "~w")))
+
+ (year (date-year thisdate))
+ ;; intel workweek 1 begins on sunday of week containing jan1
+ (jan1 (make-date 0 0 0 0 1 1 year))
+ (jan1dow (date-week-day jan1))
+ (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow))))
+
+ (ww01_delta_seconds (date-difference->seconds thisdate ww01))
+ (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) ))))
+
+ ;; we could be in ww1 of next year
+ (this-saturday (seconds->date
+ (+ seconds
+ (* 60 60 24 (- 6 thisdow)))))
+ (this-week-ends-next-year?
+ (> (date-year this-saturday) year))
+ (intelyear
+ (if this-week-ends-next-year?
+ (add1 year)
+ year))
+ (intelweek
+ (if this-week-ends-next-year?
+ 1
+ wwnum_initial)))
+ (values intelyear intelweek thisdow)))
+
+(define (string-leftpad in width pad-char)
+ (let* ((unpadded-str (->string in))
+ (padlen_temp (- width (string-length unpadded-str)))
+ (padlen (if (< padlen_temp 0) 0 padlen_temp))
+ (padding (make-string padlen pad-char)))
+ (conc padding unpadded-str)))
+
+(define (string-rightpad in width pad-char)
+ (let* ((unpadded-str (->string in))
+ (padlen_temp (- width (string-length unpadded-str)))
+ (padlen (if (< padlen_temp 0) 0 padlen_temp))
+ (padding (make-string padlen pad-char)))
+ (conc unpadded-str padding)))
+
+(define (zeropad num width)
+ (string-leftpad num width #\0))
+
+(define (seconds->wwdate seconds)
+
+ (let-values (((intelyear intelweek day-of-week-num)
+ (seconds->wwdate-values seconds)))
+ (let ((intelyear-str
+ (zeropad
+ (->string
+ (if (> intelyear 1999)
+ (- intelyear 2000) intelyear))
+ 2))
+ (intelweek-str
+ (zeropad (->string intelweek) 2))
+ (dow-str (->string day-of-week-num)))
+ (conc intelyear-str "ww" intelweek-str "." dow-str))))
+
+(define (isodate->wwdate isodate)
+ (seconds->wwdate
+ (isodate->seconds isodate)))
+
+(define (wwdate->seconds wwdate)
+ (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" wwdate)))
+ (if
+ (not match)
+ #f
+ (let* (
+ (intelyear-raw (string->number (list-ref match 1)))
+ (intelyear (if (< intelyear-raw 100)
+ (+ intelyear-raw 2000)
+ intelyear-raw))
+ (intelww (string->number (list-ref match 2)))
+ (dayofweek (string->number (list-ref match 3)))
+
+ (day-of-seconds (* 60 60 24 ))
+ (week-of-seconds (* day-of-seconds 7))
+
+
+ ;; get seconds at ww1.0
+ (new-years-date (make-date 0 0 0 0 1 1 intelyear))
+ (new-years-seconds
+ (date->seconds new-years-date))
+ (new-years-dayofweek (date-week-day new-years-date))
+ (ww1.0_seconds (- new-years-seconds
+ (* day-of-seconds
+ new-years-dayofweek)))
+ (workweek-adjustment (* week-of-seconds (sub1 intelww)))
+ (weekday-adjustment (* dayofweek day-of-seconds))
+
+ (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment)))
+ result))))
+
+(define (wwdate->isodate wwdate)
+ (seconds->isodate (wwdate->seconds wwdate)))
+
+(define (current-wwdate)
+ (seconds->wwdate (current-seconds)))
+
+(define (current-isodate)
+ (seconds->isodate (current-seconds)))
+
+(define (wwdate-tests)
+ (test-group
+ "date conversion tests"
+ (let ((test-table
+ '(("16ww01.5" . "2016-01-01")
+ ("16ww18.5" . "2016-04-29")
+ ("1999ww33.5" . "1999-08-13")
+ ("16ww18.4" . "2016-04-28")
+ ("16ww18.3" . "2016-04-27")
+ ("13ww01.0" . "2012-12-30")
+ ("13ww52.6" . "2013-12-28")
+ ("16ww53.3" . "2016-12-28"))))
+ (for-each
+ (lambda (test-pair)
+ (let ((wwdate (car test-pair))
+ (isodate (cdr test-pair)))
+ (test
+ (conc "(isodate->wwdate "isodate ") => "wwdate)
+ wwdate
+ (isodate->wwdate isodate))
+
+ (test
+ (conc "(wwdate->isodate "wwdate ") => "isodate)
+ isodate
+ (wwdate->isodate wwdate))))
+ test-table))))
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -8,11 +8,11 @@
;; 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) ;; sqlite3
+(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) ;; sqlite3
;; (import (prefix sqlite3 sqlite3:))
(use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)
;; Configurations for server
@@ -47,11 +47,11 @@
;; Call this to start the actual server
;;
(define *db:process-queue-mutex* (make-mutex))
-(define (http-transport:run hostn run-id server-id)
+(define (http-transport:run hostn)
(debug:print 2 *default-log-port* "Attempting to start the server ...")
(let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
(hostname (get-host-name))
(ipaddrstr (let ((ipstr (if (string=? "-" hostn)
;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
@@ -104,18 +104,17 @@
((equal? (uri-path (request-uri (current-request)))
'(/ "hey"))
(send-response body: "hey there!\n"
headers: '((content-type text/plain))))
(else (continue))))))))
- (http-transport:try-start-server run-id ipaddrstr start-port server-id)))
+ (http-transport:try-start-server ipaddrstr start-port)))
;; This is recursively run by http-transport:run until sucessful
;;
-(define (http-transport:try-start-server run-id ipaddrstr portnum server-id)
- (let ((config-hostname (configf:lookup *configdat* "server" "hostname"))
- (tdbdat (tasks:open-db)))
- (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname)
+(define (http-transport:try-start-server ipaddrstr portnum)
+ (let ((config-hostname (configf:lookup *configdat* "server" "hostname")))
+ (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum " config-hostname=" config-hostname)
(handle-exceptions
exn
(begin
(print-error-message exn)
(if (< portnum 64000)
@@ -126,34 +125,26 @@
(portlogger:open-run-close portlogger:set-failed portnum)
(debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
(thread-sleep! 0.1)
;; get_next_port goes here
- (http-transport:try-start-server run-id
- ipaddrstr
- (portlogger:open-run-close portlogger:find-port)
- server-id))
+ (http-transport:try-start-server ipaddrstr
+ (portlogger:open-run-close portlogger:find-port)))
(begin
- (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server")
(print "ERROR: Tried and tried but could not start the server"))))
;; any error in following steps will result in a retry
(set! *server-info* (list ipaddrstr portnum))
- (tasks:server-set-interface-port
- (db:delay-if-busy tdbdat)
- server-id
- ipaddrstr portnum)
(debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
;; This starts the spiffy server
;; NEED WAY TO SET IP TO #f TO BIND ALL
;; (start-server bind-address: ipaddrstr port: portnum)
(if config-hostname ;; this is a hint to bind directly
(start-server port: portnum bind-address: (if (equal? config-hostname "-")
ipaddrstr
config-hostname))
(start-server port: portnum))
- ;; (portlogger:open-run-close portlogger:set-port portnum "released")
- (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server")
+ (portlogger:open-run-close portlogger:set-port portnum "released")
(debug:print 1 *default-log-port* "INFO: server has been stopped"))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
@@ -292,11 +283,11 @@
'timeout
'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))))
;; careful closing of connections stored in *runremote*
;;
-(define (http-transport:close-connections run-id)
+(define (http-transport:close-connections)
(let* ((server-dat (if *runremote*
(remote-conndat *runremote*)
#f))) ;; (hash-table-ref/default *runremote* run-id #f)))
(if (vector? server-dat)
(let ((api-dat (http-transport:server-dat-get-api-uri server-dat)))
@@ -341,17 +332,16 @@
server-dat))
;; run http-transport:keep-running in a parallel thread to monitor that the db is being
;; used and to shutdown after sometime if it is not.
;;
-(define (http-transport:keep-running server-id run-id)
+(define (http-transport:keep-running)
;; if none running or if > 20 seconds since
;; server last used then start shutdown
;; This thread waits for the server to come alive
- (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server for run-id=" run-id)
- (let* ((tdbdat (tasks:open-db))
- (server-start-time (current-seconds))
+ (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server")
+ (let* ((server-start-time (current-seconds))
(server-info (let loop ((start-time (current-seconds))
(changed #t)
(last-sdat "not this"))
(let ((sdat #f))
(thread-sleep! 0.01)
@@ -368,48 +358,33 @@
(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 " server-id " for run " run-id)
- (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature")
+ (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")
(exit))
(loop start-time
(equal? sdat last-sdat)
sdat)))))))
(iface (car server-info))
(port (cadr server-info))
(last-access 0)
(server-timeout (server:get-timeout))
- (server-going #f))
+ (server-going #f)
+ (server-log-file (args:get-arg "-log"))) ;; always set when we are a server
(let loop ((count 0)
(server-state 'available)
(bad-sync-count 0)
(start-time (current-milliseconds)))
- ;;(BB> "http-transport: top of loop; count="count" server-state="server-state" bad-sync-count="bad-sync-count" server-going="server-going)
;; Use this opportunity to sync the tmp db to megatest.db
(if (not server-going) ;; *dbstruct-db*
- ;; Removed code is pasted below (keeping it around until we are clear it is not needed).
- ;; no *dbstruct-db* yet, set running after our first pass through and start the db
- (if (eq? server-state 'available)
- (let ((new-server-id (tasks:server-am-i-the-server? (db:delay-if-busy tdbdat) run-id))) ;; try to ensure no double registering of servers
- (if (equal? new-server-id server-id)
- (begin
- (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
- ;;(BB> "http-transport: ->dbprep")
- (thread-sleep! 0.5) ;; give some margin for queries to complete before switching from file based access to server based access
- (set! *dbstruct-db* (db:setup)) ;; run-id))
- (set! server-going #t)
- (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
- ;;(BB> "http-transport: ->running")
- (server:write-dotserver *toppath* iface port (current-process-id) 'http)
- (thread-start! *watchdog*)
- (server:complete-attempt *toppath*))
- (begin ;; gotta exit nicely
- ;;(BB> "http-transport: ->collision")
- (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "collision")
- (http-transport:server-shutdown server-id port))))))
+ (begin
+ (debug:print 0 *default-log-port* "SERVER: dbprep")
+ (set! *dbstruct-db* (db:setup)) ;; run-id))
+ (set! server-going #t)
+ (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version)) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine.
+ (thread-start! *watchdog*)))
;; when things go wrong we don't want to be doing the various queries too often
;; so we strive to run this stuff only every four seconds or so.
(let* ((sync-time (- (current-milliseconds) start-time))
(rem-time (quotient (- 4000 sync-time) 1000)))
@@ -423,183 +398,111 @@
;; Check that iface and port have not changed (can happen if server port collides)
(mutex-lock! *heartbeat-mutex*)
(set! sdat *server-info*)
(mutex-unlock! *heartbeat-mutex*)
- (if (or (not (equal? sdat (list iface port)))
- (not server-id))
- (begin
- (debug:print-info 0 *default-log-port* "interface changed, refreshing iface and port info")
- (set! iface (car sdat))
- (set! port (cadr sdat))
- (server:write-dotserver *toppath* iface port (current-process-id) 'http)))
+ (if (not (equal? sdat (list iface port)))
+ (let ((new-iface (car sdat))
+ (new-port (cadr sdat)))
+ (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info")
+ (set! iface new-iface)
+ (set! port new-port)
+ (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds))
+ (flush-output *default-log-port*)))
;; Transfer *db-last-access* to last-access to use in checking that we are still alive
(mutex-lock! *heartbeat-mutex*)
(set! last-access *db-last-access*)
(mutex-unlock! *heartbeat-mutex*)
+
+ (if (common:low-noise-print 120 (conc "server running on " iface ":" port))
+ (begin
+ (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds))
+ (flush-output *default-log-port*)))
- ;; (debug:print 11 *default-log-port* "last-access=" last-access ", server-timeout=" server-timeout)
- ;;
- ;; no_traffic, no running tests, if server 0, no running servers
- ;;
- ;; (let ((wait-on-running (configf:lookup *configdat* "server" b"wait-on-running"))) ;; wait on running tasks (if not true then exit on time out)
- ;;
(let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600))
(adjusted-timeout (if (> hrs-since-start 1)
(- server-timeout (inexact->exact (round (* hrs-since-start 60)))) ;; subtract 60 seconds per hour
server-timeout)))
(if (common:low-noise-print 120 "server timeout")
(debug:print-info 0 *default-log-port* "Adjusted server timeout: " adjusted-timeout))
(cond
- ((not (server:confirm-dotserver *toppath* iface port (current-process-id) 'http))
- (debug:print-info 0 *default-log-port* "Server .server file does not exist or contents do not match. Initiate server shutdown.")
- (http-transport:server-shutdown server-id port))
((and *server-run*
- (> (+ last-access server-timeout)
- (current-seconds)))
+ (> (+ last-access server-timeout)
+ (current-seconds))
+ (< (- (current-seconds) server-start-time) 3600)) ;; do not update log or touch log if we've been running for more than one hour.
(if (common:low-noise-print 120 "server continuing")
- (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)))
- ;;
- ;; Consider implementing some smarts here to re-insert the record or kill self is
- ;; the db indicates so
- ;;
- ;; (if (tasks:server-am-i-the-server? tdb run-id)
- ;; (tasks:server-set-state! tdb server-id "running"))
- ;;
+ (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
+ (let ((curr-time (current-seconds)))
+ (change-file-times server-log-file curr-time curr-time)))
(loop 0 server-state bad-sync-count (current-milliseconds)))
(else
- (debug:print-info 0 *default-log-port* "Server timeed out. seconds since last db access: " (- (current-seconds) last-access))
- (http-transport:server-shutdown server-id port)))))))
-
-;; code cut out from above
-;;
-;; (condition-case
-;; ;; (if (and (member (mutex-state *db-sync-mutex*) '(abandoned not-abandoned))
-;; ;; (> (- (current-seconds) *db-last-sync*) 5)) ;; if not currently being synced nor recently synced
-;; (db:sync-touched *dbstruct-db* *run-id* force-sync: #t) ;; usually done in the watchdog, not here.
-;; ((sync-failed)(cond
-;; ((> bad-sync-count 10) ;; time to give up
-;; (http-transport:server-shutdown server-id port))
-;; (else ;; (> bad-sync-count 0) ;; we've had a fail or two, delay and loop
-;; (thread-sleep! 5)
-;; (loop count server-state (+ bad-sync-count 1)))))
-;; ((exn)
-;; (debug:print-error 0 *default-log-port* "error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server")
-;; (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running crashed")
-;; (exit)))
-;; (set! sync-time (- (current-milliseconds) start-time))
-;; (set! rem-time (quotient (- 4000 sync-time) 1000))
-;; (debug:print 4 *default-log-port* "SYNC: time= " sync-time ", rem-time=" rem-time)
-;;
-;; (if (and (<= rem-time 4)
-;; (> rem-time 0))
-;; (thread-sleep! rem-time)
-;; (thread-sleep! 4))) ;; fallback for if the math is changed ...
-
-(define (http-transport:server-shutdown server-id port)
+ (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
+ (http-transport:server-shutdown port)))))))
+
+(define (http-transport:server-shutdown port)
(let ((tdbdat (tasks:open-db)))
;;(BB> "http-transport:server-shutdown called")
(debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
;;
;; start_shutdown
;;
- (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down")
+ ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down")
(set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up
(portlogger:open-run-close portlogger:set-port port "released")
- (thread-sleep! 5)
-;; (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*)
-;; (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*)
-;; (debug:print-info 0 *default-log-port* "Average cached write time "
-;; (if (eq? *number-of-writes* 0)
-;; "n/a (no writes)"
-;; (/ *writes-total-delay*
-;; *number-of-writes*))
-;; " ms")
-;; (debug:print-info 0 *default-log-port* "Number non-cached queries " *number-non-write-queries*)
-;; (debug:print-info 0 *default-log-port* "Average non-cached time "
-;; (if (eq? *number-non-write-queries* 0)
-;; "n/a (no queries)"
-;; (/ *total-non-write-delay*
-;; *number-non-write-queries*))
- ;; " ms")
-
+ (thread-sleep! 1)
+
+ ;; (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*)
+ ;; (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*)
+ ;; (debug:print-info 0 *default-log-port* "Average cached write time "
+ ;; (if (eq? *number-of-writes* 0)
+ ;; "n/a (no writes)"
+ ;; (/ *writes-total-delay*
+ ;; *number-of-writes*))
+ ;; " ms")
+ ;; (debug:print-info 0 *default-log-port* "Number non-cached queries " *number-non-write-queries*)
+ ;; (debug:print-info 0 *default-log-port* "Average non-cached time "
+ ;; (if (eq? *number-non-write-queries* 0)
+ ;; "n/a (no queries)"
+ ;; (/ *total-non-write-delay*
+ ;; *number-non-write-queries*))
+ ;; " ms")
+
(db:print-current-query-stats)
(debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
- (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete")
- ;; if the .server file contained :myport then we can remove it
- (server:remove-dotserver-file *toppath* port)
- ;;(BB> "http-transport:server-shutdown -> exit")
(exit)))
;; all routes though here end in exit ...
;;
;; start_server?
;;
-(define (http-transport:launch run-id)
- (server:attempting-start *toppath*)
- (let* ((tdbdat (tasks:open-db)))
- (set! *run-id* run-id)
- (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*)))))
- (if (and (server:read-dotserver *toppath*)
- (server:check-if-running run-id))
- (begin
- (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running")
- (exit 0))
- (begin ;; ok, no server detected, clean out any lingering records
- (tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id "notresponding")))
- (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
- (remtries 4))
- (if (not server-id)
- (if (> remtries 0)
- (begin
- (thread-sleep! 2)
- (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
- (- remtries 1)))
- (begin
- ;; since we didn't get the server lock we are going to clean up and bail out
- (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
- (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
- (server:complete-attempt *toppath*)
- ))
- (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")
- "-")
- run-id
- server-id)) "Server run"))
- (th3 (make-thread (lambda ()
- (debug:print-info 0 *default-log-port* "Server monitor thread started")
- (http-transport:keep-running server-id run-id))
- "Keep running")))
- (thread-start! th2)
- (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor.
- (thread-start! th3)
- (set! *didsomething* #t)
- (thread-join! th2)
- (exit))))))
-
-;; (define (http:ping run-id host-port)
-;; (let* ((server-dat (http-transport:client-connect (car host-port)(cadr host-port)))
-;; (login-res (rmt:login-no-auto-client-setup server-dat run-id)))
-;; (if (and (list? login-res)
-;; (car login-res))
-;; (begin
-;; (print "LOGIN_OK")
-;; (exit 0))
-;; (begin
-;; (print "LOGIN_FAILED")
-;; (exit 1)))))
+(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*)))))
+ (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")
+ "-")
+ )) "Server run"))
+ (th3 (make-thread (lambda ()
+ (debug:print-info 0 *default-log-port* "Server monitor thread started")
+ (http-transport:keep-running)
+ "Keep running"))))
+ (thread-start! th2)
+ (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor.
+ (thread-start! th3)
+ (set! *didsomething* #t)
+ (thread-join! th2)
+ (exit)))
(define (http-transport:server-signal-handler signum)
(signal-mask! signum)
(handle-exceptions
exn
Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ megatest-version.scm
@@ -1,7 +1,7 @@
;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
(declare (unit megatest-version))
-(define megatest-version 1.6305)
+(define megatest-version 1.6306)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -43,10 +43,11 @@
(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
+(declare (uses diff-report))
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
@@ -175,10 +176,18 @@
-archive cmd : archive runs specified by selectors to one of disks specified
in the [archive-disks] section.
cmd: keep-html, restore, save, save-remove
-generate-html : create a simple html tree for browsing your runs
+Diff report
+ -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname
+ and either -diff-email or -diff-html)
+ -src-target
+ -src-runname
+ -diff-email : comma separated list of email addresses to send diff report
+ -diff-html : path to html file to generate
+
Spreadsheet generation
-extract-ods fname.ods : extract an open document spreadsheet from the database
-pathmod path : insert path, i.e. path/runame/itempath/logfile.html
will clear the field if no rundir/testname/itempath/logfile
if it contains forward slashes the path will be converted
@@ -267,10 +276,15 @@
"-fields"
"-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
"-sort"
"-target-db"
"-source-db"
+
+ "-src-target"
+ "-src-runname"
+ "-diff-email"
+ "-diff-html"
)
(list "-h" "-help" "--help"
"-manual"
"-version"
"-force"
@@ -327,11 +341,13 @@
"-sync-to-configdb"
"-logging"
"-v" ;; verbose 2, more than normal (normal is 1)
"-q" ;; quiet 0, errors/warnings only
- )
+
+ "-diff-rep"
+ )
args:arg-hash
0))
;; Add args that use remargs here
;;
@@ -353,15 +369,32 @@
;;
(define *watchdog* (make-thread common:watchdog "Watchdog thread"))
(if (not (args:get-arg "-server"))
(thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
-;;(BB> "thread-start! watchdog")
-(if (args:get-arg "-log")
- (let ((oup (open-output-file (args:get-arg "-log"))))
- (debug:print-info 0 *default-log-port* "Sending log output to " (args:get-arg "-log"))
+;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
+(define (open-logfile logpath)
+ (condition-case
+ (let* ((log-dir (or (pathname-directory logpath) ".")))
+ (if (not (directory-exists? log-dir))
+ (system (conc "mkdir -p " log-dir)))
+ (open-output-file logpath))
+ (exn ()
+ (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath)
+ (define *didsomething* #t)
+ (exit 1))))
+
+
+(if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server
+ (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server
+ (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
+ (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log")))
+ (oup (open-logfile logf)))
+ (if (not (args:get-arg "-log"))
+ (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
+ (debug:print-info 0 *default-log-port* "Sending log output to " logf)
(set! *default-log-port* oup)))
(if (or (args:get-arg "-h")
(args:get-arg "-help")
(args:get-arg "--help"))
@@ -700,50 +733,17 @@
;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;; we start the server if not running else start the client thread
;;======================================================================
+;; Server? Start up here.
+;;
(if (args:get-arg "-server")
-
- ;; Server? Start up here.
- ;;
(let ((tl (launch:setup))
- ;; (run-id (and (args:get-arg "-run-id")
- ;; (string->number (args:get-arg "-run-id"))))
(transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
- ;; (if run-id
- ;; (begin
(server:launch 0 transport-type)
(set! *didsomething* #t)))
-;; ;; (debug:print-error 0 *default-log-port* "server requires run-id be specified with -run-id")))
-;;
-;; ;; Not a server? This section will decide how to communicate
-;; ;;
-;; ;; Setup client for all expect listed here
-;; (if (null? (lset-intersection
-;; equal?
-;; (hash-table-keys args:arg-hash)
-;; '("-list-servers"
-;; "-stop-server"
-;; "-kill-server"
-;; "-show-cmdinfo"
-;; "-list-runs"
-;; "-ping")))
-;; (if (launch:setup)
-;; (let ((run-id (and (args:get-arg "-run-id")
-;; (string->number (args:get-arg "-run-id")))))
-;; ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db")))
-;; ;; if not list or kill then start a client (if appropriate)
-;; (if (or (args-defined? "-h" "-version" "-create-megatest-area" "-create-test")
-;; (eq? (length (hash-table-keys args:arg-hash)) 0))
-;; (debug:print-info 1 *default-log-port* "Server connection not needed")
-;; (begin
-;; ;; (if run-id
-;; ;; (client:launch run-id)
-;; ;; (client:launch 0) ;; without run-id we'll start a server for "0"
-;; #t
-;; ))))))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-stop-server")
(args:get-arg "-kill-server"))
(let ((tl (launch:setup)))
@@ -1869,10 +1869,30 @@
;;======================================================================
;; fakeout readline
(include "readline-fix.scm")
+
+(when (args:get-arg "-diff-rep")
+ (when (and
+ (not (args:get-arg "-diff-html"))
+ (not (args:get-arg "-diff-email")))
+ (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep")
+ (set! *didsomething* 1)
+ (exit 1))
+
+ (let* ((toppath (launch:setup)))
+ (do-diff-report
+ (args:get-arg "-src-target")
+ (args:get-arg "-src-runname")
+ (args:get-arg "-target")
+ (args:get-arg "-runname")
+ (args:get-arg "-diff-html")
+ (args:get-arg "-diff-email"))
+ (set! *didsomething* #t)
+ (exit 0)))
+
(if (or (getenv "MT_RUNSCRIPT")
(args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (launch:setup))
(dbstruct (if (and toppath
@@ -1992,11 +2012,11 @@
(set! *didsomething* #t)))
(if (args:get-arg "-generate-html")
(let* ((toppath (launch:setup)))
(if (tests:create-html-tree #f)
- (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/runs-index.html")
+ (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page#.html")
(debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
(set! *didsomething* #t)))
;;======================================================================
;; Exit and clean up
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -36,12 +36,12 @@
(define (rmt:get-connection-info areapath) ;; TODO: push areapath down.
(let ((cinfo (remote-conndat *runremote*))
(run-id 0))
(if cinfo
cinfo
- (if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)
- (client:setup run-id)
+ (if (server:check-if-running areapath)
+ (client:setup areapath)
#f))))
(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
@@ -62,11 +62,11 @@
(debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.")
(exit 1))
;; reset the connection if it has been unused too long
((and *runremote*
(remote-conndat *runremote*)
- (let ((expire-time (- start-time (remote-server-timeout *runremote*))))
+ (let ((expire-time (+ (- start-time (remote-server-timeout *runremote*))(random 30)))) ;; add 30 seconds of noise so that not all running tests expire at the same time causing a storm of server starts
(< (http-transport:server-dat-get-last-access (remote-conndat *runremote*)) expire-time)))
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 8")
(remote-conndat-set! *runremote* #f)
(mutex-unlock! *rmt-mutex*)
(rmt:send-receive cmd rid params attemptnum: attemptnum))
@@ -92,12 +92,12 @@
;; on homehost and this is a write, we already have a server, but server has died
((and (cdr (remote-hh-dat *runremote*)) ;; on homehost
(not (member cmd api:read-only-queries)) ;; this is a write
(remote-server-url *runremote*) ;; have a server
- (not (server:read-dotserver *toppath*))) ;; server has died.
- (set! *runremote* #f)
+ (not (server:check-if-running *toppath*))) ;; server has died.
+ (set! *runremote* (make-remote))
(mutex-unlock! *rmt-mutex*)
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1")
(rmt:send-receive cmd rid params attemptnum: attemptnum))
;; on homehost and this is a write, we already have a server
@@ -106,60 +106,28 @@
(remote-server-url *runremote*)) ;; have a server
(mutex-unlock! *rmt-mutex*)
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 4")
(rmt:open-qry-close-locally cmd 0 params))
- ;; commented by bb; this was blocking server passive start on write on homehost (case 5)
- ;; ;; on homehost and this is a write, we have a server (we know because case 4 checked)
- ;; ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost
- ;; (not (member cmd api:read-only-queries)))
- ;; (mutex-unlock! *rmt-mutex*)
- ;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1")
- ;; (rmt:open-qry-close-locally cmd 0 params))
-
-
;; on homehost, no server contact made and this is a write, passively start a server
((and (cdr (remote-hh-dat *runremote*)) ; new
(not (remote-server-url *runremote*))
(not (member cmd api:read-only-queries)))
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 5")
- (let ((server-url (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
+ (let ((server-url (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
(if server-url
(remote-server-url-set! *runremote* server-url) ;; the string can be consumed by the client setup if needed
- (if (not (server:start-attempted? *toppath*))
- (server:kind-run *toppath*))))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5.1")
- (rmt:open-qry-close-locally cmd 0 params))
-
-
-
- ;;;
- ;; (begin ;; not on homehost, start server and wait
- ;; (mutex-unlock! *rmt-mutex*)
- ;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5.2")
- ;; (tasks:start-and-wait-for-server (tasks:open-db) 0 15)
- ;; (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;) ;)
-;;;;
-
- ;; if not on homehost ensure we have a connection to a live server
- ;; NOTE: we *have* a homehost record by now
-
- ;; ((and (not (cdr (remote-hh-dat *runremote*))) ;; not on a homehost
- ;; (not (remote-conndat *runremote*)) ;; and no connection
- ;; (server:read-dotserver *toppath*)) ;; .server file exists
- ;; ;; something caused the server entry in tdb to disappear, but the server is still running
- ;; (server:remove-dotserver-file *toppath* ".*")
- ;; (mutex-unlock! *rmt-mutex*)
- ;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 20")
- ;; (rmt:send-receive cmd rid params attemptnum: (add1 attemptnum)))
+ (server:kind-run *toppath*)))
+ (mutex-unlock! *rmt-mutex*)
+ (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5.1")
+ (rmt:open-qry-close-locally cmd 0 params))
((and (not (cdr (remote-hh-dat *runremote*))) ;; not on a homehost
(not (remote-conndat *runremote*))) ;; and no connection
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 6 hh-dat: " (remote-hh-dat *runremote*) " conndat: " (remote-conndat *runremote*))
(mutex-unlock! *rmt-mutex*)
- (tasks:start-and-wait-for-server (tasks:open-db) 0 15)
+ (server:start-and-wait *toppath*)
(remote-conndat-set! *runremote* (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http
(rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as
;; all set up if get this far, dispatch the query
((cdr (remote-hh-dat *runremote*)) ;; we are on homehost
(mutex-unlock! *rmt-mutex*)
@@ -198,11 +166,11 @@
(debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
(remote-conndat-set! *runremote* #f)
(remote-server-url-set! *runremote* #f)
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1")
(mutex-unlock! *rmt-mutex*)
- (tasks:start-and-wait-for-server (tasks:open-db) 0 15)
+ (server:start-and-wait *toppath*)
(rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))))))))
;; (define (rmt:update-db-stats run-id rawcmd params duration)
;; (mutex-lock! *db-stats-mutex*)
;; (handle-exceptions
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -8,11 +8,11 @@
;; 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)
+(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils posix-extras matchable)
;; (use zmq)
(use spiffy uri-common intarweb http-client spiffy-request-vars)
(declare (unit server))
@@ -47,35 +47,15 @@
;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id transport-type)
- ;;(BB> "server:launch fired for run-id="run-id" transport-type="transport-type)
-
- (let ((attempt-in-progress (server:start-attempted? *toppath*))) ; check for .server-starting
- (when attempt-in-progress
- (debug:print-info 0 *default-log-port* "Server start attempt in progress in other process (=> "attempt-in-progress"<=). Aborting server launch attempt in this process ("(current-process-id)")")
- (exit)))
-
- (let ((dotserver-url (server:check-if-running *toppath*))) ;; check for .server
- (when dotserver-url
- (debug:print-info 0 *default-log-port* "Server already running (=> "dotserver-url"<=). Aborting server launch attempt in this process ("(current-process-id)")")
- (exit)
- ))
-
(case transport-type
- ((http)(http-transport:launch run-id))
+ ((http)(http-transport:launch))
;;((nmsg)(nmsg-transport:launch run-id))
((rpc) (rpc-transport:launch run-id))
- (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type)))
-
- ;; is this a good place to print server exit stats?
- (debug:print 0 "SERVER: max parallel api requests: " *max-api-process-requests*)
-
- )
-;; (else (debug:print-error 0 *default-log-port* "No known transport set, transport=" transport ", using rpc")
-;; (rpc-transport:launch run-id)))))
+ (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
@@ -106,14 +86,10 @@
;; (send-message pubsock target send-more: #t)
;; (send-message pubsock
(case (server:get-transport)
((rpc) (db:obj->string (vector success/fail query-sig result)))
((http) (db:obj->string (vector success/fail query-sig result)))
- ((zmq)
- (let ((pub-socket (vector-ref *runremote* 1)))
- (send-message pub-socket return-addr send-more: #t)
- (send-message pub-socket (db:obj->string (vector success/fail query-sig result)))))
((fs) result)
(else
(debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
result)))
@@ -122,241 +98,256 @@
;; try running on that host
;; incidental: rotate logs in logs/ dir.
;;
(define (server:run areapath) ;; areapath is *toppath* for a given testsuite area
(let* ((curr-host (get-host-name))
- (attempt-in-progress (server:start-attempted? areapath))
- (dot-server-url (server:check-if-running areapath))
+ ;; (attempt-in-progress (server:start-attempted? areapath))
+ ;; (dot-server-url (server:check-if-running areapath))
(curr-ip (server:get-best-guess-address curr-host))
(curr-pid (current-process-id))
(homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" ))
(target-host (car homehost))
(testsuite (common:get-testsuite-name))
- (logfile (conc areapath "/logs/server.log"))
+ (logfile (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log"))
(cmdln (conc (common:get-megatest-exe)
- " -server " (or target-host "-") " -run-id " 0 (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
- (conc " -daemonize -log " logfile)
- "")
+ " -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
+ " -daemonize "
+ "")
+ ;; " -log " logfile
" -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &")))))
(log-rotate (make-thread common:rotate-logs "server run, rotate logs thread")))
;; we want the remote server to start in *toppath* so push there
(push-directory areapath)
- (cond
- (attempt-in-progress
- (debug:print 0 *default-log-port* "INFO: Not trying to start server because attempt is in progress: "attempt-in-progress))
- (dot-server-url
- (debug:print 0 *default-log-port* "INFO: Not trying to start server because one is already running : "dot-server-url))
- (else
- (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
- (thread-start! log-rotate)
-
- ;; host.domain.tld match host?
- (if (and target-host
- ;; look at target host, is it host.domain.tld or ip address and does it
- ;; match current ip or hostname
- (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
- (not (equal? curr-ip target-host)))
- (begin
- (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
- (setenv "TARGETHOST" target-host)))
-
- (setenv "TARGETHOST_LOGF" logfile)
- (common:wait-for-normalized-load 4 " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever
- (system (conc "nbfake " cmdln))
- (unsetenv "TARGETHOST_LOGF")
- (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
- (thread-join! log-rotate)
- (pop-directory)))))
-
+ (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
+ (thread-start! log-rotate)
+
+ ;; host.domain.tld match host?
+ (if (and target-host
+ ;; look at target host, is it host.domain.tld or ip address and does it
+ ;; match current ip or hostname
+ (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
+ (not (equal? curr-ip target-host)))
+ (begin
+ (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
+ (setenv "TARGETHOST" target-host)))
+
+ (setenv "TARGETHOST_LOGF" logfile)
+ (common:wait-for-normalized-load 4 " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever
+ (system (conc "nbfake " cmdln))
+ (unsetenv "TARGETHOST_LOGF")
+ (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
+ (thread-join! log-rotate)
+ (pop-directory)))
+
+;; given a path to a server log return: host port startseconds
+;;
+(define (server:logf-get-start-info logf)
+ (let ((rx (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+)"))) ;; SERVER STARTED: host:port AT timesecs
+ (with-input-from-file
+ logf
+ (lambda ()
+ (let loop ((inl (read-line))
+ (lnum 0))
+ (if (not (eof-object? inl))
+ (let ((mlst (string-match rx inl)))
+ (if (not mlst)
+ (if (< lnum 500) ;; give up if more than 500 lines of server log read
+ (loop (read-line)(+ lnum 1))
+ (list #f #f #f))
+ (let ((dat (cdr mlst)))
+ (list (car dat) ;; host
+ (string->number (cadr dat)) ;; port
+ (string->number (caddr dat))))))
+ (list #f #f #f)))))))
+
+;; get a list of servers with all relevant data
+;; ( mod-time host port start-time pid )
+;;
+(define (server:get-list areapath #!key (limit #f))
+ (let ((fname-rx (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))
+ (day-seconds (* 24 60 60)))
+ ;; if the directory exists continue to get the list
+ ;; otherwise attempt to create the logs dir and then
+ ;; continue
+ (if (if (directory-exists? (conc areapath "/logs"))
+ #t
+ (if (file-write-access? areapath)
+ (begin
+ (condition-case
+ (create-directory (conc areapath "/logs") #t)
+ (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
+ (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list.")))
+ (directory-exists? (conc areapath "/logs")))
+ #f))
+ (let* ((server-logs (glob (conc areapath "/logs/server-*.log")))
+ (num-serv-logs (length server-logs)))
+ (if (null? server-logs)
+ '()
+ (let loop ((hed (car server-logs))
+ (tal (cdr server-logs))
+ (res '()))
+ (let* ((mod-time (file-modification-time hed))
+ (down-time (- (current-seconds) mod-time))
+ (serv-dat (if (or (< num-serv-logs 10)
+ (< down-time day-seconds))
+ (server:logf-get-start-info hed)
+ '())) ;; don't waste time processing server files not touched in the past day if there are more than ten servers to look at
+ (serv-rec (cons mod-time serv-dat))
+ (fmatch (string-match fname-rx hed))
+ (pid (if fmatch (string->number (list-ref fmatch 2)) #f))
+ (new-res (if (null? serv-dat)
+ res
+ (cons (append serv-rec (list pid)) res))))
+ (if (null? tal)
+ (if (and limit
+ (> (length new-res) limit))
+ new-res ;; (take new-res limit) <= need intelligent sorting before this will work
+ new-res)
+ (loop (car tal)(cdr tal) new-res)))))))))
+
+;; given a list of servers get a list of valid servers, i.e. at least
+;; 10 seconds old, has started and is less than 1 hour old and is
+;; active (i.e. mod-time < 10 seconds
+;;
+;; mod-time host port start-time pid
+;;
+;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off
+;; and servers should stick around for about two hours or so.
+;;
+(define (server:get-best srvlst)
+ (let ((now (current-seconds)))
+ (sort
+ (filter (lambda (rec)
+ (let ((start-time (list-ref rec 3))
+ (mod-time (list-ref rec 0)))
+ ;; (print "start-time: " start-time " mod-time: " mod-time)
+ (and start-time mod-time
+ (> (- now start-time) 0) ;; been running at least 0 seconds
+ (< (- now mod-time) 16) ;; still alive - file touched in last 16 seconds
+ (< (- now start-time)
+ (+ (- (string->number (or (configf:lookup *configdat* "server" "runtime") "3600"))
+ 180)
+ (random 360))) ;; under one hour running time +/- 180
+ )))
+ srvlst)
+ (lambda (a b)
+ (< (list-ref a 3)
+ (list-ref b 3))))))
+
+(define (server:get-first-best areapath)
+ (let ((srvrs (server:get-best (server:get-list areapath))))
+ (if (and srvrs
+ (not (null? srvrs)))
+ (car srvrs)
+ #f)))
+
+(define (server:record->url servr)
+ (match-let (((mod-time host port start-time pid)
+ servr))
+ (if (and host port)
+ (conc host ":" port)
+ #f)))
+
(define (server:get-client-signature) ;; BB> why is this proc named "get-"? it returns nothing -- set! has not return value.
(if *my-client-signature* *my-client-signature*
(let ((sig (server:mk-signature)))
(set! *my-client-signature* sig)
*my-client-signature*)))
;; kind start up of servers, wait 40 seconds before allowing another server for a given
;; run-id to be launched
(define (server:kind-run areapath)
- (let ((last-run-time (hash-table-ref/default *server-kind-run* areapath #f)))
- (if (or (not last-run-time)
- (> (- (current-seconds) last-run-time) 30))
- (begin
- (server:run areapath)
- (hash-table-set! *server-kind-run* areapath (current-seconds))))))
+ (let* ((last-run-dat (hash-table-ref/default *server-kind-run* areapath '(0 0))) ;; callnum, whenrun
+ (call-num (car last-run-dat))
+ (when-run (cadr last-run-dat))
+ (run-delay (+ (case call-num
+ ((0) 0)
+ ((1) 20)
+ ((2) 300)
+ (else 600))
+ (random 5)))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously
+ (if (> (- (current-seconds) when-run) run-delay)
+ (server:run areapath))
+ (hash-table-set! *server-kind-run* areapath (list (+ call-num 1)(current-seconds)))))
+
+(define (server:start-and-wait areapath #!key (timeout 60))
+ (let ((give-up-time (+ (current-seconds) timeout)))
+ (let loop ((server-url (server:check-if-running areapath)))
+ (if (or server-url
+ (> (current-seconds) give-up-time)) ;; server-url will be #f if no server available.
+ server-url
+ (let ((num-ok (length (server:get-best (server:get-list areapath)))))
+ (if (< num-ok 1) ;; if there are no decent candidates for servers then try starting a new one
+ (server:kind-run areapath))
+ (thread-sleep! 5)
+ (loop (server:check-if-running areapath)))))))
(define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG.
-(define (server:attempting-start areapath)
- (with-output-to-file
- (conc areapath "/.starting-server")
- (lambda ()
- (print (current-process-id) " on " (get-host-name)))))
-
-(define (server:complete-attempt areapath)
- (delete-file* (conc areapath "/.starting-server")))
-
-(define (server:start-attempted? areapath)
- (let ((flagfile (conc areapath "/.starting-server")))
- (handle-exceptions
- exn
- #f ;; if things go wrong pretend we can't see the file
- (cond
- ((and (file-exists? flagfile)
- (< (- (current-seconds)
- (file-modification-time flagfile))
- 15)) ;; exists and less than 15 seconds old
- (with-input-from-file flagfile (lambda () (read-line))))
- ((file-exists? flagfile) ;; it is stale.
- (server:complete-attempt areapath)
- #f)
- (else #f)))))
-
-(define (server:read-dotserver areapath)
- (let ((dotfile (conc areapath "/.server")))
- (handle-exceptions
- exn
- #f ;; if things go wrong pretend we can't see the file
- (cond
- ((not (file-exists? dotfile))
- #f)
- ((not (file-read-access? dotfile))
- #f)
- ((> (server:dotserver-age-seconds areapath) (+ 5 (server:get-timeout)))
- (server:remove-dotserver-file areapath ".*")
- #f)
- (else
- (let* ((line
- (with-input-from-file
- dotfile
- (lambda ()
- (read-line))))
- (tokens (if (string? line) (string-split line ":") #f)))
- (cond
- ((eq? 4 (length tokens))
- tokens)
- (else #f))))))))
-
-(define (server:read-dotserver->url areapath)
- (let ((dotserver-tokens (server:read-dotserver areapath)))
- (if dotserver-tokens
- (conc (list-ref dotserver-tokens 0) ":" (list-ref dotserver-tokens 1))
- #f)))
-
-;; write a .server file in *toppath* with hostport
-;; return #t on success, #f otherwise
-;;
-(define (server:write-dotserver areapath host port pid transport)
- (let ((lock-file (conc areapath "/.server.lock"))
- (server-file (conc areapath "/.server")))
- (if (common:simple-file-lock lock-file)
- (let ((res (handle-exceptions
- exn
- #f ;; failed for some reason, for the moment simply return #f
- (with-output-to-file server-file
- (lambda ()
- (print (conc host ":" port ":" pid ":" transport))))
- #t)))
- (debug:print-info 0 *default-log-port* "server file " server-file " for " host ":" port " created pid="pid)
- (common:simple-file-release-lock lock-file)
- res)
- #f)))
-
-
-;; this will check that the .server file present matches the server calling this procedure.
-;; if parameters match (this-pid and transport) the file will be touched and #t returned
-;; otherwise #f will be returned.
-(define (server:confirm-dotserver areapath this-iface this-port this-pid this-transport)
- (let* ((tokens (server:read-dotserver areapath)))
- (cond
- ((not tokens)
- (debug:print-info 0 *default-log-port* "INFO: .server file does not exist.")
- #f)
- ((not (eq? 4 (length tokens)))
- (debug:print-info 0 *default-log-port* "INFO: .server file is corrupt. There are not 4 tokens as expeted; there are "(length tokens)".")
- #f)
- ((not (equal? this-iface (list-ref tokens 0)))
- (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for iface, server has value >"(list-ref tokens 0)"< but this server's value is >"this-iface"<")
- #f)
- ((not (equal? (->string this-port) (list-ref tokens 1)))
- (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for port, .server has value >"(list-ref tokens 1)"< but this server's value is >"(->string this-port)"<")
- #f)
- ((not (equal? (->string this-pid) (list-ref tokens 2)))
- (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for pid, .server has value >"(list-ref tokens 2)"< but this server's value is >"(->string this-pid)"<")
- #f)
- ((not (equal? (->string this-transport) (->string (list-ref tokens 3))))
- (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for transport, .server has value >"(list-ref tokens 3)"< but this server's value is >"this-transport"<")
- #f)
- (else (server:touch-dotserver areapath)
- #t))))
-
-(define (server:touch-dotserver areapath)
- (let ((server-file (conc areapath "/.server")))
- (change-file-times server-file (current-seconds) (current-seconds))))
-
(define (server:dotserver-age-seconds areapath)
(let ((server-file (conc areapath "/.server")))
(begin
(handle-exceptions
exn
#f
(- (current-seconds)
(file-modification-time server-file))))))
-(define (server:remove-dotserver-file areapath hostport)
- (let ((dotserver-url (server:read-dotserver->url areapath))
- (server-file (conc areapath "/.server"))
- (lock-file (conc areapath "/.server.lock")))
- (if (and dotserver-url (string-match (conc ".*:" hostport "$") dotserver-url)) ;; port matches, good enough info to decide to remove the file
- (if (common:simple-file-lock lock-file)
- (begin
- (handle-exceptions
- exn
- #f
- (delete-file* server-file))
- (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " removed")
- (common:simple-file-release-lock lock-file))
- (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " NOT removed - could not get lock."))
- (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " NOT removed - dotserver-url("dotserver-url") did not match hostport pattern ("hostport")"))))
-
;; no longer care if multiple servers are started by accident. older servers will drop off in time.
;;
(define (server:check-if-running areapath)
- (let* ((dotserver-url (server:read-dotserver->url areapath))) ;; tdbdat (tasks:open-db)))
- (if dotserver-url
- (let* ((res (case *transport-type*
- ((http)(server:ping-server dotserver-url))
- ;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server)
- )))
- (if res
- dotserver-url
- (begin
- (server:remove-dotserver-file areapath ".*") ;; remove stale dotserver
- #f)))
- #f)))
+ (let* ((servers (server:get-best (server:get-list areapath))))
+ (if (null? servers)
+ #f
+ (let loop ((hed (car servers))
+ (tal (cdr servers)))
+ (let ((res (server:check-server hed)))
+ (if res
+ res
+ (if (null? tal)
+ #f
+ (loop (car tal)(cdr tal)))))))))
+
+;; ping the given server
+;;
+(define (server:check-server server-record)
+ (let* ((server-url (server:record->url server-record))
+ (res (case *transport-type*
+ ((http)(server:ping server-url))
+ ;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server)
+ )))
+ (if res
+ server-url
+ #f)))
+
+(define (server:kill servr)
+ (match-let (((mod-time hostname port start-time pid)
+ servr))
+ (tasks:kill-server hostname pid)))
;; called in megatest.scm, host-port is string hostname:port
;;
;; NOTE: This is NOT called directly from clients as not all transports support a client running
;; in the same process as the server.
;;
(define (server:ping host-port-in #!key (do-exit #f))
(let ((host:port (if (not host-port-in) ;; use read-dotserver to find
- (server:read-dotserver->url *toppath*)
- (if (number? host-port-in) ;; we were handed a server-id
- (let ((srec (tasks:get-server-by-id (db:delay-if-busy (tasks:open-db)) host-port-in)))
- ;; (print "srec: " srec " host-port-in: " host-port-in)
- (if srec
- (conc (vector-ref srec 3) ":" (vector-ref srec 4))
- (conc "no such server-id " host-port-in)))
- host-port-in))))
+ #f ;; (server:check-if-running *toppath*)
+ ;; (if (number? host-port-in) ;; we were handed a server-id
+ ;; (let ((srec (tasks:get-server-by-id (db:delay-if-busy (tasks:open-db)) host-port-in)))
+ ;; ;; (print "srec: " srec " host-port-in: " host-port-in)
+ ;; (if srec
+ ;; (conc (vector-ref srec 3) ":" (vector-ref srec 4))
+ ;; (conc "no such server-id " host-port-in)))
+ host-port-in))) ;; )
(let* ((host-port (if host:port
(let ((slst (string-split host:port ":")))
(if (eq? (length slst) 2)
(list (car slst)(string->number (cadr slst)))
#f))
- #f))
- (toppath (launch:setup)))
+ #f)))
+;; (toppath (launch:setup)))
;; (print "host-port=" host-port)
(if (not host-port)
(begin
(if host-port-in
(debug:print 0 *default-log-port* "ERROR: bad host:port"))
@@ -367,15 +358,17 @@
(server-dat (http-transport:client-connect iface port))
(login-res (rmt:login-no-auto-client-setup server-dat)))
(if (and (list? login-res)
(car login-res))
(begin
- (print "LOGIN_OK")
- (if do-exit (exit 0)))
+ ;; (print "LOGIN_OK")
+ (if do-exit (exit 0))
+ #t)
(begin
- (print "LOGIN_FAILED")
- (if do-exit (exit 1)))))))))
+ ;; (print "LOGIN_FAILED")
+ (if do-exit (exit 1))
+ #f)))))))
;; run ping in separate process, safest way in some cases
;;
(define (server:ping-server ifaceport)
(with-input-from-pipe
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -170,315 +170,24 @@
(define (tasks:hostinfo-get-pubport vec) (vector-ref vec 3))
(define (tasks:hostinfo-get-transport vec) (vector-ref vec 4))
(define (tasks:hostinfo-get-pid vec) (vector-ref vec 5))
(define (tasks:hostinfo-get-hostname vec) (vector-ref vec 6))
-(define (tasks:server-lock-slot mdb run-id)
- (tasks:server-clean-out-old-records-for-run-id mdb run-id " tasks:server-lock-slot")
- (if (< (tasks:num-in-available-state mdb run-id) 4)
- (begin
- (tasks:server-set-available mdb run-id)
- (thread-sleep! (/ (random 1500) 1000)) ;; (thread-sleep! 2) ;; Try removing this. It may not be needed.
- (tasks:server-am-i-the-server? mdb run-id))
- #f))
-
-;; register that this server may come online (first to register goes though with the process)
-(define (tasks:server-set-available mdb run-id)
- (sqlite3:execute
- mdb
- "INSERT INTO servers (pid,hostname,port,pubport,start_time, priority,state,mt_version,heartbeat, interface,transport,run_id)
- VALUES(?, ?, ?, ?, strftime('%s','now'), ?, ?, ?,-1,?, ?, ?);"
- (current-process-id) ;; pid
- (get-host-name) ;; hostname
- -1 ;; port
- -1 ;; pubport
- (random 1000) ;; priority (used a tiebreaker on get-available)
- "available" ;; state
- (common:version-signature) ;; mt_version
- -1 ;; interface
- ;; (conc (server:get-transport)) ;; transport
- (conc *transport-type*) ;; transport
- run-id
- ))
-
-(define (tasks:num-in-available-state mdb run-id)
- (let ((res 0))
- (sqlite3:for-each-row
- (lambda (num-in-queue)
- (set! res num-in-queue))
- mdb
- "SELECT count(id) FROM servers WHERE run_id=? AND state = 'available' AND (strftime('%s','now') - start_time) < 30 ;"
- run-id)
- res))
-
-(define (tasks:num-servers-non-zero-running mdb)
- (let ((res 0))
- (sqlite3:for-each-row
- (lambda (num-running)
- (set! res num-running))
- mdb
- "SELECT count(id) FROM servers WHERE run_id != 0 AND state = 'running';")
- res))
-
-(define (tasks:server-clean-out-old-records-for-run-id mdb run-id tag)
- (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state in ('available','dbprep','shutting-down') AND (strftime('%s','now') - start_time) > 50 AND run_id=?;"
- (conc "defunct" tag) run-id))
-
-(define (tasks:server-force-clean-running-records-for-run-id mdb run-id tag)
- (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state = 'running' AND run_id=?;"
- (conc "defunct" tag) run-id))
-
-(define (tasks:server-force-clean-run-record mdb run-id iface port tag)
- (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state = 'running' AND run_id=? AND interface=? AND port=?;"
- (conc "defunct" tag) run-id iface port))
-
-
-;; BB> adding missing func for --list-servers
-(define (tasks:server-deregister mdb hostname #!key (pullport #f) (pid #f) (action #f)) ;;pullport pid: pid action: 'delete))
- (if (eq? action 'delete)
- (sqlite3:execute mdb "DELETE FROM servers WHERE pid=? AND port=? AND hostname=?;" pid pullport hostname)
- (sqlite3:execute mdb "UPDATE servers SET state='defunct', heartbeat=strftime('%s','now') WHERE hostname=? AND pid=?;"
- hostname pid)))
-
-(define (tasks:server-delete-records-for-this-pid mdb tag)
- (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE hostname=? AND pid=?;"
- (conc "defunct" tag) (get-host-name) (current-process-id)))
-
-(define (tasks:server-delete-record mdb server-id tag)
- (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE id=?;"
- (conc "defunct" tag) server-id)
- ;; use this opportuntity to clean out records over one month old or over 10 minutes old with port = -1 (i.e. a never used placeholder)
- (sqlite3:execute mdb "DELETE FROM servers WHERE state not in ('running','shutting-down','dbprep') AND (strftime('%s','now') - start_time) > 2628000;")
- (sqlite3:execute mdb "DELETE FROM servers WHERE state like 'defunct%' AND port=-1 AND (strftime('%s','now') - start_time) > 600;")
- )
-
-(define (tasks:server-set-state! mdb server-id state)
- (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE id=?;" state server-id))
-
-(define (tasks:server-set-interface-port mdb server-id interface port)
- (sqlite3:execute mdb "UPDATE servers SET interface=?,port=?,heartbeat=strftime('%s','now') WHERE id=?;" interface port server-id))
-
-;; Get random port not used in long time
-;;
-(define (tasks:server-get-next-port mdb)
- (let* ((lownum 30000)
- (highnum 64000)
- (used-ports '())
- (get-rand-port (lambda ()
- (+ lownum (random (- highnum lownum)))))
- (port-param (if (and (args:get-arg "-port")
- (string->number (args:get-arg "-port")))
- (string->number (args:get-arg "-port"))
- #f))
- ;; (config-port (if (and (config-lookup *configdat* "server" "port")
- ;; (string->number (config-lookup *configdat* "server" "port")))
- ;; (string->number (config-lookup *configdat* "server" "port"))
- ;; #f))
- )
- (sqlite3:for-each-row
- (lambda (port)
- (set! used-ports (cons port used-ports)))
- mdb
- "SELECT port FROM servers;")
- (cond
- ((and port-param res) (if (> res port-param) res port-param))
- (port-param port-param)
- ;; ((and config-port res) (if (> res config-port) res config-port))
- ;; (config-port config-port)
- (else
- (let loop ((port (get-rand-port))
- (remtries 100))
- (if (member port used-ports)
- (if (> remtries 0)
- (loop (get-rand-port)(- remtries 1))
- (get-rand-port))
- port))))))
-
-(define (tasks:server-am-i-the-server? mdb run-id)
- (let* ((all (tasks:server-get-servers-vying-for-run-id mdb run-id))
- (first (if (null? all)
- #f;; (begin (debug:print-error 0 *default-log-port* "no servers listed, should be at least one by now.")
- ;; (sqlite3:finalize! mdb)
- ;; (exit 1))
- (car (db:get-rows all)))))
- (if first
- (let* ((header (db:get-header all))
- (id (db:get-value-by-header first header "id"))
- (hostname (db:get-value-by-header first header "hostname"))
- (pid (db:get-value-by-header first header "pid"))
- (priority (db:get-value-by-header first header "priority")))
- ;; (debug:print 0 *default-log-port* "INFO: am-i-the-server got record " first)
- ;; for now a basic check. add tiebreaking by priority later
- (if (and (equal? hostname (get-host-name))
- (equal? pid (current-process-id)))
- id
- #f))
- #f)))
-
-;; Use: (db:get-value-by-header (car (db:get-rows dat)) (db:get-header dat) "fieldname")
-;; to extract info from the structure returned
-;;
-(define (tasks:server-get-servers-vying-for-run-id mdb run-id)
- (let* ((header (list "id" "hostname" "pid" "interface" "port" "pubport" "state" "run_id" "priority" "start_time"))
- (selstr (string-intersperse header ","))
- (res '()))
- (sqlite3:for-each-row
- (lambda (a . b)
- (set! res (cons (apply vector a b) res)))
- mdb
- (conc "SELECT " selstr " FROM servers WHERE state in ('available','running','dbprep') ORDER BY start_time DESC;")
- )
- (vector header res)))
-
-(define (tasks:get-server mdb run-id #!key (retries 10))
- (let ((res #f)
- (best #f))
- (handle-exceptions
- exn
- (begin
- (print-call-chain (current-error-port))
- (debug:print 0 *default-log-port* "WARNING: tasks:get-server db access error.")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 *default-log-port* " for run " run-id)
- (print-call-chain (current-error-port))
- (if (> retries 0)
- (begin
- (debug:print 0 *default-log-port* " trying call to tasks:get-server again in 10 seconds")
- (thread-sleep! 10)
- (tasks:get-server mdb run-id retries: (- retries 0)))
- (debug:print 0 *default-log-port* "10 tries of tasks:get-server all crashed and burned. Giving up and returning \"no server found\"")))
- (sqlite3:for-each-row
- (lambda (id interface port pubport transport pid hostname)
- (set! res (vector id interface port pubport transport pid hostname)))
- mdb
- ;; removed:
- ;; strftime('%s','now')-heartbeat < 10 AND mt_version = ?
- "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers
- WHERE run_id=? AND state='running'
- ORDER BY start_time DESC LIMIT 1;" run-id) ;; (common:version-signature) run-id)
- res)))
-
-(define (tasks:server-running-or-starting? mdb run-id)
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (id)
- (set! res id))
- mdb ;; NEEDS dbprep ADDED
- "SELECT id FROM servers WHERE run_id=? AND (state = 'running' OR (state = 'dbprep' AND (strftime('%s','now') - start_time) < 60));" run-id)
- res))
-
-(define (tasks:server-running? mdb run-id)
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (id)
- (set! res id))
- mdb ;; NEEDS dbprep ADDED
- "SELECT id FROM servers WHERE run_id=? AND state = 'running';" run-id)
- res))
-
(define (tasks:need-server run-id)
(equal? (configf:lookup *configdat* "server" "required") "yes"))
-;; (maxqry (cdr (rmt:get-max-query-average run-id)))
-;; (threshold (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") "10"))))
-;; (cond
-;; (forced
-;; (if (common:low-noise-print 60 run-id "server required is set")
-;; (debug:print-info 0 *default-log-port* "Server required is set, starting server for run-id " run-id "."))
-;; #t)
-;; ((> maxqry threshold)
-;; (if (common:low-noise-print 60 run-id "Max query time execeeded")
-;; (debug:print-info 0 *default-log-port* "Max avg query time of " maxqry "ms exceeds limit of " threshold "ms, server needed for run-id " run-id "."))
-;; #t)
-;; (else
-;; #f))))
-
-;; try to start a server and wait for it to be available
-;;
-(define (tasks:start-and-wait-for-server tdbdat run-id delay-max-tries)
- ;; ensure a server is running for this run
- (let loop ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id))
- (delay-time 0))
- (if (and (not server-dat)
- (< delay-time delay-max-tries))
- (begin
- (if (common:low-noise-print 60 "tasks:start-and-wait-for-server" run-id)
- (debug:print 0 *default-log-port* "Try starting server for run-id " run-id))
- (thread-sleep! (/ (random 2000) 1000))
- (server:kind-run *toppath*)
- (thread-sleep! (min delay-time 1))
- (if (not (or (server:start-attempted? *toppath*)
- (server:read-dotserver *toppath*))) ;; no point in trying
- (loop (tasks:get-server (db:delay-if-busy tdbdat) run-id)(+ delay-time 1))
- #f))
- #f)))
-
-(define (tasks:get-all-servers mdb)
- (let ((res '()))
- (sqlite3:for-each-row
- (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id)
- ;; 0 1 2 3 4 5 6 7 8 9 10 11 12
- (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res)))
- mdb
- "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id
- FROM servers WHERE state NOT LIKE 'defunct%' ORDER BY start_time DESC;")
- res))
-
-(define (tasks:get-server-by-id mdb id)
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id)
- ;; 0 1 2 3 4 5 6 7 8 9 10 11 12
- (set! res (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id)))
- mdb
- "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id
- FROM servers WHERE id=?;"
- id)
- res))
-
-(define (tasks:get-server-records mdb run-id)
- (let ((res '()))
- (sqlite3:for-each-row
- (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id)
- ;; 0 1 2 3 4 5 6 7 8 9 10 11 12
- (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res)))
- mdb
- "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id
- FROM servers WHERE run_id=? AND state NOT LIKE 'defunct%' ORDER BY start_time DESC;"
- run-id)
- (reverse res)))
-
;; no elegance here ...
;;
(define (tasks:kill-server hostname pid #!key (kill-switch ""))
- (server:remove-dotserver-file *toppath* ".*")
(debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname)
(setenv "TARGETHOST" hostname)
(setenv "TARGETHOST_LOGF" "server-kills.log")
(system (conc "nbfake kill "kill-switch" "pid))
(unsetenv "TARGETHOST_LOGF")
(unsetenv "TARGETHOST"))
-;; look up a server by run-id and send it a kill, also delete the record for that server
-;;
-(define (tasks:kill-server-run-id run-id #!key (tag "default"))
- (let* ((tdbdat (tasks:open-db))
- (sdat (tasks:get-server (db:delay-if-busy tdbdat) run-id)))
- (if sdat
- (let ((hostname (vector-ref sdat 6))
- (pid (vector-ref sdat 5))
- (server-id (vector-ref sdat 0)))
- (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "killed")
- (debug:print-info 0 *default-log-port* "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid)
- (server:remove-dotserver-file *toppath* ".*")
- (tasks:kill-server hostname pid)
- (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id tag) )
- (debug:print-info 0 *default-log-port* "No server found for run-id " run-id ", nothing to kill"))
- ;; (sqlite3:finalize! tdb)
- ))
-
;;======================================================================
;; M O N I T O R S
;;======================================================================
(define (tasks:remove-monitor-record mdb)
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -569,13 +569,41 @@
#<
ul.LinkedList { display: block; }
/* ul.LinkedList ul { display: none; } */
.HandCursorStyle { cursor: pointer; cursor: hand; } /* For IE */
+th {background-color: #8c8c8c;}
+td.test {background-color: #d9dbdd;}
+td.PASS {background-color: #347533;}
+td.FAIL {background-color: #cc2812;}
+
+
+