Megatest

Diff
Login

Differences From Artifact [fe6673ff15]:

To Artifact [9d03c1c19f]:


9
10
11
12
13
14
15
16

17
18
19
20
21
22
23
9
10
11
12
13
14
15

16
17
18
19
20
21
22
23







-
+







;;  PURPOSE.

(require-extension (srfi 18) extras tcp s11n)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
(import (prefix sqlite3 sqlite3:))

(use spiffy uri-common intarweb http-client spiffy-request-vars)
(use spiffy uri-common intarweb http-client spiffy-request-vars  uri-common intarweb)

;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048) 

(declare (unit http-transport))

144
145
146
147
148
149
150
151
152


153
154
155
156
157

158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174




175
176



177
178


179
180
181
182


183
184
185
186



187
188
189

190
191


192
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
224
225
226
227
228
229
230
231


232
233
234
235
236
237
238
144
145
146
147
148
149
150


151
152
153
154
155
156

157
158
159
160
161
162
163
164
165
166
167
168
169
170
171



172
173
174
175
176
177
178
179
180


181
182
183
184
185

186
187
188



189
190
191
192
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
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240

241
242
243
244
245
246
247
248
249







-
-
+
+




-
+














-
-
-
+
+
+
+


+
+
+
-
-
+
+



-
+
+

-
-
-
+
+
+



+
-
-
+
+
-
-
-
+
+
+
+
+









+
-
+








-
-
-
-
+
+
+
+
+














-
+
+







	 (print "ERROR: Tried and tried but could not start the server")))
   ;; any error in following steps will result in a retry
   (set! *runremote* (list ipaddrstr portnum))
   ;; (open-run-close tasks:remove-server-records tasks:open-db)
   (open-run-close tasks:server-register 
		   tasks:open-db 
		   (current-process-id)
		   ipaddrstr portnum 0 'live 'http)
   (print "INFO: Trying to start server on " ipaddrstr ":" portnum)
		   ipaddrstr portnum 0 'startup 'http)
   (debug:print 1 "INFO: Trying to start server on " ipaddrstr ":" portnum)
   ;; This starts the spiffy server
   ;; NEED WAY TO SET IP TO #f TO BIND ALL
   (start-server bind-address: ipaddrstr port: portnum)
   (open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum)
   (print "INFO: server has been stopped")))
   (debug:print 1 "INFO: server has been stopped")))

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

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

;; <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    (conc url "/ctrl")) ;; (conc url "/?dat=" msg)))
	 (numretries 0))     
  (let* (;; (url        (http-transport:make-server-url serverdat))
	 (fullurl    (caddr serverdat)) ;; (conc url "/ctrl")) ;; (conc url "/?dat=" msg)))
	 (numretries 10)
	 (res        #f))
    (handle-exceptions
     exn
     (begin
       (print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn))
       (thread-sleep! 2)
     (if (< numretries 200)
	 (http-transport:client-send-receive serverdat msg))
       (if (> numretries 0)
	   (http-transport:client-send-receive serverdat msg)))
     (begin
       (debug:print-info 11 "fullurl=" fullurl "\n")
       ;; set up the http-client here
       (max-retry-attempts 100)
       (max-retry-attempts 5)
       ;; consider all requests indempotent
       (retry-request? (lambda (request)
			 (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10))
			 (set! numretries (+ numretries 1))
			 #t))
			 #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 ()
       (let* ((res   (with-input-from-request fullurl 
					      ;; #f
			      (set! res (with-input-from-request 
					 fullurl 
					      ;; msg 
					      (list (cons 'dat msg)) 
					      read-string)))
					 (list (cons 'dat msg)) 
					 read-string))))
	      (th1 (make-thread send-recieve "with-input-from-request")))
	 (thread-start! th1)
	 (thread-join! th1)
	 (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)))))))

(define (http-transport:client-connect iface port)
  (let* ((login-res   #f)
	 (uri-dat     (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl"))))
	 (serverdat   (list iface port)))
	 (serverdat   (list iface port uri-dat)))
    (set! login-res (client:login serverdat))
    (if (and (not (null? login-res))
	     (car login-res))
	(begin
	  (debug:print-info 2 "Logged in and connected to " iface ":" port)
	  (set! *runremote* serverdat)
	  serverdat)
	(begin
	  (debug:print-info 0 "Failed to login or connect to " iface ":" port)
	  (set! *runremote* #f)
	  (set! *transport-type* 'fs)
	  #f))))
	  (debug:print-info 0 "ERROR: Failed to login or connect to " iface ":" port)
	  (exit 1)))))
;; 	  (set! *runremote* #f)
;; 	  (set! *transport-type* 'fs)
;; 	  #f))))


;; run http-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (http-transport:keep-running)
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive
  (let* ((server-info (let loop ()
                        (let ((sdat #f))
                          (mutex-lock! *heartbeat-mutex*)
                          (set! sdat *runremote*)
                          (mutex-unlock! *heartbeat-mutex*)
                          (if sdat sdat
                          (if sdat
			      sdat
                              (begin
                                (sleep 4)
                                (loop))))))
         (iface       (car server-info))
         (port        (cadr server-info))
         (last-access 0)
	 (tdb         (tasks:open-db))