16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
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
127
128
129
130
131
132
133
134
135
136
137
138
139
|
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
-
-
-
-
+
-
-
-
+
+
+
+
-
+
+
+
-
-
-
+
+
+
+
-
+
+
+
-
-
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; 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 (uses commonmod))
(import commonmod)
(declare (uses dbmod))
(declare (uses debugprint))
(declare (uses rmt))
(declare (uses servermod))
(declare (uses dbmod))
(import commonmod)
(import dbmod)
(import debugprint)
(import servermod)
(declare (uses rmt))
(declare (uses servermod))
(module client
*
(import scheme chicken data-structures extras ports)
(import servermod)
;; 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))
#;(define (client:connect iface port)
(http-transport:client-connect iface port)
#;(case (server:get-transport)
((rpc) (rpc:client-connect iface port))
((http) (http:client-connect iface port))
((zmq) (zmq:client-connect iface port))
(else (rpc:client-connect iface port))))
(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0))
(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)
#;(case (server:get-transport)
((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id))
((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects))
(else (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id))))
;; 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 (client:setup-http areapath #!key (remaining-tries 100) (failed-connects 0)(area-dat #f))
(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:get-rand-best areapath)) ;; (server:get-first-best areapath))
(runremote (or area-dat *runremote*)))
(if (not server-dat) ;; no server found
(client:setup-http areapath remaining-tries: (- remaining-tries 1))
(let ((host (cadr server-dat))
(port (caddr server-dat))
(server-id (caddr (cddr server-dat))))
(debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
(if (and (not area-dat)
(not *runremote*))
(begin
;; POSSIBLE BUG. I removed the full initialization call. mrw
(set! *runremote* (create-remote-record))
(let* ((server-info (remote-server-info *runremote*)))
(if server-info
(begin
(remote-server-url-set! *runremote* (server:record->url server-info))
(remote-server-id-set! *runremote* (server:record->id server-info)))))))
(if (and host port server-id)
(let* ((start-res (http-transport:client-connect host port server-id))
(ping-res (rmt:login-no-auto-client-setup start-res)))
(if (and start-res
ping-res)
(let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago
(remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res)
(debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))
start-res)
(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 ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332
(case *transport-type*
((http)(http-transport:close-connections)))
(remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id)
(thread-sleep! 1)
(client:setup-http areapath 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 remaining-tries: (- remaining-tries 1)))))))))
|