Megatest

Check-in [9509385707]
Login
Overview
Comment:Read-only calls can bypass the server if it isn't already running.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60
Files: files | file ages | folders
SHA1: 950938570781e475c89cc9b703d8a4637769d66d
User & Date: matt on 2014-08-25 23:27:25
Other Links: branch diff | manifest | tags
Context
2014-08-26
00:02
Added message on read-only query bypassing server check-in: aeed6c5c75 user: matt tags: v1.60
2014-08-25
23:27
Read-only calls can bypass the server if it isn't already running. check-in: 9509385707 user: matt tags: v1.60
2014-08-24
23:55
Removed error message on calling get-runs with run-id=#f, it is harmless check-in: 48f04e9bff user: matt tags: v1.60
Changes

Modified api.scm from [dd5a58c49b] to [904aa00978].

8
9
10
11
12
13
14

































15
16
17
18
19
20
21
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

(declare (unit api))
(declare (uses rmt))
(declare (uses db))


































;; These are called by the server on recipt of /api calls

(define (api:execute-requests dbstruct cmd params)
  (case (string->symbol cmd)
    ;; SERVERS
    ((start-server)                (apply server:kind-run params))







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

(declare (unit api))
(declare (uses rmt))
(declare (uses db))

;; allow these queries through without starting a server
;;
(define api:read-only-queries
  '(get-key-val-pairs
    get-keys
    test-toplevel-num-items
    get-test-info-by-id
    test-get-rundir-from-test-id
    get-count-tests-running
    get-count-tests-running-in-jobgroup
    get-previous-test-run-record
    get-matching-previous-test-run-records
    test-get-logfile-info
    test-get-records-for-index-file
    get-testinfo-state-status
    test-get-paths-matching-keynames-target-new
    get-prereqs-not-met
    get-count-tests-running-for-run-id
    get-run-info
    register-run
    get-tests-for-run
    get-test-id
    get-tests-for-runs-mindata
    get-run-name-from-id
    get-runs
    get-all-run-ids
    get-prev-run-ids
    get-run-ids-matching-target
    get-runs-by-patt
    get-steps-data
    login
    testmeta-get-record))

;; These are called by the server on recipt of /api calls

(define (api:execute-requests dbstruct cmd params)
  (case (string->symbol cmd)
    ;; SERVERS
    ((start-server)                (apply server:kind-run params))

Modified rmt.scm from [0fc94cf8d5] to [a10d02527a].

34
35
36
37
38
39
40
41
42
43
44








45
46
47
48
49
50
51
52
53
54
55
56

57
58
59
60
61
62











63
64
65
66
67
68
69
;;  S U P P O R T   F U N C T I O N S
;;======================================================================

;; cmd is a symbol
;; vars is a json string encoding the parameters for the call
;;
(define (rmt:send-receive cmd rid params)
  (let* ((run-id  (if rid rid 0))
	 (connection-info (let ((cinfo (hash-table-ref/default *runremote* run-id #f)))
			    (if cinfo
				cinfo








				(let loop ((numtries 100))
				  (let ((res (client:setup run-id)))
				    (if res 
					(hash-table-ref/default *runremote* run-id #f) ;; client:setup filled this in (hopefully)
					(if (> numtries 0)
					    (begin
					      (thread-sleep! 10)
					      (loop (- numtries 1)))
					    (begin
					      (debug:print 0 "ERROR: 100 tries and no server, giving up")
					      (exit 1)))))))))
	 (jparams         (db:obj->string params))

	 (res     (http-transport:client-api-send-receive run-id connection-info cmd jparams)))
    (if res
	(db:string->obj res)
	(let ((new-connection-info (client:setup run-id)))
	  (debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.")
	  (rmt:send-receive cmd run-id params)))))












(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
  (let* ((run-id   (if run-id run-id 0))
	 (jparams         (db:obj->string params)) ;; (rmt:dat->json-str params))
	 (res (http-transport:client-api-send-receive run-id connection-info cmd jparams)))
    (if res
	(db:string->obj res)







|



>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>







34
35
36
37
38
39
40
41
42
43
44
45
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
86
87
88
89
;;  S U P P O R T   F U N C T I O N S
;;======================================================================

;; cmd is a symbol
;; vars is a json string encoding the parameters for the call
;;
(define (rmt:send-receive cmd rid params)
  (let* ((run-id          (if rid rid 0))
	 (connection-info (let ((cinfo (hash-table-ref/default *runremote* run-id #f)))
			    (if cinfo
				cinfo
				;; if read only query and server not already running
				;; bypass starting the server. 
				;;
				;; NB// can cache the answer for server running for 10 seconds ...
				;;
				(if (and (member cmd api:read-only-queries)
					 (not (open-run-close tasks:get-server tasks:open-db run-id)))
				    #f
				    (let loop ((numtries 100))
				      (let ((res (client:setup run-id)))
					(if res 
					    (hash-table-ref/default *runremote* run-id #f) ;; client:setup filled this in (hopefully)
					    (if (> numtries 0)
						(begin
						  (thread-sleep! 10)
						  (loop (- numtries 1)))
						(begin
						  (debug:print 0 "ERROR: 100 tries and no server, giving up")
						  (exit 1))))))))))
	 (jparams         (db:obj->string params)))
    (if connection-info
	(let ((res             (http-transport:client-api-send-receive run-id connection-info cmd jparams)))
	  (if res
	      (db:string->obj res)
	      (let ((new-connection-info (client:setup run-id)))
		(debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.")
		(rmt:send-receive cmd run-id params))))
	(rmt:open-qry-close-locally cmd run-id params))))

(define (rmt:open-qry-close-locally cmd run-id params)
  (let* ((dbdir (conc    (configf:lookup *configdat* "setup" "linktree") "/.db"))
	 (dbstruct-local (make-dbr:dbstruct path:  dbdir
					    local: #t))
	 (db-file-path   (db:dbfile-path 0))
	 ;; (read-only      (not (file-read-access? db-file-path)))
	 (res            (api:execute-requests dbstruct-local (symbol->string cmd) params)))
    (db:close-all dbstruct-local)
    res))

(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
  (let* ((run-id   (if run-id run-id 0))
	 (jparams         (db:obj->string params)) ;; (rmt:dat->json-str params))
	 (res (http-transport:client-api-send-receive run-id connection-info cmd jparams)))
    (if res
	(db:string->obj res)