| ︙ | | | ︙ | |
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
|
;;
;;======================================================================
;;======================================================================
;; Tests
;;======================================================================
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(require-library stml)
|
<
<
<
<
>
>
>
>
>
|
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
|
;;
;;======================================================================
;;======================================================================
;; Tests
;;======================================================================
(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))
(declare (uses tdb))
(declare (uses common))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
(declare (uses server))
;;(declare (uses stml2))
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(require-library stml)
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(include "js-path.scm")
|
| ︙ | | | ︙ | |
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
|
(change-directory orig-dir)
;; NB// tests:test-set-toplog! is remote internal...
(tests:test-set-toplog! run-id test-name outputfilename))
;; didn't get the lock, check to see if current update started later than this
;; update, if so we can exit without doing any work
(if (> my-start-time (handle-exceptions
exn
0
(file-modification-time lockf)))
;; we started since current re-gen in flight, delay a little and try again
(begin
(debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it")
(thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds
(loop (common:simple-file-lock lockf))))))))))
|
>
>
|
|
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
|
(change-directory orig-dir)
;; NB// tests:test-set-toplog! is remote internal...
(tests:test-set-toplog! run-id test-name outputfilename))
;; didn't get the lock, check to see if current update started later than this
;; update, if so we can exit without doing any work
(if (> my-start-time (handle-exceptions
exn
(begin
(print "failed to get mod time on " lockf ", exn=" exn)
0)
(file-modification-time lockf)))
;; we started since current re-gen in flight, delay a little and try again
(begin
(debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it")
(thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds
(loop (common:simple-file-lock lockf))))))))))
|
| ︙ | | | ︙ | |
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
|
;; tests:genrate dashboard body
;;
(define (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links flag run-patt target-patt)
(let* ((start (* page pg-size))
;(runsdat (rmt:get-runs "%" pg-size start (map (lambda (x)(list x "%")) keys)))
(runsdat (rmt:get-runs-by-patt keys run-patt target-patt start pg-size #f 0 sort-order: "desc"))
; db:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-update
(header (vector-ref runsdat 0))
(runs (vector-ref runsdat 1))
(s:html tests:css-jscript-block (tests:css-jscript-block-cond flag)
(s:title "Summary for " area-name)
(s:body 'onload "addEvents();"
(get-prev-links page linktree)
(get-next-links page linktree total-runs)
(s:h1 "Summary for " area-name)
(s:h3 "Filter" )
(s:input 'type "text" 'name "testname" 'id "testname" 'length "30" 'onkeyup "filtersome()")
;; top list
(s:table 'id "LinkedList1" 'border "1" 'cellspacing 0
(map (lambda (key)
(let* ((res (s:tr 'class "something"
(s:th key )
(map (lambda (run)
(s:th (vector-ref run ctr)))
runs))))
(set! ctr (+ ctr 1))
res))
keys)
(s:tr
(s:th "Run Name")
(map (lambda (run)
(s:th (db:get-value-by-header run header "runname")))
runs))
(map (lambda (test-name)
(let* ((item-hash (hash-table-ref/default test-runs-hash test-name #f))
(item-keys (sort (hash-table-keys item-hash) string<=?)))
(map (lambda (item-name)
(let* ((res (s:tr 'class item-name
(s:td item-name 'class "test" )
(map (lambda (run)
(let* ((run-test (hash-table-ref/default item-hash item-name #f))
(run-id (db:get-value-by-header run header "id"))
(result (hash-table-ref/default run-test run-id "n/a"))
;(relative-path (get-relative-path))
(status (if (string? result)
result
(car result)))
(link (if (string? result)
result
(if (equal? flag #t)
(s:a (car result) 'href (conc "./test_log?runid=" run-id "&testname=" item-name ))
(s:a (car result) 'href (string-substitute (conc linktree "/") "" (cadr result) "-"))))))
(s:td link 'class status)))
runs))))
res))
item-keys)))
test-list))))))
;; (tests:create-html-tree "test-index.html")
;;
(define (tests:create-html-tree outf)
(let* ((lockfile (conc outf ".lock"))
(runs-to-process '())
(keys (rmt:get-keys))
(numkeys (length keys))
(args:get-arg "-runname")
"%"))
(args:get-arg "-target")
"%"))
(targlist (string-split target "/"))
(numtarg (length targlist))
(targtweaked (if (> numkeys numtarg)
(append targlist (make-list (- numkeys numtarg) "%"))
targlist))
(target-patt (string-join targtweaked "/"))
;(total-runs (rmt:get-num-runs "%")) ;;this needs to be changed to filter by target
(total-runs (rmt:get-runs-cnt-by-patt run-patt target-patt keys ))
;(print total-runs)
(let loop ((page 0))
(let* ((oup (open-output-file (or outf (conc linktree "/page" page ".html"))))
(get-prev-links (lambda (page linktree )
(let* ((link (if (not (eq? page 0))
(s:a "<<prev" 'href (conc "page" (- page 1) ".html"))
(s:a "" 'href (conc "page" page ".html")))))
link)))
(get-next-links (lambda (page linktree total-runs)
(let* ((link (if (> total-runs (+ 10 (* page pg-size)))
(s:a "next>>" 'href (conc "page" (+ page 1) ".html"))
(s:a "" 'href (conc "page" page ".html")))))
link))) )
(print "total runs: " total-runs)
(s:output-new
oup
(tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function
(close-output-port oup)
; (set! page (+ 1 page))
(if (> total-runs (* (+ 1 page) pg-size))
(loop (+ 1 page)))))
#f)))
(define (tests:readlines filename)
(call-with-input-file filename
(lambda (p)
(let loop ((line (read-line p))
(result '()))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
|
;; tests:genrate dashboard body
;;
(define (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links flag run-patt target-patt)
(let* ((start (* page pg-size))
;(runsdat (rmt:get-runs "%" pg-size start (map (lambda (x)(list x "%")) keys)))
(runsdat (rmt:get-runs-by-patt keys run-patt target-patt start pg-size #f 0 sort-order: "desc"))
; db:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-update
(header (vector-ref runsdat 0))
(runs (vector-ref runsdat 1))
(ctr 0)
(test-runs-hash (tests:get-rest-data runs header numkeys))
(test-list (hash-table-keys test-runs-hash)))
(s:html tests:css-jscript-block (tests:css-jscript-block-cond flag)
(s:title "Summary for " area-name)
(s:body 'onload "addEvents();"
(get-prev-links page linktree)
(get-next-links page linktree total-runs)
(s:h1 "Summary for " area-name)
(s:h3 "Filter" )
(s:input 'type "text" 'name "testname" 'id "testname" 'length "30" 'onkeyup "filtersome()")
;; top list
(s:table 'id "LinkedList1" 'border "1" 'cellspacing 0
(map (lambda (key)
(let* ((res (s:tr 'class "something"
(s:th key )
(map (lambda (run)
(s:th (vector-ref run ctr)))
runs))))
(set! ctr (+ ctr 1))
res))
keys)
(s:tr
(s:th "Run Name")
(map (lambda (run)
(s:th (db:get-value-by-header run header "runname")))
runs))
(map (lambda (test-name)
(let* ((item-hash (hash-table-ref/default test-runs-hash test-name #f))
(item-keys (sort (hash-table-keys item-hash) string<=?)))
(map (lambda (item-name)
(let* ((res (s:tr 'class item-name
(s:td item-name 'class "test" )
(map (lambda (run)
(let* ((run-test (hash-table-ref/default item-hash item-name #f))
(run-id (db:get-value-by-header run header "id"))
(result (hash-table-ref/default run-test run-id "n/a"))
;(relative-path (get-relative-path))
(status (if (string? result)
result
(car result)))
(link (if (string? result)
result
(if (equal? flag #t)
(s:a (car result) 'href (conc "./test_log?runid=" run-id "&testname=" item-name ))
(s:a (car result) 'href (string-substitute (conc linktree "/") "" (cadr result) "-"))))))
(s:td link 'class status)))
runs))))
res))
item-keys)))
test-list))))))
;; (tests:create-html-tree "test-index.html")
;;
(define (tests:create-html-tree outf)
(let* ((lockfile (conc outf ".lock"))
(runs-to-process '())
(linktree (common:get-linktree))
(area-name (common:get-testsuite-name))
(keys (rmt:get-keys))
(numkeys (length keys))
(run-patt (or (args:get-arg "-run-patt")
(args:get-arg "-runname")
"%"))
(target (or (args:get-arg "-target-patt")
(args:get-arg "-target")
"%"))
(targlist (string-split target "/"))
(numtarg (length targlist))
(targtweaked (if (> numkeys numtarg)
(append targlist (make-list (- numkeys numtarg) "%"))
targlist))
(target-patt (string-join targtweaked "/"))
;(total-runs (rmt:get-num-runs "%")) ;;this needs to be changed to filter by target
(total-runs (rmt:get-runs-cnt-by-patt run-patt target-patt keys ))
(pg-size 10))
(if (common:simple-file-lock lockfile)
(begin
;(print total-runs)
(let loop ((page 0))
(let* ((oup (open-output-file (or outf (conc linktree "/page" page ".html"))))
(get-prev-links (lambda (page linktree )
(let* ((link (if (not (eq? page 0))
(s:a "<<prev" 'href (conc "page" (- page 1) ".html"))
(s:a "" 'href (conc "page" page ".html")))))
link)))
(get-next-links (lambda (page linktree total-runs)
(let* ((link (if (> total-runs (+ 10 (* page pg-size)))
(s:a "next>>" 'href (conc "page" (+ page 1) ".html"))
(s:a "" 'href (conc "page" page ".html")))))
link))) )
(print "total runs: " total-runs)
(s:output-new
oup
(tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function
(close-output-port oup)
; (set! page (+ 1 page))
(if (> total-runs (* (+ 1 page) pg-size))
(loop (+ 1 page)))))
(common:simple-file-release-lock lockfile))
(begin
(debug-print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f))))
(define (tests:readlines filename)
(call-with-input-file filename
(lambda (p)
(let loop ((line (read-line p))
(result '()))
|
| ︙ | | | ︙ | |
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
|
(if fnamepatt
(apply append
(map (lambda (p)
(if (directory-exists? p)
(let ((glob-query (conc p "/" fnamepatt)))
(handle-exceptions
exn
(with-input-from-pipe
(conc "echo " glob-query)
read-lines) ;; we aren't going to try too hard. If glob breaks it is likely because someone tried to do */*/*.log or similar
(glob glob-query)))
'()))
paths-from-db))
paths-from-db)))
;;======================================================================
|
>
>
|
|
|
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
|
(if fnamepatt
(apply append
(map (lambda (p)
(if (directory-exists? p)
(let ((glob-query (conc p "/" fnamepatt)))
(handle-exceptions
exn
(begin
(print "built-in glob on " glob-query ", failed, try using the shell. exn=" exn)
(with-input-from-pipe
(conc "echo " glob-query)
read-lines)) ;; we aren't going to try too hard. If glob breaks it is likely because someone tried to do */*/*.log or similar
(glob glob-query)))
'()))
paths-from-db))
paths-from-db)))
;;======================================================================
|
| ︙ | | | ︙ | |
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
|
(cache-exists (and cache-file
(not force-create) ;; if force-create then pretend there is no cache to read
(common:file-exists? cache-file)))
(cached-dat (if (and (not force-create)
cache-exists
use-cache)
(handle-exceptions
exn
#f ;; any issues, just give up with the cached version and re-read
(configf:read-alist cache-file))
#f))
(test-full-name (if (and item-path (not (string-null? item-path)))
(conc test-name "/" item-path)
test-name)))
(if cached-dat
cached-dat
(let ((dat (hash-table-ref/default *testconfigs* test-full-name #f)))
|
|
>
>
|
|
|
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
|
(cache-exists (and cache-file
(not force-create) ;; if force-create then pretend there is no cache to read
(common:file-exists? cache-file)))
(cached-dat (if (and (not force-create)
cache-exists
use-cache)
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "failed to read " cache-file ", exn=" exn)
#f) ;; any issues, just give up with the cached version and re-read
(configf:read-alist cache-file))
#f))
(test-full-name (if (and item-path (not (string-null? item-path)))
(conc test-name "/" item-path)
test-name)))
(if cached-dat
cached-dat
(let ((dat (hash-table-ref/default *testconfigs* test-full-name #f)))
|
| ︙ | | | ︙ | |
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
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
1992
1993
1994
|
(lambda (count)
(set! res count))
tdb
"SELECT count(id) FROM test_rundat;")
res))
0)
(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)
(rmt:general-call 'update-test-rundat run-id test-id (current-seconds) (or cpuload -1)(or diskfree -1) -1 (or minutes -1))
(if (and cpuload diskfree)
(rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id))
(if minutes
(rmt:general-call 'update-run-duration run-id minutes test-id))
(if (and uname hostname)
(rmt:general-call 'update-uname-host run-id uname hostname test-id)))
(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries)
;; (define (tests:set-full-meta-info test-id run-id minutes work-area)
;; (let ((remtries 10))
(let* ((cpuload (get-cpu-load))
(diskfree (get-df (current-directory)))
(uname (get-uname "-srvpio"))
(hostname (get-host-name)))
(tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)))
;; (define (tests:set-partial-meta-info test-id run-id minutes work-area)
#;(define (tests:set-partial-meta-info test-id run-id minutes work-area remtries)
(let* ((cpuload (get-cpu-load))
(diskfree (get-df (current-directory)))
(remtries 10))
(handle-exceptions
exn
(if (> remtries 0)
(begin
(print-call-chain (current-error-port))
(debug:print-info 0 *default-log-port* "WARNING: failed to set meta info. Will try " remtries " more times")
(set! remtries (- remtries 1))
(thread-sleep! 10)
(tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1)))
(let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
(debug:print-error 0 *default-log-port* "tried for over a minute to update meta info and failed. Giving up")
(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.")
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 5 *default-log-port* "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
(print-call-chain (current-error-port))))
(tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
)))
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
|
|
|
|
|
|
|
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
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
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
|
(lambda (count)
(set! res count))
tdb
"SELECT count(id) FROM test_rundat;")
res))
0)
;;
(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname #!key (update-db #f)(tmpfree #f))
(if (get-environment-variable "MT_TEST_RUN_DIR")
(let* ((dest-dir (conc (get-environment-variable "MT_TEST_RUN_DIR") "/.mt_data"))
(or-dash (lambda (instr)
(cond
((not instr) "") ;; #f -> blank, indicates value unchanged since last measurement taken
((string? instr)(if (string-search " " instr) (conc "\"" instr "\"") instr))
(else instr))))
(file-new (not (directory-exists? dest-dir))))
(if file-new (create-directory dest-dir #t))
(let* ((outp (open-output-file (conc dest-dir "/test-run.dat") #:append)))
(with-output-to-port outp
(lambda ()
(if file-new
(print "epoch_time,run_id,test_id,cpuload,diskfree,tmpfree,run_minutes,hostname,uname"))
(print (current-seconds) "," (or-dash run-id) "," (or-dash test-id) ","
(or-dash cpuload) "," (or-dash diskfree) "," (or-dash tmpfree) ","
(or-dash minutes) "," (or-dash hostname) ","
(or-dash uname)))) ;; put uname last as it has spaces in it
(close-output-port outp)))
(begin
(rmt:general-call 'update-test-rundat run-id test-id (current-seconds) (or cpuload -1)(or diskfree -1) -1 (or minutes -1))))
(if update-db
(begin
(if (and cpuload diskfree)
(rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id))
(if minutes
(rmt:general-call 'update-run-duration run-id minutes test-id))
(if (and uname hostname)
(rmt:general-call 'update-uname-host run-id uname hostname test-id)))))
;; This one is for running with no db access (i.e. via rmt: internally)
(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries #!key (update-db #f))
;; (define (tests:set-full-meta-info test-id run-id minutes work-area)
;; (let ((remtries 10))
(let* ((cpuload (get-cpu-load))
(diskfree (get-df (current-directory)))
(tmpfree (get-df "/tmp"))
(uname (get-uname "-srvpio"))
(hostname (get-host-name)))
(tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname update-db: update-db tmpfree: tmpfree)))
;;======================================================================
;; A R C H I V I N G
;;======================================================================
(define (test:archive db test-id)
#f)
(define (test:archive-tests db keynames target)
#f)
|