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

(in-package :kira)

(define-persistent-class post ()
  ((updated-time :initform nil :accessor updated-time)
   (canonical-name :initform nil :accessor canonical-name)
   (canonical-path :allocation :instance :reader canonical-path)
   (posted-time :initform (get-local-time) :accessor posted-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)))

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

(defun recent (objects)
  (loop with count of-type fixnum = 0 for object in objects
        when (and (typep object 'post) (canonical-name object))
        collect object and do (when (= (incf count) 4) (loop-finish))))

(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 ((handler (eql 'home)))
    (render-log (recent (get-root 'log))))
  (:method :around ((session session))
    (render-log (session-log session))))

(define-html-macro :info (contact-mail)
  (let ((mail-uri (resolve-uri contact-mail "mailto:")))
    `(:div ((:a :href ,mail-uri) "Contact") #\Space
           (:small "Powered by " (render-link 'kira)))))

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

(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"))
                        (render-link 'system) " | " (render-link 'scratch))
                      ((:div :id "content") (render-content object))
                      ((:div :id "footer") (:info "info@cl-pdx.com"))))))))

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

(defun hilite (pathname)
  (with-lexer ((file-string pathname))
    (loop with link and html-output = *html-output*
          with buffer = (make-buffer 80 'character)
          with kira-package = (find-package :kira)
          for mark of-type array-index = $lexer-position
          do (macrolet ((escape-code-lexer-extent (&optional (start 'mark))
                          (let ((extent `(:start ,start :end $lexer-position)))
                            `(escape-html $lexer-string nil ,@extent))))
               (lexer-skip (or alphanumeric ":$%&*_-=+<>.!^/?~|"))
               (cond ((> $lexer-position mark) ; Got token?
                      (setf (fill-pointer buffer) (the fixnum (- $lexer-position mark)))
                      (replace buffer $lexer-string :start2 mark :end2 $lexer-position)
                      (cond ((every #'digit-char-p buffer) (html ((:span :class "low-level") (:string buffer))))
                            ((eql (char buffer 0) #\:) (html ((:span :class "keyword") (escape-code-lexer-extent))))
                            ((eql (char buffer 0) #\%) (html ((:span :class "low-level") (escape-code-lexer-extent))))
                            ((multiple-value-bind (symbol status) (find-symbol (nstring-upcase buffer) kira-package)
                               (cond ((not status) (html ((:span :class "low-level") (escape-code-lexer-extent))))
                                     ((setq link (get symbol 'system:link)) (write-string link html-output))
                                     ((eq (symbol-package symbol) kira-package)
                                      (html ((:span :class "kira") (escape-code-lexer-extent))))
                                     ((html ((:span :class "ccl") (escape-code-lexer-extent)))))))))
                     ((when (lexer-match #\;) (lexer-skip (not #\Newline)))
                      (html ((:span :class "comment") (escape-code-lexer-extent))))
                     ((whereas ((macro-char (lexer-match #\# "\\_$")))
                        (cond ((eql macro-char #\\)
                               (or (lexer-match (not word)) (lexer-skip (or word #\+)))
                               (html ((:span :class "character") (escape-code-lexer-extent))))
                              ((lexer-skip word) (html ((:span :class "c") (escape-code-lexer-extent)))))))
                     ((lexer-match #\")
                      (loop while (lexer-case (c) (#\\ (lexer-match t)) (#\") (otherwise t))
                            finally (html ((:span :class "string") (escape-code-lexer-extent)))))
                     ;; Punctuation, e.g. parens and backquotes.
                     ((let ((reader-macro-p (lexer-match #\# (not "()[]{}"))))
                        (if (or (if (lexer-match "'`,") (lexer-skip "'`,.@")) reader-macro-p)
                            (html ((:span :class "tick") (:string $lexer-string :start mark :end $lexer-position)))
                            (progn (when (or (lexer-match t) (loop-finish)) (lexer-skip (or whitespace "()[]{}")))
                                   (write-string $lexer-string html-output :start mark :end $lexer-position))))))))))

