Megatest

Check-in [e90eacf59a]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:tweaks 'n problems
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: e90eacf59a9242a23789326fad57686dbe2db4d5
User & Date: matt on 2013-11-12 01:50:10
Other Links: manifest | tags
Context
2013-11-12
02:11
Blah check-in: 4612e9e264 user: matt tags: trunk
01:50
tweaks 'n problems check-in: e90eacf59a user: matt tags: trunk
2013-11-11
23:54
tweaks check-in: 38b08475b3 user: matt tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified api.scm from [3d6462efb6] to [ff2b1171fc].

︙
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114

99
100
101
102
103
104
105


106
107
108
109
110
111
112








-
-








(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
    (db:sync-to *inmemdb* *db*)
    
    (rmt:dat->json-str
     (if (or (string? res)
	     (list?   res)
	     (number? res)
	     (boolean? res))
	 res 
	 (list "ERROR" 1 cmd params res)))))
︙

Modified db.scm from [b88b6ecfeb] to [c36e0c2c6c].

︙
209
210
211
212
213
214
215
216


217
218
219
220
221
222
223

209
210
211
212
213
214
215

216
217
218
219
220
221
222
223
224








-
+
+








		    (apply sqlite3:execute rputstmt (vector->list rdat))))))
	  rdats)))
      (sqlite3:finalize! rgetstmt)
      (sqlite3:finalize! rputstmt))

    (if (> rrecchgd 0)  (debug:print 0 "synced " rrecchgd " changed records in runs  table"))
    (if (> trecchgd 0)  (debug:print 0 "synced " trecchgd " changed records in tests table"))
    (if (> tmrecchgd 0) (debug:print 0 "sync'd " tmrecchgd " changed records in test_meta table"))))
    (if (> tmrecchgd 0) (debug:print 0 "sync'd " tmrecchgd " changed records in test_meta table"))
    (+ rrecchgd trecchgd tmrecchgd)))

(define (db:sync-back)
  (db:sync-to *inmemdb* *db*))

;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling  proc idb . params)
  (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
︙
890
891
892
893
894
895
896
897

898
899
900
901
902
903
904

891
892
893
894
895
896
897

898
899
900
901
902
903
904
905








-
+








     runnamepatt)
    (vector header res)))

;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
(define (db:get-run-info db run-id)
  ;;(if (hash-table-ref/default *run-info-cache* run-id #f)
  ;;    (hash-table-ref *run-info-cache* run-id)
  (let* ((res      #f)
  (let* ((res       (vector #f #f #f #f))
	 (keys      (db:get-keys db))
	 (remfields (list "id" "runname" "state" "status" "owner" "event_time"))
	 (header    (append keys remfields))
	 (keystr    (conc (keys->keystr keys) ","
			  (string-intersperse remfields ","))))
    (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
    (sqlite3:for-each-row
︙

Modified http-transport.scm from [49ce87a953] to [87e7581569].

︙
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109

81
82
83
84
85
86
87

88
89
90
91
92
93
94
95
96
97




98
99
100
101
102
103
104








-










-
-
-
-








				 (string->number (args:get-arg "-port")))
			    (string->number (args:get-arg "-port"))
			    (if (and (config-lookup  *configdat* "server" "port")
				     (string->number (config-lookup  *configdat* "server" "port")))
				(string->number (config-lookup  *configdat* "server" "port"))
				(+ 5000 (random 1001)))))
	 (link-tree-path (config-lookup *configdat* "setup" "linktree")))
    (set! *cache-on* #t)
    (root-path     (if link-tree-path 
		       link-tree-path
		       (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 
				 ;; This is were we set up the database connections
			       (set! *db*       (open-db))
			       (set! *inmemdb*  (open-in-mem-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
︙
508
509
510
511
512
513
514






515
516
517
518
519
520
521

503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522








+
+
+
+
+
+








	    (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")))
	      (set! *cache-on* #t)
	      (set! *db*       (open-db))
	      (set! *inmemdb*  (open-in-mem-db))
	      (set! db *inmemdb*)
	      (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 runs.scm from [9e4d65748b] to [9303dbbcd6].

︙
119
120
121
122
123
124
125
126




127
128
129
130
131
132
133

119
120
121
122
123
124
125

126
127
128
129
130
131
132
133
134
135
136








-
+
+
+
+








       (if (and (string? key)
		(string? val))
	   (setenv key val)
	   (debug:print 0 "ERROR: Malformed environment variable definition: var=" var ", val=" val))))
    (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
    (alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))
    ;; Lets use this as an opportunity to put MT_RUNNAME in the environment
    (setenv "MT_RUNNAME" (if inrunname inrunname (rmt:get-run-name-from-id run-id)))
    (let ((runname  (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
      (if runname
	  (setenv "MT_RUNNAME" runname)
	  (debug:print 0 "ERROR: no value for runname for id " run-id)))
    (setenv "MT_RUN_AREA_HOME" *toppath*)))

(define (set-item-env-vars itemdat)
  (for-each (lambda (item)
	      (debug:print 2 "setenv " (car item) " " (cadr item))
	      (setenv (car item) (cadr item)))
	    itemdat))
︙

Modified tests/unittests/server.scm from [71c1d67bf7] to [55b7665339].

︙
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

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
90
91








+
+
+
+
+
+
+
+













+
+















-
+








			       (vector? dat))))

(define *keys*               (keys:config-get-fields *configdat*))
(define *keyvals*            (keys:target->keyval *keys* "a/b/c"))

(test #f #t                       (string? (car *runremote*)))
(test #f '(#t "successful login") (rmt:login)) ;;  *runremote* *toppath* *my-client-signature*)))

(define inmem (open-in-mem-db))
(define (inmem-test t b)
  (test "inmem sync to"   t (db:sync-to *db* inmem))
  (test "inmem sync back" b (db:sync-to inmem *db*)))

(inmem-test 0 0)

(test #f #f                       (rmt:get-test-info-by-id 99)) ;; get non-existant test

;; RUNS
(test #f 1                        (rmt:register-run  *keyvals* "firstrun" "new" "n/a" (current-user-name)))
(test "get run info"  "firstrun"  (let ((rinfo (rmt:get-run-info 1)))
				    (vector-ref (vector-ref rinfo 1) 3)))
(test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1))

;; TESTS
(test "get tests (no data)" '()   (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))
(test "register test"       #t    (rmt:general-call 'register-test 1 "test1" ""))
(test "get tests (some data)"  1  (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)))
(test "get test id"            1  (rmt:get-test-id 1 "test1" ""))

(inmem-test 1 1)

(test "get test id from main"  1  (db:get-test-id *db* 1 "test1" ""))
(test "get keys"               #t (list? (rmt:get-keys)))
(test "set comment"            #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t))
(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1)))
					  (db:test-get-comment trec)))

;; MORE RUNS
(test "get runs"  #t (let* ((runs   (rmt:get-runs "%" #f #f '()))
			    (header (vector-ref runs 0))
			    (data   (vector-ref runs 1)))
		       (and (list?   header)
			    (list?   data)
			    (vector? (car data)))))

;; (test "sync back"              #t (begin (rmt:sync-back) #t))
(inmem-test 1 1)

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

(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))

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