Ignore:
Timestamp:
10/29/09 19:48:53 (11 years ago)
Author:
Moritz Heidkamp
Message:

change route path format to match that of uri-common (breaks backwards compatibility)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/uri-match/trunk/uri-match.scm

    r16104 r16315  
    2020
    2121(import chicken scheme)
    22 (use uri-common srfi-1 srfi-13 data-structures)
     22(use uri-common srfi-1 srfi-13 data-structures extras)
    2323(require-library regex)
    2424(import irregex)
     25
     26(define (find-map f p l)
     27  (let find ((l l))
     28    (and (not (null? l))
     29         (let ((v (f (car l))))
     30           (if (p v) v (find (cdr l)))))))
    2531
    2632(define (maybe-string->sre obj) ;; Remove when irregex is updated in chicken
     
    2935;; Transforms something like this:
    3036;;
    31 ;; (("/foo"
    32 ;;   (get "this!")
    33 ;;   ("/bar" (get "and this!"))
    34 ;;   (post "also this")))
     37;; (((/ "foo" "bar")
     38;;   (GET "this!")
     39;;   ((/ (+ numeric))
     40;;    (GET "and this!"))
     41;;   (POST "also this")))
    3542;;
    3643;; Into this:
    3744;;
    38 ;; ((get  (("/foo" "this!)
    39 ;;         ("/foo/bar "and this!"))
    40 ;;  (post (("/foo" "also this"))))
     45;; ((GET  ((("foo" "bar") "this!")
     46;;      (("foo" "bar" (+ numeric)) "and this!")))
     47;;  (POST ((("foo" "bar") "also this"))))
    4148;;
    42 (define (make-routes routes #!optional (path ""))
    43   (let ((path (maybe-string->sre path)))
    44     (if (null? routes) '()
    45         (let* ([method-or-path (caar routes)]
    46                [body-or-routes (cdar routes)]
    47                [result (make-routes (cdr routes) path)])
    48        
    49           (if (symbol? method-or-path)
    50               (let ([method (string->symbol (string-downcase (symbol->string method-or-path)))])
    51                 (alist-update! method (append (alist-ref method result eq? '())
    52                                               (list (cons (irregex path) body-or-routes))) result))
    53               (let ((subpath (maybe-string->sre method-or-path)))
    54                 (fold (lambda (e r)
    55                         (let ([method (car e)]
    56                               [routes (cdr e)])
    57                           (alist-update! method (append routes (alist-ref method result eq? '())) r)))
    58                       result (make-routes body-or-routes `(seq ,path ,subpath)))))))))
     49(define (make-routes routes #!optional (path '()))
     50  (if (null? routes) '()
     51      (let* ([method-or-path (caar routes)]
     52             [body-or-routes (cdar routes)]
     53             [result (make-routes (cdr routes) path)])
    5954
    60 ;; TODO: Get rid of the irregex argument, once irregex 0.8 is imported.
     55        (if (symbol? method-or-path)
     56            (let ([method method-or-path])
     57              (alist-update! method (append (alist-ref method result eq? '())
     58                                            (list (cons (map irregex path) body-or-routes))) result))
     59
     60            (let ((subpath (map maybe-string->sre (cdr method-or-path))))
     61              (fold (lambda (e r)
     62                      (let ([method (car e)]
     63                            [routes (cdr e)])
     64                        (alist-update! method (append routes (alist-ref method result eq? '())) r)))
     65                    result (make-routes body-or-routes (append path subpath))))))))
     66
     67;; TODO: Get rid of the irregexen argument, once irregex 0.8 is imported.
    6168;; This includes a procedure to extract the named submatches from the matchdata.
    6269;; We also have irregex-match-num-submatches, which is currently not exported.
    63 (define (apply-with-matches proc irregex matchdata)
    64   (let ((positional (map (lambda (i)
    65                            (irregex-match-substring matchdata i))
    66                          (iota (irregex-submatches irregex) 1)))
    67         (named (fold (lambda (n args)
    68                        (let ((str (irregex-match-substring matchdata (car n))))
    69                          (if str
    70                              (cons (string->keyword (symbol->string (car n)))
    71                                    (cons str args))
    72                              args)))
    73                           '()
    74                           (irregex-names irregex))))
    75     (apply proc (append positional named))))
     70(define (apply-with-matches proc irregexen matches)
     71  (apply proc (fold-right (lambda (irregex matchdata args)
     72                      (let ((positional (map (lambda (i)
     73                                               (irregex-match-substring matchdata i))
     74                                             (iota (irregex-submatches irregex) 1)))
     75                            (named (fold (lambda (n args)
     76                                           (let ((str (irregex-match-substring matchdata (car n))))
     77                                             (if str
     78                                                 (cons (string->keyword (symbol->string (car n)))
     79                                                       (cons str args))
     80                                                 args)))
     81                                         '()
     82                                         (irregex-names irregex))))
     83                        (append positional args named))) '() irregexen matches)))
    7684
    7785;; Matches a given HTTP method and path (or uri-path, respectively) in
     
    8088;; possibly found capture groups.
    8189(define (uri-match method uri routes)
    82   (let ([path (if (uri-reference? uri) (string-join (cons "" (cdr (uri-path uri))) "/") uri)])
     90  (let ([path (cdr (uri-path (if (uri-reference? uri) uri (uri-reference uri))))])
    8391    (let find ([routes (alist-ref method routes)])
    8492      (and routes (not (null? routes))
    85            (let ([matches (irregex-match (caar routes) path)])
    86              (if matches
    87                  (let ([body (cadar routes)])
    88                    (if (procedure? body)
    89                        (lambda () (apply-with-matches body (caar routes) matches))
    90                        (lambda () body)))
    91                  (find (cdr routes))))))))
     93           (let ([route (car routes)])
     94             (and (= (length (car route)) (length path))
     95                  (let ([matches (map-in-order irregex-match (car route) path)])
     96                    (if (every identity matches)
     97                        (let ([body (cadr route)])
     98                          (if (procedure? body)
     99                              (lambda () (apply-with-matches body (car route) matches))
     100                              (lambda () body)))
     101                        (find (cdr routes))))))))))
    92102
    93103
Note: See TracChangeset for help on using the changeset viewer.