source: project/release/4/spiffy-request-vars/trunk/spiffy-request-vars.scm @ 17991

Last change on this file since 17991 was 17991, checked in by Mario Domenech Goulart, 9 years ago

spiffy-request-vars (trunk)

  • syntax changes
  • added as-list', as-number' and `as-boolean' as converter

procedures. The `true-boolean-values' parameter specify which strings
are to be considered `#t' when passed through the URL and converted
with `as-boolean'.

  • with-request-vars' and with-request-vars*' admit specifying a

converter to variables values

File size: 3.4 KB
Line 
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
Note: See TracBrowser for help on using the repository browser.