blob: b6e47ec0a4a3386898ff4708cbf246ba39d988d2 (
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
|
;;; Weeb --- Web microframework for GNU Guile
;;; Copyright © 2026 Jakob Kreuze <zerodaysfordays@sdf.org>
;;;
;;; This file is part of Weeb.
;;;
;;; Weeb is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU Affero General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; Weeb is distributed in the hope that it will be useful, but WITHOUT
;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
;;; Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with Weeb. If not, see <https://www.gnu.org/licenses/>.
(define-module (weeb main)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) ;; Temporary, probably
#:use-module (srfi srfi-26)
#:use-module (system repl error-handling)
#:use-module (weeb fcgi)
#:use-module (weeb request)
#:use-module (weeb response)
#:use-module (weeb router)
#:use-module (weeb struct)
#:use-module (weeb sxml)
#:export (run-server))
(define status-codes
'((100 . "Continue")
(101 . "Switching Protocols")
(102 . "Processing")
(200 . "OK")
(201 . "Created")
(202 . "Accepted")
(203 . "Non-Authoritative Information")
(204 . "No Content")
(205 . "Reset Content")
(206 . "Partial Content")
(207 . "Multi-Status")
(208 . "Already Reported")
(226 . "IM Used")
(300 . "Multiple Choices")
(301 . "Moved Permanently")
(302 . "Found")
(303 . "See Other")
(304 . "Not Modified")
(305 . "Use Proxy")
(306 . "Reserved")
(307 . "Temporary Redirect")
(308 . "Permanent Redirect")
(400 . "Bad Request")
(401 . "Unauthorized")
(402 . "Payment Required")
(403 . "Forbidden")
(404 . "Not Found")
(405 . "Method Not Allowed")
(406 . "Not Acceptable")
(407 . "Proxy Authentication Required")
(408 . "Request Timeout")
(409 . "Conflict")
(410 . "Gone")
(411 . "Length Required")
(412 . "Precondition Failed")
(413 . "Request Entity Too Large")
(414 . "Request-URI Too Long")
(415 . "Unsupported Media Type")
(416 . "Requested Range Not Satisfiable")
(417 . "Expectation Failed")
(422 . "Unprocessable Entity")
(423 . "Locked")
(424 . "Failed Dependency")
(426 . "Upgrade Required")
(428 . "Precondition Required")
(429 . "Too Many Requests")
(431 . "Request Header Fields Too Large")
(500 . "Internal Server Error")
(501 . "Not Implemented")
(502 . "Bad Gateway")
(503 . "Service Unavailable")
(504 . "Gateway Timeout")
(505 . "HTTP Version Not Supported")
(506 . "Variant Also Negotiates (Experimental)")
(507 . "Insufficient Storage")
(508 . "Loop Detected")
(510 . "Not Extended")
(511 . "Network Authentication Required")))
(define (write-response response)
(with-accessors (response code headers body)
(fcgi-display (format #f "Status: ~a ~a\r\n" code (assv-ref status-codes code)))
(let ((headers (if (assoc 'content-type headers)
headers
`((content-type . "text/html") ,@headers))))
(fcgi-display
(string-join (map (match-lambda
((key . value) (format #f "~a: ~a" key value)))
headers)
"\r\n")))
(fcgi-display "\r\n\r\n")
(fcgi-display body)))
(define (receive-request)
(define string->method
(match-lambda
("GET" 'GET)
("POST" 'POST)))
(define (strip-query-string uri)
(let ((match-object (string-match "^(/.*)\\?" uri)))
(if match-object
(match:substring match-object 1)
uri)))
;; According to RFC 9110, header names must be treated as case-insensitive.
(define headers
(filter-map
(lambda (var)
(let ((match-object (string-match "HTTP_(.*)=(.*)" var)))
(if match-object
`(,(string->symbol
(string-downcase
(string-map (lambda (c) (if (char=? c #\_) #\- c))
(match:substring match-object 1))))
.
,(match:substring match-object 2))
#f)))
(environ)))
(let* ((method (string->method (getenv "REQUEST_METHOD")))
(query (parse-form-urlencoded (getenv "QUERY_STRING")))
(uri (strip-query-string (getenv "REQUEST_URI"))))
(make-struct <request> method uri query headers (fcgi-read))))
(define (handle-errors thunk)
(catch #t
(lambda ()
(with-exception-handler
(lambda (exn)
(let ((captured-stack (make-stack #t)))
(throw 'custom-error-key exn captured-stack)))
thunk
#:unwind? #f))
(lambda (key exn captured-stack)
(let ((stack-trace (call-with-output-string (cut display-backtrace captured-stack <>))))
(list 500 stack-trace)))))
(define (run-server router)
(while (zero? (fcgi-accept))
(let* ((request (receive-request))
(response (iter-routes request router)))
(write-response (any->response response)))))
|
© 2015 - 2026 Jakob L. Kreuze
