;;;; Copyright (C) 2006-2008 David Patrick Mullen
;;;;
;;;; This file is part of Kira.
;;;;
;;;; Kira 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 2
;;;; of the License, or (at your option) any later version.
;;;;
;;;; Kira 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 should have received a copy of the GNU General Public License
;;;; along with Kira; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.

(in-package :kira)

(defvar *absolutep* nil
  "Print scheme, host, etc. of URIs.")

(defun parse-node-specializers (spec)
  (etypecase (first spec)
    (cons
     (destructuring-bind ((node class) view &rest spec) spec
       (values node class view spec)))
    (symbol
     (values (gensym) 'root (pop spec) spec))))

(defun normalize-node-specializers (spec)
  (multiple-value-bind (node class view spec) (parse-node-specializers spec)
    (values `((,node ,class) (,(gensym) (eql ',view))) spec)))

(define-method-macro define-canonical-uri (&qualifiers qualifiers lambda-list &body body)
  (multiple-value-bind (spec lambda-list) (normalize-node-specializers lambda-list)
    `(defmethod
         make-uri
         (,@spec
	  ,@lambda-list
	  ,@(unless (member '&key lambda-list)
	      '(&key &allow-other-keys)))
       (values
	(progn ,@body)
	,(when (member :override qualifiers)
	   t)))))

(define-canonical-uri ((root root))
  "/")

(define-canonical-uri ((root null))
  "/")

(defun uri-to (escapep absolutep to &rest query)
  (with-output-to-string (stream)
    (apply #'print-uri-to stream escapep absolutep to query)))

(defun print-uri-to (stream escapep absolutep to &rest query &aux fragment)
  (multiple-value-bind (node view uri overridden)
      (etypecase to
	((or root null)
	 *root*)
	(node
	 (multiple-value-bind (uri overridden) (apply #'canonical-uri to query)
	   (values to (pop query) uri overridden)))
	(symbol (values *root* to))
	(uri (values nil nil to))
	(string (values nil nil (parse-uri node))))
    (when (and uri (or overridden (uri-scheme uri)))
      (princ uri stream)
      (return-from print-uri-to))
    (if absolutep
	(princ *base-uri* stream)
	(write-string (uri-path *base-uri*) stream))
    (when uri
      (whereas ((path (uri-path uri))
		(start 0)
		(end (length path)))
	(when (position #\/ path)
	  (when (char= (char path start) #\/)
	    (incf start))
	  (when (char= (char path (1- end)) #\/)
	    (decf end)))
	(when (> end start)
	  (write-string path stream :start start :end end)
	  (when view (write-char #\/ stream)))))
    (when view
      (unless (keywordp view) (write-char #\$ stream))
      (format stream "~(~a~)" view))
    (when (uri-fragment uri)
      (setf fragment (uri-fragment uri)))
    (let (separator)
      (labels ((print-value (value)
		 (typecase value
		   (string (uri-encode value stream))
		   (symbol (uri-encode (string-downcase value) stream))
		   (node (princ (id value) stream))
		   (t (uri-encode (princ-to-string value) stream))))
	       (print-kv (key value)
		 (if separator
		     (write-string separator stream)
		     (progn
		       (write-char #\? stream)
		       (setf separator (if escapep "&" "&"))))
		 (print-value key)
		 (write-char #\= stream)
		 (print-value value))
	       (argument-supplied-p (argument)
		 (loop for (k v) on query by #'cddr
		       when (string-equal k argument) return t
		       finally (return nil))))
	(loop for (key . value) in (uri-parsed-query uri)
	      unless (argument-supplied-p key)
	      do (print-kv key value))
	(loop for (key value) on query by #'cddr
	      when (eq key :#) do (setf fragment value)
	      else do (print-kv key value))))
    (when fragment
      (write-char #\# stream)
      (uri-encode fragment stream))))

(defelement :uri-to (&rest args)
  (if (every #'constantp args)
      (apply #'uri-to t *absolutep* (mapcar #'eval args))
      `(print-uri-to *html-output* t *absolutep* ,@args)))

(defun node-from-uri (uri &optional (method :get) action)
  (flet ((path->symbol (path)
	   (let ((first (first path))
		 (package
		  (if (and (> (length first) 1)
			   (char= (char first 0) "$"))
		      (progn
			(pop path)
			(push (subseq first 1) path)
			:kira)
		      :keyword)))
	     (find-symbol (format nil "~{~:@(~a~)~^/~}" path) package))))
    (let* ((path (remove-if #'emptyp (rest (uri-parsed-path (uri uri)))))
	   (buf (make-string-output-stream))
	   (string (si:output-stream-string buf))
	   name)
      (if (and path
	       (setf name (path->symbol path))
	       (method-exists nil #'handle *root* name method action))
	  (values *root* name)
	  (loop with node = *root*
		do (if path
		       (whereas ((view (path->symbol path)))
			 (when (method-exists nil #'handle node view method action)
			   (return (values node view))))
		       (when (method-exists nil #'handle node nil method action)
			 (return node)))
		while path
		while
		(let (prefix
		      (suffix path)
		      (call-with-suffix-p t))
		  (reset-string-stream buf)
		  (loop for (name . rest) on path do
			(format buf "~:[/~;~]~:@(~a~)" (emptyp string) name)
			(whereas ((sym (find-symbol string :keyword)))
			  (when (or (and (method-exists nil #'internal-redirect node sym nil)
					 (prog1 t (setf call-with-suffix-p nil)))
				    (and rest
					 (method-exists nil #'internal-redirect node sym rest)
					 (setf call-with-suffix-p t)))
			    (setf prefix sym
				  suffix rest))))
		  (when (or prefix (method-exists nil #'internal-redirect node nil suffix))
		    (multiple-value-setq (node path)
		      (if call-with-suffix-p
			  (internal-redirect node prefix suffix)
			  (values (internal-redirect node prefix nil) suffix)))
		    node)))))))

(define-method-macro defhandler (&qualifiers qualifiers spec &body body)
  (with-sub-elements ((:title . title)) body
    (multiple-value-bind (spec extra-spec) (normalize-node-specializers spec)
      `(progn
	 ,(when title
	    `(defmethod render-node-title (,@spec &key &allow-other-keys)
	       (html ,@title)))
	 (defmethod handle
	     ,@(intersection qualifiers '(:around :before :after))
	     (,@spec
	      (,(gensym) (eql ',(if (member :post qualifiers) :post :get)))
	      (,(gensym) (eql ',(first extra-spec))))
	   (,(if (member :get qualifiers) 'standard-page 'progn)
	    ,@body))))))

(defmacro define-internal-redirect (spec suffix &body body)
  `(defmethod internal-redirect
       (,@(normalize-node-specializers spec)
        ,(if suffix
	     `(,suffix cons)
	     `(,(gensym) null)))
     ,@body))