1 | (module spiffy-request-vars |
---|
2 | (request-vars with-request-vars with-request-vars* |
---|
3 | |
---|
4 | ;; Parameters |
---|
5 | true-boolean-values |
---|
6 | |
---|
7 | ;; Converters |
---|
8 | as-boolean as-list as-number |
---|
9 | ) |
---|
10 | |
---|
11 | (import chicken scheme extras ports files data-structures) |
---|
12 | (use srfi-1 srfi-13 intarweb uri-common spiffy) |
---|
13 | |
---|
14 | (define true-boolean-values |
---|
15 | ;; A list of strings to be considered `#t' for request variables |
---|
16 | ;; when `as-boolean' is used as converter. |
---|
17 | (make-parameter |
---|
18 | '("y" "yes" "1" "on"))) |
---|
19 | |
---|
20 | (define (req-vars/vals var vars/vals) |
---|
21 | (and vars/vals |
---|
22 | (let loop ((vars/vals vars/vals)) |
---|
23 | (if (null? vars/vals) |
---|
24 | '() |
---|
25 | (let ((var/val (car vars/vals))) |
---|
26 | (if (eq? var (car var/val)) |
---|
27 | (cons (cdr var/val) (loop (cdr vars/vals))) |
---|
28 | (loop (cdr vars/vals)))))))) |
---|
29 | |
---|
30 | (define (as-boolean var vals) |
---|
31 | (and-let* ((val (alist-ref var vals))) |
---|
32 | (not (not (member val (true-boolean-values) string-ci=?))))) |
---|
33 | |
---|
34 | (define (as-list var vals) |
---|
35 | (let ((vals (req-vars/vals var vals))) |
---|
36 | (if (null? vals) |
---|
37 | #f |
---|
38 | vals))) |
---|
39 | |
---|
40 | (define (as-number var vals) |
---|
41 | (and-let* ((val (alist-ref var vals))) |
---|
42 | (string->number val))) |
---|
43 | |
---|
44 | (define (request-vars #!key (source 'both) max-content-length) |
---|
45 | |
---|
46 | (let* ((content-matters? (not (memq (request-method (current-request)) '(GET HEAD)))) |
---|
47 | (get-vars (and (memq source '(both query-string)) |
---|
48 | (uri-query (request-uri (current-request))))) |
---|
49 | (request-body |
---|
50 | (and (memq source '(both request-body)) |
---|
51 | content-matters? ;; don't bother reading the contents when method is either GET or HEAD |
---|
52 | (let* ((headers (request-headers (current-request))) |
---|
53 | (content-length (header-value 'content-length headers))) |
---|
54 | (when (and max-content-length |
---|
55 | content-length ;; sometimes this header does not exist |
---|
56 | (> content-length max-content-length)) |
---|
57 | (error 'request-vars "content-length exceeds the provided max-content-length.")) |
---|
58 | (let ((body (read-string (or max-content-length content-length) |
---|
59 | (request-port (current-request))))) |
---|
60 | (case (header-value 'content-type headers) |
---|
61 | ((application/x-www-form-urlencoded) (form-urldecode body)) |
---|
62 | (else body))))))) |
---|
63 | |
---|
64 | (lambda (var #!optional default/converter) |
---|
65 | (let* ((var (if (string? var) |
---|
66 | (string->symbol var) |
---|
67 | var)) |
---|
68 | (vals (or get-vars request-body))) |
---|
69 | |
---|
70 | (if (procedure? default/converter) |
---|
71 | (default/converter var vals) |
---|
72 | (let ((vals (req-vars/vals var vals))) |
---|
73 | (if (null? vals) |
---|
74 | default/converter |
---|
75 | (car vals)))))))) |
---|
76 | |
---|
77 | (define-syntax with-request-vars* |
---|
78 | (syntax-rules () |
---|
79 | ((_ $ () form . forms) |
---|
80 | (begin form . forms)) |
---|
81 | |
---|
82 | ((_ $ ((var converter) . more-bindings) forms ...) |
---|
83 | (let* ((var ($ (quote var) converter))) |
---|
84 | (with-request-vars* $ more-bindings forms ...))) |
---|
85 | |
---|
86 | ((_ $ (var . more-bindings) forms ...) |
---|
87 | (let* ((var ($ (quote var)))) |
---|
88 | (with-request-vars* $ more-bindings forms ...))))) |
---|
89 | |
---|
90 | (define-syntax with-request-vars |
---|
91 | (syntax-rules () |
---|
92 | ((_ bindings forms ...) |
---|
93 | (with-request-vars* (request-vars) bindings forms ...)) |
---|
94 | ((_ $ bindings forms ...) |
---|
95 | (with-request-vars* $ bindings forms ...)))) |
---|
96 | |
---|
97 | ) ; end module |
---|