Megatest

Check-in [078d2c5ac2]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:All parts of the /api interface basically now working
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 078d2c5ac2c283020c287cba28a89375f723fcf3
User & Date: matt on 2013-11-10 21:33:47
Other Links: manifest | tags
Context
2013-11-10
23:17
11 out of 30 calls converted to api check-in: b9aa1e0ac7 user: matt tags: trunk
21:33
All parts of the /api interface basically now working check-in: 078d2c5ac2 user: matt tags: trunk
21:08
Added missing section from http-server for /api check-in: a94cab85fc user: matt tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified api.scm from [8e32b52fed] to [3215f5c017].

︙
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

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








-





-
+
+








-
+
-








(declare (unit api))
(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)
  (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)))
    ((get-test-info-by-id)	    (let ((res (apply db:get-test-info-by-id db params)))
				      (if (vector? res)(vector->list res) res)))
    ((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)
    ((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 client.scm from [e09e6cd211] to [3b8eec1fa9].

︙
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50

33
34
35
36
37
38
39




40
41
42
43
44
45
46








-
-
-
-








;; client:get-signature
(define (client:get-signature)
  (if *my-client-signature* *my-client-signature*
      (let ((sig (conc (get-host-name) " " (current-process-id))))
	(set! *my-client-signature* sig)
	*my-client-signature*)))

;; client:login serverdat
(define (client:login serverdat)
  (cdb:login serverdat *toppath* (client:get-signature)))

;; Not currently used! But, I think it *should* be used!!!
(define (client:logout serverdat)
  (let ((ok (and (socket? serverdat)
		 (cdb:logout serverdat *toppath* (client:get-signature)))))
    ok))

;; Do all the connection work, look up the transport type and set up the
︙

Modified db.scm from [fab4b93153] to [eb49309475].

︙
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765

1746
1747
1748
1749
1750
1751
1752






1753
1754
1755
1756
1757
1758
1759








-
-
-
-
-
-








	  (thread-join!  th1)
	  (debug:print-info 11 "cdb:client-call returning res=" res)
	  res))))))

(define (cdb:set-verbosity serverdat val)
  (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val))

(define (cdb:login serverdat keyval signature)
  (cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature))

