blob: 1a25771738313bcb91b9e6d44d9db39ddbf00657 (
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
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
(define-module (entry-points server)
:export (main)
:use-module (util)
:use-module (vcomponent)
:use-module (parameters)
)
(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-88)))
(use-modules (datetime)
(datetime util))
(define (file-extension name)
(car (last-pair (string-split name #\.))))
(define (sxml->html-string sxml)
(with-output-to-string
(lambda () (display "<!doctype html>\n") (sxml->xml sxml))))
(define (directory-table dir)
`(table
(thead
(tr (th "") (th "Name") (th "Perm")))
(tbody
,@(map (lambda (kv)
(let* (((k stat) kv))
`(tr (td ,(case (stat:type stat)
[(directory) "📁"]
[(regular) "📰"]
[else "🙃"]))
(td (a (@ (href "/" ,dir ,k)) ,k))
(td ,(number->string (stat:perms stat) 8)))))
(cddr (file-system-tree dir))))))
(define (make-make-routes calendar events)
(make-routes
(GET "/week/:start-date.html" (start-date)
(let* ((start-date (parse-iso-date start-date)))
(return '((content-type text/html))
(with-output-to-string
(lambda ()
(html-generate calendars: calendar
events: events
start-date: start-date
end-date: (date+ start-date (date day: 6))
next-start: (lambda (d) (date+ d (date day: 7)))
prev-start: (lambda (d) (date- d (date day: 7)))
render-calendar: render-calendar
))))))
(GET "/month/:start-date.html" (start-date)
(let* ((start-date (parse-iso-date start-date)))
(return '((content-type text/html))
(with-output-to-string
(lambda ()
(html-generate calendars: calendar
events: events
start-date: start-date
end-date: (date- (month+ start-date)
(date day: 1))
next-start: month+
prev-start: month-
render-calendar: render-calendar-table
pre-start: (start-of-week start-date)
post-end: (end-of-week start-date)
))))))
(GET "/static" ()
(return
'((content-type text/html))
(sxml->html-string
(directory-table "static/"))))
(GET "/static/:filename.css" (filename)
(return
`((content-type text/css))
(call-with-input-file (string-append "static/" filename ".css")
read-string)))
(GET "/static/:filename.js" (filename)
(return
`((content-type text/javascript))
(call-with-input-file (string-append "static/" filename ".js")
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))
|
