;;======================================================================
;; 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))
(declare (uses portlogger))
(module transport
*
(import scheme chicken data-structures extras ports)
(import commonmod)
(import configfmod)
(import portlogger)
(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"))))
)