blob: af87a63839d6029f97898d1cc05660ee34e567dc (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
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
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
|
(define-module (server)
:use-module (util))
(use-modules* (web (server request response uri))
(output (html))
(server (util macro))
(sxml (simple))
(ice-9 (match control rdelim curried-definitions ftw
getopt-long
iconv regex #| regex here due to bad macros |# ))
(srfi (srfi-1 srfi-19 srfi-88)))
(use-modules (srfi srfi-19 util))
(define (file-extension name)
(car (last-pair (string-split name #\.))))
(define (sxml->xml-string sxml)
(with-output-to-string
(lambda () (sxml->xml sxml))))
(define (directory-table dir)
`(table
(thead
(tr (th "Name") (th "Type") (th "Perm")))
(tbody
,@(map (lambda (kv)
(let* (((k stat) kv))
`(tr (td (a (@ (href ,dir ,k)) ,k))
(td ,(stat:type stat))
(td ,(number->string (stat:perms stat) 8)))))
(cddr (file-system-tree dir))))))
(define (make-make-routes calendar events)
(make-routes
(GET "/" (y m) ; m in [1, 12]
(let* ((cd (current-date))
(start (if m
(date year: 2019 day: 1 month: (string->number m))
(current-date)))
(end (set (date-month start) = (+ 1))))
(return '((content-type text/html))
(with-output-to-string
(lambda () (html-generate calendar events start end))))))
(GET "/static" ()
(return
'((content-type text/html))
(sxml->xml-string
(directory-table "static/"))))
(GET "/static/:filename" (filename)
(return
`((content-type ,(case (string->symbol (file-extension filename))
((js) 'text/javascript)
((css) 'text/css))))
(call-with-input-file (string-append "static/" filename) read-string)))
(GET "/count" ()
;; (sleep 1)
(return '((content-type text/plain))
(string-append (number->string state) "\n")
(1+ state)))
))
(define options
'((port (value #t) (single-char #\p))
(addr (value #t))))
(define-public (server-main c e args)
(define opts (getopt-long args options))
(define port (option-ref opts 'port 8080))
(define addr (option-ref opts 'addr INADDR_LOOPBACK))
(format #t "Starting server on ~a:~a~%I'm ~a, runing from ~a~%"
(number->string addr 16) port
(getpid) (getcwd))
(run-server (make-make-routes c e)
'http
`(port: ,port
addr: ,addr)
0))
|
