Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -998,25 +998,19 @@
 	  #f)))
 
 (define (common:get-area-path-signature)
   (message-digest-string (md5-primitive) *toppath*))
 
-(define (common:get-signature str)
-  (message-digest-string (md5-primitive) str))
-
 ;;======================================================================
 ;; E X I T   H A N D L I N G
 ;;======================================================================
 
 (define (common:run-sync?)
   (and *toppath*               ;; gate if called before *toppath* is set
        (common:on-homehost?)
        (args:get-arg "-server")))
 
-(define (common:human-time)
-  (time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S"))
-
 
 (define (std-signal-handler signum)
   ;; (signal-mask! signum)
   (set! *time-to-exit* #t) 
   ;;(debug:print-info 13 *default-log-port* "got signal "signum)
@@ -2653,291 +2647,10 @@
     (cond
      (with-vars     (common:without-vars  fullcmd))
      (with-orig-env (common:with-orig-env fullcmd))
      (else          (common:without-vars  fullcmd "MT_.*")))))
 		  
-;;======================================================================
-;; T I M E   A N D   D A T E
-;;======================================================================
-
-;;======================================================================
-;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
-(define (common:hms-string->seconds tstr)
-  (let ((parts     (string-split-fields "\\w+" tstr))
-	(time-secs 0)
-	;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks
-	(trx       (regexp "(\\d+)([smhdMyw])")))
-    (for-each (lambda (part)
-		(let ((match  (string-match trx part)))
-		  (if match
-		      (let ((val (string->number (cadr match)))
-			    (unt (caddr match)))
-			(if val 
-			    (set! time-secs (+ time-secs (* val
-							    (case (string->symbol unt)
-							      ((s) 1)
-							      ((m) 60) ;; minutes
-							      ((h) 3600)
-							      ((d) 86400)
-							      ((w) 604800)
-							      ((M) 2628000) ;; aproximately one month
-							      ((y) 31536000)
-							      (else #f))))))))))
-	      parts)
-    time-secs))
-		       
-(define (seconds->hr-min-sec secs)
-  (let* ((hrs (quotient secs 3600))
-	 (min (quotient (- secs (* hrs 3600)) 60))
-	 (sec (- secs (* hrs 3600)(* min 60))))
-    (conc (if (> hrs 0)(conc hrs "hr ") "")
-	  (if (> min 0)(conc min "m ")  "")
-	  sec "s")))
-
-(define (seconds->time-string sec)
-  (time->string 
-   (seconds->local-time sec) "%H:%M:%S"))
-
-(define (seconds->work-week/day-time sec)
-  (time->string
-   (seconds->local-time sec) "ww%V.%u %H:%M"))
-
-(define (seconds->work-week/day sec)
-  (time->string
-   (seconds->local-time sec) "ww%V.%u"))
-
-(define (seconds->year-work-week/day sec)
-  (time->string
-   (seconds->local-time sec) "%yww%V.%w"))
-
-(define (seconds->year-work-week/day-time sec)
-  (time->string
-   (seconds->local-time sec) "%Yww%V.%w %H:%M"))
-
-(define (seconds->year-week/day-time sec)
-  (time->string
-   (seconds->local-time sec) "%Yw%V.%w %H:%M"))
-
-(define (seconds->quarter sec)
-  (case (string->number
-	 (time->string 
-	  (seconds->local-time sec)
-	  "%m"))
-    ((1 2 3) 1)
-    ((4 5 6) 2)
-    ((7 8 9) 3)
-    ((10 11 12) 4)
-    (else #f)))
-
-;;======================================================================
-;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch
-;;
-(define (common:date-time->seconds datetime)
-  (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S")))
-
-;;======================================================================
-;; given span of seconds tstart to tend
-;; find start time to mark and mark delta
-;;
-(define (common:find-start-mark-and-mark-delta tstart tend)
-  (let* ((deltat   (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
-	 (result   #f)
-	 (min      60)
-	 (hr       (* 60 60))
-	 (day      (* 24 hr))
-	 (yr       (* 365 day)) ;; year
-	 (mo       (/ yr 12))
-	 (wk       (* day 7)))
-    (for-each
-     (lambda (max-blks)
-       (for-each
-	(lambda (span) ;; 5 2 1
-	  (if (not result)
-	      (for-each 
-	       (lambda (timeunit timesym) ;; year month day hr min sec
-		 (if (not result)
-		     (let* ((time-blk (* span timeunit))
-			    (num-blks (quotient deltat time-blk)))
-		       (if (and (> num-blks 4)(< num-blks max-blks))
-			   (let ((first (* (quotient tstart time-blk) time-blk)))
-			     (set! result (list span timeunit time-blk first timesym))
-			     )))))
-	       (list yr mo wk day hr min 1)
-	       '(     y  mo w  d   h  m   s))))
-	(list 8 6 5 2 1)))
-     '(5 10 15 20 30 40 50 500))
-    (if values
-	(apply values result)
-	(values 0 day 1 0 'd))))
-
-;;======================================================================
-;; given x y lim return the cron expansion
-;;
-(define (common:expand-cron-slash x y lim)
-  (let loop ((curr x)
-	     (res  `()))
-    (if (< curr lim)
-	(loop (+ curr y) (cons curr res))
-	(reverse res))))
-
-;;======================================================================
-;; expand a complex cron string to a list of cron strings
-;;
-;;  x/y   => x, x+y, x+2y, x+3y while x+Ny<max_for_field
-;;  a,b,c => a, b ,c
-;;
-;;   NOTE: with flatten a lot of the crud below can be factored down.
-;;
-(define (common:cron-expand cron-str)
-  (if (list? cron-str)
-      (flatten
-       (fold (lambda (x res)
-	       (if (list? x)
-		   (let ((newres (map common:cron-expand x)))
-		     (append x newres))
-		   (cons x res)))
-	     '()
-	     cron-str)) ;; (map common:cron-expand cron-str))
-      (let ((cron-items (string-split cron-str))
-	    (slash-rx   (regexp "(\\d+)/(\\d+)"))
-	    (comma-rx   (regexp ".*,.*"))
-	    (max-vals   '((min        . 60)
-			  (hour       . 24)
-			  (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations
-			  (month      . 12)
-			  (dayofweek  . 7))))
-	(if (< (length cron-items) 5) ;; bad spec
-	    cron-str ;; `(,cron-str)              ;; just return the string, something downstream will fix it
-	    (let loop ((hed  (car cron-items))
-		       (tal  (cdr cron-items))
-		       (type 'min)
-		       (type-tal '(hour dayofmonth month dayofweek))
-		       (res  '()))
-	      (regex-case
-		  hed
-		(slash-rx ( _ base incr ) (let* ((basen          (string->number base))
-						 (incrn          (string->number incr))
-						 (expanded-vals  (common:expand-cron-slash basen incrn (alist-ref type max-vals)))
-						 (new-list-crons (fold (lambda (x myres)
-									 (cons (conc (if (null? res)
-											 ""
-											 (conc (string-intersperse res " ") " "))
-										     x " " (string-intersperse tal " "))
-									       myres))
-								       '() expanded-vals)))
-					    ;; (print "new-list-crons: " new-list-crons)
-					    ;; (fold (lambda (x res)
-					    ;; 	    (if (list? x)
-					    ;; 		(let ((newres (map common:cron-expand x)))
-					    ;; 		  (append x newres))
-					    ;; 		(cons x res)))
-					    ;; 	  '()
-					    (flatten (map common:cron-expand new-list-crons))))
-		;;					    (map common:cron-expand (map common:cron-expand new-list-crons))))
-		(else (if (null? tal)
-			  cron-str
-			  (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed)))))))))))
-
-;;======================================================================
-;; given a cron string and the last time event was processed return #t to run or #f to not run
-;;
-;;  min    hour   dayofmonth month  dayofweek
-;; 0-59    0-23   1-31       1-12   0-6          ### NOTE: dayofweek does not include 7
-;;
-;;  #t => yes, run the job
-;;  #f => no, do not run the job
-;;
-(define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW.
-  (let* ((cron-items     (map string->number (string-split cron-str)))
-	 (now-seconds    (or now-seconds-in (current-seconds)))
-	 (now-time       (seconds->local-time now-seconds))
-	 (last-done-time (seconds->local-time last-done))
-	 (all-times      (make-hash-table)))
-    ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items))
-    (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings
-	#f
-	(match-let (((     cmin chour cdayofmonth cmonth    cdayofweek)
-		     cron-items)
-		    ;; 0     1    2        3         4    5      6
-		    ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9)
-		     (vector->list now-time))
-		    ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9)
-		     (vector->list last-done-time)))
-	  ;; create all possible time slots
-	  ;; remove invalid slots due to (for example) day of week
-	  ;; get the start and end entries for the ref-seconds (current) time
-	  ;; if last-done > ref-seconds => this is an ERROR!
-	  ;; does the last-done time fall in the legit region?
-	  ;;    yes => #f  do not run again this command
-	  ;;    no  => #t  ok to run the command
-	  (for-each ;; month
-	   (lambda (month)
-	     (for-each ;; dayofmonth
-	      (lambda (dom)
-		(for-each
-		 (lambda (hr) ;; hour
-		   (for-each
-		    (lambda (minute) ;; minute
-		      (let ((copy-now (apply vector (vector->list now-time))))
-			(vector-set! copy-now 0 0) ;; force seconds to zero
-			(vector-set! copy-now 1 minute)
-			(vector-set! copy-now 2 hr)
-			(vector-set! copy-now 3 dom)  ;; dom is already corrected for zero referenced
-			(vector-set! copy-now 4 month)
-			(let* ((copy-now-secs (local-time->seconds copy-now))
-			       (new-copy      (seconds->local-time copy-now-secs))) ;; remake the time vector
-			  (if (or (not cdayofweek)
-				  (equal? (vector-ref new-copy 6)
-					  cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified
-			      (if (or (not cdayofmonth)
-				      (equal? (vector-ref new-copy 3)
-					      (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified
-				  (hash-table-set! all-times copy-now-secs new-copy))))))
-		    (if cmin
-			`(,cmin)  ;; if given cmin, have to use it
-			(list (- nmin 1) nmin (+ nmin 1))))) ;; minute
-		 (if chour
-		     `(,chour)
-		     (list (- nhour 1) nhour (+ nhour 1))))) ;; hour
-	      (if cdayofmonth
-		  `(,cdayofmonth)
-		  (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1)))))
-	   (if cmonth
-	       `(,cmonth)
-	       (list (- nmonth 1) nmonth (+ nmonth 1))))
-	  (let ((before #f)
-		(is-in  #f))
-	    (for-each
-	     (lambda (moment)
-	       (if (and before
-			(<= before now-seconds)
-			(>= moment now-seconds))
-		   (begin
-		     ;; (print)
-		     ;; (print "Before: " (time->string (seconds->local-time before)))
-		     ;; (print "Now:    " (time->string (seconds->local-time now-seconds)))
-		     ;; (print "After:  " (time->string (seconds->local-time moment)))
-		     ;; (print "Last:   " (time->string (seconds->local-time last-done)))
-		     (if (<  last-done before)
-			 (set! is-in before))
-		     ))
-	       (set! before moment))
-	     (sort (hash-table-keys all-times) <))
-	    is-in)))))
-
-(define (common:extended-cron  cron-str now-seconds-in last-done)
-  (let ((expanded-cron (common:cron-expand cron-str)))
-    (if (string? expanded-cron)
-	(common:cron-event expanded-cron now-seconds-in last-done)
-	(let loop ((hed (car expanded-cron))
-		   (tal (cdr expanded-cron)))
-	  (if (common:cron-event hed now-seconds-in last-done)
-	      #t
-	      (if (null? tal)
-		  #f
-		  (loop (car tal)(cdr tal))))))))
-
 ;;======================================================================
 ;; C O L O R S
 ;;======================================================================
       
 (define (common:name->iup-color name)

Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -23,15 +23,28 @@
 (use srfi-69)
 
 (module commonmod
 	*
 
-(import scheme chicken data-structures extras files)
-(import (prefix sqlite3 sqlite3:)
-	posix typed-records srfi-18 srfi-69
-	md5 message-digest
-	regex srfi-1)
+(import scheme
+	chicken
+
+	(prefix sqlite3 sqlite3:)
+	data-structures
+	extras
+	files
+	matchable
+	md5
+	message-digest
+	posix
+	regex
+	regex-case
+	srfi-1
+	srfi-18
+	srfi-69
+	typed-records
+	)
 
 ;;======================================================================
 ;; CONTENTS
 ;;
 ;;  config file utils
@@ -208,18 +221,304 @@
   (let ((adat (get-section cfgdat "areas")))
     (map (lambda (entry)
 	   `(,(car entry) . 
 	     ,(val->alist (cadr entry))))
 	 adat)))
+
+;;======================================================================
+;; time utils
+;;======================================================================
+
+(define (common:human-time)
+  (time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S"))
+
+;;======================================================================
+;; T I M E   A N D   D A T E
+;;======================================================================
+
+;;======================================================================
+;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
+(define (common:hms-string->seconds tstr)
+  (let ((parts     (string-split-fields "\\w+" tstr))
+	(time-secs 0)
+	;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks
+	(trx       (regexp "(\\d+)([smhdMyw])")))
+    (for-each (lambda (part)
+		(let ((match  (string-match trx part)))
+		  (if match
+		      (let ((val (string->number (cadr match)))
+			    (unt (caddr match)))
+			(if val 
+			    (set! time-secs (+ time-secs (* val
+							    (case (string->symbol unt)
+							      ((s) 1)
+							      ((m) 60) ;; minutes
+							      ((h) 3600)
+							      ((d) 86400)
+							      ((w) 604800)
+							      ((M) 2628000) ;; aproximately one month
+							      ((y) 31536000)
+							      (else #f))))))))))
+	      parts)
+    time-secs))
+		       
+(define (seconds->hr-min-sec secs)
+  (let* ((hrs (quotient secs 3600))
+	 (min (quotient (- secs (* hrs 3600)) 60))
+	 (sec (- secs (* hrs 3600)(* min 60))))
+    (conc (if (> hrs 0)(conc hrs "hr ") "")
+	  (if (> min 0)(conc min "m ")  "")
+	  sec "s")))
+
+(define (seconds->time-string sec)
+  (time->string 
+   (seconds->local-time sec) "%H:%M:%S"))
+
+(define (seconds->work-week/day-time sec)
+  (time->string
+   (seconds->local-time sec) "ww%V.%u %H:%M"))
+
+(define (seconds->work-week/day sec)
+  (time->string
+   (seconds->local-time sec) "ww%V.%u"))
+
+(define (seconds->year-work-week/day sec)
+  (time->string
+   (seconds->local-time sec) "%yww%V.%w"))
+
+(define (seconds->year-work-week/day-time sec)
+  (time->string
+   (seconds->local-time sec) "%Yww%V.%w %H:%M"))
+
+(define (seconds->year-week/day-time sec)
+  (time->string
+   (seconds->local-time sec) "%Yw%V.%w %H:%M"))
+
+(define (seconds->quarter sec)
+  (case (string->number
+	 (time->string 
+	  (seconds->local-time sec)
+	  "%m"))
+    ((1 2 3) 1)
+    ((4 5 6) 2)
+    ((7 8 9) 3)
+    ((10 11 12) 4)
+    (else #f)))
+
+;;======================================================================
+;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch
+;;
+(define (common:date-time->seconds datetime)
+  (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S")))
+
+;;======================================================================
+;; given span of seconds tstart to tend
+;; find start time to mark and mark delta
+;;
+(define (common:find-start-mark-and-mark-delta tstart tend)
+  (let* ((deltat   (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
+	 (result   #f)
+	 (min      60)
+	 (hr       (* 60 60))
+	 (day      (* 24 hr))
+	 (yr       (* 365 day)) ;; year
+	 (mo       (/ yr 12))
+	 (wk       (* day 7)))
+    (for-each
+     (lambda (max-blks)
+       (for-each
+	(lambda (span) ;; 5 2 1
+	  (if (not result)
+	      (for-each 
+	       (lambda (timeunit timesym) ;; year month day hr min sec
+		 (if (not result)
+		     (let* ((time-blk (* span timeunit))
+			    (num-blks (quotient deltat time-blk)))
+		       (if (and (> num-blks 4)(< num-blks max-blks))
+			   (let ((first (* (quotient tstart time-blk) time-blk)))
+			     (set! result (list span timeunit time-blk first timesym))
+			     )))))
+	       (list yr mo wk day hr min 1)
+	       '(     y  mo w  d   h  m   s))))
+	(list 8 6 5 2 1)))
+     '(5 10 15 20 30 40 50 500))
+    (if values
+	(apply values result)
+	(values 0 day 1 0 'd))))
+
+;;======================================================================
+;; given x y lim return the cron expansion
+;;
+(define (common:expand-cron-slash x y lim)
+  (let loop ((curr x)
+	     (res  `()))
+    (if (< curr lim)
+	(loop (+ curr y) (cons curr res))
+	(reverse res))))
+
+;;======================================================================
+;; expand a complex cron string to a list of cron strings
+;;
+;;  x/y   => x, x+y, x+2y, x+3y while x+Ny<max_for_field
+;;  a,b,c => a, b ,c
+;;
+;;   NOTE: with flatten a lot of the crud below can be factored down.
+;;
+(define (common:cron-expand cron-str)
+  (if (list? cron-str)
+      (flatten
+       (fold (lambda (x res)
+	       (if (list? x)
+		   (let ((newres (map common:cron-expand x)))
+		     (append x newres))
+		   (cons x res)))
+	     '()
+	     cron-str)) ;; (map common:cron-expand cron-str))
+      (let ((cron-items (string-split cron-str))
+	    (slash-rx   (regexp "(\\d+)/(\\d+)"))
+	    (comma-rx   (regexp ".*,.*"))
+	    (max-vals   '((min        . 60)
+			  (hour       . 24)
+			  (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations
+			  (month      . 12)
+			  (dayofweek  . 7))))
+	(if (< (length cron-items) 5) ;; bad spec
+	    cron-str ;; `(,cron-str)              ;; just return the string, something downstream will fix it
+	    (let loop ((hed  (car cron-items))
+		       (tal  (cdr cron-items))
+		       (type 'min)
+		       (type-tal '(hour dayofmonth month dayofweek))
+		       (res  '()))
+	      (regex-case
+		  hed
+		(slash-rx ( _ base incr ) (let* ((basen          (string->number base))
+						 (incrn          (string->number incr))
+						 (expanded-vals  (common:expand-cron-slash basen incrn (alist-ref type max-vals)))
+						 (new-list-crons (fold (lambda (x myres)
+									 (cons (conc (if (null? res)
+											 ""
+											 (conc (string-intersperse res " ") " "))
+										     x " " (string-intersperse tal " "))
+									       myres))
+								       '() expanded-vals)))
+					    ;; (print "new-list-crons: " new-list-crons)
+					    ;; (fold (lambda (x res)
+					    ;; 	    (if (list? x)
+					    ;; 		(let ((newres (map common:cron-expand x)))
+					    ;; 		  (append x newres))
+					    ;; 		(cons x res)))
+					    ;; 	  '()
+					    (flatten (map common:cron-expand new-list-crons))))
+		;;					    (map common:cron-expand (map common:cron-expand new-list-crons))))
+		(else (if (null? tal)
+			  cron-str
+			  (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed)))))))))))
+
+;;======================================================================
+;; given a cron string and the last time event was processed return #t to run or #f to not run
+;;
+;;  min    hour   dayofmonth month  dayofweek
+;; 0-59    0-23   1-31       1-12   0-6          ### NOTE: dayofweek does not include 7
+;;
+;;  #t => yes, run the job
+;;  #f => no, do not run the job
+;;
+(define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW.
+  (let* ((cron-items     (map string->number (string-split cron-str)))
+	 (now-seconds    (or now-seconds-in (current-seconds)))
+	 (now-time       (seconds->local-time now-seconds))
+	 (last-done-time (seconds->local-time last-done))
+	 (all-times      (make-hash-table)))
+    ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items))
+    (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings
+	#f
+	(match-let (((     cmin chour cdayofmonth cmonth    cdayofweek)
+		     cron-items)
+		    ;; 0     1    2        3         4    5      6
+		    ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9)
+		     (vector->list now-time))
+		    ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9)
+		     (vector->list last-done-time)))
+	  ;; create all possible time slots
+	  ;; remove invalid slots due to (for example) day of week
+	  ;; get the start and end entries for the ref-seconds (current) time
+	  ;; if last-done > ref-seconds => this is an ERROR!
+	  ;; does the last-done time fall in the legit region?
+	  ;;    yes => #f  do not run again this command
+	  ;;    no  => #t  ok to run the command
+	  (for-each ;; month
+	   (lambda (month)
+	     (for-each ;; dayofmonth
+	      (lambda (dom)
+		(for-each
+		 (lambda (hr) ;; hour
+		   (for-each
+		    (lambda (minute) ;; minute
+		      (let ((copy-now (apply vector (vector->list now-time))))
+			(vector-set! copy-now 0 0) ;; force seconds to zero
+			(vector-set! copy-now 1 minute)
+			(vector-set! copy-now 2 hr)
+			(vector-set! copy-now 3 dom)  ;; dom is already corrected for zero referenced
+			(vector-set! copy-now 4 month)
+			(let* ((copy-now-secs (local-time->seconds copy-now))
+			       (new-copy      (seconds->local-time copy-now-secs))) ;; remake the time vector
+			  (if (or (not cdayofweek)
+				  (equal? (vector-ref new-copy 6)
+					  cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified
+			      (if (or (not cdayofmonth)
+				      (equal? (vector-ref new-copy 3)
+					      (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified
+				  (hash-table-set! all-times copy-now-secs new-copy))))))
+		    (if cmin
+			`(,cmin)  ;; if given cmin, have to use it
+			(list (- nmin 1) nmin (+ nmin 1))))) ;; minute
+		 (if chour
+		     `(,chour)
+		     (list (- nhour 1) nhour (+ nhour 1))))) ;; hour
+	      (if cdayofmonth
+		  `(,cdayofmonth)
+		  (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1)))))
+	   (if cmonth
+	       `(,cmonth)
+	       (list (- nmonth 1) nmonth (+ nmonth 1))))
+	  (let ((before #f)
+		(is-in  #f))
+	    (for-each
+	     (lambda (moment)
+	       (if (and before
+			(<= before now-seconds)
+			(>= moment now-seconds))
+		   (begin
+		     ;; (print)
+		     ;; (print "Before: " (time->string (seconds->local-time before)))
+		     ;; (print "Now:    " (time->string (seconds->local-time now-seconds)))
+		     ;; (print "After:  " (time->string (seconds->local-time moment)))
+		     ;; (print "Last:   " (time->string (seconds->local-time last-done)))
+		     (if (<  last-done before)
+			 (set! is-in before))
+		     ))
+	       (set! before moment))
+	     (sort (hash-table-keys all-times) <))
+	    is-in)))))
+
+(define (common:extended-cron  cron-str now-seconds-in last-done)
+  (let ((expanded-cron (common:cron-expand cron-str)))
+    (if (string? expanded-cron)
+	(common:cron-event expanded-cron now-seconds-in last-done)
+	(let loop ((hed (car expanded-cron))
+		   (tal (cdr expanded-cron)))
+	  (if (common:cron-event hed now-seconds-in last-done)
+	      #t
+	      (if (null? tal)
+		  #f
+		  (loop (car tal)(cdr tal))))))))
+
+
 
 ;;======================================================================
 ;; misc stuff
 ;;======================================================================
 
-;; (define (debug:print . params) #f)
-;; (define (debug:print-info . params) #f)
-;; 
-;; (define (set-functions dbgp dbgpinfo)
-;;   (set! debug:print dbgp)
-;;   (set! debug:print-info dbgpinfo))
+(define (common:get-signature str)
+  (message-digest-string (md5-primitive) str))
 
 )

Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -922,12 +922,14 @@
 
 ;; Server? Start up here.
 ;;
 (if (args:get-arg "-server")
     (let ((tl        (launch:setup)))
-      ;; (server:launch 0 'http)
-      (http-transport:launch)
+      (case (rmt:transport-mode)
+	((http)(http-transport:launch))
+	((tcp) (tt:start-server tl))
+	(else (debug:print 0 "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode))))
       (set! *didsomething* #t)))
 
 ;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
 ;; a specific Megatest area. Detail are being hashed out and this may change.
 ;;

Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -22,10 +22,11 @@
      sxml-modifications matchable)
 
 (declare (unit runs))
 (declare (uses db))
 (declare (uses common))
+(declare (uses commonmod))
 (declare (uses items))
 (declare (uses runconfig))
 (declare (uses tests))
 (declare (uses server))
 (declare (uses mt))
@@ -37,10 +38,12 @@
 (include "db_records.scm")
 (include "run_records.scm")
 (include "test_records.scm")
 
 ;; (include "debugger.scm")
+
+(import commonmod)
 
 ;; use this struct to facilitate refactoring
 ;;
 
 (defstruct runs:dat

Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -101,24 +101,24 @@
   (if *server-id* *server-id*
       (let ((sig (server:mk-signature))) ;; clients re-use the server:mk-signature logic
         (set! *server-id* sig)
         *server-id*)))
 
-;; When using zmq this would send the message back (two step process)
-;; with spiffy or rpc this simply returns the return data to be returned
-;; 
-(define (server:reply return-addr query-sig success/fail result)
-  (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
-  ;; (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)))
-    ((fs)   result)
-    (else 
-     (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
-     result)))
+;; ;; When using zmq this would send the message back (two step process)
+;; ;; with spiffy or rpc this simply returns the return data to be returned
+;; ;; 
+;; (define (server:reply return-addr query-sig success/fail result)
+;;   (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
+;;   ;; (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)))
+;;     ((fs)   result)
+;;     (else 
+;;      (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
+;;      result)))
 
 ;; Given an area path,  start a server process    ### NOTE ### > file 2>&1 
 ;; if the target-host is set 
 ;; try running on that host
 ;;   incidental: rotate logs in logs/ dir.

Index: tcp-transportmod.scm
==================================================================
--- tcp-transportmod.scm
+++ tcp-transportmod.scm
@@ -24,40 +24,59 @@
 
 (module tcp-transportmod
 	*
 	
   (import scheme
+	  (prefix sqlite3 sqlite3:)
 	  chicken
 	  data-structures
+	  directory-utils
 	  extras
-	  matchable)
-  
-(import (prefix sqlite3 sqlite3:)
-	posix typed-records srfi-18 srfi-1
-	srfi-69
-	stack
-	files
-	ports
-
-	commonmod
-	;; debugprint
+	  files
+	  hostinfo
+	  matchable
+	  md5
+	  message-digest
+	  ports
+	  posix
+	  srfi-1
+	  srfi-18
+	  srfi-4
+	  srfi-69
+	  stack
+	  typed-records
+	  
+	  commonmod
+	  debugprint
 	)
 
 ;;======================================================================
 ;; client
 ;;======================================================================
 
 ;; (define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic
 
 (defstruct tt
-  (area #f)
+  ;; all
+  (areapath #f)
+  ;; client related
   (conns (make-hash-table)) ;; dbfname -> conn
-  
+  ;; server related
+  (cleanup-proc #f)
   )
+
+(defstruct tt-conn
+  host
+  port
+  dbfname
+)
 
 (define (tt:make-remote areapath)
   (make-tt area: areapath))
+
+(define (tt:client-connect-to-server ttdat)
+  #f)
 
 (define (tt:handler runremote cmd rid params attemptnum area-dat areapath readonly-mode dbfname)
   ;; NOTE: areapath is passed in and in tt struct. We'll use passed in value for now.
   (let* ((conn (hash-table-ref/default (tt-conns runremote) dbfname #f)))
     (if conn
@@ -70,11 +89,11 @@
 	   (else
 	    res)))
 	;; no conn yet, find and or start and find a server
 	(let* ((server (tt:find-server areapath dbfname)))
 	  (if server
-	      (let* ((conn (tt:server-connect server)))
+	      (let* ((conn (tt:client-connect-to-server server)))
 		(hash-table-set! (tt-conns runremote) dbfname conn)
 		(tt:handler  runremote cmd rid params attemptnum area-dat areapath readonly-mode dbfname))
 	      ;; no server, try to start one
 	      (begin
 		(tt:start-server areapath dbfname)
@@ -95,20 +114,101 @@
 ;;======================================================================
 
 (define (tt:sync-dbs ttdat)
   #f)
 
+;; start the listener and start responding to requests
+;;
 (define (tt:start-server ttdat)
   #f)
 
-(define (tt:server-connect ttdat)
-  #f)
-
-(define (tt:find-server ttdat)
-  #f)
-
 (define (tt:shutdown-server ttdat)
-  #f)
+  (let* ((cleanproc (tt-cleanup-proc ttdat)))
+    (if cleanproc (cleanproc))
+    ;; close up ports here
+    #f))
+
+;; return servid
+;; side-effects:
+;;   ttdat-cleanup-proc is populated with function to remove the serverinfo file
+(define (tt:create-server-registration-file ttdat dbfname)
+  (let* ((areapath (tt-areapath ttdat))
+	 (servdir  (tt:get-servinfo-dir areapath))
+	 (conn     (hash-table-ref/default (tt-conns ttdat) dbfname #f)))
+    (assert conn "FATAL: tt:create-server-registration-file called with no conn, dbfname="dbfname)
+    (let* ((host    (tt-conn-host conn))
+	   (port    (tt-conn-port conn))
+	   (servinf (conc servdir"/"host":"port"-"(current-process-id)":"dbfname))
+	   (serv-id (tt:mk-signature areapath))
+	   (clean-proc (lambda ()
+			 (delete-file* servinf))))
+      (tt-cleanup-proc-set! ttdat clean-proc)
+      (with-output-to-file servinf
+	(lambda ()
+	  (print "SERVER STARTED: "host":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id))))
+      serv-id)))
+
+;; find valid server
+;; get servers listed, last part of name must match :<dbfname>
+;; if more than one, wait one second and look again
+;; future: ping oldest, if alive remove other :<dbfname> files
+;;
+(define (tt:find-server ttdat dbfname)
+  (let* ((areapath (tt-areapath ttdat))
+	 (servdir  (tt:get-servinfo-dir areapath))
+	 (sfiles   (glob (conc servdir"/*:"dbfname))))
+    sfiles))
+
+;; Given an area path,  start a server process    ### NOTE ### > file 2>&1 
+;; if the target-host is set 
+;; try running on that host
+;;   incidental: rotate logs in logs/ dir.
+;;
+(define  (tt:server-process-run areapath testsuite mtexe #!key (profile-mode "")) ;; areapath is *toppath* for a given testsuite area
+  (let* ((logfile   (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log"))
+	 (cmdln     (conc
+		     mtexe
+		     " -server - ";; (or target-host "-")
+		     " -m testsuite:" testsuite
+		     " " profile-mode
+		     ))) ;; (conc " >> " logfile " 2>&1 &")))))
+    ;; we want the remote server to start in *toppath* so push there
+    (push-directory areapath)
+    (debug:print 0 *default-log-port* "INFO: Trying to start server in tcp mode (" cmdln ") ...")
+    (debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time))
+    (system (conc "nbfake " cmdln))
+    (pop-directory)))
+
+;;======================================================================
+;; utils
+;;======================================================================
+
+;; Generate a unique signature for this server
+(define (tt:mk-signature areapath)
+  (message-digest-string (md5-primitive) 
+			 (with-output-to-string
+			   (lambda ()
+			     (write (list areapath
+                                          (current-process-id)
+					  (argv)))))))
+
+
+(define (tt:get-best-guess-address hostname)
+  (let ((res #f))
+    (for-each 
+     (lambda (adr)
+       (if (not (eq? (u8vector-ref adr 0) 127))
+	   (set! res adr)))
+     ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
+     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
+    (string-intersperse 
+     (map number->string
+	  (u8vector->list
+	   (if res res (hostname->ip hostname)))) ".")))
 
-
+(define (tt:get-servinfo-dir areapath)
+  (let* ((spath (conc areapath"/.servinfo")))
+    (if (not (file-exists? spath))
+	(create-directory spath #t))
+    spath))
 
 )