Megatest

Artifact [3021f407ce]
Login

Artifact 3021f407ce22a2d7d6f21f6429391ef843b52204:


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

)