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

(in-package :kira)

(define-persistent-class post ()
  ((author :reader author :allocation :instance)
   (title :reader title :allocation :instance)
   (body :reader body :allocation :instance)
   (canonical-name :initform nil :accessor canonical-name)
   (canonical-path :allocation :instance :reader canonical-path)
   (posted-time :initform (get-local-time) :reader posted-time)
   (history :initform '() :accessor history :initarg :history)
   (edited-time :reader edited-time :allocation :instance)
   (session :initform *session* :accessor session)))

(define-persistent-class edit ()
  ((post :reader original-post :initarg :post)
   (edit-time :initform (get-local-time) :reader edit-time :reader edited-time)
   (author :initform (parameter 'author) :accessor author :initarg :author)
   (title :initform (parameter 'title) :accessor title :initarg :title)
   (body :initform (parameter 'body) :accessor body :initarg :body)
   (session :initform *session* :reader session)))

(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) :before (canonical-name (post post))
  (unless (or (not canonical-name) (some #'alpha-char-p canonical-name))
    (error "Invalid ~A on ~S: ~S." 'canonical-name post canonical-name))
  (unless canonical-name (return-from canonical-name))
  (whereas ((term (get-term canonical-name (get-root 'pages))))
    (when (string-equal (canonical-name term) canonical-name)
      (unless (eq term post) (setf (canonical-name term) nil)))))

(defmethod (setf canonical-name) :after (name (post post))
  (when name (setf (get-term name (get-root '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 ((punt t)) (throw 'response +not-found+))
  (:method :around ((session session))
    (render-log (session-log session))))

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

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

(defun render-page (object)
  (html ((:html-page :lang "en-US")
         (((: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 (uri-query (request-uri *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"))
                        " | " ((:a :href "mailto:info@cl-pdx.com") "Contact"))
                      ((:div :id "content") (render-content object))
                      ((:div :id "footer") (:div (:powered-by 'kira)))))))))

(defmethod canonical-path ((pathname pathname))
  (unless (member pathname 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)
  (with-gensyms (multiple-escape-p char)
    `(loop initially (reset-buffer ,buffer) with ,char and ,multiple-escape-p
           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 hilite (pathname)
  (with-lexer ((file-string pathname))
    (loop with html-output = *html-output*
          with kira-package = (load-time-package :kira)
          with link and buffer = (make-buffer 80 'character)
          for start of-type array-index = lexer-position
          do (cond ((%read-token buffer)
                    (case (schar lexer-string start)
                      (#\: (html ((:span :class "keyword") (print-code-extent))))
                      (#\% (html ((:span :class "low-level") (print-code-extent))))
                      (t (multiple-value-bind (symbol status) (find-symbol buffer kira-package)
                           (cond ((not status) (html ((:span :class "low-level") (print-code-extent))))
                                 ((setq link (get symbol 'system:link)) (write-string link html-output))
                                 ((eq (symbol-package symbol) kira-package)
                                  (html ((:span :class "kira") (print-code-extent))))
                                 ((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 #\# "\\_$&>")))
                      (progn (decf lexer-position) (%read-token buffer))
                      (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 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)))
    (html (:if (uri= (request-uri *request*) 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) :test #'string-equal))
          ((get-term segment (get-root 'pages))))))

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

(defmethod get-inferior-object (segment (parent (eql 'kira)) &aux (directory system:+kira-source-files+))
  (let* ((file (string-downcase segment)) (name (pathname-name file)) (type (pathname-type file)))
    (find (make-pathname :name name :type type :defaults #p"kira:code;") directory :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 (test)
  (when test (return-from authorize-if-not))
  (html ((:div :class "box" :id "authorize")
         ((:standard-form :action (uri-to 'authorize :return-to (request-uri *request*)))
          (:b "*** PASSWORD REQUIRED") (:p ((:input :type :password :name "password")))
          (:p ((:input :type :submit :value "Authorize")))))))

(defmethod handle ((handler (eql 'authorize)))
  (let ((return-to (or (parameter :return-to) (absolute-uri-to 'home))))
    (forbidden-if-not (eql (digest (parameter "password")) system:+password-digest+))
    (setf (authorization-time *session*) (get-local-time))
    (throw 'response (resolve-uri 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 file)
  (destructuring-bind (filename . temporary-name) upload-info
    (let ((name (if (typep file 'file) (file-name file) (return-from match-upload))))
      (and (equal (file-namestring name) filename) (files-equal name temporary-name)))))

(defmethod handle ((handler (eql 'home)) &aux (last-file-upload (session-entry-of-type 'file)))
  (whereas ((info (parameter "uploaded-file")) (filename (car info)) (temporary-name (cdr info)))
    (unless (or (match-upload info last-file-upload) (match-upload info (first (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")))))))

(defun post-changed-p (post new-edit)
  (or (null (history post)) ; Initial edit?
      (not (and (equal (author post) (author new-edit))
                (equal (title post) (title new-edit))
                (equal (body post) (body new-edit))))))

(defun edit-post (post &aux (edit (make-instance 'edit :post post)))
  (unless (post-changed-p post edit) (return-from edit-post (rollback)))
  (slot-makunbound post 'author)
  (slot-makunbound post 'title)
  (slot-makunbound post 'body)
  (slot-makunbound post 'edited-time)
  (push edit (history post)))

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

(defun compute-canonical-name (post)
  (let ((pages (get-root 'pages)) (title (title post)) object-under-name)
    (let ((canonical-name (nstring-downcase (collapse (or title "")))))
      (cond ((zerop (length canonical-name)) (setf (canonical-name post) nil))
            ((or (not (setq object-under-name (get-term canonical-name pages)))
                 (not (equalp (canonical-name object-under-name) canonical-name))
                 (eq object-under-name post))
             ;; CANONICAL-NAME is usable (i.e unique).
             (setf (canonical-name 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 #'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)))
    (forbidden-if-not (can-edit-p post))
    (with-accessors ((session-name session-name)) *session*
      (let ((old-author (author post)) (new-author (parameter 'author)))
        (unless (equal new-author old-author) (setq session-name new-author)))
      (progn (edit-post post) (compute-canonical-name post) (redirect post)))))

(defun cache-edit-content (edit)
  (let ((original-post (original-post edit)))
    (with-slots (author title body) original-post
      (multiple-value-setq (author title body)
        (values (author edit)
                (title edit)
                (body edit))))))

(defmethod slot-unbound ((class t) (post post) (slot-name (eql 'author)))
  (progn (cache-edit-content (last-edit post)) (slot-value post 'author)))

(defmethod slot-unbound ((class t) (post post) (slot-name (eql 'title)))
  (progn (cache-edit-content (last-edit post)) (slot-value post 'title)))

(defmethod slot-unbound ((class t) (post post) (slot-name (eql 'body)))
  (progn (cache-edit-content (last-edit post)) (slot-value post 'body)))

(defun last-edit (post)
  (check-type post post)
  (let ((history (history post)))
    (check-type history cons)
    (car history)))

(defmethod slot-unbound ((class t) (edited-post post) (slot-name (eql 'edited-time)))
  (setf (slot-value edited-post 'edited-time) (edit-time (last-edit edited-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 for (new old . more) on (history (parameter 'post t #'uri-object))
        for diff = (if old (uri-to 'diff :old old :new new) (loop-finish))
        do (html ((:a :href diff) (render-local-time (edit-time new)))
                 (:when more (:br)))))

(defmethod render-content ((handler (eql 'diff)))
  (html (:let* ((old (parameter "old" t #'uri-object))
                (new (parameter "new" t #'uri-object))
                (old-time (edited-time old))
                (new-time (edited-time new)))
           (render-link (original-post new))
           " / " (render-local-time old-time)
           " → " (render-local-time new-time)
           ((:pre :class "diff")
            (render-diff (body new)
                         (body old))))))

(defgeneric render-xml (object)
  (:method :before ((object t))
    (html +canonical-xml-declaration+))
  (:method ((symbol (eql 'rss)))
    (let ((title (title 'home)))
      (with-xml-element
          ("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"
          (with-xml-element
              ("atom:link"
               "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 ,@system:+kira-source-files+)))
      (with-xml-element "url" (with-xml-element "loc" (absolute-uri-to object))))))

(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 (process-kill server-process))
      (process-run-function "HTTP" #'http-serve))))