;; 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 scheme)
(import (chicken base))
(import (chicken irregex))
(import (chicken keyword))
(import (srfi 1))
(import (srfi 13))
(import uri-common)

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

)