;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: kira; Coding: utf-8 -*-
;;;; Copyright © 2024 David Mullen. All Rights Reserved. Origin: <https://cl-pdx.com/kira/>

(in-package :kira)

(define-persistent-class content-mixin ()
  ((author :initform nil :accessor author :initarg :author)
   (title :initform nil :accessor title :initarg :title)
   (body :initform nil :accessor body :initarg :body))
  (:default-initargs
    :author (parameter 'author)
    :title (parameter 'title)
    :body (parameter 'body)))

(define-persistent-class message (input-mixin content-mixin)
  ((posted-time :reader posted-time :initform *response-time*)))

(define-persistent-class post (input-mixin content-mixin)
  ((canonical-name :initform nil :accessor canonical-name)
   (canonical-path :allocation :instance :reader canonical-path)
   (posted-time :initform *response-time* :reader posted-time)
   (edited-time :initarg :edited-time :accessor edited-time)
   (history :initform nil :accessor history)))

(defmethod slot-unbound ((class t) (post post) (slot-name (eql 'canonical-path)))
  (symbol-macrolet ((path-segment (or (canonical-name post) (object-id post))))
    (setf (slot-value post 'canonical-path) (format nil "/~A" path-segment))))

(defmethod (setf canonical-name) :around (canonical-name (post post))
  (unless (or (some #'alpha-char-p canonical-name) (not canonical-name))
    (error "Canonical name for ~S not valid: ~S." post canonical-name))
  (whereas ((object (and canonical-name (find-object canonical-name))))
    (when (and (typep object 'post) (not (eq object post)))
      (when (equalp (canonical-name object) canonical-name)
        (setf (canonical-name object) nil))))
  (symbol-macrolet ((pages (get-root 'pages)))
    (when (setq canonical-name (call-next-method))
      (setf (get-term canonical-name pages) post))
    (slot-makunbound post 'canonical-path)
    canonical-name))

(defgeneric render-content (object)
  (:method :around ((object-wrapped-in-box t))
    (html ((:div :class "box") (call-next-method))))
  (:method ((no-view t)) (respond-with :not-found))
  (:method ((handler (eql 'redirect)))
    (redirect (parameter 'uri t #'uri)))
  (:method :around ((session session))
    (let ((session-log (session-log session)))
      (cond (session-log (render-log session-log))
            (t (html ((:div :class "box")
                      (:let ((expiration-time (expiration-time session)))
                        (:pl (:pr :ip-address (:ip-address (ip-address session)))
                             (:pr :expiration-time (render-local-time expiration-time))
                             (:let ((authorization-time (authorization-time session)))
                               (:pr :authorization-time (:if authorization-time
                                                             (render-local-time authorization-time)
                                                             (:em "session not authorized")))))))))))))

(define-html-macro :with-header (logo-element-content . menu-items)
  (let ((home-page-link `((:a :href "/") ,logo-element-content)))
    `((:div :id "header") (:div ((:h1 :id "logo") ,home-page-link)
                                ((:div :id "menu") ,@menu-items)))))

(define-html-macro :powered-by (&rest link-specifier)
  `(:progn "Powered by " (render-link ,@link-specifier)))

(defun system-request-p (request &aux (uri (request-uri request)))
  (or (uri-query uri) (equal (cadr (uri-segments uri)) "system")))

(defun render-page (object)
  (html ((:html-page :lang "en-US")
         ((:progn ((:meta :charset :utf-8)) ((:link :rel "shortcut icon" :href "/favicon.ico")))
          ((:link :rel "stylesheet" :href (:princ (versioned-uri "kira:www;static;style.css"))))
          ((:link :rel "alternate" :href "/rss.xml" :title "RSS" :type "application/rss+xml"))
          (:when (system-request-p *request*) ((:meta :name "robots" :content "noindex")))
          ((:meta :name "viewport" :content "width=device-width, initial-scale=1"))
          (:title (render-title object) (:unless (eq object 'home) " | CL-PDX")))
         (:if (typep object 'pathname)
              ((:body :class "code")
               (:pre (hilite object)))
              (:body ((:div :id "frame")
                      (:with-header (:b ((:span :id "site-title") "CL-PDX"))
                        (render-link 'post) " | " (render-link 'contact))
                      ((:div :id "content") (render-content object))
                      ((:div :id "footer") (:div (:powered-by 'kira)))))))))

(define-html-macro :pacific-time-zone (&optional (local-time '(get-local-time)))
  `(:let ((hours-west (- (/ (local-time-zone (get-localized-time ,local-time)) 3600))))
     "Pacific " (:if (= hours-west 7) "Daylight" "Standard") " Time (UTC−0" hours-west
     ":00)"))

(define-html-macro :sent-at (message)
  `(:let ((message-time (posted-time ,message)))
     (:mark (render-local-time message-time))))

(defmethod render-content ((handler (eql 'contact)))
  (let ((message (parameter 'message nil #'find-object)))
    (html (:table-form (:tr (:th "Mail/To") (:td (link "mailto:info@cl-pdx.com")))
                       (:tr (:th "BTC/Addr") (:td (link "bitcoin:368YNSt3gLLT7KWBmSrwzkrGUVunLFKqwD")))
                       (:tr (:th "USDC/Addr") (:td (:code "0x6EE5ab6Df565bcC7E7f35a49d8Ef76b524a84Bf8")))
                       (:tr (:th "LT/Zone") (:td (:pacific-time-zone *response-time*)))
                       (:when message (:tr (:th "Sent/At") (:td (:sent-at message))))
                       (:tr ((:td :colspan 2) ((:textarea :name 'body :rows 10 :cols 80))))
                       (:tr ((:td :colspan 2) ((:input :type :submit :value "Send Message"))))))))

(defmethod handle ((handler (eql 'contact)))
  (redirect 'contact :message (when (parameter 'body)
                                (let ((message (make-instance 'message)))
                                  (prog1 message (push-to-inbox message))))))

(defmethod canonical-path ((pathname pathname))
  (let ((kira-source-files (get 'system 'kira-source-files)))
    (if (member pathname kira-source-files :test #'equal)
        (format nil "/kira/~A" (file-namestring pathname))
        (call-next-method))))

(defmacro print-code-extent (&optional safe)
  (let ((extent-arguments '(:start start :end lexer-position)))
    `(,(if safe 'write-string 'escape-html) lexer-string
      ,(if safe 'html-output nil) ,@extent-arguments)))

(defmacro %read-token (buffer package)
  (with-gensyms (multiple-escape-p char)
    `(loop initially (reset-buffer ,buffer) with ,char and ,multiple-escape-p
           initially (setq ,package (if (lexer-match #\:) keyword-package kira-package))
           if (lexer-match #\|) do (setq ,multiple-escape-p (not ,multiple-escape-p))
           else do (unless (setq ,char (and (or (lexer-match #\\) ,multiple-escape-p) (lexer-match t)))
                     (lexer-case (c) ((or alphanumeric ":$%&*_-=@+<>.!/?~") (setq ,char (char-upcase c)))))
                   (vector-push-extend (or ,char (return (and (> lexer-position start) ,buffer))) ,buffer))))

(defun symbol-id (symbol)
  (orf (get symbol 'id)
       (with-output-to-string (stream)
         (write-string "kira." stream)
         (with-lexer ((prin1-to-string symbol))
           (loop (lexer-case (char (return))
                   ((or #\- #\_ #\. digit) (write-char char stream))
                   (alpha (write-char (char-downcase char) stream))
                   (t (format stream ".~2,'0X" (char-code char)))))))))

(defun source-note-pathname (source-note)
  (symbol-macrolet ((files (get 'system 'kira-source-files)))
    (let ((key (pathname-name (source-note-filename source-note))))
      (find key files :key #'pathname-name :test #'string-equal))))

(defun symbol-uri (symbol)
  (orf (get symbol 'uri)
       (whereas ((source-note (cadar (find-definition-sources symbol))))
         (whereas ((source-note-pathname (source-note-pathname source-note)))
           (uri-string (make-uri :path (canonical-path source-note-pathname)
                                 :fragment (symbol-id symbol)))))))

(defun %global-definer-p (symbol)
  (case symbol ((define-persistent-class
                 defclass :accessor :reader
                 defvar defparameter defconstant
                 defsetf define-setf-expander
                 defstruct deftype defmacro
                 defun defgeneric defpackage
                 define-symbol-macro
                 define-modify-macro
                 defstaticvar
                 defstatic) t)))

(define-html-macro :kira (class symbol-id symbol-uri)
  `(:if (or ,symbol-id (not (setq ,symbol-uri (symbol-uri symbol))))
        ((:span :class ,class :if* ,symbol-id :id ,symbol-id) (print-code-extent))
        ((:a :class ,class :href (:string ,symbol-uri)) (print-code-extent))))

(defun hilite (pathname)
  (with-lexer ((file-string pathname))
    (loop with html-output = *html-output*
          with token-buffer = (make-buffer 40 'character)
          with kira-package = (load-time-package :kira)
          with keyword-package = (load-time-package :keyword)
          with pending-definition-p and package and symbol-uri
          for start of-type array-index = lexer-position
          for symbol-id = nil
          do (cond ((%read-token token-buffer package)
                    (multiple-value-bind (symbol status)
                        (find-symbol token-buffer package)
                      (cond (pending-definition-p
                             (setq pending-definition-p nil symbol-id (symbol-id symbol)))
                            ((%global-definer-p symbol) (setq pending-definition-p t)))
                      ;; SYMBOL-ID is set if this symbol is the name for a definition.
                      (cond ((not status) (html ((:span :class "low-level") (print-code-extent))))
                            ((keywordp symbol) (html (:kira "keyword" symbol-id symbol-uri)))
                            ((eq (symbol-package symbol) (load-time-package :common-lisp))
                             (html ((:span :class "cl") (print-code-extent))))
                            ((eq (symbol-package symbol) kira-package)
                             (case (schar lexer-string start)
                               (#\% (html (:kira "low-level" symbol-id symbol-uri)))
                               (otherwise (html (:kira "kira" symbol-id symbol-uri)))))
                            ((html ((:span :class "ccl") (print-code-extent)))))))
                   ((when (lexer-match #\;) (lexer-skip (not #\Newline)))
                    (html ((:span :class "comment") (print-code-extent))))
                   ((whereas ((macro-char (lexer-match #\# "\\_$&>")))
                      (decf lexer-position) (%read-token token-buffer package)
                      (let ((class (case macro-char (#\\ "character") (t "c"))))
                        (html ((:span :class (:string class)) (print-code-extent))))))
                   ((lexer-match #\")
                    (loop while (lexer-case (c) (#\\ (lexer-match t)) (#\") (t t))
                          finally (html ((:span :class "string") (print-code-extent)))))
                   ;; Other macro characters.
                   ((html (lexer-skip "'`,.@")
                          (lexer-advance-if
                           (lexer-match #\#)
                           (lexer-skip digit)
                           (lexer-match (not "()[]{}<>&")))
                          (:if (> lexer-position start)
                               ((:span :class "quote") (print-code-extent t))
                               (progn (when (or (lexer-match t) (loop-finish))
                                        (lexer-skip (or whitespace "()[]{}")))
                                      (print-code-extent t)))))))))

(defmethod render-content ((handler (eql 'kira)))
  (loop for (pathname . more) on (get 'system 'kira-source-files)
        do (html (render-link pathname) (:when more (:br)))))

(define-persistent-class file (input-mixin)
  ((pathname :initform nil :accessor file-name :initarg :pathname)
   (canonical-path :allocation :instance :initarg :canonical-path :accessor canonical-path)
   (upload-time :initform *response-time* :accessor upload-time :accessor posted-time)))

(defmethod slot-unbound ((class t) (file file) (slot-name (eql 'canonical-path)))
  (setf (canonical-path file) (uri-path (pathname-uri (file-name file)))))

(defun render-title (object &aux (title (title object)))
  (when title (return-from render-title (html (:attribute title))))
  (let ((object-id (when (typep object 'object) (object-id object))))
    (format *html-output* "~(~A~)~@[:~D~]" (type-of object) object-id)))

(defgeneric title (object)
  (:method ((symbol symbol))
    (with-accessors ((capitalized-name string-capitalize)) symbol
      (orf (get symbol 'title) (substitute #\Space #\- capitalized-name))))
  (:method (object) (unless (typep object 'object) object))
  (:method ((pathname pathname)) (file-namestring pathname))
  (:method ((file file)) (file-namestring (file-name file))))

(defun render-link (object &rest parameters)
  (let ((canonical-uri (apply #'uri-to object parameters)))
    (with-accessors ((request-uri request-uri)) *request*
      (html (:if (uri= request-uri canonical-uri)
                 ((:span :class "non-link") (render-title object))
                 ((:a :href canonical-uri) (render-title object)))))))

(defgeneric get-inferior-object (name superior-object)
  (:method ((no-object-found t) (object t)) nil)
  (:method (segment (superior-object (eql 'home)) &aux potential-object-id)
    (cond ((setq potential-object-id (ignore-errors (parse-integer segment)))
           (when (plusp potential-object-id) (get-object potential-object-id)))
          ((find segment '(kira system contact) :test #'string-equal))
          ((get-term segment (get-root 'pages))))))

(defmethod get-inferior-object (handler-name (dispatcher (eql 'system)))
  (find-symbol (string-upcase handler-name) (load-time-package :kira)))

(defmethod get-inferior-object (segment (parent (eql 'kira)))
  (let ((pathname (pathname (format nil "kira:code;~(~A~)" segment))))
    (find pathname (get 'system 'kira-source-files) :test #'equal)))

(defun render-local-time (local-time &aux (localized-time (get-localized-time local-time)))
  (html ((:time :datetime localized-time) (print-local-time localized-time *html-output*))))

(defmethod render-content ((handler (eql 'home)))
  (html (:standard-form (:p ((:input :type 'file :name "uploaded-file")))
                        (:p ((:input :type :submit :value "Upload"))))))

(defmethod render-content :around ((handler (eql 'home)))
  (html (call-next-method) (render-log (get-root 'log))))

(defun render-log (log-entries)
  (dolist (object log-entries)
    (html ((:div :class "box")
           (:let ((action (if (typep object 'file) "uploaded" "posted")))
             (render-link object) (:br) (render-local-time (posted-time object)) (:br)
             ((:small :class "by") (:string action) " by " (render-link (session object))))))))

(defun authorize-if-not (allowed-test)
  (when allowed-test (return-from authorize-if-not))
  (when (eq (request-method *request*) :post)
    (respond-with :authorized-personnel-only))
  (with-accessors ((return-to request-uri)) *request*
    (let ((uri (uri-to 'authorize :return-to return-to)))
      (html ((:div :class "box" :id "authorize")
             ((:standard-form :action uri)
              (:p (:strong "*** PASSWORD REQUIRED ***"))
              (:p ((:input :type :password :name :password :size 20))
                  " &nbsp; " ((:input :type :submit :value "Authorize")))))))))

(defmethod handle ((handler (eql 'authorize)))
  (let ((return-to (or (parameter :return-to nil #'resolve-uri) *base-uri*)))
    (when (eql (parameter "password" nil #'digest) (get 'system 'password-digest))
      (setf (authorization-time *session*) *response-time*))
    (redirect return-to)))

(defun push-to-log (object)
  (with-accessors ((session-log session-log)) (session object)
    (progn (push object (get-root 'log)) (push object session-log))))

(defun log-entry-of-type (type-specifier)
  (loop for object in (get-root 'log)
        when (typep object type-specifier)
        return object))

(defun duplicate-upload-p (filename temporary-name)
  (whereas ((existing-file (log-entry-of-type 'file) file))
    (and (equal filename (file-namestring (file-name existing-file)))
         (files-equal temporary-name (file-name existing-file)))))

(defun push-to-inbox (object)
  (push object (get-root 'inbox)))

(defmethod handle ((handler (eql 'home)))
  (whereas ((uploaded-file (parameter "uploaded-file")))
    (destructuring-bind (filename . temporary-name) uploaded-file
      (when (duplicate-upload-p filename temporary-name) (return-from handle))
      (let* ((namestring (concatenate 'simple-string "kira:www;static;" filename))
             (uploaded-file (make-instance 'file :pathname (pathname namestring)))
             (file-type (pathname-type filename)))
        (with-accessors ((uploaded-file-id object-id)) uploaded-file
          (unless (and file-type (rename-file temporary-name namestring :if-exists nil))
            (setq namestring (format nil "kira:www;static;~D;~A" uploaded-file-id filename))
            (ensure-directories-exist (setf (file-name uploaded-file) (pathname namestring)))
            (rename-file temporary-name (typed-pathname namestring) :if-exists :supersede))
          (push-to-log uploaded-file)
          (push-to-inbox uploaded-file))))))

(defun can-edit-p (object &optional (session *session*))
  (unless (typep object 'post) (return-from can-edit-p))
  (with-accessors ((authorization-time authorization-time)) session
    (and session (or (eq (session object) session) authorization-time))))

(define-html-macro :text-field (value can-edit-p name &rest attributes)
  `((:input :type :text :name ,name :if* ,value :value ,value ,@attributes
            :if* (not ,can-edit-p) :readonly :||)))

(defun render-textarea (text-designator &key (name 'body) (rows 10) (cols 80) can-edit-p)
  (html ((:textarea :name name :rows rows :cols cols :if* (not can-edit-p) :readonly :||)
         (:when text-designator text-designator))))

(defmethod render-content ((handler (eql 'post)))
  (html (:table-form (:tr (:th "Author") (:td (:text-field nil t 'author)))
                     (:tr (:th "Title") (:td (:text-field nil t 'title)))
                     (:tr ((:td :colspan 2) (render-textarea nil :can-edit-p t)))
                     (:tr ((:td :colspan 2) ((:input :type :submit :value "Post")))))))

(defun duplicate-content-p (content)
  (and (equal (parameter 'author) (author content))
       (equal (parameter 'title) (title content))
       (equal (parameter 'body) (body content))))

(defmethod handle ((handler (eql 'post)))
  (redirect (or (whereas ((post (log-entry-of-type 'post)))
                  (when (duplicate-content-p post) post))
                (first (push-to-log (write-post))))))

(define-persistent-class revision (input-mixin content-mixin)
  ((posted-time :reader posted-time :initform *response-time*)))

(defun write-post (&optional (post (make-instance 'post)))
  (whereas ((author (parameter 'author)) (session *session*))
    (with-accessors ((session-name session-name)) session
      (unless (and (equal author (author post)) session-name)
        (setq session-name author))))
  (with-accessors ((history history)) post
    (setf (edited-time post) *response-time*)
    (let ((revision (make-instance 'revision)))
      (setf (author post) (author revision))
      (setf (title post) (title revision))
      (setf (body post) (body revision))
      (push-to-inbox revision)
      (push revision history)
      post)))

(defmethod (setf title) :after (title (post post))
  (let ((canonical-name (nstring-downcase (collapse (or title "")))))
    (setf (canonical-name post) (when (some #'alpha-char-p canonical-name)
                                  (let* ((object (find-object canonical-name))
                                         (object-name (when (typep object 'post)
                                                        (canonical-name object))))
                                    ;; Ensure uniqueness of the CANONICAL-NAME.
                                    (let ((name-taken-p (equalp object-name canonical-name)))
                                      (when (or (not name-taken-p) (eq object post))
                                        canonical-name)))))))

(define-html-macro :save-button (&rest attributes &key (can-edit-p nil) &allow-other-keys)
  `((:input :type :submit :if* (not ,can-edit-p) :disabled :|| ,@(sans attributes :can-edit-p))))

(defmethod render-content :around ((handler (eql 'edit)))
  (let (can-edit-p (post (parameter 'post t #'find-object)))
    (authorize-if-not (setq can-edit-p (can-edit-p post)))
    (unless (typep post 'post) (respond-with :not-found))
    (with-accessors ((title title) (name author)) post
      (html ((:div :class "box")
             (:table-form (:tr (:th "Author") (:td (:text-field name can-edit-p 'author)))
                          (:tr (:th "Title") (:td (:text-field title can-edit-p 'title)))
                          (:tr ((:td :colspan 2) (render-textarea (body post) :can-edit-p can-edit-p)))
                          (:tr ((:td :colspan 2) (:save-button :value "Save" :can-edit-p can-edit-p)))))))))

(defmethod handle ((handler (eql 'edit)))
  (let ((post (parameter 'post t #'find-object)))
    (redirect (if (can-edit-p post)
                  (write-post post)
                  post))))

(defmethod render-content ((post post))
  (let ((edited-time (edited-time post))
        (posted-time (posted-time post)))
    (render-text (body post))
    (html ((:p :class "meta")
           ((:a :href (uri-to post) :class "permalink")
            ((:span :class "permalink-text") "permalink"))
           #\Space (render-link 'edit :post post)
           (:br) "posted " (render-local-time posted-time)
           (:br) "edited " (render-local-time edited-time)))))

(defun render-diff-options (post selected)
  (loop for (new old) on (history post) while old
        do (with-accessors ((time posted-time)) new
             (let ((uri (uri-to 'history :post post :new new :old old)))
               (html ((:option :value uri :if* (eq new selected) :selected :||)
                      (print-local-time (get-localized-time time) *html-output*)))))))

(defmethod render-content :around ((handler (eql 'history)))
  (html (:let ((old (parameter "old" nil #'find-object))
               (new (parameter "new" nil #'find-object))
               (post (parameter 'post t #'find-object)))
          ((:div :class "box")
           ((:standard-form
             :method :get :action (uri-to 'redirect))
            ((:select :name 'uri :class "history")
             (render-diff-options post new))
            "&nbsp; &nbsp;" (:submit "Diff")))
          (:when (and old new)
            ((:div :class "box")
             ((:pre :class "diff")
              (render-diff (body new)
                           (body old))))))))

(defun authorized-session-p (&optional (session *session*))
  (and session (if (authorization-time session) t nil)))

(defmethod render-content :around ((handler (eql 'system)))
  (loop initially (authorize-if-not (authorized-session-p))
        for object in (get-root 'inbox)
        do (html ((:div :class "box")
                  (:pl (do-slots (slot-name slot-value object)
                         (render-slot-value slot-name slot-value)))))))

(defgeneric render-slot-value (slot-name slot-value)
  (:method :around ((slot-name symbol) slot-value)
    (unless (whitespacep slot-value) (call-next-method)))
  (:method (slot-name slot-value)
    (html (:pr slot-name (render-value slot-value))))
  (:method ((slot-name (eql 'ip-address)) ip-address)
    (html (:pr slot-name (:ip-address ip-address)))))

(defun render-value (object)
  (labels ((render-uri (uri)
             (html ((:a :href uri) uri)))
           (render-pathname (pathname)
             (or (whereas ((uri (ignore-errors (pathname-uri pathname))))
                   (let ((file-namestring (file-namestring pathname)))
                     (html ((:a :href uri) file-namestring))))
                 (default-render-value pathname)))
           (default-render-value (object)
             (html (:code (:princ object)))))
    (declare (dynamic-extent #'default-render-value))
    (funcall (typecase object
               (uri #'render-uri)
               (object #'render-link)
               (pathname #'render-pathname)
               (local-time #'render-local-time)
               (otherwise #'default-render-value))
             object)))

(defgeneric render-xml (object)
  (:method :before ((object t))
    (html +canonical-xml-declaration+))
  (:method ((symbol (eql 'rss)))
    (html ((:rss-channel
            :|xmlns:dc| "http://purl.org/dc/elements/1.1/"
            :|xmlns:atom| "http://www.w3.org/2005/Atom")
           ((:|atom:link|
             :href (:princ (resolve-uri "/rss.xml"))
             :rel "self" :type "application/rss+xml"
             :/))
           (:link (absolute-uri-to 'home))
           (:title (:string (title 'home)))
           (:|pubDate| (822-time *html-output* (get-local-time)))
           (:description "Posts and file uploads listed on CL-PDX.")
           (loop with uri and title for object in (get-root 'log)
                 do (html (:item (:link (:princ (setq uri (absolute-uri-to object))))
                                 (:title (:string (setq title (grab (render-title object)))))
                                 (:guid *base-uri* (princ (object-id object) *html-output*))
                                 (:description (:cdata ((:a :href uri) (:string title))))
                                 (:pubDate (822-time *html-output* (posted-time object)))
                                 (:|dc:creator| (render-title (session object))))))))))

(defun cache-xml (symbol &aux (pathname (format nil "kira:www;~(~A~).xml" symbol)))
  (with-open-file (*html-output* pathname :direction :output :if-exists :supersede)
    (render-xml symbol)))

(defmethod render-xml ((symbol (eql 'sitemap)))
  (let ((kira-source-files (get 'system 'kira-source-files)))
    (html ((:urlset :xmlns "http://www.sitemaps.org/schemas/sitemap/0.9")
           (dolist (object `(home kira contact ,@kira-source-files))
             (html (:url (:loc (absolute-uri-to object)))))
           (:url (:loc (:princ (resolve-uri "/comp.lang.lisp/"))))))))

(defstatic *http-process*
  (let ((initial-package (load-time-package :kira)))
    `(:initial-bindings ((*package* . ,initial-package))
      :name "HTTP")))

(defun kill-server (server-process)
  (process-kill server-process)
  (close (make-socket :connect :active
                      :connect-timeout 0.5
                      :remote-host "127.0.0.1"
                      :remote-port 8080)))

(defun start-server (&optional restart-server-p)
  (setq *random-state* (make-random-state t))
  (setq *package* (load-time-value (find-package :kira)))
  (setq *default-external-format* +binary-external-format+)
  (setf *print-length* 1000 (get 'home 'title) "CL-PDX")
  (open-database "kira:data;")
  (let ((server-process (find-process "HTTP")))
    (unless (and server-process (not restart-server-p))
      (when server-process (kill-server server-process))
      (process-run-function *http-process* #'http-serve))))