(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)))
          ((eql (char segment 0) #\$)
           (let ((handler-package (load-time-value (find-package :kira))))
             (find-symbol (nstring-upcase (subseq segment 1)) handler-package)))
          ((string-equal segment 'kira) 'kira)
          ((get-term segment (get-root 'pages))))))

(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 'system)))
  (html (:standard-form (:p ((:input :type :file :name "uploaded-file")))
                        (:p ((:input :type :submit :value "Upload"))))))

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

(defun render-log (log-entries)
  (loop for object in log-entries
        for session = (session object)
        do (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-action-link session)))))))

(defmethod render-content ((handler (eql 'authorize)))
  (html (:standard-form (: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 (equal (parameter 'password) (get-root 'password)))
    (setf (authorization-time *session*) (get-local-time))
    (throw 'response (resolve-uri return-to))))

(defun scratch-pad (&optional (session *session*))
  (when (eq session nil) (return-from scratch-pad nil))
  (values (session-pad session) (session-token session)))

(define-html-macro :body-field (body &attributes attributes)
  `((:textarea :rows 10 :cols 80 :name 'body ,@attributes)
    ,(rebinding (body) `(when ,body (escape-html ,body)))))

(define-html-macro :post-option (session-token &rest label)
  `((:option :if* ,session-token :value (:string ,session-token)
             :if* (not ,session-token) :disabled :||) ,@label))

(define-html-macro :mode (&attributes attributes session-token)
  (let ((default-option `((:option :selected :||) "Scratch Pad"))
        (post-option `(:post-option ,session-token "Create Post")))
    `((:select :name "mode" ,@attributes) ,default-option ,post-option)))

(defmethod render-content ((handler (eql 'scratch)) &aux session-pad session-token)
  (render-text (setf (values session-pad session-token) (scratch-pad *session*)))
  (html (:standard-form (:table (:tr ((:td :colspan 2) (:body-field session-pad)))
                                (:tr (:td ((:input :type :submit :value "Save")))
                                     ((:td :align :right) (:mode session-token)))))))

(defmethod handle :before ((handler (eql 'scratch)) &aux (session *session*))
  (let (post (body (parameter 'body)) (session-token (session-token session)))
    (when (and body session-token (equal (parameter "mode") session-token))
      (setf (session-token session) nil (session-pad session) nil)
      (unless (and (setq post (session-entry-of-type 'post session)) (equal (body post) body))
        (push-to-log (setq post (make-instance 'post :body body :author (session-name session)))))
      (redirect post))))

(defmethod handle ((handler (eql 'scratch)))
  (with-accessors ((session-token session-token)) *session*
    (orf session-token (format nil "K~D" (random (ash 1 64))))
    (setf (session-pad *session*) (parameter 'body))))

(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 'system)) &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 :link-input (&rest attributes)
  (let ((input-element `((:input ,@attributes))))
    `(:when (authorization-time *session*)
       (:tr (:th "Link") (:td ,input-element)))))

(define-html-macro :with-editing-form (body-field &body table-rows)
  (loop for input-element in `(,body-field ((:input :type :submit :value "Save")))
        collect `(:tr ((:td :colspan 2) ,input-element)) into trailing-table-rows
        finally (return `(:standard-form (:table ,@table-rows ,.trailing-table-rows)))))

(defmethod render-content ((handler (eql 'edit)) &aux (post (parameter-object 'post)))
  (with-accessors ((title title) (name author) (canonical-name canonical-name)) post
    (unless (can-edit-p post) (redirect 'authorize :return-to (request-uri *request*)))
    (html (:with-editing-form (:body-field (body post))
            (:tr (:th "Author") (:td ((:input :type :text :name 'author :if* name :value name))))
            (:tr (:th "Title") (:td ((:input :type :text :name 'title :if* title :value title))))
            (:link-input :type :text :name 'canonical-name :if* canonical-name :value canonical-name)))))

(defmethod handle ((handler (eql 'edit)))
  (let ((post (parameter-object 'post)))
    (forbidden-if-not (can-edit-p post))
    (with-accessors ((author author)) post
      (setf (title post) (parameter 'title))
      (setf (body post) (parameter 'body))
      (setf (updated-time post) (get-local-time))
      (when (authorization-time *session*)
        (setf (canonical-name post) (parameter 'canonical-name)))
      (unless (equal author (setq author (parameter 'author)))
        (setf (session-name *session*) author))
      (redirect post))))

(defun edited-time (post)
  (or (updated-time post)
      (posted-time post)))

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

(defun render-action-link (object &rest parameters)
  (let ((canonical-uri (apply #'uri-to object parameters)))
    (html ((:a :href canonical-uri :class "action-link")
           "[" (render-title object) "]"))))

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