Megatest

;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

;;======================================================================
;;
;; This is the Megatest specific stuff for starting and maintaining a
;; server. Anything that talks to the server should go in client.scm (maybe - might get rid of client.scm)
;; General nanomsg stuff (not Megatest specific) should go in the
;; nmsg-transport.scm file.
;;
;;======================================================================

(require-extension (srfi 18) extras tcp s11n)

;; P K T S   S T U F F 
;;======================================================================

;;======================================================================
;;  N A N O M S G   B A S E D   S E R V E R
;;======================================================================

(defstruct area
  (conn  #f)
  (port  #f)
  (myaddr #f)
  (hosts (make-hash-table))
  pktid  ;; get pkt from hosts table if needed
  pktspec
  pktfile
  pktsdir
  mtrah
  (mutex    (make-mutex))
  )

;; make it a global? Well, it is local to area module

(define *area-conndat* (make-area))
(area-pktspec-set! *area-conndat*
		   `((server (hostname . h)
			     (port     . p)
			     (pid      . i)
			     )))

(define (server:get-mtrah)
  (or (get-environment-variable "MT_RUN_AREA_HOME")
      (if (file-exists? "megatest.config")
	  (current-directory)
	  #f)))

;; get a port
;; start the nmsg server
;; look for other servers
;; contact other servers and compile list of servers
;; there are two types of server
;;     main servers - dashboards, runners and dedicated servers - need pkt
;;     passive servers - test executers, step calls, list-runs - no pkt
;;
(define (server:start-nmsg #!optional (force-server-type #f))
  (mutex-lock! (area-mutex *area-conndat*))
  (let* ((server-type  (or force-server-type
			   (if (args:any? "-run" "-server")
			       'main
			       'passive)))
	 (port-num     (portlogger:open-run-close portlogger:find-port))
	 (area-conn    (nmsg:start-server port-num))
	 (pktspec      (area-pktspec *area-conndat*))
	 (mtdir        (or (server:get-mtrah)


			   (begin
			     (print "ERROR: megatest.config not found and MT_RUN_AREA_HOME is not set.")
			     #f)))
	 (pktdir       (conc mtdir
			     "/.server-pkts")))
    (if (not mtdir)
	#f
	(begin
	  (if  (not (directory? pktdir))(create-directory pktdir))
	  ;; server is started, now create pkt if needed
	  (if (eq? server-type 'main)
	      (begin
		(area-pktid-set! *area-conndat* 
				 (write-alist->pkt
				  pktdir 
				  `((hostname . ,(get-host-name))
				    (port     . ,port-num)
				    (pid      . ,(current-process-id)))
				  pktspec: pktspec
				  ptype:   'server))
		(area-pktfile-set! *area-conndat* (conc pktdir "/" (area-pktid *area-conndat*) ".pkt"))))
	  ;; set all the area info in the 
	  (area-pktsdir-set! *area-conndat* pktdir)
	  (area-mtrah-set!   *area-conndat* mtdir)
	  (area-conn-set!    *area-conndat* area-conn)
	  (area-port-set!    *area-conndat* port-num)
	  (mutex-unlock! (area-mutex *area-conndat*))
	  #t))))

;; Call this to start the actual server
;;
;; start_server
;;
;;   mode: '
;;
(define (server:launch mode)
  (let ((start-time (current-seconds)))
    (server:start-nmsg mode)
    (let loop ((dead-time (- (current-seconds) start-time)))
      (thread-sleep! 1)
      (if (< dead-time 10)
	  (loop (- (current-seconds) start-time))
	  (print "Timed out. Exiting")))))

(define (server:shutdown)
  (let ((conn (area-conn    *area-conndat*))
	(pktf (area-pktfile *area-conndat*))
	(port (area-port    *area-conndat*)))
    (if conn
	(begin
	  (if pktf (delete-file* pktf))
	  (server:send-all "imshuttingdown")
	  (nmsg:close conn)
	  (portlogger:open-run-close portlogger:release-port port)))))

(define (server:send-all msg)
  #f)

;; given a area record look up all the packets
(define (server:get-all-server-pkts rec)
  (let ((all-pkt-files (glob (conc (area-pktsdir rec) "/*.pkt")))
	(pktspec       (area-pktspec rec)))
    (map (lambda (pkt-file)
	   (read-pkt->alist pkt-file pktspec: pktspec))
	 all-pkt-files)))

;; look up all pkts and get the server id (the hash), port, host/ip
;; store this info in the global struct *area-conndat*
;;
(define (server:get-all)
  ;; readll all pkts
  ;; foreach pkt; if it isn't me ping the server; if alive, add to hosts hash, else rm the pkt
  '())

;; send out an "I'm about to exit notice to all known servers"
;;
(define (server:announce-death)
  '())

(define (server:get-my-best-address)
  (ip->string (car (filter (lambda (x)
			     (not (eq? (u8vector-ref x 0) 127)))
			   (vector->list (hostinfo-addresses (hostname->hostinfo "zeus")))))))

;; whoami? I am my pkt
;;
(define (server:whoami? area)
  (hash-table-ref/default (area-hosts area)(area-pktid area) #f))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

;; get a signature for identifing this process
(define (server:get-process-signature)
  (cons (get-host-name)(current-process-id)))


;; ;; Get the transport
;; (define (server:get-transport)
;;   (if *transport-type*
;;       *transport-type*
;;       (let ((ttype (string->symbol