Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -22,10 +22,11 @@ (declare (uses common)) (declare (uses db)) (declare (uses tests)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (declare (uses server)) +(declare (uses daemon)) (include "common_records.scm") (include "db_records.scm") (define (http-transport:make-server-url hostport) @@ -43,10 +44,22 @@ ;; Call this to start the actual server ;; (define *db:process-queue-mutex* (make-mutex)) +(define (server:get-best-guess-address hostname) + (let ((res #f)) + (for-each + (lambda (adr) + (if (not (eq? (u8vector-ref adr 0) 127)) + (set! res adr))) + (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) + (string-intersperse + (map number->string + (u8vector->list + (if res res (hostname->ip hostname)))) "."))) + (define (http-transport:run hostn) (debug:print 2 "Attempting to start the server ...") (if (not *toppath*) (if (not (setup-for-run)) (begin @@ -56,11 +69,12 @@ ;; #f ;; (get-host-name) ;; hostn)) (db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) - (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") + ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") + (server:get-best-guess-address hostname) #f))) (if ipstr ipstr hostn))) ;; hostname))) (start-port (if (and (args:get-arg "-port") (string->number (args:get-arg "-port"))) (string->number (args:get-arg "-port")) @@ -118,11 +132,11 @@ exn (begin (print-error-message exn) (if (< portnum 9000) (begin - (print "WARNING: failed to start on portnum: " portnum ", trying next port") + (debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port") (thread-sleep! 0.1) ;; (open-run-close tasks:remove-server-records tasks:open-db) (open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum) (http-transport:try-start-server ipaddrstr (+ portnum 1))) (print "ERROR: Tried and tried but could not start the server"))) @@ -133,11 +147,12 @@ tasks:open-db (current-process-id) ipaddrstr portnum 0 'live 'http) (print "INFO: Trying to start server on " ipaddrstr ":" portnum) ;; This starts the spiffy server - (start-server port: portnum) + ;; NEED WAY TO SET IP TO #f TO BIND ALL + (start-server bind-address: ipaddrstr port: portnum) (open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum) (print "INFO: server has been stopped"))) ;;====================================================================== ;; S E R V E R U T I L I T I E S @@ -312,10 +327,25 @@ (set! *didsomething* #t) (thread-join! th2)) (debug:print 0 "ERROR: Failed to setup for megatest"))) (exit))) +;; (use trace) +;; (trace http-transport:keep-running +;; tasks:get-best-server +;; http-transport:run +;; http-transport:launch +;; http-transport:try-start-server +;; http-transport:client-send-receive +;; http-transport:make-server-url +;; tasks:server-register +;; tasks:server-delete +;; start-server +;; hostname->ip +;; with-input-from-request +;; tasks:server-deregister-self) + (define (http-transport:server-signal-handler signum) (handle-exceptions exn (debug:print " ... exiting ...") (let ((th1 (make-thread (lambda () Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -23,10 +23,11 @@ (declare (uses launch)) (declare (uses server)) (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) +(declare (uses daemon)) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") @@ -313,21 +314,29 @@ (hash-table-keys args:arg-hash) '("-runtests" "-list-runs" "-rollup" "-remove-runs" "-lock" "-unlock" "-update-meta" "-extract-ods")))) (if (setup-for-run) - (let ((servers (open-run-close tasks:get-best-server tasks:open-db))) + (let loop ((servers (open-run-close tasks:get-best-server tasks:open-db)) + (trycount 0)) (if (or (not servers) (null? servers)) (begin - (debug:print 0 "INFO: Starting server as none running ...") - ;; (server:launch (string->symbol (args:get-arg "-transport" "http")))) - (system (conc (car (argv)) " -server - -daemonize -transport " (args:get-arg "-transport" "http"))) - (thread-sleep! 3)) ;; give the server a few seconds to start - (debug:print 0 "INFO: Servers already running " servers) + (if (eq? trycount 0) ;; just do the server start once + (begin + (debug:print 0 "INFO: Starting server as none running ...") + ;; (server:launch (string->symbol (args:get-arg "-transport" "http")))) + ;; (process-run (car (argv)) (list "-server" "-" "-daemonize" "-transport" (args:get-arg "-transport" "http"))) + (process-fork (lambda () + (daemon:ize) + (server:launch (string->symbol (args:get-arg "-transport" "http"))))) + (thread-sleep! 3)) + (debug:print-info 0 "Waiting for server to start")) + (loop (open-run-close tasks:get-best-server tasks:open-db) + (+ trycount 1))) + (debug:print 0 "INFO: Server(s) running " servers) ))))) - (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server")) (let ((tl (setup-for-run))) (if tl @@ -370,12 +379,11 @@ (debug:print-info 0 "Attempting to stop server with pid " pid) (tasks:kill-server status hostname pullport pid transport))))) servers) (debug:print-info 1 "Done with listservers") (set! *didsomething* #t) - (exit) ;; must do, would have to add checks to many/all calls below - ) + (exit)) ;; must do, would have to add checks to many/all calls below (exit))) ;; if not list or kill then start a client (if appropriate) (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") (eq? (length (hash-table-keys args:arg-hash)) 0)) (debug:print-info 1 "Server connection not needed")