Megatest

;; (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
  port
  uuid
  dbfile


  )

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




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

;;======================================================================

    (handle-directory spiffy-directory-listing)
    (handle-exception (lambda (exn chain)
			(signal (make-composite-condition
				 (make-property-condition 
				  'server
				  'message "server error")))))

    ;; http-transport:handle-directory) ;; simple-directory-handler)
    ;; Setup the web server and a /ctrl interface
    ;;
    (vhost-map `(((* any) . ,(lambda (continue)
			       ;; open the db on the first call 
				 ;; This is were we set up the database connections
			       (let* (($   (request-vars source: 'both))
				      (dat ($ 'dat))
				      (res #f))
				 (cond
				  ((equal? (uri-path (request-uri (current-request)))
					   '(/ "api"))
				   (send-response ;; the $ is the request vars proc
				    body: ((http-get-function 'api:process-request) *dbstruct-db* $)
				    headers: '((content-type text/plain)))
				   (mutex-lock! *heartbeat-mutex*)
				   (set! *db-last-access* (current-seconds))
				   (mutex-unlock! *heartbeat-mutex*))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ ""))
				   (send-response body: ((http-get-function 'http-transport:main-page))))

  (set! *http-connections-next-cleanup* (+ (current-seconds) 10))
  (mutex-unlock! *http-mutex*))

(define (http-transport:inc-requests-and-prep-to-close-all-connections)
  (mutex-lock! *http-mutex*)
  (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)))





;; serverdat contains uuid to be used for connection validation
;;
;; TODO: translate http-transport:client-connect to use servdat

;;
(define (http-transport:basic-send-receive serverdat cmd params #!key (numretries 3))
  (let* ((fullurl    (servdat->url serverdat))
	 (res        #f)
	 (success    #t)
         (server-id  (servdat-uuid serverdat)))
       ;; set up the http-client here
    (max-retry-attempts 1)
    ;; consider all requests indempotent
    (retry-request? (lambda (request)
		      #f))
    ;; send the data and get the response extract the needed info from
    ;; the http data and process and return it.
    (let* ((send-recieve (lambda ()
			   (set! res
				 (vector
				  #t ;; success
				  (with-input-from-request
				   fullurl 
				   (list (cons 'key server-id)
					 (cons 'cmd cmd)
					 (cons 'params sparams))
				   read)))))
	      (time-out     (lambda ()
			      (thread-sleep! 45)
			      (debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!")
			      #f))
	      (th1 (make-thread send-recieve "with-input-from-request"))
	      (th2 (make-thread time-out     "time out")))
	 (thread-start! th1)
	 (thread-start! th2)
	 (thread-join! th1)
	 (close-idle-connections!)
	 (thread-terminate! th2)
	 (if (vector? res)
	     (if (vector-ref res 0) ;; this is the first flag or the second flag? 
                 (let* ((res-dat (vector-ref res 1)))
                    (if (and (string? res-dat) (string-contains res-dat "server-id mismatch"))
                     (signal (make-composite-condition
		          (make-property-condition 
		       'servermismatch
		       'message  (vector-ref res 1))))       
		      res)) ;; this is the *inner* vector? seriously? why?
                 (if (debug:debug-mode 11)
                     (let ((call-chain (get-call-chain))) ;; note: this code also called in nmsg-transport - consider consolidating it
                       (print-call-chain (current-error-port))
                       (debug:print-error 11 *default-log-port* "error above occured at server, res=" res) ;; " message: " ((condition-property-accessor 'exn 'message) exn))
                       (debug:print 11 *default-log-port* " server call chain:")
                       (pp (vector-ref res 1) (current-error-port))
                       (signal (vector-ref res 0)))
                     res))
	     (signal (make-composite-condition
		      (make-property-condition 
		       'timeout
		       'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))))

;; Send "cmd" with json payload "params" to serverdat and receive result
;;
(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)(area-dat #f))
  (let* ((fullurl    (if (vector? serverdat)
			 (http-transport:server-dat-get-api-req serverdat)
			 (begin
			   (debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info")
			   (exit 1))))
	 (res        (vector #f "uninitialized"))
	 (success    #t)
	 (sparams    (db:obj->string params transport: 'http))
	 (runremote  (or area-dat *runremote*))
         (server-id   (if (vector? serverdat) 
                           (http-transport:server-dat-get-server-id serverdat)
                           (begin
			     (debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info")
			     (exit 1)))))
       (debug:print-info 11 *default-log-port* "cmd=" cmd " fullurl=" fullurl " server-id=" server-id " current time:" (current-seconds)) 

       ;; set up the http-client here
       (max-retry-attempts 1)
       ;; consider all requests indempotent
       (retry-request? (lambda (request)
			 #f))
       ;; send the data and get the response
       ;; extract the needed info from the http data and 
       ;; process and return it.
       (let* ((send-recieve (lambda ()
			      (mutex-lock! *http-mutex*)
			      ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines)
			      ;;					       ((exn http client-error) e (print e)))
			      (set! res (vector                ;;; DON'T FORGET - THIS IS THE CLIENT SIDE! NOTE: consider moving this to client.scm since we are only supporting http transport at this time.
					 success
					 (db:string->obj 
					  (handle-exceptions
					      exn
					      (let ((call-chain (get-call-chain))
						    (msg        ((condition-property-accessor 'exn 'message) exn)))
						(set! success #f)
                                                (if (debug:debug-mode 1)
                                                    (debug:print-info 0 *default-log-port* "couldn't talk to server, trying again ...")
                                                    (begin
                                                      (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
                                                      (debug:print 0 *default-log-port* " message: " msg ", exn=" exn)
                                                      (debug:print 0 *default-log-port* " cmd: " cmd " params: " params " key:" (or server-id "thekey"))
                                                      (debug:print 0 *default-log-port* " call-chain: " call-chain)))
                                                (if runremote
						    (remote-conndat-set! runremote #f))
						;; Killing associated server to allow clean retry.")
						;; (tasks:kill-server-run-id run-id)  ;; better to kill the server in the logic that called this routine?
						(mutex-unlock! *http-mutex*)
					     ;;; (signal (make-composite-condition
					     ;;;          (make-property-condition 'commfail 'message "failed to connect to server")))
					     ;;; "communications failed"
						(db:obj->string #f))
					    (with-input-from-request ;; was dat
					     fullurl 
					     (list (cons 'key (or server-id   "thekey"))
						   (cons 'cmd cmd)
						   (cons 'params sparams))
					     read-string))
					  transport: 'http)
                                         0)) ;; added this speculatively
			      ;; Shouldn't this be a call to the managed call-all-connections stuff above?
			      (close-idle-connections!)
			      (mutex-unlock! *http-mutex*)
			      ))
	      (time-out     (lambda ()
			      (thread-sleep! 45)
			      (debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!")
			      #f))
	      (th1 (make-thread send-recieve "with-input-from-request"))
	      (th2 (make-thread time-out     "time out")))
	 (thread-start! th1)
	 (thread-start! th2)
	 (thread-join! th1)
          (vector-set! res 0 success)
	 (thread-terminate! th2)
	 (if (vector? res)
	     (if (vector-ref res 0) ;; this is the first flag or the second flag? 
                 (let* ((res-dat (vector-ref res 1)))
                    (if (and (string? res-dat) (string-contains res-dat "server-id mismatch"))
                     (signal (make-composite-condition
		          (make-property-condition 
		       'servermismatch
		       'message  (vector-ref res 1))))       
		      res)) ;; this is the *inner* vector? seriously? why?
                 (if (debug:debug-mode 11)
                     (let ((call-chain (get-call-chain))) ;; note: this code also called in nmsg-transport - consider consolidating it
                       (print-call-chain (current-error-port))
                       (debug:print-error 11 *default-log-port* "error above occured at server, res=" res) ;; " message: " ((condition-property-accessor 'exn 'message) exn))
                       (debug:print 11 *default-log-port* " server call chain:")
                       (pp (vector-ref res 1) (current-error-port))
                       (signal (vector-ref res 0)))
                     res))
	     (signal (make-composite-condition
		      (make-property-condition 
		       '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 #!key (area-dat #f))
  (let* ((runremote  (or area-dat *runremote*))
	 (server-dat (if runremote
                         (remote-conndat runremote)

;;
(define (http-transport:client-connect iface port server-id) 
  (let* ((api-url      (conc "http://" iface ":" port "/api"))
	 (api-uri      (uri-reference (conc "http://" iface ":" port "/api")))
	 (api-req      (make-request method: 'POST uri: api-uri))
	 (server-dat   (vector iface port api-uri api-url api-req (current-seconds) server-id)))
    server-dat))













;;======================================================================
;; NEW SERVER METHOD
;;======================================================================










(define *srvpktspec*
  `((server (host    . h)
	    (port    . p)
	    (servkey . k)
	    (pid     . i)
	    (ipaddr  . a)

		  (loop (cdr tail) new-best)))))))
	  
	  

