99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(define (server:get-server-id)
(if *server-id* *server-id*
(let ((sig (server:mk-signature))) ;; clients re-use the server:mk-signature logic
(set! *server-id* sig)
*server-id*)))
;; When using zmq this would send the message back (two step process)
;; with spiffy or rpc this simply returns the return data to be returned
;;
(define (server:reply return-addr query-sig success/fail result)
(debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
;; (send-message pubsock target send-more: #t)
;; (send-message pubsock
(case (server:get-transport)
((rpc) (db:obj->string (vector success/fail query-sig result)))
((http) (db:obj->string (vector success/fail query-sig result)))
((fs) result)
(else
(debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
result)))
;; ;; When using zmq this would send the message back (two step process)
;; ;; with spiffy or rpc this simply returns the return data to be returned
;; ;;
;; (define (server:reply return-addr query-sig success/fail result)
;; (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
;; ;; (send-message pubsock target send-more: #t)
;; ;; (send-message pubsock
;; (case (server:get-transport)
;; ((rpc) (db:obj->string (vector success/fail query-sig result)))
;; ((http) (db:obj->string (vector success/fail query-sig result)))
;; ((fs) result)
;; (else
;; (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
;; result)))
;; Given an area path, start a server process ### NOTE ### > file 2>&1
;; if 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
|
467
468
469
470
471
472
473
474
475
476
477
478
479
480
|
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
|
+
|
;; find oldest alive
;; 1. sort by age ascending and ping until good
;; find alive rand from youngest
;; 1. sort by age descending
;; 2. take five
;; 3. check alive, discard if not and repeat
;; first we clean up old server files
(assert (eq? (rmt:transport-mode) 'http) "FATAL: server:run called with rmt:transport-mode="(rmt:transport-mode))
(server:clean-up-old areapath)
(let* ((since-last (- (current-seconds) server-last-start))
(server-start-delay 10))
(if ( < (- (current-seconds) server-last-start) 10 )
(begin
(debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
(debug:print 2 *default-log-port* "server:choose-server: last server start less than " server-start-delay " seconds ago. Sleeping " server-start-delay " seconds")
|
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
|
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
|
+
-
+
+
|
(debug:print 0 *default-log-port* "WARNING: failed to delete old server info file "sfile)
(delete-file sfile))))))
sfiles)))
;; would like to eventually get rid of this
;;
(define (common:on-homehost?)
(if (eq? (rmt:transport-mode) 'http)
(server:choose-server *toppath* 'home?))
(server:choose-server *toppath* 'home?)
#t)) ;; there is no homehost for tcp and nfs is always on home so #t should work
;; kind start up of server, wait before allowing another server for a given
;; area to be launched
;;
(define (server:kind-run areapath)
;; look for $MT_RUN_AREA_HOME/logs/server-start-last
;; and wait for it to be at least <server idletime> seconds old
|
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
|
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
|
-
+
|
(list (car slst)(string->number (cadr slst)))
#f)))
(else
#f))))
(cond
((and (list? host-port)
(eq? (length host-port) 2))
(let* ((myrunremote (make-remote))
(let* ((myrunremote (make-and-init-remote *toppath*))
(iface (car host-port))
(port (cadr host-port))
(server-dat (client:connect iface port server-id myrunremote))
(login-res (rmt:login-no-auto-client-setup myrunremote)))
(http-transport:close-connections myrunremote)
(if (and (list? login-res)
(car login-res))
|