-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathagena.scm
187 lines (164 loc) · 6.13 KB
/
agena.scm
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
(import (scheme)
(chicken base)
(chicken condition)
(chicken module)
(only (chicken tcp) tcp-listen)
(chicken time)
(chicken time posix)
(chicken io)
(chicken pathname)
(chicken process)
(chicken process-context)
(chicken process-context posix)
(chicken file posix)
(only (srfi 13) string-null? string-join)
(srfi 4)
(only (srfi 128) make-comparator)
(srfi 146)
(args)
(fmt)
(tcp-server)
;(unveil)
(uri-generic))
;; Replace me when SRFI 162 has been packaged.
(define string-comparator
(make-comparator string? string=? string<? #f))
(include "mime-types.scm")
(define buffer-size 4096)
(define log-timestamp-format "%Y-%m-%d %H:%M:%SZ")
(define server-uid 2)
(define server-gid 2)
;;;; Logging
(define (write-log msg . objs)
(let* ((tv (seconds->utc-time (current-seconds)))
(stamp (time->string tv log-timestamp-format)))
(parameterize ((current-output-port (current-error-port)))
(if (pair? objs)
(fmt #t "[" stamp "] " msg " | irritants: " objs nl)
(fmt #t "[" stamp "] " msg nl)))))
;;;; Gemini
;; Snarfed from Kooda's geminid.
(define status-codes
'((input . 10)
(sensitive-input . 11)
(success . 20)
(redirect . 30)
(redirect-temporary . 30)
(redirect-permanent . 31)
(temporary-failure . 40)
(server-unavailable . 41)
(cgi-error . 42)
(proxy-error . 43)
(slow-down . 44)
(permanent-failure . 50)
(not-found . 51)
(gone . 52)
(proxy-request-refused . 53)
(bad-request . 59)
(client-certificate-required . 60)
(certificate-not-authorised . 61)
(certificate-not-valid . 62)))
(define (extension-mime-type ext)
(mapping-ref/default mime-types ext "application/octet-stream"))
(define (status->integer s)
(cond ((assv s status-codes) => cdr)
(else (error "unknown status" s))))
;; Read and validate a Gemini request.
(define (read-request)
(let ((line (read-line)))
(cond ((eof-object? line)
(write-log "empty request")
#f)
((> (string-length line) 1024)
(write-log "overlong request")
#f)
(else line))))
(define (write-response-header status meta)
(let ((code (status->integer status)))
(display code)
(write-char #\space)
(write-string meta)
(write-string "\r\n")
(unless (and (>= code 20) (< code 30))
(flush-output)
#;(close-output-port (current-output-port)))))
(define (serve-failure path)
(write-log "serve file failed" path)
(write-response-header 'not-found "File not found"))
(define (serve-file ps)
(let* ((raw-path (if (null? ps) "" (string-join (cdr ps) "/")))
(path (if (string=? raw-path "") "." raw-path)))
(cond ((regular-file? path) (serve-regular-file path))
((directory? path)
(serve-regular-file (make-pathname path "index.gmi")))
(else (serve-failure path)))))
;; Write all data from port to the current output.
(define (write-all port)
(let* ((buffer (make-u8vector buffer-size))
(read-bytes (lambda () (read-u8vector! #f buffer port))))
(let lp ((k (read-bytes)))
(write-u8vector buffer (current-output-port) 0 k)
(unless (< k buffer-size)
(lp (read-bytes))))))
(define (serve-regular-file path)
(call-with-current-continuation
(lambda (k)
(let ((port
(condition-case (open-input-file path)
((exn file) (serve-failure path) (k #f)))))
(write-response-header 'success
(extension-mime-type (pathname-extension path)))
(write-all port)
(close-input-port port)))))
(define (simple-handler uri)
;; TODO: Validate host.
(if (not (eqv? (uri-scheme uri) 'gemini))
(begin
(write-log "unhandled protocol" (uri-scheme uri))
(write-response-header 'proxy-request-refused
"Unhandled protocol"))
(serve-file (uri-path uri))))
(define (request-handler)
(write-log "got request")
(and-let* ((line (read-request))
(uri (uri-reference line)))
(simple-handler uri)))
;;;; Server
(define (run root-path port)
(let* ((listener (tcp-listen port))
(serve (make-tcp-server listener request-handler)))
;(unveil root-path "r")
;(unveil-lock)
(change-directory root-path)
(and server-gid (set! (current-group-id) server-gid))
(and server-uid (set! (current-user-id) server-uid))
(serve)))
(define (daemon-run root-path port)
(file-creation-mode 0)
(close-output-port (current-output-port))
(close-input-port (current-input-port))
(run root-path port))
(letrec* ((opts (list (args:make-option (D) #:none "Daemonize.")
(args:make-option (p) (#:required "<port>")
"Listen on <port> (default: 1965)")
(args:make-option (h) #:none
"Show this text."
(usage))))
(usage (lambda ()
(parameterize ((current-output-port (current-error-port)))
(display "Usage: agena [options...] <directory>\n")
(display (args:usage opts))
(exit 1)))))
(let-values (((cli-opts operands) (args:parse (command-line-arguments) opts)))
(let ((root-path (cond ((= (length operands) 1) (car operands))
(else (usage))))
(listen-port (cond ((assv 'p cli-opts) =>
(lambda (p)
(or (string->number (cdr p))
(error "invalid port" (cdr p)))))
(else 1965))))
(cond ((assv 'D cli-opts)
;; TODO: Handle fork errors.
(process-fork (lambda () (daemon-run root-path listen-port)))
(exit 0))
(else (run root-path listen-port))))))