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

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

removed uri-match.import.scm and moved everything else into trunk

File size: 2.7 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 regex)
23
24
25;; Transforms something like this:
26;;
27;; (("/foo"
28;;   (get "this!")
29;;   ("/bar" (get "and this!"))
30;;   (post "also this")))
31;;
32;; Into this:
33;;
34;; ((get  (("/foo" "this!)
35;;         ("/foo/bar "and this!"))
36;;  (post (("/foo" "also this"))))
37;;
38(define (make-routes routes #!optional (path ""))
39  (if (null? routes) '()
40      (let* ([method-or-path (caar routes)]
41             [body-or-routes (cdar routes)]
42             [result (make-routes (cdr routes) path)])
43       
44        (if (symbol? method-or-path)
45            (let ([method (string->symbol (string-downcase (symbol->string method-or-path)))])
46              (alist-update! method (append (alist-ref method result eq? '()) 
47                                            (list (cons (if (string= path "") "/" path) body-or-routes))) result))
48            (fold (lambda (e r) 
49                    (let ([method (car e)]
50                          [routes (cdr e)])
51                      (alist-update! method (append routes (alist-ref method result eq? '())) r)))
52                  result (make-routes body-or-routes (conc path method-or-path)))))))
53
54
55;; Matches a given HTTP method and path (or uri-path, respectively) in
56;; routes and returns the body of the first matching route, #f
57;; otherwise. If the body is a procedure, it is applied to the
58;; possibly found capture groups.
59(define (uri-match method uri routes)
60  (let ([path (if (uri-reference? uri) (string-join (cons "" (cdr (uri-path uri))) "/") uri)])
61    (let find ([routes (alist-ref method routes)])
62      (and routes (not (null? routes))
63           (let ([matches (string-match (caar routes) path)])
64             (if matches
65                 (let ([body (cadar routes)])
66                   (if (procedure? body)
67                       (lambda () (apply body (cdr matches)))
68                       (lambda () body)))
69                 (find (cdr routes))))))))
70
71
72;; Accepts a route list like make-routes and returns a procedure for
73;; matching against these.
74(define (make-uri-matcher routes)
75  (let ([routes (make-routes routes)])
76    (lambda (method path)
77      (uri-match method path routes))))
78
79)
Note: See TracBrowser for help on using the repository browser.