︙ | | |
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
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
|
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(declare (uses testsmod))
(declare (uses vgmod))
(module rmtmod
*
(import scheme chicken data-structures extras)
(import
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable
(prefix sqlite3 sqlite3:)
s11n stml2 srfi-13 stack regex irregex z3
call-with-environment-variables
csv)
call-with-environment-variables
csv
format
http-client
intarweb
irregex
matchable
ports
posix
regex
s11n
spiffy
spiffy-directory-listing
spiffy-request-vars
srfi-1
srfi-13
srfi-18
srfi-69
stack
stml2
typed-records
uri-common
z3
)
;; (import apimod)
(import archivemod)
(import clientmod)
(import commonmod)
(import configfmod)
(import dbmod)
|
︙ | | |
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
-
+
|
(include "task_records.scm")
(include "test_records.scm")
(include "run_records.scm")
;;======================================================================
;; L O C K I N G M E C H A N I S M S
;;======================================================================
;; (include "f2.scm")
(include "f2.scm")
;; General data
;;
(define (dcommon:general-info)
(let ((general-matrix (iup:matrix
#:alignment1 "ALEFT"
#:expand "YES" ;; "HORIZONTAL"
|
︙ | | |
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
|
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
|
(mutex-lock! *http-mutex*)
;; (condition-case (with-input-from-request "http://localhost"; #f read-lines)
;; ((exn http client-error) e (print e)))
(set! res (vector ;;; DON'T FORGET - THIS IS THE CLIENT SIDE! NOTE: consider moving this to client.scm since we are only supporting http transport at this time.
success
(db:string->obj
(handle-exceptions
exn
(let ((call-chain (get-call-chain))
(msg ((condition-property-accessor 'exn 'message) exn)))
(set! success #f)
(if (debug:debug-mode 1)
(debug:print-info 0 *default-log-port* "couldn't talk to server, trying again ...")
(begin
(debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
(debug:print 0 *default-log-port* " message: " msg)
(debug:print 0 *default-log-port* " cmd: " cmd " params: " params)
(debug:print 0 *default-log-port* " call-chain: " call-chain)))
(if areadat
(areadat-conndat-set! areadat #f))
;; Killing associated server to allow clean retry.")
;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine?
(mutex-unlock! *http-mutex*)
exn
(let ((call-chain (get-call-chain))
(msg ((condition-property-accessor 'exn 'message) exn)))
(set! success #f)
(if (debug:debug-mode 1)
(debug:print-info 0 *default-log-port* "couldn't talk to server, trying again ...")
(begin
(debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
(debug:print 0 *default-log-port* " message: " msg)
(debug:print 0 *default-log-port* " cmd: " cmd " params: " params)
(debug:print 0 *default-log-port* " call-chain: " call-chain)))
(if areadat
(areadat-conndat-set! areadat #f))
;; Killing associated server to allow clean retry.")
;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine?
(mutex-unlock! *http-mutex*)
;;; (signal (make-composite-condition
;;; (make-property-condition 'commfail 'message "failed to connect to server")))
;;; "communications failed"
(db:obj->string #f))
(with-input-from-request ;; was dat
fullurl
(list (cons 'key (or *server-id* "thekey"))
(cons 'cmd cmd)
(cons 'params sparams))
read-string))
(db:obj->string #f)) ;; end of the error handling part
(with-input-from-request ;; was dat
fullurl
(list (cons 'key (or *server-id* "thekey"))
(cons 'cmd cmd)
(cons 'params sparams))
read-string))
transport: 'http)
0)) ;; added this speculatively
;; Shouldn't this be a call to the managed call-all-connections stuff above?
(close-all-connections!)
(mutex-unlock! *http-mutex*)
))
(time-out (lambda ()
|
︙ | | |
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
|
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
|
-
+
|
(debug:print-info 11 *default-log-port* "got res=" res)
(if (vector? res)
(if (vector-ref res 0) ;; this is the first flag or the second flag?
res ;; this is the *inner* vector? seriously? why?
(if (debug:debug-mode 11)
(let ((call-chain (get-call-chain))) ;; note: this code also called in nmsg-transport - consider consolidating it
(print-call-chain (current-error-port))
(debug:print-error 11 *default-log-port* "error above occured at server, res=" res " message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print-error 11 *default-log-port* "error above occured at server, res=" res) ;; there is NO exn at this time " message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 11 *default-log-port* " server call chain:")
(pp (vector-ref res 1) (current-error-port))
(signal (vector-ref res 0)))
res))
(signal (make-composite-condition
(make-property-condition
'timeout
|
︙ | | |
2378
2379
2380
2381
2382
2383
2384
2385
2386
|
2400
2401
2402
2403
2404
2405
2406
2407
2408
|
-
+
|
;;(close-idle-connections!)
#t))
#f)))
;; http-transport:server-dat definition moved to common_records.scm
;; bunch of small functions factored out of send-receive to make debug easier
;;
;; (include "f1.scm")
(include "f1.scm")
)
|