Megatest

servermod.scm at [51225a42e5]
Login

File servermod.scm artifact e99a19822e part of check-in 51225a42e5


;;======================================================================
;; 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 servermod))
(declare (uses commonmod))
(declare (uses debugprint))
(declare (uses configfmod))
(declare (uses http-transportmod))
(declare (uses pkts))

(module servermod
	*
	
(import scheme
	chicken.base
	chicken.string
	chicken.process
	chicken.io
	chicken.time
	chicken.condition
	chicken.file
	chicken.process-context
	chicken.process-context.posix
	chicken.random
	chicken.file.posix
	
	system-information
	(prefix sqlite3 sqlite3:)
	typed-records
	regex
	directory-utils
	matchable
	
	srfi-18
	srfi-69

	commonmod
	debugprint
	configfmod
	http-transportmod
	pkts
	
	)

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

;; reuse this for server load?
;;
#;(define (common:wait-for-homehost-load maxnormload msg)
  (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local.
                     #f
                     (common:get-homehost)))
         (hh     (if hh-dat (car hh-dat) #f)))
    (common:wait-for-normalized-load maxnormload msg hh)))


;; Given a run id start a server process    ### NOTE ### > file 2>&1 
;; if the run-id is zero and the target-host is set 
;; try running on that host
;;   incidental: rotate logs in logs/ dir.
;;
(define  (server:run areapath) ;; areapath is *toppath* for a given testsuite area
  (let* ((curr-host   (get-host-name))
	 (curr-ip     (server:get-best-guess-address curr-host))
	 (curr-pid    (current-process-id))
	 (testsuite   (common:get-area-name))
	 (logfile     (conc areapath "/logs/server.log"))
	 (profile-mode (or (configf:lookup *configdat* "misc" "profilesw")
			   ""))
	 (cmdln (conc
		 (common:get-megatest-exe)
		 " -server " (or (get-host-name) "-")
		 (if (equal? (configf:lookup *configdat* "server" "daemonize")
			     "yes")
		     " -daemonize "
		     "")
		 ;; " -log " logfile
		 " -m testsuite:" testsuite
		 " " profile-mode
		 ))
         (load-limit  (configf:lookup-number *configdat* "jobtools" "max-server-start-load" default: 3.0)))
    ;; 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 (" cmdln ") ...")
    (setenv "NBFAKE_LOG" logfile)
    (system (conc "nbfake " cmdln))
    (unsetenv "NBFAKE_LOG")
    (pop-directory)))

(define (server:record->url servr)
  (handle-exceptions
   exn
   (begin 
     (debug:print-info 0 *default-log-port*  "Unable to get server url from " servr ", exn=" exn)     
   #f)
  (match-let (((mod-time host port start-time server-id pid)
	       servr))
    (if (and host port)
	(conc host ":" port)
	#f))))


(define (server:kill servr)
  (handle-exceptions
    exn
    (begin 
      (debug:print-info 0 *default-log-port*  "Unable to get host and/or port from " servr ", exn=" exn)     
    #f)
  (match-let (((mod-time hostname port start-time server-id pid)
	       servr))
    (tasks:kill-server hostname pid))))


)