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

(in-package :kira)

(define-persistent-class post ()
  ((canonical-name :initform nil :accessor canonical-name)
   (canonical-path :allocation :instance :reader canonical-path)
   (posted-time :initform (get-local-time) :reader posted-time)
   (edited-time :initform :unspecific :accessor edited-time)
   (author :initform nil :accessor author :initarg :author)
   (title :initform nil :accessor title :initarg :title)
   (body :initform nil :accessor body :initarg :body)
   (session :initform *session* :accessor session)
   (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))))

(defun legal-canonical-name-p (canonical-name)
  (or (some #'alpha-char-p canonical-name)
      (eq canonical-name nil)))

(defmethod (setf canonical-name) :around (canonical-name (post post))
  (assert (legal-canonical-name-p canonical-name) (canonical-name))
  (whereas ((object (and canonical-name (uri-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)

(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 :around ((session session))
    (let ((log (session-log session)))
      (cond ((endp log) (call-next-method))
            (t (render-log log))))))

(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)))))))))

(defmethod render-content ((handler (eql 'contact)))
  (let ((pt-offset (format nil "(UTC−~D:00)" (nth-value 8 (get-decoded-time)))))
    (html (:table-form (:tr (:th "Email/Addr") (:td (link "mailto:info@cl-pdx.com")))
                       (:tr (:th "BTC/Addr") (:td (link "bitcoin:368YNSt3gLLT7KWBmSrwzkrGUVunLFKqwD")))
                       (:tr (:th "Lat/Long") (:td "45°30'42.8\"N 122°31'14.1\"W"))
                       (:tr (:th "LT/Zone") (:td "Pacific Time Zone " pt-offset))))))

(defmethod canonical-path ((pathname pathname))
  (unless (member pathname (get 'system 'kira-source-files))
    (return-from canonical-path (call-next-method)))
  (format nil "/kira/~A" (file-namestring pathname)))

(defmacro print-code-extent (&optional safep)
  (cond ((not safep) `(escape-html lexer-string nil :start start :end lexer-position))
        (t `(write-string lexer-string html-output :start start :end lexer-position))))

(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)))))))

