1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
|
;; Copyright 2006-2012, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
(require-extension (srfi 18) extras tcp s11n)
(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) ;; sqlite3
;; (import (prefix sqlite3 sqlite3:))
(use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)
;; Configurations for server
|
>
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
|
;; Copyright 2006-2012, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
(require-extension (srfi 18) extras tcp s11n)
(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) ;; sqlite3
;; (import (prefix sqlite3 sqlite3:))
(use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)
;; Configurations for server
|
| ︙ | | | ︙ | |
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
|
(declare (uses server))
(declare (uses daemon))
(declare (uses portlogger))
(declare (uses rmt))
(include "common_records.scm")
(include "db_records.scm")
(define (http-transport:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
|
>
>
|
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
|
(declare (uses server))
(declare (uses daemon))
(declare (uses portlogger))
(declare (uses rmt))
(include "common_records.scm")
(include "db_records.scm")
(include "js-path.scm")
(require-library stml)
(define (http-transport:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
|
| ︙ | | | ︙ | |
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
(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)
(let ((config-hostname (configf:lookup *configdat* "server" "hostname")))
|
|
>
>
>
>
>
>
>
>
>
>
>
>
|
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
(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))))
((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)))
'(/ "test_log"))
(send-response body: (http-transport:html-test-log $)
headers: '((content-type text/HTML))))
((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
;;
(define (http-transport:try-start-server ipaddrstr portnum)
(let ((config-hostname (configf:lookup *configdat* "server" "hostname")))
|
| ︙ | | | ︙ | |
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
|
(thread-sleep! 3) ;; give the flush three seconds to do it's stuff
(debug:print 0 *default-log-port* " 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)
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
|
(thread-sleep! 3) ;; give the flush three seconds to do it's stuff
(debug:print 0 *default-log-port* " Done.")
(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 *java-script-lib*)))
(string-join data "\n")))
;;======================================================================
;; web pages
;;======================================================================
(define (http-transport:html-test-log $)
(let* ((run-id ($ 'runid))
(test-item ($ 'testname))
(parts (string-split test-item ":"))
(test-name (car parts))
(item-name (if (equal? (length parts) 1)
""
(cadr parts))))
;(print $)
(tests:get-test-log run-id test-name item-name)))
(define (http-transport:html-dboard $)
(let* ((page ($ 'page))
(oup (open-output-string))
(bdy "--------------------------")
(ret (tests:dynamic-dboard page)))
(s:output-new oup ret)
(close-output-port oup)
(set! bdy (get-output-string oup))
(conc "<h1>Dashboard</h1>" bdy "<br/> <br/> " )))
(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)
|
| ︙ | | | ︙ | |