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
184
185
186
187
188
189
190
|
(define-module (entry-points server)
:use-module (util)
:use-module (util app)
:use-module (srfi srfi-1)
:use-module (ice-9 match)
:use-module (ice-9 control)
:use-module (ice-9 rdelim)
:use-module (ice-9 curried-definitions)
:use-module (ice-9 ftw)
:use-module (ice-9 getopt-long)
:use-module (ice-9 iconv)
:use-module (ice-9 regex) #| regex here due to bad macros |#
:use-module (web server)
:use-module (web request)
:use-module (web response)
:use-module (web uri)
:use-module (sxml simple)
:use-module (server util)
:use-module (server macro)
:use-module (vcomponent)
:use-module (datetime)
:use-module (datetime util)
:use-module (output html)
:use-module (output ical)
:export (main)
)
(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 (// . args) (string-join args file-name-separator-string ))
(define (directory-table dir)
`(table
(thead
(tr (th "") (th "Name") (th "Perm")))
(tbody
,@(map (lambda (k)
(let* ((stat (lstat (// dir k))))
`(tr (td ,(case (stat:type stat)
[(directory) "📁"]
[(regular) "📰"]
[else "🙃"]))
(td (a (@ (href "/" ,dir "/" ,k)) ,k))
(td ,(number->string (stat:perms stat) 8)))))
(cdr (scandir dir))))))
(define-method (make-make-routes)
(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: (getf 'calendars)
events: (getf 'event-set)
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: (getf 'calendars)
events: (getf 'event-set)
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)
(return '((content-type text/calendar))
(with-output-to-string
(lambda ()
(ical-main (parse-iso-date start)
(parse-iso-date end))))))
;; TODO this fails if there's a period in the uid.
(GET "/calendar/:uid.ics" (uid)
(aif (get-event-by-uid uid)
(return '((content-type text/calendar))
(with-output-to-string
(lambda () (print-components-with-fake-parent
(list it)))))
(return (build-response code: 404)
(format #f "No component with UID=~a found." uid))))
;; NOTE this only handles files with extensions. Limited, but since this
;; is mostly for development, and something like nginx should be used in
;; production it isn't a huge problem.
(GET "/static/:*{.*}.:ext" (* ext)
(return
;; TODO actually check mimetype
`((content-type ,(string->symbol (string-append "text/" ext))))
(call-with-input-file (string-append "static/" * "." ext)
read-string)))
(GET "/static/:*{.*}" (*)
(return
'((content-type text/html))
(sxml->html-string
(directory-table (// "static" *)))))
(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]))
;; 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)
'http
`(family: ,family
port: ,port
host: ,addr)
0))
|
