source: project/scgi/scgi.scm @ 427

Last change on this file since 427 was 427, checked in by Thomas Chust, 15 years ago

scgi v1.1.0
multiple request parameters of the same name are now accepted and collected
in a list, single parameters are still atomic

File size: 8.7 KB
Line 
1;;;; scgi.scm
2;;;; SCGI server library
3
4(define-extension scgi
5  (export
6   scgi:max-request-length
7   scgi:request-method-handler
8   scgi:request-parameter-parser
9   scgi:resources
10   scgi:add-resource
11   scgi:find-resource
12   scgi:remove-resource
13   scgi:write-response-header
14   scgi:write-error-response
15   scgi:make-server))
16
17(declare
18 (fixnum-arithmetic)
19 (usual-integrations))
20
21(require-extension
22 (srfi 1) (srfi 18) (srfi 26) (srfi 69)
23 extras regex match synch tcp-server url)
24
25;;; Utilities
26
27(define (scgi:read-netstring)
28  (let ((l (string->number (read-token char-numeric?))))
29    (unless l
30      (error
31       'scgi:read-netstring
32       "client side protocol error: malformed netstring (bad length)"))
33    (unless (eq? (read-char) #\:)
34      (error
35       'scgi:read-netstring
36       "client side protocol error: malformed netstring (bad delimiter)"))
37    (let ((s (read-string l)))
38      (unless (eq? (read-char) #\,)
39        (error
40         'scgi:read-netstring
41         "client side protocol error: malformed netstring (bad terminal)"))
42      s)))
43
44(define scgi:key/value->pair
45  (match-lambda
46   (("")
47    #f)
48   ((key)
49    (cons key #t))
50   ((key value)
51    (cons key value))))
52
53(define (scgi:write-header-line key/value)
54  (printf "~A: ~A\r\n" (car key/value) (cdr key/value)))
55
56;;; Public management interface (and directly related stuff)
57
58(define scgi:max-request-length
59  (make-parameter
60   #f
61   (lambda (l)
62     (cond
63      ((integer? l)
64       l)
65      (l
66       (abort
67        (make-composite-condition
68         (make-property-condition
69          'exn
70          'location 'scg:max-request-length
71          'message "parameter must be set to an integer"
72          'arguments (list l))
73         (make-property-condition
74          'type))))
75      (else
76       #f)))))
77
78(define scgi:request-method-handlers
79  (make-mutex 'scgi:request-method-handlers))
80
81(mutex-specific-set! scgi:request-method-handlers (make-hash-table))
82
83(define (scgi:request-method-handler name #!optional proc)
84  (call/synch scgi:request-method-handlers
85    (lambda (ht)
86      (if proc
87          (hash-table-set! ht name proc)
88          (hash-table-ref/default ht name #f)))))
89 
90(define scgi:request-parameter-parsers
91  (make-mutex 'scgi:request-parameter-parsers))
92
93(mutex-specific-set! scgi:request-parameter-parsers (make-hash-table))
94
95(define (scgi:request-parameter-parser name #!optional proc)
96  (call/synch scgi:request-parameter-parsers
97    (lambda (ht)
98      (if proc
99          (hash-table-set! ht name proc)
100          (hash-table-ref/default ht name #f)))))
101
102(define scgi:resources
103  (make-parameter
104   '()
105   (lambda (resources)
106     (cond
107      ((list? resources)
108       (let ((mtx (make-mutex (gensym 'scgi:resources))))
109         (mutex-specific-set! mtx (alist->hash-table resources))
110         mtx))
111      ((hash-table? resources)
112       (let ((mtx (make-mutex (gensym 'scgi:resources))))
113         (mutex-specific-set! mtx resources)
114         mtx))
115      ((and (mutex? resources) (hash-table? (mutex-specific resources)))
116       resources)
117      (else
118       (abort
119        (make-composite-condition
120         (make-property-condition
121          'exn
122          'location 'scgi:resources
123          'message
124          "parameter must be set to a mutex containing a hash table, a hash table or an association list"
125          'arguments (list resources))
126         (make-property-condition
127          'type))))))))
128
129(define (scgi:add-resource name proc)
130  (call/synch (scgi:resources)
131    (lambda (resources)
132      (for-each
133       (cut hash-table-set! resources <> proc)
134       (if (list? name) name (list name))))))
135
136(define (scgi:find-resource name)
137  (call/synch (scgi:resources)
138    (cut hash-table-ref/default <> name #f)))
139
140(define (scgi:remove-resource name)
141  (call/synch (scgi:resources)
142    (lambda (resources)
143      (for-each
144       (cut hash-table-delete! resources <>)
145       (if (list? name) name (list name))))))
146
147;;; Public output interface routines
148
149(define (scgi:write-response-header
150         content-type
151         #!optional
152         content-length
153         (more-headers '())
154         (status-code 200) (status-message "OK"))
155  (for-each
156   scgi:write-header-line
157   (cons*
158    (cons "Status" (sprintf "~A ~A" status-code status-message))
159    (cons "Content-type" content-type)
160    (if content-length
161        (cons
162         (cons "Content-length" content-length)
163         more-headers)
164        more-headers)))
165  (display "\r\n"))
166
167(define (scgi:write-error-response
168         status-code status-message long-message
169         #!optional
170         (more-headers '()))
171  (let ((doc (sprintf #<<EOD
172<?xml version="1.0" encoding="US-ASCII"?>
173<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
174<html xmlns="http://www.w3.org/1999/xhtml">
175<head>
176<meta http-equiv="content-type" content="text/html; charset=US-ASCII" />
177<meta name="robots" content="noindex" />
178<title>~A ~A</title>
179</head>
180<body>
181<h1>~A ~A</h1>
182<p>~A</p>
183</body>
184</html>
185EOD
186              status-code status-message status-code status-message
187              long-message)))
188    (scgi:write-response-header
189     "text/html" (string-length doc)
190     more-headers
191     status-code status-message)
192    (display doc)))
193
194;;; Pre-installed default handlers (and directly related stuff)
195
196(define (query-string->parameter-hash qs)
197  (let ((ht (make-hash-table)))
198   (for-each
199    (lambda (key/value)
200      (cond
201       ((scgi:key/value->pair (string-split key/value "="))
202        => (lambda (pair)
203             (let ((new (if (string? (cdr pair))
204                          (url-decode (cdr pair))
205                          (cdr pair))))
206               (hash-table-update!/default ht (car pair)
207                 (lambda (value)
208                   (if value
209                     (if (list? value)
210                       (cons new value)
211                       (list new value))
212                     new))
213                 #f))))))
214    (string-split qs "&"))
215   ht))
216
217(scgi:request-parameter-parser "application/x-www-form-urlencoded"
218  (lambda (env len)
219    (query-string->parameter-hash (read-string len))))
220
221(scgi:request-parameter-parser "multipart/form-data"
222  (let ((brx (regexp "boundary=([^ ;\n\r\t]+)"))
223        (lrx (regexp "\r\n\r\n"))
224        (nrx (regexp "name=\"([^ ;\n\r\t\"]*)\""))
225        (frx (regexp "filename=\"([^ ;\n\r\t\"]*)\"")))
226    (lambda (env len)
227      (alist->hash-table
228       (map
229        (lambda (raw)
230          (match (string-search-positions lrx raw)
231            (((idx0 idx1) . _)
232             (let* ((hdr (substring raw 0 idx0))
233                    (name (string-search nrx hdr))
234                    (filename (string-search frx hdr))
235                    (value (substring raw idx1)))
236               (cons
237                (cadr name)
238                (if filename
239                    (list 'file (cadr filename) value)
240                    value))))))
241        (cdr
242         (string-split-fields
243          (string-append
244           "(\r\n)?--"
245           (cadr (string-search brx (hash-table-ref env "CONTENT_TYPE")))
246           "(--)?\r\n")
247          (read-string len)
248          #:suffix)))))))
249
250(scgi:request-method-handler "GET"
251  (lambda (env response-handler)
252    (response-handler
253     env
254     (query-string->parameter-hash
255      (hash-table-ref/default env "QUERY_STRING" "")))))
256
257(scgi:request-method-handler "POST"
258  (let ((rx (regexp "^([^;]+)($|;)")))
259    (lambda (env response-handler)
260      (let ((len (string->number
261                  (hash-table-ref/default env "CONTENT_LENGTH" ""))))
262        (cond
263         ((and (scgi:max-request-length) (not len))
264          (scgi:write-error-response
265           411 "Length required"
266           "The server refuses processing as no <tt>Content-length</tt> was sent with the request."))
267         ((and (scgi:max-request-length) (> len (scgi:max-request-length)))
268          (scgi:write-error-response
269           413 "Request entity too large"
270           "The server refuses processing as the request's <tt>Content-length</tt> is too large."))
271         ((scgi:request-parameter-parser
272           (and-let* ((type (hash-table-ref/default env "CONTENT_TYPE" #f))
273                      (fields (string-search rx type)))
274             (cadr fields)))
275          => (lambda (content-parser)
276               (response-handler env (content-parser env len))))
277         (else
278          (scgi:write-error-response
279           501 "Not implemented"
280           "The server doesn't know how to parse request parameters from the content type sent.")))))))
281
282;;; Public server startup interface (and directly related stuff)
283
284(define (scgi:dispatcher)
285  (let ((env (alist->hash-table
286              (filter-map
287               scgi:key/value->pair
288               (chop (string-split (scgi:read-netstring) "\x00" #t) 2)))))
289    (cond
290     ((scgi:find-resource
291       (hash-table-ref/default env "PATH_INFO" #f))
292      => (lambda (response-handler)
293           (cond
294            ((scgi:request-method-handler
295              (hash-table-ref/default env "REQUEST_METHOD" #f))
296             => (lambda (method-handler)
297                  (method-handler env response-handler)))
298            (else
299             ;; request method unknown
300             (scgi:write-error-response
301              405 "Method not allowed"
302              "The access method used to request the document is not supported."
303              (list
304               (cons
305                "Allow"
306                (string-intersperse
307                 (call/synch scgi:request-method-handlers
308                   hash-table-keys)
309                 ", "))))))))
310     (else
311      ;; resource unknown
312      (scgi:write-error-response
313       404 "Not found"
314       "The requested resource does not exist.")))))
315
316(define (scgi:make-server listener . max-requests)
317  (apply
318   make-tcp-server
319   listener
320   scgi:dispatcher
321   max-requests))
322
323;;;; vim:set shiftwidth=2 softtabstop=2: ;;;;
Note: See TracBrowser for help on using the repository browser.