Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -30,11 +30,11 @@
(declare (uses portlogger))
(declare (uses rmt))
(include "common_records.scm")
(include "db_records.scm")
-
+(require-library stml)
(define (http-transport:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
@@ -101,12 +101,20 @@
'(/ any))
(send-response body: "hey there!\n"
headers: '((content-type text/plain))))
((equal? (uri-path (request-uri (current-request)))
'(/ "hey"))
- (send-response body: "hey there!\n"
+ (send-response body: "hey there!\n"
headers: '((content-type text/plain))))
+ ((equal? (uri-path (request-uri (current-request)))
+ '(/ "jquery3.1.0.js"))
+ (send-response body: (http-transport:show-jquery)
+ headers: '((content-type application/javascript))))
+ ((equal? (uri-path (request-uri (current-request)))
+ '(/ "dashboard"))
+ (send-response body: (http-transport:html-dboard $)
+ headers: '((content-type text/HTML))))
(else (continue))))))))
(http-transport:try-start-server ipaddrstr start-port)))
;; This is recursively run by http-transport:run until sucessful
;;
@@ -519,15 +527,36 @@
(exit 4))
"exit on ^C timer")))
(thread-start! th2)
(thread-start! th1)
(thread-join! th2))))
+
+;;===============================================
+;; Java script
+;;===============================================
+(define (http-transport:show-jquery)
+ (let* ((data (tests:readlines "/nfs/site/disks/ch_ciaf_disk023/fdk_gwa_disk003/pjhatwal/fdk/docs/qa-env-team/jquery-3.1.0.slim.min.js")))
+(string-join data "\n")))
;;======================================================================
;; web pages
;;======================================================================
+(define (http-transport:html-dboard $)
+ (let* ((page ($ 'page))
+ (oup (open-output-string))
+ (bdy "--------------------------")
+
+ (ret (tests:dynamic-dboard page)))
+ ;(display ret oup)
+ (s:output-new oup ret)
+ (close-output-port oup)
+
+ (set! bdy (get-output-string oup))
+ ;(debug:print-info 0 *default-log-port* "val: " bdy)
+ (conc "Dashboard
" bdy "
" )))
+
(define (http-transport:main-page)
(let ((linkpath (root-path)))
(conc "" (pathname-strip-directory *toppath*) "
"
""
"Run area: " *toppath*
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -573,13 +573,11 @@
.HandCursorStyle { cursor: pointer; cursor: hand; } /* For IE */
th {background-color: #8c8c8c;}
td.test {background-color: #d9dbdd;}
td.PASS {background-color: #347533;}
td.FAIL {background-color: #cc2812;}
-
-
-
+
EOF
)
+(define tests:css-jscript-block-dynamic
+#<
+EOF
+)
+(define tests:css-jscript-block-static
+#<
+EOF
+)
+
+
+(define (tests:css-jscript-block-cond dynamic)
+ (if (equal? dynamic #t)
+ tests:css-jscript-block-dynamic
+ tests:css-jscript-block-static))
+
+
(define (tests:run-record->test-path run numkeys)
(append (take (vector->list run) numkeys)
(list (vector-ref run (+ 1 numkeys)))))
@@ -701,55 +717,32 @@
(hash-table-set! (hash-table-ref/default (hash-table-ref/default resh test-name #f) test-item #f) run-id (list test-status test-html-path))))
test-data)))
runs)
resh))
-;; (tests:create-html-tree "test-index.html")
+
+;; tests:genrate dashboard body
;;
-(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))
- (total-runs (rmt:get-num-runs "%"))
- (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"))))
- (start (* page pg-size))
+
+(define (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links flag)
+ (let* ((start (* page pg-size))
(runsdat (rmt:get-runs "%" pg-size start (map (lambda (x)(list x "%")) keys)))
(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))
- (get-prev-links (lambda (page linktree )
- (let* ((link (if (not (eq? page 0))
- (s:a "<<prev" 'href (conc linktree "/page" (- page 1) ".html"))
- (s:a "" 'href (conc linktree "/page" page ".html")))))
- link)))
- (get-next-links (lambda (page linktree total-runs)
- (let* ((link (if (> total-runs (+ 1 (* page pg-size)))
- (s:a "next>>" 'href (conc linktree "/page" (+ page 1) ".html"))
- (s:a "" 'href (conc linktree "/page" page ".html")))))
- link))))
- (s:output-new
- oup
- (s:html tests:css-jscript-block
+ )
+ (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"
(map (lambda (key)
(let* ((res (s:tr 'class "something"
(s:th key )
@@ -783,21 +776,92 @@
(s:a (car result) 'href (cadr result)))))
(s:td link 'class status)))
runs))))
res))
item-keys)))
- test-list)))))
+ 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))
+ (total-runs (rmt:get-num-runs "%"))
+ (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 linktree "/page" (- page 1) ".html"))
+ (s:a "" 'href (conc linktree "/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 linktree "/page" (+ page 1) ".html"))
+ (s:a "" 'href (conc linktree "/page" page ".html")))))
+ link))) )
+ ;(print (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name))
+ (s:output-new
+ oup
+ (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f))
(close-output-port oup)
; (set! page (+ 1 page))
(if (> total-runs (* (+ 1 page) pg-size))
(loop (+ 1 page)))))
(common:simple-file-release-lock lockfile))
#f)))
+(define (tests:readlines filename)
+ (call-with-input-file filename
+ (lambda (p)
+ (let loop ((line (read-line p))
+ (result '()))
+ (if (eof-object? line)
+ (reverse result)
+ (loop (read-line p) (cons line result)))))))
+
+
+(define (tests:dynamic-dboard page)
+;(define (tests:create-html-tree o)
+ (let* (
+;(page "1")
+ (linktree (common:get-linktree))
+ (area-name (common:get-testsuite-name))
+ (keys (rmt:get-keys))
+ (numkeys (length keys))
+ (total-runs (rmt:get-num-runs "%"))
+ (pg-size 10)
+ (pg (if (equal? page #f)
+ 0
+ (- (string->number page) 1)))
+ (get-prev-links (lambda (pg linktree)
+ (debug:print-info 0 *default-log-port* "val: " (- 1 pg))
+ (let* ((link (if (not (eq? pg 0))
+ (s:a "<<prev " 'href (conc "dashboard?page=" pg ))
+ (s:a "" 'href (conc "dashboard?page=" pg)))))
+ link)))
+ (get-next-links (lambda (pg linktree total-runs)
+ (debug:print-info 0 *default-log-port* "val: " pg)
+ (debug:print-info 0 *default-log-port* "val: " total-runs " size" pg-size)
+
+ (let* ((link (if (> total-runs (+ 10 (* pg pg-size)))
+ (s:a "next>> " 'href (conc "dashboard?page=" (+ pg 2) ))
+ (s:a "" 'href (conc "dashboard?page=" pg )))))
+ link)))
+ (html-body (tests:dashboard-body pg pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #t)))
+ ;(print (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name))
+html-body))
(define (tests:create-html-tree-old outf)
(let* ((lockfile (conc outf ".lock"))