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)))))))
|