;;======================================================================
;; 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 tcp-transportmod))
(declare (uses debugprint))
(declare (uses commonmod))
(module tcp-transportmod
*
(import scheme
(prefix sqlite3 sqlite3:)
chicken
data-structures
directory-utils
extras
files
hostinfo
matchable
md5
message-digest
ports
posix
srfi-1
srfi-18
srfi-4
srfi-69
stack
typed-records
commonmod
debugprint
)
;;======================================================================
;; client
;;======================================================================
;; (define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic
(defstruct tt
;; all
(areapath #f)
;; client related
(conns (make-hash-table)) ;; dbfname -> conn
;; server related
(cleanup-proc #f)
)
(defstruct tt-conn
host
port
dbfname
)
(define (tt:make-remote areapath)
(make-tt area: areapath))
(define (tt:client-connect-to-server ttdat)
#f)
(define (tt:handler runremote cmd rid params attemptnum area-dat areapath readonly-mode dbfname)
;; NOTE: areapath is passed in and in tt struct. We'll use passed in value for now.
(let* ((conn (hash-table-ref/default (tt-conns runremote) dbfname #f)))
(if conn
;; have connection, call the server
(let* ((res (tt:send-receive runremote conn cmd rid params)))
(cond
((member res '(busy starting))
(thread-sleep! 1)
(tt:handler runremote cmd rid params attemptnum area-dat areapath readonly-mode dbfname))
(else
res)))
;; no conn yet, find and or start and find a server
(let* ((server (tt:find-server areapath dbfname)))
(if server
(let* ((conn (tt:client-connect-to-server server)))
(hash-table-set! (tt-conns runremote) dbfname conn)
(tt:handler runremote cmd rid params attemptnum area-dat areapath readonly-mode dbfname))
;; no server, try to start one
(begin
(tt:start-server areapath dbfname)
(thread-sleep! 1)
(tt:handler runremote cmd rid params attemptnum area-dat areapath readonly-mode dbfname)))))))
(define (tt:bid-for-servership run-id)
#f)
(define (tt:get-current-server run-id)
#f)
(define (tt:send-receive ttdat conn cmd run-id params)
#f)
;;======================================================================
;; server
;;======================================================================
(define (tt:sync-dbs ttdat)
#f)
;; start the listener and start responding to requests
;;
(define (tt:start-server ttdat)
#f)
(define (tt:shutdown-server ttdat)
(let* ((cleanproc (tt-cleanup-proc ttdat)))
(if cleanproc (cleanproc))
;; close up ports here
#f))
;; return servid
;; side-effects:
;; ttdat-cleanup-proc is populated with function to remove the serverinfo file
(define (tt:create-server-registration-file ttdat dbfname)
(let* ((areapath (tt-areapath ttdat))
(servdir (tt:get-servinfo-dir areapath))
(conn (hash-table-ref/default (tt-conns ttdat) dbfname #f)))
(assert conn "FATAL: tt:create-server-registration-file called with no conn, dbfname="dbfname)
(let* ((host (tt-conn-host conn))
(port (tt-conn-port conn))
(servinf (conc servdir"/"host":"port"-"(current-process-id)":"dbfname))
(serv-id (tt:mk-signature areapath))
(clean-proc (lambda ()
(delete-file* servinf))))
(tt-cleanup-proc-set! ttdat clean-proc)
(with-output-to-file servinf
(lambda ()
(print "SERVER STARTED: "host":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id))))
serv-id)))
;; find valid server
;; get servers listed, last part of name must match :<dbfname>
;; if more than one, wait one second and look again
;; future: ping oldest, if alive remove other :<dbfname> files
;;
(define (tt:find-server ttdat dbfname)
(let* ((areapath (tt-areapath ttdat))
(servdir (tt:get-servinfo-dir areapath))
(sfiles (glob (conc servdir"/*:"dbfname))))
sfiles))
;; Given an area path, start a server process ### NOTE ### > file 2>&1
;; if the target-host is set
;; try running on that host
;; incidental: rotate logs in logs/ dir.
;;
(define (tt:server-process-run areapath testsuite mtexe #!key (profile-mode "")) ;; areapath is *toppath* for a given testsuite area
(let* ((logfile (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log"))
(cmdln (conc
mtexe
" -server - ";; (or target-host "-")
" -m testsuite:" testsuite
" " profile-mode
))) ;; (conc " >> " logfile " 2>&1 &")))))
;; we want the remote server to start in *toppath* so push there
(push-directory areapath)
(debug:print 0 *default-log-port* "INFO: Trying to start server in tcp mode (" cmdln ") ...")
(debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time))
(system (conc "nbfake " cmdln))
(pop-directory)))
;;======================================================================
;; utils
;;======================================================================
;; Generate a unique signature for this server
(define (tt:mk-signature areapath)
(message-digest-string (md5-primitive)
(with-output-to-string
(lambda ()
(write (list areapath
(current-process-id)
(argv)))))))
(define (tt:get-best-guess-address hostname)
(let ((res #f))
(for-each
(lambda (adr)
(if (not (eq? (u8vector-ref adr 0) 127))
(set! res adr)))
;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
(vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
(string-intersperse
(map number->string
(u8vector->list
(if res res (hostname->ip hostname)))) ".")))
(define (tt:get-servinfo-dir areapath)
(let* ((spath (conc areapath"/.servinfo")))
(if (not (file-exists? spath))
(create-directory spath #t))
spath))
)