Megatest

Check-in [b564e3a921]
Login
Overview
Comment:wip
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.65-wip-alt
Files: files | file ages | folders
SHA1: b564e3a921293af1df4c6425823045d083ea7abc
User & Date: matt on 2019-11-02 10:19:09
Other Links: branch diff | manifest | tags
Context
2019-11-02
23:22
wip check-in: 813b6b2b30 user: matt tags: v1.65-wip-alt
10:19
wip check-in: b564e3a921 user: matt tags: v1.65-wip-alt
09:56
whatAmess check-in: d684bd81f1 user: matt tags: v1.65-wip-alt
Changes

Modified megamod.scm from [c009b819e5] to [15a913aff1].

46
47
48
49
50
51
52

53
54
55
56






















57
58
59
60
61
62
63
(declare (uses testsmod))
(declare (uses vgmod))

(module rmtmod
	*
	
(import scheme chicken data-structures extras)

(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable
	s11n stml2 srfi-13 stack regex irregex z3
	call-with-environment-variables
	csv)























;; (import apimod)
(import archivemod)
(import clientmod)
(import commonmod)
(import configfmod)
(import dbmod)







>
|
<
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







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
 (prefix sqlite3 sqlite3:)

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

;; General data
;;
(define (dcommon:general-info)
  (let ((general-matrix (iup:matrix
			 #:alignment1 "ALEFT"
			 #:expand "YES" ;; "HORIZONTAL"







|







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

;; 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
			      (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*)
					     ;;; (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))
					  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 ()







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|



|
|
|
|
|
|
|







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*)
					     ;;; (signal (make-composite-condition
					     ;;;          (make-property-condition 'commfail 'message "failed to connect to server")))
					     ;;; "communications failed"
					     (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
	 (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 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







|







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) ;; 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
            ;;(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")
)







|

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