Megatest

transport.scm at [bddb808811]
Login

File transport.scm artifact 49215ea3a2 part of check-in bddb808811


;;======================================================================
;; Copyright 2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(declare (unit transport))
(declare (uses commonmod))
(declare (uses configfmod))

(module transport
	*
	
(import commonmod)
(import configfmod)
(declare (uses portlogger))
(declare (uses portlogger.import))

(import portlogger)

(import scheme chicken data-structures extras ports)
(import
  (prefix base64 base64:)
  (prefix sqlite3 sqlite3:)
  call-with-environment-variables
  csv
  csv-xml
  directory-utils
  files
  hostinfo
  http-client
  intarweb
  matchable
  md5
  message-digest
  posix
  posix-extras
  regex
  regex-case
  s11n
  spiffy
  spiffy-directory-listing
  spiffy-request-vars
  srfi-1
  srfi-13
  srfi-18
  srfi-69
  stack
  tcp
  typed-records
  uri-common
  z3
  )

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

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

;; Call this to start the actual server
;;

;; (define *db:process-queue-mutex* (make-mutex))

(define (http-transport: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))) 
	 (start-port      (portlogger:open-run-close
			   (lambda (db)
			     (portlogger:find-port db))))
	 (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: " start-port)
    ;; set some parameters for the server
    (root-path     (if link-tree-path 
		       link-tree-path
		       (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
    (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 body:    (api:process-request *dbstruct-db* $) ;; the $ is the request vars proc
						  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-transport:main-page)))
				;;((equal? (uri-path (request-uri (current-request))) 
				;;	   '(/ "json_api"))
				;; (send-response body: (http-transport:main-page)))
				;;((equal? (uri-path (request-uri (current-request))) 
				;;	   '(/ "runs"))
				;; (send-response body: (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-transport:show-jquery) 
				;;		  headers: '((content-type application/javascript))))
                                ;;((equal? (uri-path (request-uri (current-request))) 
				;;	   '(/ "test_log"))
				;; (send-response body: (http-transport:html-test-log $) 
				;;		  headers: '((content-type text/HTML))))    
                                ;;((equal? (uri-path (request-uri (current-request))) 
				;;	   '(/ "dashboard"))
				;; (send-response body: (http-transport:html-dboard $) 
				;;		  headers: '((content-type text/HTML)))) 
				  (else (continue))))))))
    (handle-exceptions
	exn
      (debug:print 0 *default-log-port* "Failed to create file " start-file ", exn=" exn)
      (with-output-to-file start-file (lambda ()(print (current-process-id)))))
    (http-transport:try-start-server ipaddrstr start-port)))


;; This is recursively run by http-transport:run until sucessful
;;
(define (http-transport:try-start-server ipaddrstr portnum)
  (let ((config-hostname (configf:lookup *configdat* "server" "hostname"))
	(config-use-proxy (equal? (configf:lookup *configdat* "client" "use-http_proxy") "yes")))
    (if (not config-use-proxy)
	(determine-proxy (constantly #f)))
    (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum " config-hostname=" config-hostname)
    (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)
		
		;; get_next_port goes here
		(http-transport: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
      (set! *server-info* (list ipaddrstr portnum))
      (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
      ;; This starts the spiffy server
      ;; NEED WAY TO SET IP TO #f TO BIND ALL
      ;; (start-server bind-address: ipaddrstr port: portnum)
      (if config-hostname ;; this is a hint to bind directly
	  (start-server port: portnum bind-address: (if (equal? config-hostname "-")
							ipaddrstr
							config-hostname))
	  (start-server port: portnum))
      (portlogger:open-run-close
       (lambda (db)
	 (portlogger:set-port db portnum "released")))
      (debug:print 1 *default-log-port* "INFO: server has been stopped"))))


)