Megatest

Check-in [575dfee04c]
Login
☰Home Timeline Files Branches Tags Tickets Wiki 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
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

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

︙
53
54
55
56
57
58
59
60












61
62
63
64
65
66
67

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)            (map vector->list (apply db:get-tests-for-run 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

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  (rmt:json-str->dat paramsj))
	 (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" 1 cmd params res)))))
    ;; (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

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

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

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)
    ((fs-aint-here)
     (debug:print 0 "ERROR: Not yet (re)supported")
     (exit 1))
    ((http)
     (let* ((jparams (rmt:dat->json-str params))
    ((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
	   (rmt:json-str->dat 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

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)
  (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))))
  (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)
  (map list->vector (rmt:send-receive 'get-tests-for-runs-mindata (list 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

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 -transport fs -rows 20 &
	cd fullrun && $(BINPATH)/dashboard -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
︙

This page was generated in about 0.11s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00