(define (cdb:logout serverdat keyval signature)
  (cdb:client-call serverdat 'logout #t *default-numtries* keyval signature))

(define (cdb:num-clients serverdat)
  (cdb:client-call serverdat 'numclients #t *default-numtries*))

;; I think this would be more efficient if executed on client side FIXME???
(define (cdb:test-set-status-state serverdat test-id status state msg)
  (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
      (cdb:client-call serverdat 'set-test-start-time #t *default-numtries* test-id))
︙
1955
1956
1957
1958
1959
1960
1961
1962

1963
1964
1965
1966

1967
1968
1969
1970
1971
1972
1973

1949
1950
1951
1952
1953
1954
1955

1956
1957
1958
1959

1960
1961
1962
1963
1964
1965
1966
1967








-
+



-
+








;; 	  ;; 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)
(define (db:login db 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))
	(hash-table-set! *logged-in-clients* client-signature (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))
︙

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

︙
91
92
93
94
95
96
97
98
99
100



101
102
103
104
105


106
107
108
109
110
111
112

91
92
93
94
95
96
97



98
99
100





101
102
103
104
105
106
107
108
109








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








		       (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
    (handle-directory spiffy-directory-listing)
    ;; http-transport:handle-directory) ;; simple-directory-handler)
    ;; Setup the web server and a /ctrl interface
    ;;
    (vhost-map `(((* any) . ,(lambda (continue)
			       ;; open the db on the first call 
			       (let loop ()
				 (if (not db)
				     (if (not (sqlite3:database? *inmemdb*))
				 ;; This is were we set up the database connections
			       (set! *db*       (open-db))
			       (set! *inmemdb*  (open-in-mem-db))
					 (begin
					   (debug:print 0 "WARNING: db not ready yet. Waiting for it to be ready")
					   (thread-sleep! 5)
					   (loop)))
				     (set! db *inmemdb*))) ;; (open-db)))
			       (set! db *inmemdb*)
			       (db:sync-to *db* *inmemdb*)
			       (let* (($   (request-vars source: 'both))
				      (dat ($ 'dat))
				      (res #f))
				 (cond
				  ((equal? (uri-path (request-uri (current-request)))
					   '(/ "api"))
				   (send-response body:    (api:process-request db $) ;; the $ is the request vars proc
︙
380
381
382
383
384
385
386

387
388


389
390
391
392
393
394
395

377
378
379
380
381
382
383
384


385
386
387
388
389
390
391
392
393








+
-
-
+
+








	 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 uri-api-dat)))
    (set! *runremote* serverdat) ;; may or may not be good ...
    (set! login-res (client:login serverdat))
    (if (and (not (null? login-res))
    (set! login-res (rmt:login))
    (if (and (list? login-res)
	     (car login-res))
	(begin
	  (debug:print-info 2 "Logged in and connected to " iface ":" port)
	  (set! *runremote* serverdat)
	  serverdat)
	(begin
	  (debug:print-info 0 "ERROR: Failed to login or connect to " iface ":" port)
︙
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529

510
511
512
513
514
515
516




517
518
519
520
521
522
523








-
-
-
-








	    (let* ((th2 (make-thread (lambda ()
				       (http-transport:run 
					(if (args:get-arg "-server")
					    (args:get-arg "-server")
					    "-"))) "Server run"))
		   (th3 (make-thread http-transport:keep-running "Keep running")))
;;		   (th1 (make-thread server:write-queue-handler  "write queue")))
	      ;; This is were we set up the database connections
	      (set! *db* (open-db))
	      (set! *inmemdb* (open-in-mem-db))
	      (db:sync-to *db* *inmemdb*)
	      (thread-start! th2)
	      (thread-start! th3)
	      ;; (thread-start! th1)
	      (set! *didsomething* #t)
	      (thread-join! th2))
	    (debug:print 0 "ERROR: Failed to setup for megatest")))
    (exit)))
︙

Modified rmt.scm from [fb7beb3bdd] to [c21b152e2b].

︙
77
78
79
80
81
82
83
84
85




86
87
88
89
90
91
92

77
78
79
80
81
82
83


84
85
86
87
88
89
90
91
92
93
94








-
-
+
+
+
+








  (rmt:send-receive 'get-key-val-pairs (list run-id)))

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

(define (rmt:get-test-info-by-id test-id)
  (list->vector
   (rmt:send-receive 'get-test-info-by-id (list test-id))))
  (let ((res (rmt:send-receive 'get-test-info-by-id (list test-id))))
    (if (list? res)
	(list->vector res)
	res)))

(define (rmt:test-get-rundir-from-test-id test-id)
  (rmt:send-receive 'test-get-rundir-from-test-id (list test-id)))

(define (rmt:open-test-db-by-test-id test-id #!key (work-area #f))
  (let* ((test-path (if (string? work-area)
			work-area
︙

Modified tests/unittests/server.scm from [f61539c17c] to [4fd1b18b7f].

︙
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

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








-
+











-
-
-
+
+
+









;; 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)))
(system "megatest -server - -debug 2 &")
(system "megatest -server - &")

(thread-sleep! 3) ;; need to wait for server to start. Yes, a better way is needed.
(test "get-best-server" #t (begin 
			     (client:launch)
			     (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 (string? (car *runremote*)))
(test #f #t (rmt:login)) ;;  *runremote* *toppath* *my-client-signature*)))
(test #f #f (rmt:get-test-info-by-id 99))
(test #f #t                       (string? (car *runremote*)))
(test #f '(#t "successful login") (rmt:login)) ;;  *runremote* *toppath* *my-client-signature*)))
(test #f #f                       (rmt:get-test-info-by-id 99))

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

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