;; 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 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
;; General Public License for more details.
;;
;; You can find a copy of the GNU 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 regex)


;; Transforms something like this:
;; 
;; (("/foo"
;;   (get "this!")
;;   ("/bar" (get "and this!"))
;;   (post "also this")))
;; 
;; Into this:
;; 
;; ((get  (("/foo" "this!)
;;         ("/foo/bar "and this!"))
;;  (post (("/foo" "also this"))))
;;
(define (make-routes routes #!optional (path ""))
  (if (null? routes) '()
      (let* ([method-or-path (caar routes)]
  	     [body-or-routes (cdar routes)]
  	     [result (make-routes (cdr routes) path)])
	
  	(if (symbol? method-or-path)
  	    (let ([method (string->symbol (string-downcase (symbol->string method-or-path)))])
  	      (alist-update! method (append (alist-ref method result eq? '()) 
  					    (list (cons (if (string= path "") "/" path) body-or-routes))) result))
  	    (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 (conc path method-or-path)))))))


;; 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 (if (uri-reference? uri) (string-join (cons "" (cdr (uri-path uri))) "/") uri)])
    (let find ([routes (alist-ref method routes)])
      (and routes (not (null? routes))
	   (let ([matches (string-match (caar routes) path)])
	     (if matches
		 (let ([body (cadar routes)])
		   (if (procedure? body)
		       (lambda () (apply body (cdr matches)))
		       (lambda () body)))
		 (find (cdr routes))))))))


;; 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))))

)