Megatest

;; http-server  send-response
;;                 api:process-request
;;                    db:*
;;
;; NB// Runs on the server as part of the server loop
;;
(define (api:process-request dbstruct indat) ;; the $ is the request vars proc
  (debug:print 0 *default-log-port* "server-id:"  *server-id*)
  (let* ((cmd-in  (alist-ref 'cmd indat)) ;; ($ 'cmd))
	 (cmd     (if (string? cmd-in)(string->symbol cmd-in) cmd-in))
	 (params  (string->sexpr (alist-ref 'params indat)))
         (key     (alist-ref 'key indat))    ;; TODO - add this back
	 )
    (debug:print 0 *default-log-port* "cmd:" cmd " with params " params "key " key)
    (if (equal? key "nokey") ;; *server-id*) ;; TODO - get real key involved
	(begin
	  (set! *api-process-request-count* (+ *api-process-request-count* 1))
	  (let* ((res (api:execute-requests dbstruct cmd params))) 
	    (debug:print 0 *default-log-port* "res:" res)

(define (string->sexpr instr)
  (handle-exceptions
   exn
   (begin
     (debug:print 0 *default-log-port* "ERROR: string->sexpr bad input \""instr"\"")
     #f)
   (with-input-from-string instr
     read)))

)

#!/bin/bash

(killall mtest -v;sleep 1;killall mtest -v -9;rm -f tests/simplerun/.db/* tests/simplerun/logs/* tests/basicserver.log) &
ck5 make -j install &&
wait  &&
script -c "ck5 make unit" 

	chicken.port
	chicken.pretty-print
	chicken.process
	chicken.process-context
	chicken.process-context.posix
	chicken.sort
	chicken.string
	;; chicken.tcp
	chicken.random
	chicken.time
	chicken.time.posix
	(prefix sqlite3 sqlite3:)
	
	directory-utils
	;; http-client
	;; intarweb
	matchable
	md5
	message-digest
	(prefix base64 base64:)
	(prefix sqlite3 sqlite3:)
	regex
	s11n
	;; spiffy
	;; spiffy-directory-listing
	;; spiffy-request-vars
	srfi-1
	srfi-13
	srfi-18
	srfi-69
	stack
	system-information
	tcp6
	typed-records
	uri-common
	z3
       
	apimod
	clientmod
	commonmod

;; 
;; 
;; (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) 

;; info about me as a server
;;
(defstruct servdat
  (host #f)
  (port #f)
  (uuid #f)

  (dbname   #f)
  (fullname #f)
  (hostport #f)
  (ipaddr   #f)
  (port     #f)
  (srvpkt   #f)
  (lastmsg  0)
  (expires  0)
  (inport   #f)
  (outport  #f))

;;======================================================================
;;  S U P P O R T   F U N C T I O N S
;;======================================================================

;; replaces *runremote*
(define *rmt:remote* (make-rmt:remote))

	   (if (list? res) ;; server has been registered and the info was returned. pass it on.
	       res
	       (begin
		 (debug:print-info 0 *default-log-port* "Unexpected result: " res)
		 res)))))))))

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


;; Defaults to current area
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f))
  (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote)))
  (let* ((apath *toppath*)
	 (conns *rmt:remote*)
	 (dbname (db:run-id->dbname rid)))
    (rmt:general-open-connection conns apath dbname)
    (rmt:send-receive-real conns apath dbname cmd params)))

(define (rmt:send-receive-setup conn)
  (if (not (rmt:conn-inport conn))
      (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn)
				      (rmt:conn-port conn))))
	(rmt:conn-inport-set! conn i)
	(rmt:conn-outport-set! conn o))))
  
;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future
;;
(define (rmt:send-receive-real remote apath dbname cmd params)
  (let* ((conn (rmt:get-conn remote apath dbname)))
    (assert conn "FATAL: rmt:send-receive-real called without the needed channels opened")
    (rmt:send-receive-setup conn)
    (let* ((key     #f)
	   (payload (sexpr->string `((cmd . ,cmd)
				     (key . ,key)
				     (params . ,params))))
	   (res      (begin
		       (write payload (rmt:conn-outport conn))
		       (with-input-from-port
			   (rmt:conn-inport conn)



			 read-string))))
      (if (string? res)
	  (string->sexpr res)
	  res))))



;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future.
;;
;; Purpose - call the main.db server and request a server be started
;; for the given area path and dbname
;;
(define (rmt:send-receive-server-start remote apath dbname)
  (let* ((conn (rmt:get-conn remote apath dbname)))
    (assert conn "FATAL: Unable to connect to db "apath"/"dbname)
    #;(let* ((res      (with-input-from-request
		      (rmt:conn->uri conn "api") 
		      `((params . (,apath ,dbname)))
		      read-string)))
      (string->sexpr res))))

(define (rmt:print-db-stats)
  (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"

			      (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)))))
                              #;(http-client#close-idle-connections!)
                              (if (not (eq? *default-log-port* (current-error-port)))
                                  (close-output-port *default-log-port*))
			      (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
	  (th2 (make-thread (lambda ()
			      (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
			      (if no-hurry
                                  (begin

(define (common:run-sync?)
    ;; (and (common:on-homehost?)
  (args:get-arg "-server"))

;; 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 server-id #!key (do-exit #f))
  (server-ready? host port "nokey yet"))

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

;; NOTE: http-transport:launch is the entry point
;;          -> http-transport:run
;;             -> http-transport:try-start-server -> http-transport:try-start-server (until success)

(define (http-get-function fnkey)
  (hash-table-ref/default *http-functions* fnkey (lambda () "nothing here yet")))

#;(define (rmt:launch-server hostn port)
   (if *server-info*
	(begin
	  (servdat-host-set! *server-info* hostn)
	  (servdat-port-set! *server-info* port)
	  (servdat-status-set! *server-info* 'trying-port)
	  (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1)))
	(set! *server-info* (make-servdat host: ipaddrstr port: portnum)))
   (let* ((l        (tcp-listen port))
	 (dbstruct #f))
    (let-values (((i o) (tcp-accept l)))
      ;; (write-line "Hello!" o)
      (let loop ((indat (read i)))
	(let* ((res (api:process-request dbstruct indat)))
	  (case res
	    ((quit)
	     (close-input-port i)
	     (close-output-port o))
	    (else
	     (write res o))))))))

(define (rmt:run hostn)
  ;;  ;; Configurations for server
  ;;  (tcp-buffer-size 2048)
  ;;  (max-connections 2048) 
  (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))) ".")
					   (server:get-best-guess-address hostname)
					   #f)))
			    (if ipstr ipstr hostn))) ;; hostname))) 
	 (port            (portlogger:open-run-close portlogger:find-port))
	 (link-tree-path  (common:get-linktree))
	 (tmp-area        (common:get-db-tmp-area))
	 #;(start-file      (conc tmp-area "/.server-start")))
    (debug:print-info 0 *default-log-port* "portlogger recommended port: " port)











































































    (if *server-info*
	(begin
	  (servdat-host-set! *server-info* ipaddrstr)
	  (servdat-port-set! *server-info* port)
	  (servdat-status-set! *server-info* 'trying-port)
	  (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1)))
	(set! *server-info* (make-servdat host: ipaddrstr port: port)))
    (let* ((l        (rmt:try-start-server ipaddrstr port))

	   (dbstruct #f))




      (let-values (((i o) (tcp-accept l)))
      ;; (write-line "Hello!" o)


      (let loop ((indat (read i)))





	(let* ((res (api:process-request dbstruct indat)))
	  (case res
	    ((quit)
	     (close-input-port i)

	     (close-output-port o))
	    (else



	     (set! *db-last-access* (current-seconds))

	     (write res o)))))








      (let* ((portnum (servdat-port *server-info*)))
	(portlogger:open-run-close portlogger:set-port portnum "released")
	(debug:print 1 *default-log-port* "INFO: server has been stopped"))))))

(define (rmt:try-start-server ipaddrstr portnum)
  (if *server-info*
      (begin
	(servdat-host-set! *server-info* ipaddrstr)
	(servdat-port-set! *server-info* portnum)
	(servdat-status-set! *server-info* 'trying-port)
	(servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1)))
      (set! *server-info* (make-servdat host: ipaddrstr port: portnum)))
  (debug:print-info 0 *default-log-port* "rmt:try-start-server time="
		    (seconds->time-string (current-seconds))
		    " ipaddrsstr=" ipaddrstr
		    " portnum=" portnum)
  (handle-exceptions
   exn
   (begin
     (print-error-message exn)
     (if (< portnum 64000)
	 (begin 
	   (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...")
	   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	   (debug:print 5 *default-log-port* "exn=" (condition->list exn))
	   (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)
	   (rmt:try-start-server ipaddrstr
				 (portlogger:open-run-close portlogger:find-port)))
	 (begin
	   (print "ERROR: Tried and tried but could not start the server"))))
   ;; any error in following steps will result in a retry
   (if *server-info*
       (servdat-status-set! *server-info* 'starting)
       (set! *server-info* (make-servdat host: ipaddrstr port: portnum)))
   
   (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
   (tcp-listen portnum)))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

;;======================================================================
;; C L I E N T S
;;======================================================================


(define (http-transport:get-time-to-cleanup)
  (let ((res #f))
    (mutex-lock! *http-mutex*)
    (set! res (> (current-seconds) *http-connections-next-cleanup*))
    (mutex-unlock! *http-mutex*)
    res))

  (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
  (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds
    (if (> *http-requests-in-progress* 0)
	(if (> etime (current-seconds))
	    (begin
	      (thread-sleep! 0.052)
	      (loop etime))
	    (debug:print-error 0 *default-log-port*
			       "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections"))
	#;(close-idle-connections!)))
  (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*)))

	 all-pkt-files)))

(define (server-address srv-pkt)
  (conc (alist-ref 'host srv-pkt) ":"
	(alist-ref 'port srv-pkt)))
	
(define (server-ready? host port key) ;; server-address is host:port
  (let-values (((i o)(handle-exceptions
		      exn
		      (values #f #f)
		      (tcp-connect host port))))
    (if (and i o)
	(begin
	  (write `((cmd . ping)
		   (key . ,key)
		   (params . ())) o)
	  (let ((res (with-input-from-port i


		       read)))
	    (close-output-port o)
	    (close-input-port i)
	    (if (string? res)
		(string->sexpr res)
		res)))
	(begin ;; connection failed
	  (debug:print-info 0 *default-log-port* "Server at "host":"port" is not responding.")
	  #f))))
 	      
(define (loop-test host port data) ;; server-address is host:port
  ;; ping the server and ask it
  ;; if it ready
  ;; (let* ((sdat (servdat-init #f host port #f)))
  ;;   (http-transport:send-receive sdat "abc" 'ping '())))
  #;(let* ((payload (sexpr->string data))
	 (res     (with-input-from-request
		   (conc "http://"host":"port"/loop-test")
		   `((data . ,payload))
		   read-string)))
  (string->sexpr res))
  #f
  )
	      
; from the pkts return servers associated with dbpath
;; NOTE: Only one can be alive - have to check on each
;;       in the list of pkts returned
;;
(define (get-viable-servers serv-pkts dbpath)
  (let loop ((tail serv-pkts)

	  (thread-sleep! 0.25)
	  (loop curr-host curr-port (+ tries 1)))
	 ((or (not (equal? last-host curr-host))
	      (not (equal? last-port curr-port)))
	  (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info")
	  (thread-sleep! 0.25)
	  (loop curr-host curr-port (+ tries 1)))
	 ((< (- (current-seconds) stime) 1) ;; keep up the looping until at least 3 seconds have passed
	  (thread-sleep! 0.5)
	  (loop curr-host curr-port (+ tries 1)))
	 (else
	  (if (not *server-id*)(set! *server-id* (server:mk-signature)))
	  (servdat-status-set! *server-info* 'interface-stable)
	  (debug:print 0 *default-log-port*
		       "SERVER STARTED: " curr-host
		       ":" curr-port
		       " AT " (current-seconds) " server-id: " *server-id*
		       " with "(servdat-trynum *server-info*)" port changes")
	  (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 (rmt: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))

;; Call this to start the actual server
;;
;; all routes though here end in exit ...
;;
;; This is the point at which servers are started
;;
(define (rmt:server-launch dbname)







  (let* ((th2 (make-thread (lambda ()
			     (debug:print-info 0 *default-log-port* "Server run thread started")

			     (rmt: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")
			     (rmt:keep-running dbname)
			     "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))

  #f
  )
	    
;; 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)
                                          (current-process-id)
					  (argv)))))))

(define (server:get-client-signature) 
  (if *my-client-signature* *my-client-signature*
      (let ((sig (server:mk-signature)))
        (set! *my-client-signature* sig)
        *my-client-signature*)))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

;; run ping in separate process, safest way in some cases
;;
#;(define (server:ping-server ifaceport)
  (with-input-from-pipe 
   (conc (common:get-megatest-exe) " -ping " ifaceport)
   (lambda ()
     (let loop ((inl (read-line))
		(res "NOREPLY"))
       (if (eof-object? inl)
	   (case (string->symbol res)
	     ((NOREPLY)  #f)
	     ((LOGIN_OK) #t)
	     (else       #f))
	   (loop (read-line) inl))))))









;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).
;;
#;(define (server:login toppath)
  (lambda (toppath)
    (set! *db-last-access* (current-seconds)) ;; might not be needed.
    (if (equal? *toppath* toppath)
	#t

;;       (server:release-sync-lock)
;;       (server:have-sync-lock?))
;;      (else #f))))



)

;;======================================================================
;; A T T I C
;;======================================================================


    ;; (handle-directory spiffy-directory-listing)
;; #;(handle-exception (lambda (exn chain)
;; 			(signal (make-composite-condition
;; 				 (make-property-condition 
;; 				  'server
;; 				  'message "server error")))))
;; 
;; ;; 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"))
;; 				   (debug:print 0 *default-log-port* "In api request $=" $)
;; 				   (send-response ;; the $ is the request vars proc
;; 				    body: (http-handle-api *dbstruct-db* $)
;; 				    headers: '((content-type text/plain)))
;; 				   (set! *db-last-access* (current-seconds)))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "ping"))
;; 				   (send-response body: (conc *toppath*"/"(args:get-arg "-db"))
;; 						  headers: '((content-type text/plain))))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "loop-test"))
;; 				   (send-response body: (alist-ref 'data ($))
;; 						  headers: '((content-type text/plain))))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ ""))
;; 				   (send-response body: ((http-get-function 'http-transport:main-page))))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "json_api"))
;; 				   (send-response body: ((http-get-function 'http-transport:main-page))))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "runs"))
;; 				   (send-response body: ((http-get-function 'http-transport:main-page))))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ any))
;; 				   (send-response body: "hey there!\n"
;; 						  headers: '((content-type text/plain))))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "hey"))
;; 				   (send-response body: "hey there!\n" 
;; 						  headers: '((content-type text/plain))))
;;                               ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "jquery3.1.0.js"))
;; 				   (send-response body: ((http-get-function 'http-transport:show-jquery))
;; 						  headers: '((content-type application/javascript))))
;;                               ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "test_log"))
;; 				   (send-response body: ((http-get-function 'http-transport:html-test-log) $) 
;; 						  headers: '((content-type text/HTML))))    
;;                               ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "dashboard"))
;; 				   (send-response body: ((http-get-function 'http-transport:html-dboard) $)
;; 						  headers: '((content-type text/HTML)))) 
;; 				  (else (continue))))))))

;; Run like this:
;;
;;  ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)

(import rmtmod trace http-client apimod dbmod
	launchmod)

(trace-call-sites #t)
(trace
 ;; db:get-dbdat
 ;; rmt:find-main-server
 rmt:send-receive-real
 rmt:send-receive
 ;; sexpr->string
 ;; server-ready?
 ;; rmt:register-server
 ;; rmt:open-main-connection
 rmt:general-open-connection
 ;; rmt:get-conny
 ;; common:watchdog
 ;; rmt:find-main-server
 ;; get-all-server-pkts
 ;; get-viable-servers
 ;; get-best-candidate
 api:run-server-process
 rmt:run
 rmt:try-start-server
 )

(test #f #t (rmt:remote? (let ((r (make-rmt:remote)))
			   (set! *rmt:remote* r)
			   r)))
(test #f #f (rmt:get-conn *rmt:remote* *toppath* ".db/main.db"))
(test #f #f (rmt:find-main-server *toppath* ".db/main.db"))

(define apath *toppath*)
(define dbname ".db/2.db")
(define remote *rmt:remote*)
(define keyvals  '(("SYSTEM" "a")("RELEASE" "b")))

(test #f 'server-started (api:execute-requests *db* 'get-server (list *toppath* ".db/2.db")))
(set! *dbstruct-db* #f)

(exit)

(test #f #t (rmt:open-main-connection remote apath))
(test #f #t (rmt:conn? (rmt:get-conn *rmt:remote* *toppath* ".db/main.db")))
(test #f 'server-started (rmt:send-receive-real *rmt:remote* *toppath* ".db/main.db" 'get-server `(,apath ,dbname)))

(thread-sleep! 2)
(test #f #t (list? (rmt:general-open-connection *rmt:remote* *toppath* ".db/2.db")))