Megatest

	)

(defstruct alldat
  (areapath #f)
  (ulexdat  #f)
  )


;; (require-extension (srfi 18) extras tcp s11n)
;; 
;; 
;; (use  srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras)
;; 
;; (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)
;; 
;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048) 

(defstruct servdat
  (host #f)
  (port #f)
  (uuid #f)
  (dbfile #f)
  (api-url #f)
  (api-uri #f)
  (api-req #f)
  (status 'starting))

(define (servdat->url sdat)
  (conc (servdat-host sdat)":"(servdat-port sdat)))

;; (include "db_records.scm")

;;======================================================================
;; return the handle struct for sending queries to a specific database
;;  - initializes the connection object if this is the first access
;;    - finds the "captain" and asks who to talk to for the given dbfname
;;    - establishes the connection to the current dbowner

		       (begin
			 (bdat-time-to-exit-set! *bdat* #t)
			 #t))))
    (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
    (if (and no-hurry (debug:debug-mode 18))
	(rmt:print-db-stats))
    (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds

                              (if *server-info*
				  (let ((pkt-file (conc (get-pkts-dir *toppath*)
							"/" (servdat-uuid *server-info*)
							".pkt"))
					(dbfile   (servdat-dbfile *server-info*)))
				    (if dbfile
					(begin

					      (rmt:send-receive-real *rmt:remote* *toppath*
								     (db:run-id->dbname #f)
								     'deregister-server
								     `(,(servdat-uuid sdat)
								       ,(current-process-id)
								       ,(servdat-host sdat)   ;; iface
								       ,(servdat-port sdat)))))))))
			      (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
			      (if (bdat-task-db *bdat*)    ;; TODO: Check that this is correct for task db
				  (let ((db (cdr (bdat-task-db *bdat*))))
				    (if (sqlite3:database? db)
					(begin
					  (sqlite3:interrupt! db)
					  (sqlite3:finalize! db #t)
					  (bdat-task-db-set! *bdat* #f)))))

  (let* ((sdat       (servdat-init #f host port server-id)))
    (rmt:send-receive sdat 'ping '())))

;;======================================================================
;; http-transportmod.scm contents moved here
;;======================================================================
























(define (http-transport:make-server-url hostport)
  (if (not hostport)
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

;;======================================================================
;; S E R V E R

								   ,(current-process-id)
								   ,iface
								   ,apath
								   ,dbname)))

(define (http-transport:wait-for-stable-interface #!optional (num-tries-allowed 100))
  ;; wait until *server-info* stops changing
  (let* ((stime (current-seconds)))
    (let loop ((sdat  #f) ;; this is our copy of the *last* *server-info*
	       (tries 0))
      ;; first we verify port and interface, update *server-info* in need be.
      (cond
       ((> tries num-tries-allowed)
	(debug:print 0 *default-log-port* "http-transport:keep-running, giving up after trying for several minutes.")
	(exit 1))
       ((not *server-info*)
	(thread-sleep! 0.25)
	(loop *server-info* (+ tries 1)))
       ((not sdat)
	(debug:print 0 *default-log-port* "http-transport:keep-running, still no interface, tries="tries)
	(thread-sleep! 0.25)
	(loop *server-info* (+ tries 1)))
       ((or (not (equal? (servdat-host sdat)(servdat-host *server-info*)))
	    (not (equal? (servdat-port sdat)(servdat-port *server-info*))))
	(debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info")
	(thread-sleep! 0.25)
	(loop *server-info* (+ tries 1)))
       ((< (- (current-seconds) stime) 3) ;; keep up the looping until at least 3 seconds have passed
	(thread-sleep! 1)
	(loop *server-info* (+ tries 1)))
       (else
	(if (not *server-id*)(set! *server-id* (server:mk-signature)))
	(servdat-status-set! *server-info* 'interface-alive)
	(debug:print 0 *default-log-port*
		     "SERVER STARTED: " (servdat-host *server-info*)
		     ":" (servdat-port *server-info*)
		     " AT " (current-seconds) " server-id: " *server-id*)
	(flush-output *default-log-port*)
	#t)))))

;; 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 dbname) 
  ;; 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")

  (let* ((server-start-time (current-seconds))
	 (pkts-dir          (get-pkts-dir))
	 (server-key        (server:mk-signature))
	 (is-main           (equal? (args:get-arg "-db") ".db/main.db"))
	 (last-access       0)
	 (server-timeout    (server:expiration-timeout)))
    ;; exits if nothing found in 100 tries (switch to a duration would be good)
    (http-transport:wait-for-stable-interface)
    (if is-main (http-transport:wait-for-server pkts-dir dbname server-key))
    ;; this is our forever loop
    (let* ((iface             (servdat-host *server-info*))
	   (port              (servdat-port *server-info*)))
      (let loop ((count         0)

		 (bad-sync-count 0)
		 (start-time     (current-milliseconds)))
	(debug:print-info 0 *default-log-port* "servdat-status is " (servdat-status *server-info*) ", is-main="is-main)
	;; set up the database handle
	(if (not *dbstruct-db*) ;; no db opened yet, open the db and register with main if appropriate
	    (let ((watchdog (bdat-watchdog *bdat*)))		 
	      (debug:print 0 *default-log-port* "SERVER: dbprep")
	      (db:setup dbname) ;; sets *dbstruct-db* as side effect
	      
	      ;; IFF I'm not main, call into main and register self
	      (if (not is-main)
		  (let ((res (rmt:register-server *rmt:remote*
						  *toppath* iface port
						  server-key dbname)))
		    (if res ;; we are not the server!
			(servdat-status-set! *server-info* 'have-interface-and-db)
			(begin
			  (debug:print 0 *default-log-port* "We are not the server for "dbname", exiting.")
			  (exit)))))
	      (debug:print 0 *default-log-port*
			   "SERVER: running, megatest version: "
			   (common:get-full-version)) 
	      (if watchdog
		  (if (not (member (thread-state watchdog)
				   '(ready running blocked
					   sleeping dead)))
		      (begin
			(debug:print-info 0 *default-log-port* "Starting watchdog thread (in state "(thread-state watchdog)")")
			(thread-start! watchdog)))
		  (debug:print 0 *default-log-port* "ERROR: *watchdog* not setup, cannot start it."))
	      (loop (+ count 1) bad-sync-count start-time)))
	
	;; 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)))
	  (if (and (<= rem-time 4)
		   (>  rem-time 0))
	      (thread-sleep! rem-time)))
	
	(if (< count 1) ;; 3x3 = 9 secs aprox
	    (loop (+ count 1) bad-sync-count (current-milliseconds)))
	
	;; 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 60 "dbstats")
	    (begin
	      (debug:print 0 *default-log-port* "Server stats:")
	      (db:print-current-query-stats)))
	(let* ((hrs-since-start  (/ (- (current-seconds) server-start-time) 3600)))
	  (cond
	   ((and *server-run*
		 (> (+ last-access server-timeout)
		    (current-seconds)))
	    (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)))
	    (loop 0 bad-sync-count (current-milliseconds)))
	   (else
	    (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)
  (begin
    ;;(BB> "http-transport:server-shutdown called")

;;     (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j")))
;;  (list "test1" "test2" "test3" "test4" "test5"))
;; 
;; 
;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))
;; 

;; (exit)