(in-package :kira)

(defun creator (node &optional (type 'person))
  (whereas ((creator (slot-value node 'creator)))
    (when (typep creator type)
      creator)))

(defsetf creator (node) (creator)
  `(setf (slot-value ,node 'creator) ,creator))

(defun creation-time (node)
  (or (slot-value node 'creation-time) *now*))

(defsetf creation-time (node) (creation-time)
  `(setf (slot-value ,node 'creation-time) ,creation-time))

(defun external-uri (node)
  (whereas ((uri (slot-value node 'external-uri)))
    (uri uri)))

(defsetf external-uri (node) (external-uri)
  `(setf (slot-value ,node 'external-uri) ,external-uri))

(defun viewing (node &optional view)
  (and (eq *node* node) (or (eq *view* view) (eq view t))))

(defmethod status ((node node))
  (let ((creator (creator node)))
    (cond ((and (not creator) (containsp (possible-spam *root*) node)) :pending-approval)
	  ((and creator (containsp (deleted-items creator) node)) :deleted)
	  ((and creator (containsp (drafts creator) node)) :draft)
	  (t :published))))

(defmethod (setf status) (status (node node))
  (prog1 status
    (unless (eq (status node) status)
      (with-transaction ()
	(ecase status
	  (:pending-approval
	   (unrealize node)
	   (add-to (possible-spam *root*) node))
	  (:deleted
	   (unrealize node)
	   (whereas ((creator (creator node)))
	     (add-to (deleted-items creator) node)
	     (remove-from (drafts creator) node)))
	  (:draft
	   (unrealize node)
	   (whereas ((creator (creator node)))
	     (remove-from (deleted-items creator) node)
	     (add-to (drafts creator) node)))
	  (:published
	   (remove-from (possible-spam *root*) node)
	   (realize node)
	   (whereas ((creator (creator node)))
	     (remove-from (deleted-items creator) node)
	     (remove-from (drafts creator) node))))))))

(defun featured (key)
  (getf (slot-value *root* 'featured) key))

(defsetf featured (key) (value)
  `(setf (getf (slot-value *root* 'featured) ,key) ,value))

(defmethod (setf featuredp) (featuredp (object t))
  ())

(defmacro feature (class key)
  `(progn
     (defmethod featuredp ((instance ,class))
       (member instance (featured ',key)))
     (defmethod (setf featuredp) (featuredp (instance ,class))
       (prog1 featuredp
	 (unless (eq (not (featuredp instance)) (not featuredp))
	   (with-transaction ()
	     (if featuredp
		 (insertf instance (featured ',key) #'lookup>)
		 (deletef instance (featured ',key)))))))))

(define-canonical-uri ((node node))
  (format nil "/node/~d" (id node)))

(define-internal-redirect ((node node)) path
  (whereas ((key (pop path)))
    (values (get-value (next-in-uri node) key) path)))

(define-internal-redirect (:node) path
  (whereas ((id (pop path)))
    (values (string->type id 'id) path)))

(defmethod string->type (string (type (eql 'id)))
  (whereas ((id (string->type string 'integer)))
    (get-value (objects *db*) id)))

(defmethod princ-object ((node node) stream)
  (if (id node)
      (uri-to stream (eq stream *html-output*) nil node)
      (call-next-method)))

(defun render-title (object &rest args)
  (if (and args (or (typep object 'node) (method-exists nil #'render-node-title object (first args))))
      (apply #'render-node-title object args)
      (typecase object
	(null)
	(node (render-node-title object nil))
	(symbol (apply #'render-node-title *root* object args))
	((or uri number) (html object))
	(string (render-inline-markup object))
	(t (html (:princ-safe object))))))

(defmethod query->plist ((node node) (view t))
  '())

(defun render-title-from-query ()
  (apply #'render-node-title *node* *view* (query->plist *node* *view*)))

(defun render-link (node &rest args)
  (if (and (typep node '(or node symbol uri))
	   *allow-links-p*
	   *allow-elements-p*)
      (let* ((*allow-links-p* nil)
	     (query args)
	     (view (typecase node
		     (node (pop query))
		     (symbol node))))
	(html ((:a :rel (:when (and view (not (keywordp view))) "nofollow"))
	       (apply #'uri-to t t *absolutep* node args)
	       (apply #'render-title node args))))
      (apply #'render-title node args)))

(defmethod render-editor ((type symbol))
  (render-editor (make-instance-from-query type)))

(defmethod render-editor ((node node))
  (html
   (:field "Title" (text-field 'title node))
   (:field "Body" (markup-field 'body node))))

(defmethod update-instance-from-query :around ((node node))
  (with-transaction ()
    (call-next-method)))

(defmethod realize :around ((node node))
  (with-transaction ()
    (call-next-method)))

(defmethod unrealize :around ((node node))
  (with-transaction ()
    (call-next-method)))

(defmethod initialize-instance-from-query progn ((node node))
  (setf (creation-time node) *now* (creator node) *person*)
  (link-back *node* node))

(defmethod link-back ((entity t) (object t))
  ())

(defmethod update-instance-from-query progn ((node node))
  (setf-accessors-from-query
   node
   title
   body
   (image file)))

(define-update-methods ((node node))
  (update-instance *root* node))

(defmethod track ((node node))
  (whereas ((creator (creator node)))
    (add-to (nodes creator) node)))

(defmethod section ((node node))
  (or (owner node) (call-next-method)))

(defun breadcrumb (node view section)
  (cond ((and node
	      view
	      (or (not (typep node 'root))
		  (keywordp view)))
	 node)
	((and section
	      (not (typep section 'root))
	      (typep node 'breadcrumb-mixin))
	 section)
	((typep node '(or page forum))
	 *root*)))

(defun make-instance-from-query (&optional type &rest initargs)
  (let ((instance
	 (apply #'make-instance
		(or type (request-query-value "type" 'symbol))
		initargs)))
    (initialize-instance-from-query instance)
    instance))

(defmethod render-node-title ((entity node) (view (eql 'create)) &key type)
  (html (:text (class-prototype type) 'create)))

(defmethod text ((node node) (symbol (eql 'create)))
  (format nil "~a ~a" (text node 'realize) (text node 'class)))

(defmethod query->plist ((entity node) (view (eql 'create)))
  (list :type (request-query-value "type" 'symbol)))

(defhandler ((node node))
  (:title
   (let ((title (title node)))
     (if title
	 (render-inline-markup title)
	 (html (:format "#<~(~a~)~@[ ~d~]>"
			(class-name (class-of node))
			(id node))))))
  (setf (rendition-variable :heading) nil)
  (render-in-style node 'view))

(defhandler ((entity node) create)
  (:let ((node (make-instance-from-query)))
    (:standard-form
     (render-editor node)
     (unless *person*
       (render-challenge))
     (:p (submit-button nil (text node 'realize))
	 (:when *person*
	   " " (submit-button :draft "Save as Draft"))))))

(defhandler :post ((entity node) create)
  (let* ((approved t)
	 (node
	  (with-transaction ()
	    (let ((node (make-instance-from-query)))
	      (prog1 node
		(update-instance-from-query node)
		(unless *person*
		  (setf-accessors-from-query node creator)
		  (setf approved (challenge-answered-p)))
		(if approved
		    (realize node)
		    (add-to (possible-spam *root*) node)))))))
    (whereas ((name (creator node 'string)))
      (set-cookie "name" name))
    (if approved
	(progn
	  (send-notifications node)
	  (redirect node))
	(redirect node 'edit))))

(defhandler :post ((entity node) create :draft)
  (redirect
   (with-transaction ()
     (let ((node (make-instance-from-query)))
       (update-instance-from-query node)
       (add-to (drafts *person*) node)
       node))))

(defhandler ((node node) edit)
  (:title "Edit")
  (:authorized-p (node-access-p node 'edit))
  (:standard-form
   (:when (eq (status node) :pending-approval)
     ((:p :class "error") "You need to answer the challenge correctly.")
     (render-challenge))
   (render-editor node)
   (:when *person*
     (:fieldset
      "Status"
      (:when (method-exists nil #'featuredp node)
	(:div (checkbox 'featuredp node "Feature on front page")))
      (:div (menu-field 'status node '((:draft "Draft") (:published "Publish") (:deleted "Delete")))))
     (:when (administratorp *person*)
       (:fieldset
	"URL"
	(text-field 'canonical-uri node))))
   (:p (submit-button nil "Save"))))

(defmethod node-access-p or ((node node) (action (eql 'edit)))
  (or (and *person* (eq *person* (creator node)))
      (whereas ((creator (creator node 'string))
		(name (cookie "name")))
	(and (string= name creator)
	     (< (- (get-universal-time) (date-time-to-ut (creation-time node)))
		(* 3600 6))))))

(defun plist-of-slots (node slots)
  (loop for slot in slots
	collect slot
	collect (slot-value node slot)))

(defun update-indices-for-slots (node slots)
  (whereas
      ((slots
	(loop for (slot old-value) on slots by #'cddr
	      for new-value = (slot-value node slot)
	      when (lookup/= new-value old-value)
	      collect slot and collect new-value
	      and do (setf (slot-value node slot) old-value))))
    (unrealize node)
    (loop for (slot new-value) on slots by #'cddr
	  do (setf (slot-value node slot) new-value))
    (realize node)))

(defmacro with-indexed-slots ((node slots) &body body)
  (rebinding (node slots)
    (with-unique-names (plist)
      `(with-transaction ()
	 (let ((,plist (plist-of-slots ,node ,slots)))
	   (multiple-value-prog1 (progn ,@body)
	     (update-indices-for-slots ,node ,plist)))))))

(defhandler :post ((node node) edit)
  (when *person*
    (setf-accessors-from-query node (status keyword))
    (when (method-exists nil #'featuredp node)
      (setf-accessors-from-query node (featuredp boolean)))
    (when (administratorp *person*)
      (setf-accessors-from-query node (canonical-uri uri))))
  (let ((status (status node)))
    (if (eq status :published)
	(with-indexed-slots (node (watched-slots node))
	  (update-instance-from-query node))
	(update-instance-from-query node))
    (when (eq status :pending-approval)
      (if (challenge-answered-p)
	  (setf (status node) :published)
	  (redirect node 'edit))))
  (alert
   "Edited " (render-link node) "."
   " (Status: " (:princ (status node)) ".)")
  (redirect node))

(defmethod text ((node node) (symbol (eql 'realize)))
  "Create")

(defmethod parse-parameter (name (type (eql 'collection)))
  (collecting
    (dolist (cons (request-query))
      (when (and (string-equal (car cons) name) (stringp (cdr cons)))
	(whereas ((object (string->type (cdr cons) 'id)))
	  (collect object))))))

(definput collection-field (name value options &key (descending nil) (n 10) multiple)
  (let ((button (if multiple #'checkbox #'radio-button))
	(firstp t))
    (do-collection (option options :descending descending :n n)
      (:if firstp
	   (setf firstp nil)
	   (:br))
      (funcall
       button
       name
       value
       (html-output (render-title option))
       :option option
       :key #'id))))

(defmethod string->type (string (type (eql 'uri)))
  (parse-uri string))

(defmethod string->type (string (type (eql 'node-from-uri)))
  (whereas ((uri (parse-uri string)))
    (node-from-uri uri)))

(defmethod string->type (string (type (eql 'node-uris)))
  (loop with start and end = -1 and node
	while (setf start (position-if-not #'whitespacep string :start (1+ end)))
	do (setf end (position-if #'whitespacep string :start start)
		 node (node-from-uri (subseq string start end)))
	when node collect node
	while end))

(defhandler ((node node) raw)
  (:title "Raw Node Data")
  (:authorized-p nil)
  (:let ((*print-id* nil))
    (:p (:prin1-safe node))
    (:p (render-link node 'raw/edit))))

(defhandler ((node node) raw/edit)
  (:title "Edit")
  (:standard-form
   (:let ((*print-id* nil))
     (:p (textarea "new-node" (prin1-to-string node)))
     (:p (submit-button nil "Save")))))

(defhandler :post ((node node) raw/edit)
  (unless (request-query-value "safe" 'boolean)
    (unrealize node))
  (with-transaction ()
    (setf (odb::dirty-objects *transaction*)
	  (list (request-query-value "new-node" t))))
  (when (eq (status node) :published)
    (realize node))
  (redirect node 'raw))

(defhandler :post ((entity node) create-from-uri)
  (redirect
   (with-transaction ()
     (let ((node (make-instance-from-query)))
       (setf-accessors-from-query node (external-uri uri))
       (fetch-node-from-uri node)
       (realize node)
       node))))

(defhandler :raw ((node node) refresh-from-uri)
  (fetch-node-from-uri node)
  (redirect node))

(defmethod fetch-node-from-uri :around ((node node))
  (with-transaction ()
    (call-next-method)))

(defmethod render-in-style ((node node) (style (eql 'rss)))
  (xml
   ("dc:creator" (escape (html-output (render-title (creator node))) +element-escapes+))
   (:title (escape (html-output (render-title node)) +element-escapes+))
   (:link (:uri-to node))))