;;======================================================================
;; END NEW SERVER METHOD
;;======================================================================

































































;; 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* ((run-id            (let ((rid (args:get-arg "-run-id"))) ;; consider getting rid of the -run-id mechanism
			      (if rid
				  (string->number rid)
				  #f)))
	 (db-file           (if dbname
				(db:dbname->path *toppath* dbname)
				(db:run-id->path *toppath* run-id)))
	 (sdat              #f)
	 ;; (tmp-area          (common:get-db-tmp-area))
	 (server-start-time (current-seconds))
	 (pkts-dir          (get-pkts-dir))
	 (server-key        (server:mk-signature))
	 (server-info (let loop ((start-time (current-seconds))
				 (changed    #t)
				 (last-sdat  "not this"))
                        (begin ;; let ((sdat #f))
			  (thread-sleep! 0.01)
			  (debug:print-info 0 *default-log-port* "Waiting for server alive signature")
                          (mutex-lock! *heartbeat-mutex*)
                          (set! sdat *server-info*)
                          (mutex-unlock! *heartbeat-mutex*)
                          (if (and sdat
				   (not changed)
				   (> (- (current-seconds) start-time) 2))
			      (begin
				(debug:print-info 0 *default-log-port* "Received server alive signature, now attempting to lock in server")
				;; create a server pkt in *toppath*/.meta/srvpkts

				;; TODO:
				;;   1. change sdat to stuct
				;;   2. add uuid to struct
				;;   3. update uuid in sdat here
				;;
				(servdat-uuid-set! sdat
						(register-server
						 pkts-dir *srvpktspec*
						 (get-host-name)
						 (servdat-port sdat) server-key
						 (servdat-host sdat) db-file))

				;; now read pkts and see if we are a contender
				(let* ((all-pkts     (get-all-server-pkts pkts-dir *srvpktspec*))
				       (viables      (get-viable-servers all-pkts db-file))
				       (best-srv     (get-best-candidate viables db-file))
				       (best-srv-key (if best-srv (alist-ref 'servkey best-srv) #f)))
				  (debug:print 0 *default-log-port* "best-srv-key: "best-srv-key", server-key: "server-key)
				  ;; am I the best-srv, compare server-keys to know
				  (if (equal? best-srv-key server-key)
				      (if (db:get-main-lock db-file)
					  (begin
					    (debug:print 0 *default-log-port* "I'm the server!")
					    (servdat-dbfile-set! sdat db-file))
					  (begin
					    (debug:print 0 *default-log-port* "I'm not the server, exiting.")
					    (bdat-time-to-exit-set! *bdat* #t)
					    (thread-sleep! 0.2)
					    (exit)))
				      (begin
					(debug:print 0 *default-log-port*
						     "Keys do not match "best-srv-key", "server-key", exiting.")
					(bdat-time-to-exit-set! *bdat* #t)
					(thread-sleep! 0.2)
					(exit)))
				  sdat))
                              (begin
				(debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat)
                                (sleep 4)
				(if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes
				    (begin
				      (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")
                                      #;(common:save-pkt `((action . died)
                                                         (T      . server)
                                                         (pid    . ,(current-process-id))
                                                         (ipaddr . ,(car sdat))
                                                         (port   . ,(cadr sdat))
                                                         (msg    . "Transport died?"))
						       *configdat* #t)
				      (exit))
				    (loop start-time
					  (equal? sdat last-sdat)
					  sdat)))))))
	 (iface       (servdat-host server-info))
         (port        (servdat-port server-info))
         (last-access 0)
	 (server-timeout (server:expiration-timeout))
	 (server-log-file (args:get-arg "-log"))) ;; always set when we are a server

    (let loop ((count         0)

                               "Keep running"))))
      (thread-start! th2)
      (thread-sleep! 0.252) ;; 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
;;    (debug:print 0 *default-log-port* " ... exiting ...")
;;    (let ((th1 (make-thread (lambda ()
;; 			     (thread-sleep! 1))
;; 			   "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! 3) ;; give the flush three seconds 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))))

	    
;; Generate a unique signature for this server
(define (server:mk-signature)
  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list (current-directory)