(in-package :kira)

(defvar *absolutep* nil
  "If true, output URIs in absolute form.")

(defun normalize-node-specializers (lambda-list)
  (let ((first (first lambda-list))
	(second (second lambda-list)))
    (etypecase first
      (cons
       (if (consp second)
	   lambda-list
	   `(,first
	     (,(gensym) (eql ',second))
	     ,@(nthcdr 2 lambda-list))))
      (symbol
       (if (consp second)
	   `((,(gensym) (eql ',first))
	     ,@(rest lambda-list))
	   `((,(gensym) root)
	     (,(gensym) (eql ',first))
	     ,@(rest lambda-list)))))))

(defmacro define-canonical-uri (lambda-list &body body)
  (let ((lambda-list (normalize-node-specializers lambda-list)))
    (unless (member '&key lambda-list)
      (setf lambda-list `(,@lambda-list &key)))
    (with-sub-elements ((:title . title)) body
      `(progn
	 ,(when title
	    `(defmethod render-node-title ,lambda-list
	       (html ,@title)))
	 (defmethod make-uri ,lambda-list
           ,@body)))))

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

(defun canonical-uri (to &rest args)
  (whereas
      ((uri
	(or (when (and (typep to 'node) (null args))
	      (slot-value to 'canonical-uri))
	    (cond
	      ((symbolp to)
	       (if (and args (method-exists nil #'make-uri to (first args)))
		   (apply #'make-uri to args)
		   (apply #'make-uri *root* to args)))
	      (args (apply #'make-uri to args))
	      (t (with-caching-slot (to '%canonical-uri)
		   (make-uri to nil)))))))
    (uri uri)))

(defun %maybe-set-canonical-uri (node uri)
  (if (eq uri nil)
      (setf (slot-value node 'canonical-uri) nil)
      (let ((old-uri (canonical-uri node)))
	(unless (uri= uri old-uri)
	  (with-transaction ()
	    (let ((path (rest (uri-parsed-path uri)))
		  (current-node *root*)
		  next-node)
	      (setf (uri-parsed-path uri) (cons :absolute path))
	      (setf (slot-value node 'canonical-uri) uri)
	      (loop while (next-in-uri current-node) do
		    (setf next-node (get-value (next-in-uri current-node) (first path)))
		    while next-node do (authorize next-node 'edit)
		    while (plusp (length (second path))) do
		    (setf current-node next-node)
		    (pop path))
	      (unless next-node
		(loop while (plusp (length (second path)))
		      do (progn
			   (setf next-node (make-instance 'node))
			   (add-kv (next-in-uri current-node) (first path) next-node)
			   (setf current-node next-node)
			   (pop path))))
	      (add-kv (next-in-uri current-node)
		      (first path)
		      node)))))))

(defsetf canonical-uri (node) (uri)
  `(%maybe-set-canonical-uri ,node ,uri))

(defun uri-to (stream escapep absolutep to &rest query &aux fragment)
  (unless to (setf to *root*))
  (with-output (stream *html-output*)
    (multiple-value-bind (node view uri)
	(etypecase to
	  (node
	   (let ((view (pop query)))
	     (if (and view (method-exists nil #'make-uri to view))
		 (progn
		   (princ (apply #'canonical-uri to view query) stream)
		   (return))
		 (values to view (canonical-uri to)))))
	  (symbol
	   (if (and query (method-exists nil #'make-uri to (first query)))
	       (progn
		 (princ (apply #'canonical-uri to query) stream)
		 (return))
	       (values *root* to)))
	  (uri (values nil nil to))
	  (string (values nil nil (parse-uri to))))
      (when (and uri (uri-scheme uri))
	(princ uri stream)
	(return))
      (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 (and uri (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)
		   (when 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 nil) on query by #'cddr
			 when (string-equal k argument) return t
			 finally (return nil))))
	  (when uri
	    (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
		do (case key
		     (:# (setf fragment value))
		     (t (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 nil t *absolutep* (mapcar #'eval args))
      `(uri-to t 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) #\$))
		       (prog1 :kira
			 (setf path (list* (subseq first 1) (rest path))))
		       :keyword)))
	     (find-symbol (format nil "~{~:@(~a~)~^/~}" path)
                          package))))
    (let* ((path (remove-if
		  (lambda (string) (zerop (length string)))
		  (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))
		  (setf (fill-pointer string) 0)
		  (loop for (name . rest) on path do
			(format buf "~:[~;/~]~:@(~a~)" (plusp (length 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 lambda-list &body body)
  (with-sub-elements ((:title . title) (:sidebar . sidebar) (:authorized-p . authorized-p)) body
    (let* ((lambda-list (normalize-node-specializers lambda-list))
	   (action (third lambda-list)))
      (when action
	(setf lambda-list
	      (ldiff lambda-list (nthcdr 2 lambda-list))))
      `(progn
	 ,(when title
	    `(defmethod render-node-title (,@lambda-list &key)
	       (html ,@title)))
	 ,(when sidebar
	    `(defmethod render-sidebar ,lambda-list
	       (html ,@sidebar)))
	 ,(when authorized-p
	    `(defmethod authorized-p (,@lambda-list &key)
	       ,@authorized-p))
	 (defmethod handle
	     ,@(intersection qualifiers '(:around :before :after))
	     (,(first lambda-list)
	      ,(second lambda-list)
	      (,(gensym) (eql ',(if (member :post qualifiers) :post :get)))
	      (,(gensym) (eql ',action)))
	   (,(if (some (lambda (qualifier)
			 (case qualifier
			   ((:post :raw :around :before :after)
			    t)))
		       qualifiers)
		 'progn
		 'standard-page)
	    ,@body))))))

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