Megatest

Check-in [bf5639be89]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Added timeout on no server. Auto starts a server on timeout
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | refactor-http-transport
Files: files | file ages | folders
SHA1: bf5639be892d205124841a184976bb5aac2099d1
User & Date: matt on 2013-05-08 00:34:52
Other Links: branch diff | manifest | tags
Context
2013-05-08
00:42
Merged in refactoring of http-transport check-in: 8c3d4217c8 user: matt tags: v1.54
00:34
Added timeout on no server. Auto starts a server on timeout Closed-Leaf check-in: bf5639be89 user: matt tags: refactor-http-transport
2013-05-07
23:06
Refactor http transport check-in: b662cb0a51 user: matt tags: refactor-http-transport
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified client.scm from [0cd46ef301] to [8b3b6e88e1].

︙
73
74
75
76
77
78
79
80







81
82
83
84
85
86
87

73
74
75
76
77
78
79

80
81
82
83
84
85
86
87
88
89
90
91
92
93








-
+
+
+
+
+
+
+








    			       (string->symbol (tasks:hostinfo-get-transport hostinfo))
			       'fs))
    ;; ;; DEBUG STUFF
    ;; (if (eq? *transport-type* 'fs)(begin (print "ERROR!!!!!!! refusing to run with transport " *transport-type*)(exit 99)))
    
    (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) ""))
    (case *transport-type* 
      ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db))))
      ((fs) ;; (if (not *megatest-db*)(set! *megatest-db* (open-db))))
       ;; we are not doing fs any longer. let's cheat and start up a server
       (set! *transport-type* #f)
       (system "megatest -list-servers | grep alive || megatest -server - -daemonize && sleep 3")
       (thread-sleep! 1)
       (if (> numtries 0)
	   (client:setup numtries: (- numtries 1))))
      ((http)
       (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
				      (tasks:hostinfo-get-port hostinfo)))
      ((zmq)
       (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
				     (tasks:hostinfo-get-port      hostinfo)
				     (tasks:hostinfo-get-pubport   hostinfo)))
︙

Modified db.scm from [98d99ca28b] to [113f8f5bae].

︙
1262
1263
1264
1265
1266
1267
1268


1269
1270





1271
1272
1273
1274
1275
1276
1277

1262
1263
1264
1265
1266
1267
1268
1269
1270


1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282








+
+
-
-
+
+
+
+
+








	    (query-sig   (message-digest-string (md5-primitive) (conc qtype immediate params)))
	    (zdat        (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds))))) ;; (with-output-to-string (lambda ()(serialize params))))
       (debug:print-info 11 "zdat=" zdat)
       (let* ((res  #f)
	      (rawdat      (http-transport:client-send-receive serverdat zdat))
	      (tmp         #f))
	 (debug:print-info 11 "Sent " zdat ", received " rawdat)
	 (if rawdat
	     (begin
	 (set! tmp (db:string->obj rawdat))
	 (vector-ref tmp 2))))
	       (set! tmp (db:string->obj rawdat))
	       (vector-ref tmp 2))
	     (begin
	       (debug:print 0 "ERROR: Communication with the server failed. Exiting if possible")
	       (exit 1))))))
    ((zmq)
     (handle-exceptions
      exn
      (begin
	(debug:print-info 0 "cdb:client-call timeout or error. Trying again in 5 seconds")
	(thread-sleep! 5) 
	(if (> numretries 0)(apply cdb:client-call serverdat qtype immediate (- numretries 1) params)))
︙

Modified http-transport.scm from [9d03c1c19f] to [f8890a14ba].

︙
160
161
162
163
164
165
166




167
168
169
170
171
172
173

160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177








+
+
+
+








;; S E R V E R   U T I L I T I E S 
;;======================================================================

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

(define *http-mutex* (make-mutex))

;; (system "megatest -list-servers | grep alive || megatest -server - -daemonize && sleep 4")

;; <html>
;; <head></head>
;; <body>1 Hello, world! Goodbye Dolly</body></html>
;; Send msg to serverdat and receive result
(define (http-transport:client-send-receive serverdat msg)
  (let* (;; (url        (http-transport:make-server-url serverdat))
	 (fullurl    (caddr serverdat)) ;; (conc url "/ctrl")) ;; (conc url "/?dat=" msg)))
︙
189
190
191
192
193
194
195

196
197
198
199
200









201

202

203
204
205
206
207
208
209

193
194
195
196
197
198
199
200
201
202
203


204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223








+



-
-
+
+
+
+
+
+
+
+
+

+

+








			 #t))   ;;  		 (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10))
       (set! numretries (- numretries 1))
       ;;  		 #t))
       ;; send the data and get the response
       ;; extract the needed info from the http data and 
       ;; process and return it.
       (let* ((send-recieve (lambda ()
			      (mutex-lock! *http-mutex*)
			      (set! res (with-input-from-request 
					 fullurl 
					 (list (cons 'dat msg)) 
					 read-string))))
	      (th1 (make-thread send-recieve "with-input-from-request")))
					 read-string))
			      (close-all-connections!) 
			      (mutex-unlock! *http-mutex*)))
	      (time-out     (lambda ()
			      (thread-sleep! 5)
			      (if (not res)
				  (debug:print 0 "ERROR: communication with the server timed out. Exiting."))))
	      (th1 (make-thread send-recieve "with-input-from-request"))
	      (th2 (make-thread time-out     "time out")))
	 (thread-start! th1)
	 (thread-start! th2)
	 (thread-join! th1)
	 (thread-terminate! th2)
	 (debug:print-info 11 "got res=" res)
	 (let ((match (string-search (regexp "<body>(.*)<.body>") res)))
	   (debug:print-info 11 "match=" match)
	   (let ((final (cadr match)))
	     (debug:print-info 11 "final=" final)
	     final)))))))
︙

This page was generated in about 0.134s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00