Overview
| Comment: | Added very basic informative page to server |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | v1.54 | v1.5428 |
| Files: | files | file ages | folders |
| SHA1: |
62a34aa67ea0f6ad90a9ca680e0e67cf |
| User & Date: | mrwellan on 2013-05-10 11:16:14 |
| Other Links: | branch diff | manifest | tags |
Context
|
2013-05-10
| ||
| 12:00 | Added very basic informative page to server check-in: aab3b2a0d7 user: mrwellan tags: v1.54, v1.5428 | |
| 11:16 | Added very basic informative page to server check-in: 62a34aa67e user: mrwellan tags: v1.54, v1.5428 | |
|
2013-05-09
| ||
| 16:37 | Added Kill Jobs button/command check-in: 901608be34 user: mrwellan tags: v1.54, v1.5427 | |
Changes
Modified db.scm from [770a8b5521] to [f20409bfcf].
| ︙ | ︙ | |||
971 972 973 974 975 976 977 978 979 980 981 982 983 984 |
(let ((res 0))
(sqlite3:for-each-row
(lambda (count)
(set! res count))
db
"SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART');")
res))
(define (db:get-count-tests-running-in-jobgroup db jobgroup)
(if (not jobgroup)
0 ;;
(let ((res 0))
(sqlite3:for-each-row
(lambda (count)
| > > > > > > > > > | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 |
(let ((res 0))
(sqlite3:for-each-row
(lambda (count)
(set! res count))
db
"SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART');")
res))
(define (db:get-running-stats db)
(let ((res '()))
(sqlite3:for-each-row
(lambda (state count)
(set! res (cons (list state count) res)))
db
"SELECT state,count(id) FROM tests GROUP BY state ORDER BY id DESC;")
res))
(define (db:get-count-tests-running-in-jobgroup db jobgroup)
(if (not jobgroup)
0 ;;
(let ((res 0))
(sqlite3:for-each-row
(lambda (count)
|
| ︙ | ︙ |
Modified http-transport.scm from [be5274c905] to [54f9cf430c].
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) (import (prefix sqlite3 sqlite3:)) | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) (import (prefix sqlite3 sqlite3:)) (use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb spiffy-directory-listing) ;; Configurations for server (tcp-buffer-size 2048) (max-connections 2048) (declare (unit http-transport)) |
| ︙ | ︙ | |||
85 86 87 88 89 90 91 |
(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!
| | > < < < < | 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 |
(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
(if (not db)(set! db (open-db)))
(let* (($ (request-vars source: 'both))
(dat ($ 'dat))
(res #f))
(cond
;; This is the /ctrl path where data is handed to the server and
;; responses
((equal? (uri-path (request-uri (current-request)))
'(/ "ctrl"))
(let* ((packet (db:string->obj dat))
(qtype (cdb:packet-get-qtype packet)))
(debug:print-info 12 "server=> received packet=" packet)
|
| ︙ | ︙ | |||
120 121 122 123 124 125 126 127 128 129 130 131 132 133 |
(set! res (db:process-queue-item db packet))
;; (mutex-unlock! *db:process-queue-mutex*)
(debug:print-info 11 "Return value from db:process-queue-item is " res)
(send-response body: (conc "<head>ctrl data</head>\n<body>"
res
"</body>")
headers: '((content-type text/plain)))))
(else (continue))))))))
(http-transport:try-start-server ipaddrstr start-port)))
;; This is recursively run by http-transport:run until sucessful
;;
(define (http-transport:try-start-server ipaddrstr portnum)
(handle-exceptions
| > > > > > > > > > > > > > > | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
(set! res (db:process-queue-item db packet))
;; (mutex-unlock! *db:process-queue-mutex*)
(debug:print-info 11 "Return value from db:process-queue-item is " res)
(send-response body: (conc "<head>ctrl data</head>\n<body>"
res
"</body>")
headers: '((content-type text/plain)))))
((equal? (uri-path (request-uri (current-request)))
'(/ ""))
(send-response body: (http-transport:main-page)))
((equal? (uri-path (request-uri (current-request)))
'(/ "runs"))
(send-response body: (http-transport:main-page)))
((equal? (uri-path (request-uri (current-request)))
'(/ 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"
headers: '((content-type text/plain))))
(else (continue))))))))
(http-transport:try-start-server ipaddrstr start-port)))
;; This is recursively run by http-transport:run until sucessful
;;
(define (http-transport:try-start-server ipaddrstr portnum)
(handle-exceptions
|
| ︙ | ︙ | |||
397 398 399 400 401 402 403 |
(thread-sleep! 3) ;; give the flush three seconds to do it's stuff
(debug:print 0 " Done.")
(exit 4))
"exit on ^C timer")))
(thread-start! th2)
(thread-start! th1)
(thread-join! th2))))
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 |
(thread-sleep! 3) ;; give the flush three seconds to do it's stuff
(debug:print 0 " Done.")
(exit 4))
"exit on ^C timer")))
(thread-start! th2)
(thread-start! th1)
(thread-join! th2))))
;;======================================================================
;; web pages
;;======================================================================
(define (http-transport:main-page)
(let ((linkpath (root-path)))
(conc "<head><h1>" (pathname-strip-directory *toppath*) "</h1></head>"
"<body>"
"Run area: " *toppath*
"<h2>Server Stats</h2>"
(http-transport:stats-table)
"<hr>"
(http-transport:runs linkpath)
"<hr>"
(http-transport:run-stats)
"</body>"
)))
(define (http-transport:stats-table)
(conc "<table>"
"<tr><td>Max cached queries</td> <td>" *max-cache-size* "</td></tr>"
"<tr><td>Number of cached writes</td> <td>" *number-of-writes* "</td></tr>"
"<tr><td>Average cached write time</td> <td>" (if (eq? *number-of-writes* 0)
"n/a (no writes)"
(/ *writes-total-delay*
*number-of-writes*))
" ms</td></tr>"
"<tr><td>Number non-cached queries</td> <td>" *number-non-write-queries* "</td></tr>"
"<tr><td>Average non-cached time</td> <td>" (if (eq? *number-non-write-queries* 0)
"n/a (no queries)"
(/ *total-non-write-delay*
*number-non-write-queries*))
" ms</td></tr></table>"))
(define (http-transport:runs linkpath)
(conc "<h3>Runs</h3>"
(string-intersperse
(let ((files (map pathname-strip-directory (glob (conc linkpath "/*")))))
(map (lambda (p)
(conc "<a href=\"" p "\">" p "</a><br>"))
files))
" ")))
(define (http-transport:run-stats)
(let ((stats (open-run-close db:get-running-stats #f)))
(conc "<table>"
(string-intersperse
(map (lambda (stat)
(conc "<tr><td>" (car stat) "</td><td>" (cadr stat) "</td></tr>"))
stats)
" ")
"</table>")))
|
Modified megatest-version.scm from [a83c2d33ad] to [ece6badde7].
1 2 3 4 5 | ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) | | | 1 2 3 4 5 6 7 | ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) (define megatest-version 1.5428) |