Megatest

Check-in [575dfee04c]
Login
Overview
Comment:Switched away from json
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 575dfee04c171ea6f6494afb75ba7f39174666da
User & Date: matt on 2013-11-16 23:13:38
Other Links: manifest | tags
Context
2013-11-16
23:22
replace one missed cdb:remote-run call check-in: 8e4249db71 user: matt tags: trunk
23:13
Switched away from json check-in: 575dfee04c user: matt tags: trunk
21:12
Merged minor fixes from v1.55 check-in: 83635d0962 user: matt tags: trunk
Changes

Modified api.scm from [6602e90b97] to [3e2760a748].

53
54
55
56
57
58
59
60











61
62
63
64
65
66
67

    ;; RUNS
    ((get-run-info)                 (let ((res (apply db:get-run-info db params)))
				      (list (vector-ref res 0)
					    (vector->list (vector-ref res 1)))))
    ((register-run)                 (apply db:register-run db params))
    ((set-tests-state-status)       (apply db:set-tests-state-status db params))
    ((get-tests-for-run)            (map vector->list (apply db:get-tests-for-run db params)))











    ((get-test-id)                  (apply db:get-test-id-not-cached db params))
    ((get-tests-for-runs-mindata)   (map vector->list (apply db:get-tests-for-runs-mindata db params)))
    ((get-run-name-from-id)         (apply db:get-run-name-from-id db params))
    ((delete-run)                   (apply db:delete-run db params))
    ((get-runs)                     (let* ((res  (apply db:get-runs db params))
					   (hedr (vector-ref res 0))
					   (data (vector-ref res 1)))







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







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

    ;; RUNS
    ((get-run-info)                 (let ((res (apply db:get-run-info db params)))
				      (list (vector-ref res 0)
					    (vector->list (vector-ref res 1)))))
    ((register-run)                 (apply db:register-run db params))
    ((set-tests-state-status)       (apply db:set-tests-state-status db params))
    ((get-tests-for-run)            (let ((res  (apply db:get-tests-for-run db params)))
				      (if (list? res)
					  (map (lambda (x)
						 (if (list? x)
						     (vector->list x)
						     (begin
						       (debug:print 0 "ERROR in remote of get-tests-for-run, not a vector")
						       x)))
					       res)
					  (begin
					    (debug:print 0 "ERROR in remote of get-tests-for-run, not a list")
					    res))))
    ((get-test-id)                  (apply db:get-test-id-not-cached db params))
    ((get-tests-for-runs-mindata)   (map vector->list (apply db:get-tests-for-runs-mindata db params)))
    ((get-run-name-from-id)         (apply db:get-run-name-from-id db params))
    ((delete-run)                   (apply db:delete-run db params))
    ((get-runs)                     (let* ((res  (apply db:get-runs db params))
					   (hedr (vector-ref res 0))
					   (data (vector-ref res 1)))
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129

130
;;                    db:*
;;
;; NB// Runs on the server as part of the server loop
;;
(define (api:process-request db $) ;; the $ is the request vars proc
  (let* ((cmd     ($ 'cmd))
	 (paramsj ($ 'params))
	 (params  (rmt:json-str->dat paramsj))
	 (res     (api:execute-requests db cmd params)))

    ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
    (rmt:dat->json-str
     (if (or (string? res)
	     (list?   res)
	     (number? res)
	     (boolean? res))
	 res 
	 (list "ERROR" 1 cmd params res)))))









|



|
|
|
|
|
|
|
>

123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
;;                    db:*
;;
;; NB// Runs on the server as part of the server loop
;;
(define (api:process-request db $) ;; the $ is the request vars proc
  (let* ((cmd     ($ 'cmd))
	 (paramsj ($ 'params))
	 (params  (db:string->obj paramsj)) ;; (rmt:json-str->dat paramsj))
	 (res     (api:execute-requests db cmd params)))

    ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
    ;; (rmt:dat->json-str
    ;;  (if (or (string? res)
    ;;          (list?   res)
    ;;          (number? res)
    ;;          (boolean? res))
    ;;      res 
    ;;      (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
    (db:obj->string res)))

Modified db.scm from [b3539e4aa6] to [cba05a0b7c].

1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
;;======================================================================

;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj)
  (case *transport-type*
    ((fs) obj)
    ((http)
     (string-substitute
      (regexp "=") "_"
      (base64:base64-encode (with-output-to-string (lambda ()(serialize obj))))
      #t))
    ((zmq)(with-output-to-string (lambda ()(serialize obj))))
    (else obj)))

(define (db:string->obj msg)
  (case *transport-type*
    ((fs) msg)
    ((http)
     (if (string? msg)
	 (with-input-from-string 
	     (base64:base64-decode
	      (string-substitute 
	       (regexp "_") "=" msg #t))
	   (lambda ()(deserialize)))
	 (vector #f #f #f))) ;; crude reply for when things go awry







|
|









|
|







1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
;;======================================================================

;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj)
  (case *transport-type*
    ;; ((fs) obj)
    ((http fs)
     (string-substitute
      (regexp "=") "_"
      (base64:base64-encode (with-output-to-string (lambda ()(serialize obj))))
      #t))
    ((zmq)(with-output-to-string (lambda ()(serialize obj))))
    (else obj)))

(define (db:string->obj msg)
  (case *transport-type*
    ;; ((fs) msg)
    ((http fs)
     (if (string? msg)
	 (with-input-from-string 
	     (base64:base64-decode
	      (string-substitute 
	       (regexp "_") "=" msg #t))
	   (lambda ()(deserialize)))
	 (vector #f #f #f))) ;; crude reply for when things go awry

Modified mt.scm from [c0f326ccbf] to [b59cdde8b5].

15
16
17
18
19
20
21

22
23
24
25
26
27
28
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses runs))


(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")








>







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses runs))
(declare (uses rmt))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")

Modified rmt.scm from [9538710db7] to [1ecb031848].

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
;;======================================================================

;; cmd is a symbol
;; vars is a json string encoding the parameters for the call
;;
(define (rmt:send-receive cmd params)
  (case *transport-type* 
    ((fs)
     (debug:print 0 "ERROR: Not yet (re)supported")
     (exit 1))
    ((http)
     (let* ((jparams (rmt:dat->json-str params))
	    (res (http-transport:client-api-send-receive *runremote* cmd jparams)))
       (if res
	   (rmt:json-str->dat res)
	   (begin
	     (debug:print 0 "ERROR: Bad value from http-transport:client-api-send-receive " res)
	     #f))
     ))
    (else
     (debug:print 0 "ERROR: Transport " *transport-type* " not yet (re)supported")
     (exit 1))))







|


|
|


|







35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
;;======================================================================

;; cmd is a symbol
;; vars is a json string encoding the parameters for the call
;;
(define (rmt:send-receive cmd params)
  (case *transport-type* 
    ((fs-aint-here)
     (debug:print 0 "ERROR: Not yet (re)supported")
     (exit 1))
    ((fs http)
     (let* ((jparams (db:obj->string params)) ;; (rmt:dat->json-str params))
	    (res (http-transport:client-api-send-receive *runremote* cmd jparams)))
       (if res
	   (db:string->obj res) ;; (rmt:json-str->dat res)
	   (begin
	     (debug:print 0 "ERROR: Bad value from http-transport:client-api-send-receive " res)
	     #f))
     ))
    (else
     (debug:print 0 "ERROR: Transport " *transport-type* " not yet (re)supported")
     (exit 1))))
127
128
129
130
131
132
133
134



135
136
137



138
139
140
141
142
143
144
  (rmt:send-receive 'test-set-state-status-by-id (list test-id newstate newstatus newcomment)))


(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus)
  (rmt:send-receive 'set-tests-state-status (list run-id testnames currstate currstatus newstate newstatus)))

(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)
  (map list->vector (rmt:send-receive 'get-tests-for-run (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals))))




(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
  (map list->vector (rmt:send-receive 'get-tests-for-runs-mindata (list run-ids testpatt states status not-in))))




(define (rmt:delete-test-records test-id)
  (rmt:send-receive 'delete-test-records (list test-id)))

(define (rmt:test-set-status-state test-id status state msg)
  (rmt:send-receive 'test-set-status-state (list test-id status state msg)))








|
>
>
>


|
>
>
>







127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
  (rmt:send-receive 'test-set-state-status-by-id (list test-id newstate newstatus newcomment)))


(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus)
  (rmt:send-receive 'set-tests-state-status (list run-id testnames currstate currstatus newstate newstatus)))

(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)
  (let ((res  (rmt:send-receive 'get-tests-for-run (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals))))
    (if (list? res)
	(map list->vector res)
	res)))

(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
  (let ((res (rmt:send-receive 'get-tests-for-runs-mindata (list run-ids testpatt states status not-in))))
    (cond 
     ((list? res)(map list->vector res))
     (else res))))

(define (rmt:delete-test-records test-id)
  (rmt:send-receive 'delete-test-records (list test-id)))

(define (rmt:test-set-status-state test-id status state msg)
  (rmt:send-receive 'test-set-status-state (list test-id status state msg)))

Modified tests/Makefile from [f4097c2b49] to [7c208855d9].

156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
	touch cleanprep

fullprep : cleanprep
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/%
	cd fullrun;$(BINPATH)/dashboard -rows 15 &

dashboard : cleanprep
	cd fullrun && $(BINPATH)/dashboard -transport fs -rows 20 &

dashboard-http : cleanprep
	cd fullrun && $(BINPATH)/dashboard -transport http -rows 20 &

remove :
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN)  -testpatt % -itempatt % :sysname % :fsname % :datapath %

clean  : 
	rm cleanprep








|
<
<
<







156
157
158
159
160
161
162
163



164
165
166
167
168
169
170
	touch cleanprep

fullprep : cleanprep
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/%
	cd fullrun;$(BINPATH)/dashboard -rows 15 &

dashboard : cleanprep
	cd fullrun && $(BINPATH)/dashboard -rows 20 &




remove :
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN)  -testpatt % -itempatt % :sysname % :fsname % :datapath %

clean  : 
	rm cleanprep