@@ -1,7 +1,7 @@
 
-;; Copyright 2006-2012, Matthew Welland.
+;; Copyright 2006-2017, Matthew Welland.
 ;; 
 ;;  This program is made available under the GNU GPL version 2.0 or
 ;;  greater. See the accompanying file COPYING for details.
 ;; 
 ;;  This program is distributed WITHOUT ANY WARRANTY; without even the
@@ -8,12 +8,12 @@
 ;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
 ;;  PURPOSE.
 
 (require-extension (srfi 18) extras tcp s11n)
 
-(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils posix-extras matchable)
-;; (use zmq)
+(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils posix-extras matchable
+     )
 
 (use spiffy uri-common intarweb http-client spiffy-request-vars)
 
 (declare (unit server))
 
@@ -20,12 +20,10 @@
 (declare (uses common))
 (declare (uses db))
 (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
 ;; (declare (uses synchash))
 (declare (uses http-transport))
-(declare (uses rpc-transport))
-;;(declare (uses nmsg-transport))
 (declare (uses launch))
 (declare (uses daemon))
 
 (include "common_records.scm")
 (include "db_records.scm")
@@ -34,10 +32,16 @@
   (if (not hostport)
       #f
       (conc "http://" (car hostport) ":" (cadr hostport))))
 
 (define  *server-loop-heart-beat* (current-seconds))
+
+;;======================================================================
+;; P K T S   S T U F F 
+;;======================================================================
+
+;; ???
 
 ;;======================================================================
 ;; S E R V E R
 ;;======================================================================
 
@@ -206,11 +210,25 @@
 		(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)))))))))
+		    (loop (car tal)(cdr tal) new-res)))))))))
+
+(define (server:get-num-alive srvlst)
+  (let ((num-alive 0))
+    (for-each
+     (lambda (server)
+       (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)))
+	   (if (< uptime 5)(set! num-alive (+ num-alive 1))))))
+     srvlst)
+    num-alive))
 
 ;; 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
 ;;
@@ -435,5 +453,92 @@
 	;; (* 3 24 60 60) ;; default to three days
 	;;(* 60 60 1)     ;; default to one hour
 	(* 60 5)          ;; default to five minutes
 	)))
 
+(define (server: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)))) ".")))
+
+;; moving this here as it needs access to db and cannot be in common.
+;;
+(define (server:writable-watchdog dbstruct)
+  (thread-sleep! 0.05) ;; delay for startup
+  (let ((legacy-sync  (common:run-sync?))
+	(debug-mode   (debug:debug-mode 1))
+	(last-time    (current-seconds))
+	(no-sync-db   (db:open-no-sync-db))
+        (this-wd-num  (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x))))
+    (set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls
+    (debug:print-info 2 *default-log-port* "Periodic sync thread started.")
+    (debug:print-info 3 *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))
+	       (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 ()
+	    ;; 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)
+					  (not recently-synced))))
+              (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop.  need-sync="need-sync" sync-in-progress="sync-in-progress" should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync)
+	      ;; (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 (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive
+		    (if (> res 0) ;; some records were transferred, keep the db alive
+			(begin
+			  (mutex-lock! *heartbeat-mutex*)
+			  (set! *db-last-access* (current-seconds))
+			  (mutex-unlock! *heartbeat-mutex*)
+			  (debug:print-info 0 *default-log-port* "sync called, " res " records transferred."))
+			(debug:print-info 2 *default-log-port* "sync called but zero records transferred"))))
+	      (if will-sync
+		  (begin
+		    (mutex-lock! *db-multi-sync-mutex*)
+		    (set! *db-sync-in-progress* #f)
+		    (set! *db-last-sync* start-time)
+		    (mutex-unlock! *db-multi-sync-mutex*)))
+	      (if (and debug-mode
+		       (> (- start-time last-time) 60))
+		  (begin
+		    (set! last-time start-time)
+		    (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
+	    
+	    ;; keep going unless time to exit
+	    ;;
+	    (if (not *time-to-exit*)
+		(let delay-loop ((count 0))
+                  ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
+                                                            
+		  (if (and (not *time-to-exit*)
+			   (< count 6)) ;; was 11, changing to 4. 
+		      (begin
+			(thread-sleep! 1)
+			(delay-loop (+ count 1))))
+		  (if (not *time-to-exit*) (loop))))
+	    ;; time to exit, close the no-sync db here
+	    (db:no-sync-close-db no-sync-db)
+	    (if (common:low-noise-print 30)
+		(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num)))))))
+