blob: 972b89a843fa96d8342541a30e768b39fa8ddc1c (
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
|
(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))
(family (value #t)
(predicate ,(lambda (v) (memv (string->symbol (string-upcase v))
'(INET INET4 INET6)))))))
(define-public (main args)
(define opts (getopt-long args options))
(define port (option-ref opts 'port 8080))
(define family (case (string->symbol (string-upcase (option-ref opts 'family "INET6")))
[(INET INET4) AF_INET]
[(INET6) AF_INET6]
[else (error "That address family is not supported")]) )
;; TODO the guile methods wants the ip address in numeric form. This is currently extra impossible
(define addr (option-ref opts 'addr 0))
(define-values (c e)
(load-calendars
calendar-files: (cond [(option-ref opts 'file #f) => list]
[else (calendar-files)]) ))
(format #t "Starting server on ~a:~a~%I'm ~a, runing from ~a~%"
(inet-ntop family addr) port
(getpid) (getcwd))
(run-server (make-make-routes c e)
'http
`(port: ,port
addr: ,addr)
0))
|
