blob: 55bfc770952e0460eed73072cad4eca4a80da500 (
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
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
(define-module (entry-points server)
:export (main)
:use-module (util)
:use-module (vcomponent)
)
(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 (k)
(let* ((stat (lstat k)))
`(tr (td ,(case (stat:type stat)
[(directory) "📁"]
[(regular) "📰"]
[else "🙃"]))
(td (a (@ (href "/" ,dir ,k)) ,k))
(td ,(number->string (stat:perms stat) 8)))))
(cddr (scandir dir))))))
(define (make-make-routes calendar regular repeating 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 (end-of-month start-date))
))))))
;; TODO export all events in interval
;; (GET "/calendar" (start end)
;; (ical-main calendars
;; regular
;; repeating
;; (parse-iso-date start)
;; (parse-iso-date end)))
;; TODO this returns "invalid" events, since the surrounding VCALENDAR is missing.
(GET "/calendar/:uid.ics" (uid)
;; NOTE build an index.
(aif (or (find (lambda (ev) (equal? uid (attr ev 'UID)))
regular)
(find (lambda (ev) (equal? uid (attr ev 'UID)))
repeating))
(return '((content-type text/calendar))
(with-output-to-string (lambda () ((@ (output ical) component->ical-string) it))))
(return (build-response code: 404)
(format #f "No component with UID=~a found." uid))))
(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))
;; TODO numbers as single-char seems to not work.
(six (single-char #\6))
(four (single-char #\4))))
(define-public (main args)
(define opts (getopt-long args options))
(define port (option-ref opts 'port 8080))
(define addr (option-ref opts 'addr #f))
(define family
(cond [(option-ref opts 'six #f) AF_INET6]
[(option-ref opts 'four #f) AF_INET]
[(and addr (string-contains addr ":")) AF_INET6]
[(and addr (string-contains addr ".")) AF_INET]
[else AF_INET6]))
(define-values (c regular repeating)
(cond [(option-ref opts 'file #f) => (compose load-calendars* list)]
[else (load-calendars*)]))
(define all-events
((@ (vcomponent load) calculate-recurrence-set) regular repeating))
;; update address if it was left blank. A bit clumsy since
;; @var{addr} & @var{family} depend on each other.
;; placed after load-calendars to keep Guile 2.2 compability.
(set! addr
(if addr addr
(if (eqv? family AF_INET6)
"::" "0.0.0.0")))
;; NOTE The default make-default-socket is broken for IPv6.
;; A patch has been submitted to the mailing list. 2020-03-31
(module-set!
(resolve-module '(web server http))
'make-default-socket
(lambda (family addr port)
(let ((sock (socket family SOCK_STREAM 0)))
(setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
(bind sock family addr port)
sock)))
;; TODO possibly test inet-pton here on address?
(format #t "Starting server on ~a:~a~%I'm ~a, runing from ~a~%"
addr port
(getpid) (getcwd))
(run-server (make-make-routes c regular repeating all-events)
'http
`(family: ,family
port: ,port
host: ,addr)
0))
|
