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

;; 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 irregexen matches)
  (apply proc (fold-right (lambda (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))) '() 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))))])
    (call/cc (lambda (return)
    	       (let find ([routes (alist-ref method routes)])
    		 (and routes (not (null? routes))
    		      (let ([route (car routes)])
    			(and (= (length (car route)) (length path))
    			     (let ([matches (map irregex-match (car route) path)]) ""
				  (and (every identity matches)
				       (return (let ([body (cadr route)])
						 (if (procedure? body)
						     (lambda () (apply-with-matches body (car route) 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))))

)