(in-package :cl-blog)

(defvar *permalinks* nil)

(defvar *template-translator*)

(defun md5sum-sequence (characters)
  (ironclad:digest-sequence :md5
                            (map '(vector (unsigned-byte 8))
                                 #'char-code characters)))

(defparameter *template-conditionals* nil)

(defmacro with-template-conditional (conditional &body body)
  `(let ((*template-conditionals* (cons ,conditional *template-conditionals*)))
     ,@body))

(defmacro without-template-conditional (conditional &body body)
  `(let ((*template-conditionals* (remove ,conditional *template-conditionals*)))
     ,@body))

(defparameter *currently-expanding-ifs* nil)

(defmethod register-key (key (class (eql 'blog-entry)))
  (setf *blog-entry-counter* (max *blog-entry-counter* key)))

(defmethod register-key (key (class (eql 'trackback)))
  (setf *trackback-counter* (max *trackback-counter* key)))

(defun archives-url (&key category rss)
  (if category
      (concatenate 'string
                   (urlstring (if rss
                                  *rss-url*
                                  *archives-url*))
                   (if rss "?" "/")
                   category)
      (urlstring (if rss *rss-url* *archives-url*))))

(defun make-archives-url (&key category month year)
  (let ((url (copy-url *archives-url*)))
    (setf (url-query url) (format nil "~A~A~A"
                                  (if category
                                      (format nil "category=~A" category)
                                      "")
                                  (if (and category month year)
                                      "&"
                                      "")
                                  (if (and month year)
                                      (format nil "month=~A&year=~A"
                                              month year)
                                      "")))
    (encode-for-pre (urlstring url))))

(defun make-archives-url-for-entry (entry)
  (multiple-value-bind (second minute hour day month year)
      (decode-universal-time (blog-entry-time entry))
    (declare (ignore second minute hour day))
    (concatenate 'string (make-archives-url :month month :year year) "#"
		 (prin1-to-string (blog-entry-number entry)))))

(defun expand-blog-template (title body-lambda)
  (extend-translator* *template-translator*
      ((<cl-blog:page-title/> title)
       (<cl-blog:page-body/> (funcall body-lambda)))
    (apply-translator *template-translator* *blog-template*)))

(defun blog-wrap-page (request title body &rest extra-request-headers)
  (apply #'request-send-headers request :expires 0 :content-type "text/html; charset=iso-8859-1" extra-request-headers)
  (send-doctype request)
  (xml-output-to-stream (request-stream request)
                        (expand-blog-template title
                         (lambda ()
                           (<div id='content'> body)))))

(defun delete-blog-entry (entry)
  (delete-instance entry)
  (setf *blog-entry-counter*
        (max 0
             (loop for entry in *blog-entries* maximizing (blog-entry-number entry)))))

(defun find-permalink (name)
  (gethash name *permalinks*))

(defun (setf find-permalink) (value name)
  (setf (gethash name *permalinks*) value))

(defun fix-blog-entries-order ()
  (setf *blog-entries*
	(sort *blog-entries* #'> :key #'blog-entry-number)))

(defun find-all-permalinks ()
  (setf *permalinks* (make-hash-table :test 'equalp))
  (dolist (entry *blog-entries*)
    (setf (gethash (blog-entry-permalink entry) *permalinks*) entry)))

(defun start-blog ()
  #-single-http-listener
  (ignore-errors (stop-listening *listener*))
  (load-store-for-class 'user)
  (load-store-for-class 'blog-entry)
  (fix-blog-entries-order)
  (find-all-permalinks)
  #-single-http-listener
  (start-listening *listener*))

(defun derive-permalink-name-from-title (title)
  (let* ((title (cl-ppcre:regex-replace-all " " title "-"))
	 (title (cl-ppcre:regex-replace-all "[\\[\\]\\{\\}\\\\~`!@#$%^&*\\(\\)+=|:;<>,./?]" title ""))
	 (title (string-downcase title)))
    (if (find-permalink title)
	(loop with candidate-title
	      for index from 2
	      do (setf candidate-title (format nil "~A-~A" title index))
	      unless (find-permalink candidate-title)
	      return candidate-title)
	title)))

(defun new-blog-entry (&key category title contents)
  (incf *blog-entry-counter*)
  (let* ((permalink (derive-permalink-name-from-title title))
	 (new-entry (make-instance 'blog-entry :number *blog-entry-counter*
				   :category category
				   :user *authenticated-user*
				   :title title
				   :time (get-universal-time)
				   :contents contents
				   :permalink permalink)))
    (setf (find-permalink permalink) new-entry)
    (register-instance new-entry)
    new-entry)) 

(defclass cl-blog-handler (handler)
  ())

(defclass validate-unhandled-part-mixin ()
  ((validate-lambda :initform (constantly t)
                    :initarg :validate-lambda
                    :accessor validate-lambda)))

(defclass authenticate-mixin () ())

(defclass new-entry-handler (cl-blog-handler authenticate-mixin) ())

(defun entry-from-regexp-validator (regexp)
  (lambda (unhandled-part)
    (let* ((l (nth-value 1 (cl-ppcre:scan-to-strings
                            regexp unhandled-part)))
           (str (and l (elt
                        l
                        0))))
      (and str (find-entry (parse-integer str))))))

(defun permalink-from-regexp-validator (regexp)
  (lambda (unhandled-part)
    (let* ((l (nth-value 1 (cl-ppcre:scan-to-strings
                            regexp unhandled-part)))
           (str (and l (elt
                        l
                        0))))
      (and str (find-permalink str)))))

(defclass display-entry-handler (validate-unhandled-part-mixin cl-blog-handler)
  ((validate-lambda :initform (permalink-from-regexp-validator "^([\\w\\d_-]+)$"))))

(defclass edit-entry-handler (cl-blog-handler authenticate-mixin)
  ())

(defclass trackback-handler (validate-unhandled-part-mixin cl-blog-handler)
  ((validate-lambda :initform (entry-from-regexp-validator "^(\\d+)$"))))

(defclass delete-entry-handler (cl-blog-handler authenticate-mixin)
  ())

(defun category-from-regexp-validator (regexp)
  (lambda (unhandled-part)
    (or (eql (length unhandled-part) 0)
        (let ((str (elt
                    (nth-value 1 (cl-ppcre:scan-to-strings
                                  regexp unhandled-part))
                    0)))
          (and str (find str *categories* :test #'string-equal))))))
  
(defclass archives-handler (cl-blog-handler)
  ())

(defclass rss-handler (validate-unhandled-part-mixin cl-blog-handler)
  ((validate-lambda :initform (category-from-regexp-validator "^\\?(\\w+)$"))))

(defclass template-generated-handler (cl-blog-handler)
  ((template :initarg :template :accessor template-page-template)
   (template-file :initarg :template-file :accessor template-page-template-file)
   (template-install-time :initarg :template-install-time :accessor template-page-install-time)))

(defun send-doctype (request)
  (write-string "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">" (request-stream request))
  (terpri (request-stream request)))

(defmethod handle-request-response ((handler rss-handler) method request)
  (request-send-headers request :expires 0 :content-type "text/xml")
  (let* ((unhandled-part (request-unhandled-part request))
         (category (if (eql (length unhandled-part) 0)
                       nil
                       (elt
                        (nth-value 1 (cl-ppcre:scan-to-strings
                                      "^\\?(\\w+)$" unhandled-part))
                        0))))
    (generate-rss
        (request *blog-short-name* (urlstring *blog-url-root*)
                 (if category
                            (format nil "~A archives for category ~A"
                                    *blog-short-name*
                                    category)
                            (format nil "~A archives"
                                    *blog-short-name*)))
      (loop for i in *blog-entries*
             for j from 1 to 20
             if (or (not category)
                    (string-equal (blog-entry-category i) category))
           do
           (rss-entry
            :title (blog-entry-title i)
            :link (entry-link i)
            :time (blog-entry-time i)
            :description
            (encode-for-http
                  (encode-for-pre
                   (blog-entry-contents i))))))))

(defclass login-handler (cl-blog-handler)
  ())

(defclass logout-handler (cl-blog-handler authenticate-mixin)
  ())

(defclass administrator-mixin ()
  ())

(defclass admin-handler (cl-blog-handler administrator-mixin)
  ())

(defclass edit-user-handler (cl-blog-handler authenticate-mixin)
  ())

(defmethod handle-request-response ((handler login-handler) (method (eql :get)) request)
  (blog-wrap-page
   request
   "Login"
   (form-html (login *login-url*))))

(defmethod handle-request-response ((handler login-handler) (method (eql :post)) request)
  (with-processed-form
      login request
      :error
      (blog-wrap-page
         request
         "Error"
         (resubmit-form *login-url*))
      :success
      (let ((*authenticated-user* user))
        (with-template-conditional 'authorized
          (if (typep *authenticated-user* 'administrator)
              (with-template-conditional 'administrator
                (blog-wrap-page request
                                "You are now logged in." nil
                                :set-cookie (make-authorization-token :extra user)))
              (blog-wrap-page request
                              "You are now logged in." nil
                              :set-cookie (make-authorization-token :extra user)))))))

(defmethod handle-request-response ((handler logout-handler) method request)
  (expire-authorization-tokens
   :timeout *authentication-timeout*
   :filter (lambda (thing)
             (eq thing *authenticated-user*)))
  (without-template-conditional 'authorized
    (blog-wrap-page
     request
     "You have been logged out."
     "You have been logged out.")))

(defparameter *week-day-names* #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
(defparameter *month-names* #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul"
			      "Aug" "Sep" "Oct" "Nov" "Dec"))

(defun date-name-from-number (number name-mapping)
  (elt name-mapping (mod (1- number) (length name-mapping))))

(defun format-entry-date (date &key long-p)
  (if (zerop date)
      "The Dawn of Time..."
      (with-date date nil
		 (if long-p
		     (format nil "~A, ~A ~A ~A ~2,'0D:~2,'0D -~4,'0D"
			     (elt *week-day-names* day-of-week)
			     day-of-month
			     (date-name-from-number month *month-names*)
			     year hour minute (truncate (* zone 100)))
		     (format nil "~A, ~A ~A ~A"
			     (elt *week-day-names* day-of-week)
			     day-of-month
			     (date-name-from-number month *month-names*)
			     year)))))

(defun format-month (date)
  (with-date date nil
             (format nil "~A ~A"
                     (date-name-from-number month *month-names*)
                     year)))

(defun beginning-of-month (date)
  (if (zerop date)
      date
      (multiple-value-bind (second minute hour date month year)
	  (decode-universal-time date)
	(declare (ignore second minute hour date))
	(encode-universal-time 0 0 0 1 month year))))

(defun date-beginning-month (month year &key next-month)
  (if next-month
      (encode-universal-time 0 0 0 1 (1+ (mod month 12)) (if (eql month 12)
                                                             (1+ year)
                                                             year))
      (encode-universal-time 0 0 0 1 month year)))

(defun month-and-year-from-strings-or-current (month year)
  (let* ((actual-month (if month (parse-integer month :junk-allowed t) 0))
         (actual-year (if year (parse-integer year :junk-allowed t) 0))
         (month (if (> actual-month 0) actual-month
                    (with-date (get-universal-time) nil month)))
         (year (if (> actual-year 0) actual-year
                   (with-date (get-universal-time) nil year))))
    (values month year)))

(defun month-selector-div (category)
  (let ((first-entry (car (last *blog-entries*))))
    (if first-entry
        (<div class='archives-box'>
              (<ul>
               (loop with first-entry-year = (with-date (blog-entry-time first-entry) nil year)
                  for i from first-entry-year
                  to (with-date (get-universal-time) nil year)
                  appending (loop for j from (if (eql i first-entry-year)
                                                 (with-date (blog-entry-time first-entry) nil month) 1)
                               to 12
                               if (> (count-if #'(lambda (ent)
                                                   (>= (date-beginning-month j i :next-month t)
                                                       (blog-entry-time ent)
                                                       (date-beginning-month j i)))
                                               *blog-entries*) 0)
                               collect (<li>
                                        (<a href=?(make-archives-url :category category
                                                                     :month j
                                                                     :year i)>
                                                                     (format-month (date-beginning-month j i))))))))
        <div class='archives-box'/>)))

(defmethod handle-request-response ((handler archives-handler) method request)
  (let* ((category (car (url-query-param (request-url request) "category")))
         (month-string (car (url-query-param (request-url request) "month")))
         (year-string (car (url-query-param (request-url request) "year"))))
    (multiple-value-bind (month year)
        (month-and-year-from-strings-or-current month-string year-string)
      (let ((bom (date-beginning-month month year))
            (eom (date-beginning-month month year :next-month t)))
        (blog-wrap-page
         request
         (if category
             (format nil "~A Archives: ~A" category
                     (format-month bom))
             (format nil "Archives for ~A" (format-month bom)))
         (list (month-selector-div category)
               (funcall (if *reverse-archives*
                            #'nreverse
                            #'identity)
                        (loop for i in *blog-entries*
                           if (and (or (not category)
                                       (string-equal (blog-entry-category i) category))
                                   (>= eom (blog-entry-time i) bom))
                           collect (format-entry i)))))))))

(defmethod handle-request-response :around ((handler validate-unhandled-part-mixin) method request)
  (if (funcall (validate-lambda handler) (request-unhandled-part request))
      (call-next-method)
      (progn
        (blog-wrap-page request "No page for you!" nil))))

(defun find-entry (number)
  (find number *blog-entries* :key #'blog-entry-number))

(defun entry-link (entry)
  (urlstring (merge-url *display-entry-url*
			(blog-entry-permalink entry))))

(defun entry-trackback (entry)
  (urlstring (merge-url *trackback-url*
			(prin1-to-string (blog-entry-number entry)))))

(defun edit-entry-link (entry)
  (urlstring
   (merge-url
    *edit-entry-url*
    (prin1-to-string (blog-entry-number entry)))))

(defun delete-entry-link (entry)
  (urlstring
   (merge-url
    *delete-entry-url*
    (prin1-to-string (blog-entry-number entry)))))

(defun format-entry-user (entry)
  (let ((user (blog-entry-user entry)))
    (<a href=?(format nil "~A?user=~A"
                        (urlstring *email-redirect-url*)
                        (user-name user))>
                        (user-display-name user))))

(defun format-entry (entry &key (display-actions t))
  (extend-translator* *template-translator*
      ((<cl-blog:entry-rdf-link/>
        (make-unescaped-string
         (format nil "<!--
<rdf:RDF xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"
         xmlns:dc=\"http://purl.org/dc/elements/1.1/\"
         xmlns:trackback=\"http://madskills.com/public/xml/rss/module/trackback/\">
<rdf:Description
    rdf:about=\"~A\"
    dc:identifier=\"~A\"
    dc:title=\"~A\"
    trackback:ping=\"~A\" />
</rdf:RDF>
-->
" (entry-link entry) (entry-link entry) (blog-entry-title entry) (entry-trackback entry))))
       (<cl-blog:entry-number/>
        (prin1-to-string (blog-entry-number entry)))
       (<cl-blog:entry-title/>
        (blog-entry-title entry))
       (<cl-blog:entry-date/>
        (format-entry-date (blog-entry-time entry)))
       (<cl-blog:entry-date long='true'/>
                            (format-entry-date (blog-entry-time entry) :long-p t))
       (<cl-blog:entry-category-link/>
        (<a href=?(make-archives-url :category (blog-entry-category entry))>
            (blog-entry-category entry)))
       (<cl-blog:entry-user-link/>
        (format-entry-user entry))
       ((<cl-blog:if-entry-modified> . body)
        (if (> (blog-entry-revised-time entry)
               (blog-entry-time entry))
            body
            <span/>))
       (<cl-blog:entry-modification-date/>
        (format-entry-date (blog-entry-revised-time entry)))
       (<cl-blog:entry-contents/>
        (make-unescaped-string (automatically-encode-non-entities (blog-entry-contents entry))))
       ((<cl-blog:if-entry-display-actions> . body)
        (if display-actions
            body
            <span/>))
       (<cl-blog:entry-permanent-link/>
        (<a class='entry-footer' href=?(entry-link entry)>
            (if (blog-entry-trackbacks entry)
                (format nil "Permanent Link (~A)"
                        (length (blog-entry-trackbacks entry)))
                "Permanent Link")))
       (<cl-blog:entry-in-context-link/>
        (<a href='entry-footer' href=?(make-archives-url-for-entry entry)>
            "In Context"))
       (<cl-blog:entry-edit-link/>
        (<a href='entry-footer' href=?(edit-entry-link entry)>
            "Edit"))
       (<cl-blog:entry-delete-link/>
        (<a href='entry-footer' href=?(delete-entry-link entry)>
            "Delete")))
    (apply-translator *template-translator* *entry-template*)))

(defun format-trackback (trackback)
  (<div class='entry'>
        (<div class='entry-head'>
              (<a href=? (trackback-url trackback)>
                  (trackback-title trackback))
              (<div class='entry-data'>
                    "From " (<i> (trackback-blog-name trackback))
                    " on " (format-entry-date (trackback-time trackback))))
        (<div class='entry-text'>
              (trackback-excerpt trackback))))

(defmethod handle-request-response ((handler template-generated-handler) method request)
  (request-send-headers request :expires 0 :content-type "text/html; charset=iso-8859-1")
  (let ((date (file-write-date
               (template-page-template-file handler))))
    (when (and date (> date (template-page-install-time handler)))
      (setf (template-page-template handler)
            (load-template (template-page-template-file handler) :tags-package #.*package*))))
  (let ((title "No title"))
    (extend-translator*
        *template-translator*
        (((<cl-blog:page> head body)
          (let ((translator (make-translator)))
            (extend-translator
                translator ((<cl-blog:title> new-title)
                            (setf title new-title))
              (apply-translator translator head))
            body))
         ((<cl-blog:wrap-page> . body)
          (expand-blog-template title (lambda () body))))
      (with-xml-output-to-stream (request-stream request)
        (apply-translator *template-translator*
                          (template-page-template handler))))))

(defmethod handle-request-response ((handler edit-entry-handler) (method (eql :get)) request)
  (let ((entry (find-entry (parse-integer (request-unhandled-part request)))))
    (blog-wrap-page
     request
     "Edit Blog Entry"
     (form-html ((entry :edit) (request-url request) :submit-text '(:edit :preview))
                   (entry entry)
                   (title (blog-entry-title entry))
                   (category (blog-entry-category entry))
                   (contents (blog-entry-contents entry))))))

(defmethod handle-request-response ((handler edit-entry-handler) (method (eql :post)) request)
  (with-processed-form
      (entry :edit) request
      :error
      (blog-wrap-page
       request
       "Error"
       `(,(resubmit-form (request-url request) :submit-text '(:edit :preview))))
      :success
      (submit-ecase request
        (:preview
         (let ((entry (shallow-copy-instance entry)))
           (set-slots-from-form-values entry)
           (blog-wrap-page
            request
            "Preview edit"
            (list
             (format-entry entry :display-actions nil)
             <p/>
             (form-html ((entry :edit) (request-url request) :submit-text '(:edit :preview) :gate-fields entry)
               (entry entry))))))
        (:edit
         (set-slots-from-form-values entry)
         (setf (blog-entry-revised-time entry) (get-universal-time))
         (serialize-instance entry)
         (blog-wrap-page
          request
          "Changed"
          (<div id='entry-form'>
                (<h2> "Your entry has been modified.")
                (format-entry entry :display-actions nil)))))))

(defmethod handle-request-response ((handler delete-entry-handler) (method (eql :get)) request)
  (let ((entry (find-entry (parse-integer (request-unhandled-part request)))))
    (blog-wrap-page
     request
     "Confirm Delete Blog Entry"
     (<form method='post' action=? (urlstring (request-url request))>
            (<span class='small-header'>
                   "Are you sure you want to delete this entry?")
            (format-entry entry)
            <input type='submit' value='Yes'/>
            <input type='submit' value='No'/>))))

(defmethod handle-request-response ((handler delete-entry-handler) (method (eql :post)) request)
  (let ((entry (find-entry (parse-integer (request-unhandled-part request)))))
    (submit-ecase request
      ("Yes" (delete-blog-entry entry)
             (blog-wrap-page
              request
              "Deleted!" nil))
      ("No" (blog-wrap-page
             request
             "Not deleted!" nil)))))

(defmethod handle-request-response ((handler new-entry-handler) (method (eql :get)) request)
  (blog-wrap-page
   request
   "New Blog Entry"
   (form-html ((entry :create) *new-entry-url* :submit-text '(:submit :preview)))))

(defun authenticate-user-from-name-and-password (user password)
  (let ((found-user (find-user user)))
    (and found-user
         (equal (coerce (md5sum-sequence password) 'list)
                (coerce (user-password found-user) 'list)))))

(defmethod handle-request-response :around ((handler authenticate-mixin) method request)
  (if (boundp '*authenticated-user*)
      (call-next-method)
      (blog-wrap-page
         request
         "Access is denied!"
         (list "Please login before doing this."
               <p/>
               (form-html (login *login-url*))))))

(defmethod handle-request-response :around ((handler administrator-mixin) method request)
  (if (and (boundp '*authenticated-user*)
           (typep *authenticated-user* 'administrator))
      (call-next-method)
      (blog-wrap-page
         request
         "Access is denied!"
         (list "Please login as an administrator before doing this."
               <p/>
               (form-html (login *login-url*))))))

(defmethod handle-request-response :around ((handler cl-blog-handler) method request)
  (expire-authorization-tokens :timeout *authentication-timeout*)
  (multiple-value-bind (token found)
      (is-authorized request)
    (declare (ignore token))
    (if found
        (let ((*authenticated-user* found))
          (with-template-conditional 'authorized
            (if (typep *authenticated-user* 'administrator)
                (with-template-conditional 'administrator
                  (call-next-method))
                (call-next-method))))
        (call-next-method))))

(defun search-for-trackbacks-for-text (text)
  (let ((url-regexp "(?i)(http://[^ \"]+)([ .,)!?\"]|$)"))
    (loop for (match new-begin) = (multiple-value-list (cl-ppcre:scan url-regexp text))
         for url = nil
         while match
         do (let ((got-url (elt (nth-value 1 (cl-ppcre:scan-to-strings url-regexp text)) 0)))
              (setf text (subseq text new-begin))
              (setf url got-url))
         if url collect url)))

(defun strip-html (text)
  (cl-ppcre:regex-replace-all "<(\"[^\"]+\"|[^>\"])*>" text ""))

(defun autotrackback-entry (entry)
  (let ((urls (search-for-trackbacks-for-text (blog-entry-contents entry))))
    (append
     (loop for url in urls
           for ping = (autodetect-ping-for-url url)
           if ping
           do (ping ping :title (blog-entry-title entry)
                              :url (entry-link entry)
                              :excerpt (strip-html (blog-entry-contents entry))
                              :blog-name *blog-short-name*)
           if ping
           collect url)
     (loop for ping in *xml-rpc-pings*
           if (ping-xml-rpc
               (format nil "~A/RPC2" ping)
               *blog-short-name*
               *blog-url-root*)
           collect ping))))

(defmethod handle-request-response ((handler new-entry-handler) (method (eql :post)) request)
  (with-processed-form
      (entry :create) request
      :error
      (blog-wrap-page
       request
       "Error"
       `(,(resubmit-form *new-entry-url* :submit-text '(:submit :preview))))
      :success
      (let ((entry (make-instance 'blog-entry
                                  :contents contents
                                  :category category
                                  :user *authenticated-user*
                                  :title title
                                  :time (get-universal-time))))
        (submit-ecase request
          (:preview
           (blog-wrap-page
            request
            "Preview entry"
            (list (format-entry entry :display-actions nil)
                  <p/>
                  (resubmit-form *new-entry-url* :submit-text '(:submit :preview)))))
          (:submit
           (let* ((entry
                   (new-blog-entry :title title :category category :contents contents))
                  (urls-pinged (ignore-errors (autotrackback-entry entry))))
             (blog-wrap-page request "Posted"
                             (<div id='entry-form'>
                                   (<h2> "Your new entry has been posted.")
                                   (<div class='trackback'>
                                         (when urls-pinged
                                           (list "Trackback pings have been sent to the following URLs:"
                                                 (<ul>
                                                  (loop for url in urls-pinged
                                                       collect (<li> (<a href=?url> url)))))))))))))))

(defmethod handle-request-response ((handler trackback-handler) (method (eql :post)) request)
  (with-body-params ((title "title")
                     (url "url")
                     (excerpt "excerpt")
                     (blog-name "blog_name"))
    request
    (request-send-headers request :expires 0
                          :content-type "text/xml; charset=iso-8859-1")
    (let ((entry 
           (let ((str (elt (nth-value 1 (cl-ppcre:scan-to-strings
                                         "^(\\d+)$" (request-unhandled-part request))) 0)))
             (and str (find-entry (parse-integer str))))))
      (if (not entry)
          (format (request-stream request)
                  "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>
<response>
<error>1</error>
<message>The specified blog entry could not be found.</message>
</response>
")
          (if (string-equal title blog-name)
              ;; hackish antispam
              (signal 'http-not-found)
              (let ((trackback (make-instance 'trackback
                                              :number (incf *trackback-counter*)
                                              :title title :url url
                                              :excerpt excerpt :time (get-universal-time)
                                              :blog-name blog-name)))
                (setf (blog-entry-trackbacks entry)
                      (nconc (blog-entry-trackbacks entry) (list trackback)))
                (register-instance trackback)
                (serialize-instance entry)
                (format (request-stream request)
                        "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>
<response>
<error>0</error>
</response>
"))))
          t)))

(defmethod handle-request-response ((handler display-entry-handler) method request)
  (let ((entry 
         (let ((str (elt (nth-value 1 (cl-ppcre:scan-to-strings
                                       "^([\\d\\w_-]+)$" (request-unhandled-part request))) 0)))
           (and str (find-permalink str)))))
    
    (blog-wrap-page
     request
     (blog-entry-title entry)
     (list* (format-entry entry)
            (<div class='trackback'>
                  "Trackback pings for this entry are listed below. The URL to ping for this entry is: "
                  (<b> (entry-trackback entry)))
            (mapcar #'format-trackback (blog-entry-trackbacks entry))))))

(defmethod handle-request-response ((handler admin-handler) (method (eql :get)) request)
  
  (blog-wrap-page
   request
   "Administrate"
   (list
    (<h1> "Administrate!")
    <p/>
    "Use this button to reload the configuration for this
     blog and reinstall all templates and pages. Note that
     changes to the URL which the blog is running on will not
     take effect now."
    (form-html (reload-configuration *admin-url*))
    (<h2> "Add a user")
    (form-html ((user :create) *admin-url* :submit-text :add-user))
    (<h2> "Edit a user")
    (<ul>
     (loop for user in *users*
        unless (typep user 'administrator)
        collect
          (<li> (<a href=?(form-get-url ((user :select) *edit-user-url*)
                            (user user))>
                            (user-display-name user))))))))

(defmethod handle-request-response ((handler admin-handler) (method (eql :post)) request)
  (submit-ecase request
      (:reload-configuration
       (reload-everything)
       (blog-wrap-page
        request
        "It's been done."
        (list (<h1> "It's been done.")
              (<a href=?(urlstring (request-url request))>
                  "Return to the administration page."))))
      (:add-user
       (with-processed-form
           (user :create) request
           :error
           (blog-wrap-page
            request
            "Error"
            (resubmit-form (request-url request) :submit-text :add-user))
           :success
           (let ((new-user
                  (make-instance 'user
                                 :name name
                                 :display-name display-name
                                 :link link
                                 :description description
                                 :password (coerce (md5sum-sequence password) 'list))))
             (register-instance new-user)
             (blog-wrap-page
              request
              "It's been done."
              (list
               (<h1> "It's been done.")
               (<a href=?(urlstring (request-url request))>
                   "Return to the administration page."))))))))

(defmethod handle-request-response ((handler edit-user-handler) (method (eql :get)) request)
  (with-processed-form
      (user :hidden-select) request
      :method :get
      :error
      (blog-wrap-page
       request
       "Error"
       (<h1> "I don't know what you did, but you sure messed up good."))
      :success
      (blog-wrap-page
       request
       "Edit Account"
       (list
        (<h1> "Edit Account")
        (<p> "Note: You must fill in all fields, except for the password, which if left blank won't change.")
        (form-html ((user :edit) *edit-user-url* :submit-text :change-settings :gate-fields user)
          (user user))
        (when (typep *authenticated-user* 'administrator)
          (list
           (<p> "Use this button to disable or enable this user.")
           (form-html ((user :hidden-select) *edit-user-url*
                       :submit-text
                       (if (user-disabled-p user)
                           :enable-user
                           :disable-user))
             (user user))))))))

(defmethod handle-request-response ((handler edit-user-handler) (method (eql :post)) request)
  (submit-ecase request
    (:change-settings
     (with-processed-form
         (user :edit) request
         :error
         (blog-wrap-page
          request
          "Error"
          (resubmit-form *edit-user-url* :submit-text :change-settings))
         :success
         (progn
           (setf (user-display-name user) display-name)
           (setf (user-link user) link)
           (setf (user-description user) description)
           (if (> (length password) 0)
               (setf (user-password user)
                     (coerce (md5sum-sequence password) 'list)))
           (serialize-instance user)
           (blog-wrap-page
            request
            "It's been done."
            (list
             (<h1> "It's been done.")
             (<a href=? (urlstring (request-url request))>
                 "Return to the settings page."))))))
    ((:disable-user :enable-user)
     (with-processed-form
         (user :hidden-select :administrator-required) request
         :error
         (blog-wrap-page
          request
          "Error"
          (<h1> "I don't know what you did, but you sure did something wrong."))
         :success
         (progn
           (setf (user-disabled-p user)
                 (not (user-disabled-p user)))
           (serialize-instance user)
           (blog-wrap-page
            request
            "It's been done."
            (list
             (<h1> "It's been done.")
              (<a href=?(urlstring *admin-url*)>
                  "Return to the settings page."))))))))
        
(defclass email-redirect-handler (handler) ())

(defmethod handle-request-response ((handler email-redirect-handler) method request)
  (let* ((user-to-email (car (url-query-param (request-url request) "user")))
         (link (if user-to-email
                   (and (find-user user-to-email)
                        (user-link (find-user user-to-email))))))
    (let ((email-url (or link (concatenate 'string "mailto:" *owner-email*))))
      (request-send-headers
       request
       :location email-url
       :expires "Fri, 30 Oct 1998 14:19:41 GMT"
       :pragma "no-cache"
       :response-code 302 :response-text "Redirected")
      (xml-output-to-stream
       (request-stream request)
       (<html> (<body> (<h1> "Redirected"))))
      t)))

(defun reinstall-templated-pages ()
  (loop for (template-handler-name . values) in
       (cdr (configuration-value *blog-configuration* :pages))
     for url = (urlstring
                (merge-url *blog-url-root*
                           (configuration-value *blog-configuration*
                                                :url template-handler-name :pages)))
       for template-file = (merge-pathnames
                            (configuration-value *blog-configuration*
                                                 :template template-handler-name :pages)
                            *blog-pathname-root*)
       do (format t "installing template ~A at ~A~%" template-file url)
     do (install-handler
         (http-listener-handler *listener*)
         (make-instance 'template-generated-handler
                        :template-file template-file
                        :template-install-time (get-universal-time)
                        :template
                        (parse-xml-from-file template-file))
         url
         (eql (configuration-value *blog-configuration*
                                   :exact-match template-handler-name :pages) :false))))

(defun reinstall-static-areas ()
  (loop for (static-area-name . values) in
       (cdr (configuration-value *blog-configuration* :static-areas))
     for url = (urlstring
                (merge-url *blog-url-root*
                           (configuration-value *blog-configuration*
                                                :url-root static-area-name :static-areas)))
     for file-root = (merge-pathnames
                      (configuration-value *blog-configuration*
                                           :file-root static-area-name :static-areas)
                      *blog-pathname-root*)
     do (format t "installing static files ~A at ~A~%" file-root url)
     do (install-handler
         (http-listener-handler *listener*)
         (make-instance 'static-file-handler :pathname file-root)
         url
         nil)))

(defun reinstall-handlers ()
  (install-handler (http-listener-handler *listener*)
                   (make-instance 'new-entry-handler)
                   (urlstring *new-entry-url*) t)

  (install-handler (http-listener-handler *listener*)
                   (make-instance 'display-entry-handler)
                   (urlstring *display-entry-url*) nil)

  (install-handler (http-listener-handler *listener*)
                   (make-instance 'archives-handler)
                   (urlstring *archives-url*) nil)

  (install-handler (http-listener-handler *listener*)
                   (make-instance 'rss-handler)
                   (urlstring *rss-url*) nil)

  (install-handler (http-listener-handler *listener*)
                   (make-instance 'edit-entry-handler)
                   (urlstring *edit-entry-url*) nil)

  (install-handler (http-listener-handler *listener*)
                   (make-instance 'delete-entry-handler)
                   (urlstring *delete-entry-url*) nil)

  (install-handler (http-listener-handler *listener*)
                   (make-instance 'email-redirect-handler)
                   (urlstring *email-redirect-url*) nil)

  (install-handler (http-listener-handler *listener*)
                   (make-instance 'trackback-handler)
                   (urlstring *trackback-url*) nil)

  (install-handler (http-listener-handler *listener*)
                   (make-instance 'login-handler)
                   (urlstring *login-url*) t)

  (install-handler (http-listener-handler *listener*)
                   (make-instance 'logout-handler)
                   (urlstring *logout-url*) t)

  (install-handler (http-listener-handler *listener*)
                   (make-instance 'admin-handler)
                   (urlstring *admin-url*) t)

  (install-handler (http-listener-handler *listener*)
                   (make-instance 'edit-user-handler)
                   (urlstring *edit-user-url*) nil))

(defun reinstall-all-pages ()
  (reinstall-templated-pages)
  (reinstall-static-areas)
  (reinstall-handlers))

(reinstall-all-pages)

(defun reload-everything ()
  (reload-configuration-variables)
  (reinstall-all-pages))
