Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -8,13 +8,14 @@ ;; PURPOSE. ;; (include "common.scm") ;; (include "megatest-version.scm") -(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json http-client directory-utils) ;; (srfi 18) extras) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json http-client directory-utils rpc) ;; (srfi 18) extras) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) +(import (prefix rpc rpc:)) ;; (use zmq) (declare (uses common)) (declare (uses megatest-version)) @@ -351,12 +352,11 @@ (let* ((run-id (string->number (args:get-arg "-run-id"))) (host-port (let ((slst (string-split (args:get-arg "-ping") ":"))) (if (eq? (length slst) 2) (list (car slst)(string->number (cadr slst))) #f))) - (toppath (setup-for-run)) - (transport (server:get-transport))) + (toppath (setup-for-run))) (set! *did-something* #t) (if (not run-id) (begin (debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n") (print "ERROR: No run-id") @@ -364,13 +364,13 @@ (if (not host-port) (begin (debug:print 0 "ERROR: argument to -ping is host:port, got " (args:get-arg "-ping")) (print "ERROR: bad host:port") (exit 1)) - (case transport + (case (server:get-transport) ((http)(http:ping run-id host-port)) - ((rpc) (rpc:ping run-id (car host-port)(cadr host-port))) + ((rpc) ((rpc:procedure 'server:login (car host-port)(cadr host-port)) *toppath*)) ;; (rpc-transport:ping run-id (car host-port)(cadr host-port))) (else (debug:print 0 "ERROR: No transport set")(exit))))))) ;;====================================================================== ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;; we start the server if not running else start the client thread @@ -396,11 +396,12 @@ equal? (hash-table-keys args:arg-hash) '("-list-servers" "-stop-server" "-show-cmdinfo" - "-list-runs"))) + "-list-runs" + "-ping"))) (if (setup-for-run) (let ((run-id (and (args:get-arg "-run-id") (string->number (args:get-arg "-run-id"))))) ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) ;; if not list or kill then start a client (if appropriate) Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ rpc-transport.scm @@ -58,17 +58,16 @@ (begin ;; since we didn't get the server lock we are going to clean up and bail out (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") (open-run-close tasks:server-delete-records-for-this-pid tasks:open-db " rpc-transport:launch") )) - (let* ((th2 (make-thread (lambda () - (rpc-transport:run - (if (args:get-arg "-server") - (args:get-arg "-server") - "-") - run-id - server-id)) "Server run")) + (let* ((th2 (rpc-transport:run + (if (args:get-arg "-server") + (args:get-arg "-server") + "-") + run-id + server-id)) (th3 (make-thread (lambda () (rpc-transport:keep-running run-id server-id)) "Keep running"))) ;; Database connection (set! *inmemdb* (db:setup run-id)) @@ -87,102 +86,44 @@ (server:get-best-guess-address hostname) #f))) (if ipstr ipstr hostn))) ;; hostname))) (start-port (open-run-close tasks:server-get-next-port tasks:open-db)) (link-tree-path (configf:lookup *configdat* "setup" "linktree")) - (rpc:listener (rpc-transport:find-free-port-and-open (rpc:default-server-port))) - (th1 (make-thread - (cute (rpc:make-server rpc:listener) "rpc:server") - 'rpc:server)) - (hostname (if (string=? "-" hostn) - (get-host-name) - hostn)) - (ipaddrstr (if (string=? "-" hostn) - (server:get-best-guess-address hostname) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") - #f)) - (portnum (rpc:default-server-port)) - (host:port (conc (if ipaddrstr ipaddrstr hostname) ":" portnum)) - (tdb (tasks:open-db))) + (rpc:listener (rpc-transport:find-free-port-and-open (rpc:default-server-port))) + (th1 (make-thread + (cute (rpc:make-server rpc:listener) "rpc:server") + 'rpc:server)) + (hostname (if (string=? "-" hostn) + (get-host-name) + hostn)) + (ipaddrstr (if (string=? "-" hostn) + (server:get-best-guess-address hostname) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") + #f)) + (portnum (rpc:default-server-port)) + (host:port (conc (if ipaddrstr ipaddrstr hostname) ":" portnum)) + (tdb (tasks:open-db))) (set! db *inmemdb*) (open-run-close tasks:server-set-interface-port tasks:open-db server-id ipaddrstr portnum) (debug:print 0 "Server started on " host:port) - ;; can use this to run most anything at the remote - (rpc:publish-procedure! - 'remote:run - (lambda (procstr . params) - (rpc-transport:autoremote procstr params))) - - ;; (rpc:publish-procedure! - ;; 'server:login - ;; (lambda (toppath) - ;; (set! *last-db-access* (current-seconds)) - ;; (if (equal? *toppath* toppath) - ;; (begin - ;; (debug:print-info 2 "login successful") - ;; #t) - ;; #f))) - ;; - ;; ;;====================================================================== - ;; ;; db specials here - ;; ;;====================================================================== - ;; ;; remote call to open-run-close - ;; (rpc:publish-procedure! - ;; 'rdb:open-run-close - ;; (lambda (procname . remargs) - ;; (debug:print-info 12 "Remote call of rdb:open-run-close " procname " " remargs) - ;; (set! *last-db-access* (current-seconds)) - ;; (apply open-run-close (eval procname) remargs))) - ;; - ;; (rpc:publish-procedure! - ;; 'cdb:test-set-status-state - ;; (lambda (test-id status state msg) - ;; (debug:print-info 12 "Remote call of cdb:test-set-status-state test-id=" test-id ", status=" status ", state=" state ", msg=" msg) - ;; (cdb:test-set-status-state test-id status state msg))) - ;; - ;; (rpc:publish-procedure! - ;; 'cdb:test-rollup-test_data-pass-fail - ;; (lambda (test-id) - ;; (debug:print-info 12 "Remote call of cdb:test-rollup-test_data-pass-fail " test-id) - ;; (cdb:test-rollup-test_data-pass-fail test-id))) - ;; - ;; (rpc:publish-procedure! - ;; 'cdb:pass-fail-counts - ;; (lambda (test-id fail-count pass-count) - ;; (debug:print-info 12 "Remote call of cdb:pass-fail-counts " test-id " passes: " pass-count " fails: " fail-count) - ;; (cdb:pass-fail-counts test-id fail-count pass-count))) - ;; - ;; (rpc:publish-procedure! - ;; 'cdb:tests-register-test - ;; (lambda (db run-id test-name item-path) - ;; (debug:print-info 12 "Remote call of cdb:tests-register-test " run-id " testname: " test-name " item-path: " item-path) - ;; (cdb:tests-register-test db run-id test-name item-path))) - ;; - ;; (rpc:publish-procedure! - ;; 'cdb:flush-queue - ;; (lambda () - ;; (debug:print-info 12 "Remote call of cdb:flush-queue") - ;; (cdb:flush-queue))) - ;; + (trace rpc:publish-procedure!) + (rpc:publish-procedure! 'server:login server:login) ;;====================================================================== ;; ;; end of publish-procedure section ;;====================================================================== ;; (on-exit (lambda () (open-run-close tasks:server-set-state! tasks:open-db server-id "stopped"))) - (thread-start! th1) - (set! *rpc:listener* rpc:listener) (tasks:server-set-state! tdb server-id "running") - ; (sqlite3:finalize! tdb) th1 - )) ;; rpc:server))) + )) (define (rpc-transport:keep-running run-id server-id) ;; if none running or if > 20 seconds since ;; server last used then start shutdown (let loop ((count 0)) @@ -209,12 +150,25 @@ (rpc-transport:find-free-port-and-open (+ port 1))) (rpc:default-server-port port) (tcp-read-timeout 240000) (tcp-listen (rpc:default-server-port) 10000))) -(define (rpc:ping run-id host port) - ((rpc:procedure 'server:login host port) *toppath*)) +(define (rpc-transport:ping run-id host port) + (handle-exceptions + exn + (begin + (print "SERVER_NOT_FOUND") + (exit 1)) + (let ((login-res ((rpc:procedure 'server:login host port) *toppath*))) + (if (and (list? login-res) + (car login-res)) + (begin + (print "LOGIN_OK") + (exit 0)) + (begin + (print "LOGIN_FAILED") + (exit 1)))))) (define (rpc-transport:client-setup run-id #!key (remtries 10)) (if *runremote* (begin (debug:print 0 "ERROR: Attempt to connect to server but already connected") @@ -221,11 +175,11 @@ #f) (let* ((host-info (hash-table-ref/default *runremote* run-id #f))) ;; (open-run-close db:get-var #f "SERVER")) (if host-info (let ((iface (car host-info)) (port (cadr host-info)) - (ping-res (rpc:ping run-id host port))) + (ping-res ((rpc:procedure 'server:login host port) *toppath*))) (if ping-res (let ((server-dat (list iface port #f #f #f))) (hash-table-set! *runremote* run-id server-dat) server-dat) (begin @@ -236,11 +190,11 @@ (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if server-db-info (let* ((iface (tasks:hostinfo-get-interface server-db-info)) (port (tasks:hostinfo-get-port server-db-info)) (server-dat (list iface port #f #f #f)) - (ping-res (rpc:ping run-id iface port))) + (ping-res ((rpc:procedure 'server:login host port) *toppath*))) (if start-res (begin (hash-table-set! *runremote* run-id server-dat) server-dat) (begin Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -166,5 +166,16 @@ (case (string->symbol res) ((NOREPLY) #f) ((LOGIN_OK) #t) (else #f)) (loop (read-line) inl)))))) + +(define (server:login toppath) + (lambda (toppath) + (set! *last-db-access* (current-seconds)) + (if (equal? *toppath* toppath) + (begin + ;; (debug:print-info 2 "login successful") + #t) + (begin + ;; (debug:print-info 2 "login failed") + #f)))) ADDED testrpc/client.scm Index: testrpc/client.scm ================================================================== --- /dev/null +++ testrpc/client.scm @@ -0,0 +1,8 @@ +;;;; client.scm +(use rpc posix) + +(define call (rpc:procedure 'foo "localhost")) + +(do ((i 10 (sub1 i))) + ((zero? i)) + (print "-> " (call (random 100)))) ADDED testrpc/server.scm Index: testrpc/server.scm ================================================================== --- /dev/null +++ testrpc/server.scm @@ -0,0 +1,15 @@ +;;;; server.scm +(use rpc) + +(rpc:publish-procedure! + 'foo + (lambda (x) + (print "foo: " x) + #f)) + +(rpc:publish-procedure! + 'fini + (lambda () (print "fini") (thread-start! (lambda () (thread-sleep! 3) (print "terminate") (exit))) #f)) + +((rpc:make-server (tcp-listen (rpc:default-server-port))) #t) +