source: project/release/4/uri-match/trunk/uri-match.scm @ 16104

Last change on this file since 16104 was 16104, checked in by Moritz Heidkamp, 10 years ago

use irregex for route matching (per Peter Bex)

File size: 3.9 KB
Line 
1;; A flexible URI matcher
2;;
3;; Copyright (C) 2009 Moritz Heidkamp
4;;
5;; This program is free software; you can redistribute it and/or
6;; modify it under the terms of the GNU General Public License as
7;; published by the Free Software Foundation; either version 3 of the
8;; License, or (at your option) any later version.
9;;
10;; This program is distributed in the hope that it will be useful, but
11;; WITHOUT ANY WARRANTY; without even the implied warranty of
12;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13;; General Public License for more details.
14;;
15;; You can find a copy of the GNU General Public License at
16;; http://www.gnu.org/licenses/
17
18(module uri-match 
19        (uri-match make-routes make-uri-matcher)
20
21(import chicken scheme)
22(use uri-common srfi-1 srfi-13 data-structures)
23(require-library regex)
24(import irregex)
25
26(define (maybe-string->sre obj) ;; Remove when irregex is updated in chicken
27  (if (string? obj) (string->sre obj) obj))
28
29;; Transforms something like this:
30;;
31;; (("/foo"
32;;   (get "this!")
33;;   ("/bar" (get "and this!"))
34;;   (post "also this")))
35;;
36;; Into this:
37;;
38;; ((get  (("/foo" "this!)
39;;         ("/foo/bar "and this!"))
40;;  (post (("/foo" "also this"))))
41;;
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)))))))))
59
60;; TODO: Get rid of the irregex argument, once irregex 0.8 is imported.
61;; This includes a procedure to extract the named submatches from the matchdata.
62;; 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))))
76
77;; Matches a given HTTP method and path (or uri-path, respectively) in
78;; routes and returns the body of the first matching route, #f
79;; otherwise. If the body is a procedure, it is applied to the
80;; possibly found capture groups.
81(define (uri-match method uri routes)
82  (let ([path (if (uri-reference? uri) (string-join (cons "" (cdr (uri-path uri))) "/") uri)])
83    (let find ([routes (alist-ref method routes)])
84      (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))))))))
92
93
94;; Accepts a route list like make-routes and returns a procedure for
95;; matching against these.
96(define (make-uri-matcher routes)
97  (let ([routes (make-routes routes)])
98    (lambda (method path)
99      (uri-match method path routes))))
100
101)
Note: See TracBrowser for help on using the repository browser.