Megatest

Check-in [e036a57959]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Added missing section from http-server for /api
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: e036a579594b31cffc085f96fef02d234aa21861
User & Date: matt on 2013-11-10 21:06:08
Other Links: manifest | tags
Context
2013-11-10
21:08
Added missing section from http-server for /api check-in: a94cab85fc user: matt tags: trunk
21:06
Added missing section from http-server for /api check-in: e036a57959 user: matt tags: trunk
17:48
Getting unit tests into shape check-in: ce1727b240 user: matt tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified api.scm from [bb24492b2f] to [8e32b52fed].

︙
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

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








-













+
+
+








(declare (uses rmt))
(declare (uses db))

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

(define (api:execute-requests db cmd params)
  (debug:print-info 1 "api:execute-requests cmd=" cmd " params=" params)
  (db:process-cached-writes db)
  (case (string->symbol cmd)
    ;; KEYS
    ((get-key-val-pairs)            (apply db:get-key-val-pairs db params))
    ;; TESTS
    ;; json doesn't do vectors, convert to list
    ((get-test-info-by-id)	    (vector->list (apply db:get-test-info-by-id db params)))
    ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id db params))
    ((testmeta-get-record)          (vector->list (apply db:testmeta-get-record db params)))
    ((test-set-state-status-by-id)  (apply db:test-set-state-status-by-id db params))
    ;; 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))
    ((login)                        ;(apply db:login db params)
     (debug:print 0 "WOOHOO: Got login") #t)
    (else
     (list "ERROR" 0))))

;; http-server  send-response
;;                 api:process-request
;;                    db:*
;;
︙

Modified db.scm from [139b089db7] to [fab4b93153].

︙
129
130
131
132
133
134
135
136

137
138
139
140
141
142
143

129
130
131
132
133
134
135

136
137
138
139
140
141
142
143








