(in-package :kira)

(defvar *old-top-level* #'si:top-level)
(setf compiler:*compile-verbose* nil
      compiler:*compile-print* nil
      compiler:*suppress-compiler-notes* t
      compiler:*suppress-compiler-warnings* t
      *load-verbose* nil
      *load-print* nil)

(defhandler (database)
  (:title "Database")
  (:let ((*print-id* nil))
    (:ul
     (do-collection (object (objects *db*) :n 30 :descending t)
       (:li (:prin1-safe object))))))

(defhandler (btrees)
  (:title "B-Trees")
  (:ul
   (do-btree (key value (btrees *db*) :n 60 :descending t)
     (:li (:b (:prin1-safe key)) " " (:prin1-safe value)))))

(defun handle-request ()
  (let* ((uri (request-uri))
	 (method (request-method))
	 (action (request-action))
	 (*person* (cookie "id" 'id)))
    (multiple-value-bind (*node* *view*) (node-from-uri uri method action)
      (if *node*
	  (let ((*section* (section *node*)))
	    (authorize *node* *view*)
	    (handle *node* *view* method action))
	  (standard-page
	   (:title "404 Not Found")
	   (setf (request-reply-code) "404 Not Found")
	   (:p "No object found for " (:tt uri) "."))))))

(define-condition response-sent ()
  ())

(defun redirect (&rest args)
  (format t "Location: ~a~%~%" (apply #'uri-to nil nil t args))
  (signal 'response-sent))

(defmacro with-kira-environment ((request) &body body)
  `(with-locks ()
     (with-object-database ()
       (setf *now* (now)
	     *root* (get-value (objects *db*) 0)
	     *request* ,request
	     (request-reply-content-type) "text/html")
       ,@body)))

(defun accept ()
  (handler-bind
      ((serious-condition
	(lambda (c)
	  (format
	   t
	   "Content-type: text/html~%~%~a"
	   (html-output
	    (:html
	     (:head
	      (:title "Condition"))
	     (:body
	      (:h1 "Condition")
	      (:pre (:princ-safe c))))))
	  (return-from accept))))
    (let* ((*html-output* (make-string-output-stream))
	   (output (si:output-stream-string *html-output*))
	   (sent nil))
      (with-kira-environment ((parse-request))
	(handler-case (handle-request)
	  (response-sent (c) (setf sent t))))
      (finalize-temporary-files)
      (unless sent
	(whereas ((status (request-reply-code)))
	  (format t "Status: ~a~%" status))
	(format t "Content-type: ~a~%~%" (request-reply-content-type))
	(write-string output)))))

(defun si:top-level ()
  (setf *print-pretty* nil)
  (set-dispatch-macro-character #\# #\. nil)
  (set-syntax-from-char #\} #\))
  (set-syntax-from-char #\] #\))
  (setf *base-uri* (parse-uri *base-uri*))
  (db:db-init)
  (ecase (si:argc)
    (1 (accept))
    (2 (funcall *old-top-level*))))

(defun top-level ()
  (with-kira-environment ((make-instance 'request :uri (parse-uri (si:argv 1))))
    (funcall *old-top-level*)))