(defmacro %global-definer-p (symbol)
  `(case ,symbol ((:accessor defclass defconstant defgeneric
                   define-modify-macro define-persistent-class
                   define-setf-expander define-symbol-macro
                   defmacro defpackage defparameter defsetf
                   defstatic defstaticvar defstruct deftype
                   defun defvar :reader) 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 80 '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-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 ()
  ((pathname :initform nil :accessor file-name :initarg :pathname)
   (session :initform *session* :accessor session :initarg :session)
   (canonical-path :allocation :instance :initarg :canonical-path :accessor canonical-path)
   (upload-time :initform (get-local-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 (and *request* (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)))
  (with-accessors ((authorization-time authorization-time)) *session*
    (let ((return-to (or (parameter :return-to nil #'resolve-uri) *base-uri*)))
      (if (eql (parameter 'password nil #'digest) (get 'system 'password-digest))
          (progn (setq authorization-time (get-local-time)) (redirect return-to))
          (redirect return-to)))))

(defun session-entry-of-type (type-specifier &optional (session *session*))
  (let ((log (if session (session-log session) (return-from session-entry-of-type))))
    (loop for object in log when (typep object type-specifier) return object)))

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

(defun match-upload (upload-info &rest objects)
  (loop with (filename . temporary-name) = upload-info
        for object in objects if (typep object 'file)
        do (whereas ((existing-name (file-name object)))
             (when (equal filename (file-namestring existing-name))
               (when (files-equal existing-name temporary-name)
                 (return-from match-upload object))))))

(defmethod handle ((handler (eql 'home)) &aux (info (parameter "uploaded-file")))
  (destructuring-bind (filename . temporary-name) (or info (return-from handle))
    (unless (match-upload info (session-entry-of-type 'file) (car (get-root 'log)))
      (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))))))

(defun can-edit-p (object &optional (session *session*))
  (with-accessors ((authorization-time authorization-time)) session
    (let ((object-owner (when (typep object 'post) (session object))))
      (and session (or (eq object-owner 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")))))))

(defmethod handle ((handler (eql 'post)))
  (let ((post (session-entry-of-type 'post))
        (body-submission (parameter 'body)))
    (unless (and post (equal (body post) body-submission))
      (write-post (setq post (make-instance 'post)))
      (progn (push-to-log post) (cache-xml 'rss)))
    (redirect post)))

(defun write-post (post)
  (with-accessors ((name session-name)) *session*
    (let ((edit-input (capture-input)) (author (author post)))
      (with-accessors ((input-time input-time)) edit-input
        (unless (and name (equal author (parameter 'author)))
          (setq name (parameter 'author)))
        (prog1 post
          (push edit-input (history post))
          (setf (author post) (parameter 'author)
                (title post) (parameter 'title)
                (body post) (parameter 'body)
                (edited-time post) input-time))))))

(defmethod (setf title) :after (title (post post))
  (let ((canonical-name (nstring-downcase (collapse (or title "")))) object object-name)
    (setf (canonical-name post) (cond ((not (legal-canonical-name-p canonical-name)) nil)
                                      ((eq (setq object (uri-object canonical-name)) post) canonical-name)
                                      ((eq (setq object-name (canonical-name object)) :unspecific) nil)
                                      ((not (equalp object-name canonical-name)) 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 #'uri-object)))
    (authorize-if-not (setq can-edit-p (can-edit-p post)))
    (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 #'uri-object)))
    (redirect (if (can-edit-p post)
                  (write-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)))))

(defmethod render-content ((handler (eql 'history)))
  (loop with post = (parameter 'post t #'uri-object) for (new old . more) on (history post)
        do (html (:let ((uri (uri-to 'diff :post post :old (or old (loop-finish)) :new new)))
                   ((:a :href uri) (render-local-time (input-time new))) (:when more (:br))))))

(defmethod body ((input input))
  (with-accessors ((parameters parameters)) input
    (cdr (assoc 'body parameters :test #'string-equal))))

(defmethod render-content ((handler (eql 'diff)))
  (html (:let ((post (parameter 'post t #'uri-object))
               (old (parameter "old" t #'uri-object))
               (new (parameter "new" t #'uri-object)))
          ((:ul :class "diff-header")
           (:li (:em "post: ") (render-link post))
           (:li (:em "old: ") (render-local-time (input-time old)))
           (:li (:em "new: ") (render-local-time (input-time new))))
          ((:pre :class "diff") (render-diff (body new) (body old))))))

(defmethod render-content :around ((handler (eql 'system)))
  (authorize-if-not (and *session* (authorization-time *session*)))
  (with-accessors ((last-object-id last-object-id)) *object-database*
    (html ((:div :class "box") (loop with print-br-p = nil
                                     for object-id downfrom last-object-id downto 1
                                     repeat (or (parameter 'max nil #'parse-integer) 20)
                                     do (html (:if print-br-p (:br) (setq print-br-p t))
                                              (render-link (get-object object-id))))))))

(defun render-value (object)
  (cond ((typep object 'object)
         (render-link object))
        ((local-time-p object)
         (render-local-time object))
        ((html (:code (:prin1 object))))))

(defmethod render-content ((object object))
  (html (:dl (loop for slot-name in (object-slots object)
                   for value = (persistent-slot-value object slot-name)
                   when value do (html (:dt (:string (string slot-name)))
                                       (:dd (render-value value)))))))

(defgeneric render-xml (object)
  (:method :before ((object t))
    (html +canonical-xml-declaration+))
  (:method ((symbol (eql 'rss)))
    (let ((title (title 'home)))
          ("rss" "version" "2.0"
           "xmlns:dc" "http://purl.org/dc/elements/1.1/"
           "xmlns:atom" "http://www.w3.org/2005/Atom")
        (with-xml-element "channel"
               "href" (:princ (resolve-uri "/rss.xml"))
               "rel" "self" "type" "application/rss+xml"))
          (with-xml-element "generator" "Kira")
          (with-xml-element "link" *base-uri*)
          (with-xml-element "title" title)
          (with-xml-element "description" "Posts and uploads via " title #\.)
          (with-xml-element "pubDate" (822-time *html-output* (get-local-time)))
          (loop for object in (get-root 'log) as uri = (absolute-uri-to object)
                do (with-xml-element "item"
                     (with-xml-element "link" uri) (with-xml-element "title" (render-title object))
                     (with-xml-element "description" (:cdata ((:a :href uri) (render-title object))))
                     (with-xml-element "guid" *base-uri* (princ (object-id object) *html-output*))
                     (with-xml-element "pubDate" (822-time *html-output* (posted-time object)))
                     (with-xml-element "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)))
  (with-xml-element ("urlset" "xmlns" "http://www.sitemaps.org/schemas/sitemap/0.9")
    (dolist (object (load-time-value `(home kira ,@(get 'system 'kira-source-files))))
      (with-xml-element "url" (with-xml-element "loc" (absolute-uri-to object))))))

(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 ""
                      :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))))