Megatest

Artifact [8200295969]
Login

Artifact 8200295969cf270773ac7217efb76912a02436e6:



;; Copyright 2006-2012, 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/>.

;;======================================================================
;; C L I E N T S
;;======================================================================

(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5
     message-digest matchable spiffy uri-common intarweb http-client
     spiffy-request-vars uri-common intarweb directory-utils)

(declare (unit client))

(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.

;; (module client
;; *
;; 
;; )
;; 
;; (import client)
;; 
;; (include "common_records.scm")
;; (include "db_records.scm")
;; 
;; ;; client:get-signature
;; (define (client:get-signature)
;;   (if *my-client-signature* *my-client-signature*
;;       (let ((sig (conc (get-host-name) " " (current-process-id))))
;; 	(set! *my-client-signature* sig)
;; 	*my-client-signature*)))
;; 
;; ;; Not currently used! But, I think it *should* be used!!!
;; #;(define (client:logout serverdat)
;;   (let ((ok (and (socket? serverdat)
;; 		 (cdb:logout serverdat *toppath* (client:get-signature)))))
;;     ok))
;; 
;; ;; Do all the connection work, look up the transport type and set up the
;; ;; connection if required.
;; ;;
;; ;; There are two scenarios. 
;; ;;   1. We are a test manager and we received *transport-type* and *runremote* via cmdline
;; ;;   2. We are a run tests, list runs or other interactive process and we must figure out
;; ;;      *transport-type* and *runremote* from the monitor.db
;; ;;
;; ;; client:setup
;; ;;
;; ;; lookup_server, need to remove *runremote* stuff
;; ;;
;;  
;; ;;(define (http-transport:server-dat-make-url runremote)
;; (define (client:get-url runremote)
;;   (if (and (remote-iface runremote)
;; 	   (remote-port  runremote))
;;       (conc "http://" 
;; 	    (remote-iface runremote)
;; 	    ":"
;; 	    (remote-port  runremote))
;;       #f))
;; 
;; (define (client:setup areapath runremote #!key (remaining-tries 100) (failed-connects 0)(area-dat #f))
;;   (mutex-lock! *rmt-mutex*)
;;   (let ((res (client:setup-http areapath runremote remaining-tries: remaining-tries failed-connects: failed-connects area-dat: area-dat)))
;;     (mutex-unlock! *rmt-mutex*)
;;     res))
;; 
;; (define (client:setup-http areapath runremote #!key (remaining-tries 100) (failed-connects 0))
;;   (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries)
;;   (server:start-and-wait areapath)
;;   (if (<= remaining-tries 0)
;;       (begin
;; 	(debug:print-error 0 *default-log-port* "failed to start or connect to server")
;; 	(exit 1))
;;       ;;
;;       ;; Alternatively here, we can get the list of candidate servers and work our way
;;       ;; through them searching for a good one.
;;       ;;
;;       (let* ((server-dat (server:choose-server areapath 'best))) ;; list host port start-time server-id pid
;; ;;	     (runremote  (or area-dat *runremote*)))
;; 	(if (not server-dat) ;; no server found
;; 	    (begin
;; 	      (if (< remaining-tries 99)(thread-sleep! 1)) ;; obviously it needs time
;; 	      (client:setup-http areapath runremote remaining-tries: (- remaining-tries 1)))
;; 	    (match server-dat
;; 	      ((host port start-time server-id pid)
;; 	       (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
;; 	       (if (not runremote)
;;                    (begin
;; 		     ;; Here we are creating a runremote where there was none or it was clobbered with #f
;; 		     ;;
;; 		     (set! runremote (make-remote))
;;                      (let* ((server-info (server:check-if-running areapath)))
;; 		       (remote-server-info-set! runremote server-info)
;;                        (if server-info
;;                            (begin
;;                              (remote-server-url-set! runremote (server:record->url server-info))
;;                              (remote-server-id-set! runremote (server:record->id server-info)))))))
;; 	       ;; at this point we have a runremote
;; 	       (if (and host port server-id)
;; 		   (let* ((nada     (client:connect host port server-id runremote))
;; 			  (ping-res (rmt:login-no-auto-client-setup runremote)))
;; 		     (if ping-res
;; 			 (if runremote
;; 			     (begin
;; 			       (debug:print-info 2 *default-log-port* "connected to " (client:get-url runremote))
;; 			       runremote)
;; 			     (client:setup-http areapath runremote remaining-tries: (- remaining-tries 1)))
;; 			 (begin    ;; login failed but have a server record, clean out the record and try again
;; 			   (debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... ping-res=" ping-res ", server-dat=" server-dat) ;; had runid.  Fixes part of Randy;s ticket 1405717332
;; 			   (http-transport:close-connections runremote)
;; 			   (thread-sleep! 1)
;; 			   (client:setup-http areapath runremote remaining-tries: (- remaining-tries 1))
;; 			   )))
;; 		   (begin    ;; no server registered
;; 		     ;; (server:kind-run areapath)
;; 		     (server:start-and-wait areapath)
;; 		     (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries)
;; 		     (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries))))  ;; give server a little time to start up, randomize a little to avoid start storms.
;; 		     (client:setup-http areapath runremote remaining-tries: (- remaining-tries 1)))))
;; 	      (else
;; 	       (debug:print 0 *default-log-port* "ERROR: malformed server-dat="server-dat)))))))
;; 
;; ;;
;; ;; connect - stored in remote-condat
;; ;;
;; ;; (define (http-transport:client-connect iface port server-id runremote)
;; (define (client:connect iface port server-id runremote-in)
;;   (let* ((runremote (or runremote-in
;; 			(make-runremote))))
;;     (debug:print-info 2 *default-log-port* "Connecting to server at "iface":"port", id "server-id)
;;     (let* ((api-url      (conc "http://" iface ":" port "/api"))
;; 	   (api-uri      (uri-reference (conc "http://" iface ":" port "/api")))
;; 	   (api-req      (make-request method: 'POST uri: api-uri)))
;;       ;;	 (server-dat   (vector iface port api-uri api-url api-req (current-seconds) server-id)))
;;       (remote-iface-set!   runremote iface)
;;       (remote-port-set!    runremote port)
;;       (remote-server-id-set! runremote server-id)
;;       (remote-connect-time-set! runremote (current-seconds))
;;       (remote-last-access-set! runremote (current-seconds))
;;       (remote-api-url-set! runremote api-url)
;;       (remote-api-uri-set! runremote api-uri)
;;       (remote-api-req-set! runremote api-req)
;;       runremote)))
;; 
;;