-
+








	  tdats)))
     run-ids)
    (sqlite3:finalize! tgetstmt)
    (sqlite3:finalize! tputstmt)
    (if (> trecchgd 0)(debug:print 0 "sync'd " trecchgd " changed records in tests table"))
    ;; Next sync runs table
    (let* ((rrecchgd    0)
	   (rdats       #f)
	   (rdats       '())
	   (keys        (db:get-keys fromdb))
	   (rstdfields  (conc "id," (string-intersperse keys ",") ",runname,state,status,owner,event_time,comment,fail_count,pass_count"))
	   (rnumfields  (length (string-split rstdfields ",")))
	   (runslots    (string-intersperse (make-list rnumfields "?") ","))
	   (rgetstmt    (sqlite3:prepare todb (conc "SELECT " rstdfields " FROM runs WHERE id=?;")))
	   (rputstmt    (sqlite3:prepare todb (conc "INSERT OR REPLACE INTO runs (" rstdfields ") VALUES ( " runslots " );"))))
      ;; first collect all the source run data
︙
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815








1816
1817
1818
1819
1820
1821
1822

1801
1802
1803
1804
1805
1806
1807








1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822








-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+








  (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path))

(define (cdb:get-test-info-by-id serverdat test-id)
  (let ((test-dat (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info-by-id #f test-id)))
    (hash-table-set! *test-info* test-id (vector (current-seconds) test-dat)) ;; cached for use where up-to-date info is not needed
    test-dat))

;; db should be db open proc or #f
(define (cdb:remote-run proc db . params)
  (if (or *db-write-access*
	  (not (member proc *db:all-write-procs*)))
      (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params)
      (begin
	(debug:print 0 "ERROR: Attempt to access read-only database")
	#f)))
;; ;; db should be db open proc or #f
;; (define (cdb:remote-run proc db . params)
;;   (if (or *db-write-access*
;; 	  (not (member proc *db:all-write-procs*)))
;;       (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params)
;;       (begin
;; 	(debug:print 0 "ERROR: Attempt to access read-only database")
;; 	#f)))

(define (db:test-get-logfile-info db run-id test-name)
  (let ((res #f))
    (sqlite3:for-each-row 
     (lambda (path final_logf)
       (set! logf final_logf)
       (set! res (list path final_logf))
︙
1955
1956
1957
1958
1959
1960
1961








1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975

1976
1977
1978
1979
1980
1981
1982

1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991








+
+
+
+
+
+
+
+














+








;; 	  ;; Do a little record keeping
;; 	  (let ((cache-size (length data)))
;; 	    (if (> cache-size *max-cache-size*)
;; 		(set! *max-cache-size* cache-size)))
;; 	  #t)
;; 	#f)))

(define (db:login db keyval calling-path calling-version client-signature)
  (if (and (equal? calling-path *toppath*)
	   (equal? megatest-version calling-version))
      (begin
	(hash-table-set! *logged-in-clients* client-key (current-seconds))
	'(#t "successful login"))      ;; path matches - pass! Should vet the caller at this time ...
      (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*))))

(define (db:process-write db request-item)
  (let ((stmt-key (vector-ref request-item 0))
	(query    (vector-ref request-item 1))
	(params   (vector-ref request-item 2))
	(queryh   (sqlite3:prepare db query)))
    (apply sqlite3:execute stmt params)
    #f))

(define *db:process-queue-mutex* (make-mutex))

(define *number-of-writes*         0)
(define *writes-total-delay*       0)
(define *total-non-write-delay*    0)
(define *number-non-write-queries* 0)


;; The queue is a list of vectors where the zeroth slot indicates the type of query to
;; apply and the second slot is the time of the query and the third entry is a list of 
;; values to be applied
;;
(define (db:queue-write-and-wait db qry-sig query params)
  (let ((queue-len  0)
︙
2066
2067
2068
2069
2070
2071
2072
2073


2074
2075
2076
2077
2078
2079
2080

2081


2082
2083
2084
2085
2086
2087
2088

2075
2076
2077
2078
2079
2080
2081

2082
2083
2084
2085
2086
2087
2088
2089
2090
2091

2092
2093
2094
2095
2096
2097
2098
2099
2100








-
+
+







+
-
+
+








		 (server:reply return-address qry-sig #t 1)) ;; (length data)))
		((set-verbosity)
		 (set! *verbosity* (car params))
		 (server:reply return-address qry-sig #t (list #t *verbosity*)))
		((killserver)
		 (let ((hostname (car  *runremote*))
		       (port     (cadr *runremote*))
		       (pid      (car params)))
		       (pid      (car params))
		       (th1      (make-thread (lambda ()(thread-sleep! 3)(debug:print 0 "Server exiting!")(exit 0)) "Server exit thread")))
		   (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!")
		   (debug:print-info 1 "current pid=" (current-process-id))
		   (open-run-close tasks:server-deregister tasks:open-db 
				   hostname
				   port: port)
		   (set! *server-run* #f)
		   (thread-sleep! 3)
		   (if pid 
		   (process-signal pid signal/kill)
		       (process-signal pid signal/kill)
		       (thread-start! th1))
		   (server:reply return-address qry-sig #t '(#t "exit process started"))))
		(else ;; not a command, i.e. is a query
		 (debug:print 0 "ERROR: Unrecognised query/command " stmt-key)
		 (server:reply return-address qry-sig #f 'failed)))))
	   (else
	    (debug:print-info 11 "Executing " stmt-key " for " params)
	    (apply sqlite3:execute (hash-table-ref queries stmt-key) params)
︙

Modified http-transport.scm from [535621aa4a] to [937a4c1927].

︙
378
379
380
381
382
383
384

385

386
387
388
389
390
391
392

378
379
380
381
382
383
384
385

386
387
388
389
390
391
392
393








+
-
+








	 (thread-terminate! th2)
	 (debug:print-info 11 "got res=" res)
	 res)))))

(define (http-transport:client-connect iface port)
  (let* ((login-res   #f)
	 (uri-dat     (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl"))))
	 (uri-api-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/api"))))
	 (serverdat   (list iface port uri-dat)))
	 (serverdat   (list iface port uri-dat uri-api-dat)))
    (set! login-res (client:login serverdat))
    (if (and (not (null? login-res))
	     (car login-res))
	(begin
	  (debug:print-info 2 "Logged in and connected to " iface ":" port)
	  (set! *runremote* serverdat)
	  serverdat)
︙

Modified rmt.scm from [851932b993] to [fb7beb3bdd].

︙
58
59
60
61
62
63
64







65
66
67
68
69
70
71

58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78








+
+
+
+
+
+
+









;;======================================================================
;;
;; A C T U A L   A P I   C A L L S  
;;
;;======================================================================

;;======================================================================
;;  A D M I N
;;======================================================================

(define (rmt:login)
  (rmt:send-receive 'login (list *toppath* megatest-version *my-client-signature*)))

;;======================================================================
;;  K E Y S 
;;======================================================================

(define (rmt:get-key-val-pairs run-id)
  (rmt:send-receive 'get-key-val-pairs (list run-id)))
︙
99
100
101
102
103
104
105




106
107
108
109
110
111
112

106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123








+
+
+
+








;;  R U N S
;;======================================================================

(define (rmt:get-run-info run-id)
  (let ((res (rmt:send-receive 'get-run-info (list run-id))))
    (vector (car res)
	    (list->vector (cadr res)))))

(define (rmt:register-run keyvals runname state status user)
  (rmt:send-receive 'register-run (list keyvals runname state status user)))
    

;;======================================================================
;;  S T E P S
;;======================================================================

;; Getting steps is more complicated.
;;
︙

Modified tests/unittests/server.scm from [d4014f151d] to [80ff782d3d]. 

1
2
3


4
5
6
7
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


















55
56
57
58
59
60
61
62
63
64
65










66
67
68
69


70

1
2
3
4
5
6
7
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
55
56
57
58
59
60











61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77




+
+









-
+




+
+
-
-
-
-
-
+
+
+
+
+
+


+
+
-
-
-
-
+
+
+
+
+
+

-
-
+
-
-
-
+
+
-

-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+




+
+


;;======================================================================
;; S E R V E R
;;======================================================================

(set! *transport-type* 'http)

(test "setup for run" #t (begin (setup-for-run)
				(string? (getenv "MT_RUN_AREA_HOME"))))

(test "server-register, get-best-server" #t (let ((res #f))
					      (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http)
					      (set! res (open-run-close tasks:get-best-server tasks:open-db))
					      (number? (vector-ref res 3))))

(test "de-register server" #t (let ((res #f))
(test "de-register server" #f (let ((res #f))
				(open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
				(vector? (open-run-close tasks:get-best-server tasks:open-db))))

(define server-pid #f)

;; Not sure how the following should work, replacing it with system of megatest -server
(test "launch server" #t (let ((pid (process-fork (lambda ()
						    ;; (daemon:ize)
						    (server:launch 'http)))))
			   (set! server-pid pid)
			   (number? pid)))
;; (test "launch server" #t (let ((pid (process-fork (lambda ()
;; 						    ;; (daemon:ize)
;; 						    (server:launch 'http)))))
;; 			   (set! server-pid pid)
;; 			   (number? pid)))
(system "megatest -server - -debug 2 &")

(thread-sleep! 3) ;; need to wait for server to start. Yes, a better way is needed.
(test "get-best-server" #t (begin 
			     (client:launch)
(test "get-best-server" #t (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
			     (set! *runremote* (list (vector-ref dat 1)(vector-ref dat 2))) ;; host ip pullport pubport
			     (and (string? (car  *runremote*))
			     	  (number? (cadr *runremote*)))))
			     (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
			       (vector? dat))))
;; (print "dat: " dat)
;; (set! *runremote* (list (vector-ref dat 1)(vector-ref dat 2) #f)) ;; host ip pullport pubport
;; (and (string? (car  *runremote*))
;; 	  (number? (cadr *runremote*)))))

(test #f #t (car (cdb:login *runremote* *toppath* *my-client-signature*)))
(test #f #t (let ((res (client:login *runremote*)))
(test #f #t (string? (car *runremote*)))
	      (car res)))


;; (test #f #f (rmt:get-test-info-by-id 99))
(test #f #t (rmt:login)) ;;  *runremote* *toppath* *my-client-signature*)))
(test #f #t (cdb:client-call *runremote* 'immediate #t 1 (lambda ()(display "Got here eh!?") #t)))

;; (set! *verbosity* 20)
(test #f *verbosity* (cadr (cdb:set-verbosity *runremote* *verbosity*)))
(test #f #f (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" "PASS"))
;; (set! *verbosity* 1)
;; (cdb:set-verbosity *runremote* *verbosity*)



(test "get-keys" "SYSTEM" (car (db:get-keys *db*)))

(define remargs (args:get-args
		 '("bar" "foo" ":runname" "bob" ":SYSTEM" "ubuntu" ":RELEASE" "v1.2" ":datapath" "blah/foo" "nada")
		 (list ":runname" ":state" ":status")
		 (list "-h")
		 args:arg-hash
		 0))

(test "register-run" #t (number?
;; ;; (set! *verbosity* 20)
;; (test #f *verbosity* (cadr (cdb:set-verbosity *runremote* *verbosity*)))
;; (test #f #f (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" "PASS"))
;; ;; (set! *verbosity* 1)
;; ;; (cdb:set-verbosity *runremote* *verbosity*)
;; 
;; 
;; 
;; (test "get-keys" "SYSTEM" (car (db:get-keys *db*)))
;; 
;; (define remargs (args:get-args
;; 		 '("bar" "foo" ":runname" "bob" ":SYSTEM" "ubuntu" ":RELEASE" "v1.2" ":datapath" "blah/foo" "nada")
;; 		 (list ":runname" ":state" ":status")
;; 		 (list "-h")
;; 		 args:arg-hash
;; 		 0))
;; 
;; (test "register-run" #t (number?
			 (db:register-run *db*
					  '(("SYSTEM" "key1")("RELEASE" "key2"))
					  "myrun" 
					  "new"
					  "n/a" 
					  "bob")))

(test #f #t             (cdb:tests-register-test *runremote* 1 "nada" ""))
(test #f 1              (cdb:remote-run db:get-test-id #f 1 "nada" ""))
(test #f "NOT_STARTED"  (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3))
(test #f "NOT_STARTED"  (vector-ref (cdb:get-test-info *runremote* 1 "nada" "") 3))
;; 			 (rmt:register-run '(("SYSTEM" "key1")("RELEASE" "key2"))
;; 					   "myrun" 
;; 					   "new"
;; 					   "n/a" 
;; 					   "bob")))
;; 
;; (test #f #t             (cdb:tests-register-test *runremote* 1 "nada" ""))
;; (test #f 1              (cdb:remote-run db:get-test-id #f 1 "nada" ""))
;; (test #f "NOT_STARTED"  (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3))
;; (test #f "NOT_STARTED"  (vector-ref (cdb:get-test-info *runremote* 1 "nada" "") 3))

;;======================================================================
;; D B
;;======================================================================

(test #f #f (cdb:kill-server *runremote* #f)) ;; *toppath* *my-client-signature* #f)))

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