;; A flexible URI matcher ;; ;; Copyright (C) 2009 Moritz Heidkamp ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License ;; as published by the Free Software Foundation; either version 3 of ;; the License, or (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You can find a copy of the GNU Lesser General Public License at ;; http://www.gnu.org/licenses/ (module uri-match (uri-match make-routes make-uri-matcher) (import chicken scheme) (use uri-common srfi-1 srfi-13 data-structures extras) (require-library regex) (import irregex) (define (maybe-string->sre obj) ;; Remove when irregex is updated in chicken (if (string? obj) (string->sre obj) obj)) ;; Transforms something like this: ;; ;; (((/ "foo" "bar") ;; (GET "this!") ;; ((/ (+ numeric)) ;; (GET "and this!")) ;; (POST "also this"))) ;; ;; Into this: ;; ;; ((GET ((("foo" "bar") "this!") ;; (("foo" "bar" (+ numeric)) "and this!"))) ;; (POST ((("foo" "bar") "also this")))) ;; (define (make-routes routes #!optional (path '())) (if (null? routes) '() (let* ((method-or-path (caar routes)) (body-or-routes (cdar routes)) (path (if (and (> (length path) 1) (or (eq? 'epsilon (car path)) (eq? "" (car path)))) (cdr path) path)) (result (make-routes (cdr routes) path))) (if (symbol? method-or-path) (let ((method method-or-path)) (alist-update! method (append (alist-ref method result eq? '()) (list (cons (map irregex path) body-or-routes))) result)) (let ((subpath (map maybe-string->sre (cdr method-or-path)))) (fold (lambda (e r) (let ((method (car e)) (routes (cdr e))) (alist-update! method (append routes (alist-ref method result eq? '())) r))) result (make-routes body-or-routes (append path subpath)))))))) (define (irregex-match->args irregex matchdata args) (let ((positional (map (lambda (i) (irregex-match-substring matchdata i)) (iota (irregex-submatches irregex) 1))) (named (fold (lambda (n args) (let ((str (irregex-match-substring matchdata (car n)))) (if str (cons (string->keyword (symbol->string (car n))) (cons str args)) args))) '() (irregex-names irregex)))) (append positional args named))) ;; TODO: Get rid of the irregexen argument, once irregex 0.8 is imported. ;; This includes a procedure to extract the named submatches from the matchdata. ;; We also have irregex-match-num-submatches, which is currently not exported. (define (apply-with-matches proc next irregexen matches) (apply proc (cons next (fold-right irregex-match->args '() irregexen matches)))) ;; Matches a given HTTP method and path (or uri-path, respectively) in ;; routes and returns the body of the first matching route, #f ;; otherwise. If the body is a procedure, it is applied to the ;; possibly found capture groups. (define (uri-match method uri routes) (let ((path (cdr (uri-path (if (uri-reference? uri) uri (uri-reference uri)))))) (let find ((routes (alist-ref method routes))) (and routes (pair? routes) (let ((route (car routes)) (next (lambda () (find (cdr routes))))) (or (and (= (length (car route)) (length path)) (let ((matches (map irregex-match (car route) path))) (and (every identity matches) (let ((body (cadr route))) (if (procedure? body) (lambda () (apply-with-matches body (lambda () (and-let* ((next (next))) (next))) (car route) matches)) (lambda () body)))))) (next))))))) ;; Accepts a route list like make-routes and returns a procedure for ;; matching against these. (define (make-uri-matcher routes) (let ((routes (make-routes routes))) (lambda (method path) (uri-match method path routes)))) )