path: root/pastiche.lisp

;;;; pastiche.lisp

(in-package #:pastiche)

;;; SERVICE CONFIG, STARTING, STOPPING

(def:var *config*
  :init nil
  :doc "Global config instance.")

(def:var *server*
  :init nil
  :doc "The hunchentoot acceptor instance.")

(def:const +paste-title-limit+
    80
  "The upper limit on the character length of a paste title.")

(def:class config ()
  ((service-domain "Most public domain name where this service is running.")
   (service-protocol "HTTP or HTTPS")
   :ro
   :type string
   :initform (error "Missing required slot."))
  ((db-path "Path to BKNR.DATASTORE root.")
   (paste-path "Path to where pastes data is stored.")
   :ro
   :type (or string pathname)
   :initform (error "Missing required slot"))
  ((localhost-port "Port on which the HTTP server should listen.")
   (service-port "Port that should be mentioned in URLs generated by the app.")
   :ro
   :type integer
   :initform (error "Missing required slot"))
  :documentation "Application confiration, probably loaded from disk via LOAD-CONFIG.")

(defun service-protocol* ()
  (service-protocol *config*))

(defun service-domain* ()
  (service-domain *config*))

(defun service-port* ()
  (service-port *config*))

(defun localhost-port* ()
  (localhost-port *config*))

(defun db-path* ()
  (db-path *config*))

(defun paste-path* ()
  (paste-path *config*))

(defun load-config (path)
  "Loads a PLIST from disk from PATH.

E.g. you'd put this in a file.

(:service-domain \"paste.coolstuff.somewhere\",
 :service-protocol 8989
 :db-path \"/absolute/path/to/a/directory/\",
 :paste-path \"/absolute/path/to/another/directory/\",
 :server-port 8000)"
  (destructuring-bind
      (&key
         service-domain
         service-protocol
         service-port
         localhost-port
         db-path
         paste-path)
      (uiop:read-file-form path)
    (setf *config*
          (make-instance 'config
            :service-domain service-domain
            :service-protocol service-protocol
            :service-port service-port
            :localhost-port localhost-port
            :db-path db-path
            :paste-path paste-path))))

(defun start ()
  (unless *config*
    (error "No CONFIG has been loaded."))
  (when *server*
    (warn "STOPPING ALREADY RUNNING PASTICHE SERVER.")
    (hunchentoot:stop *server*))

  (ensure-directories-exist (db-path*))
  (ensure-directories-exist (paste-path*))

  (make-instance 'db:mp-store
    :directory (db-path*)
    :subsystems (list (make-instance 'db:store-object-subsystem)))

  (setf *server*
        (make-instance 'hunchentoot:easy-acceptor
          :port (localhost-port*)))

  (hunchentoot:start *server*))

;;; MODEL

(def:class paste (db:store-object)
  ((title "A name for this paste. Used to generate file name on disk.")
   (filename "Filename relative to CONFIG's PASTE-PATH")
   :type string
   :initform (error "Missing required slot")
   :index-type bknr.indices:string-unique-index
   :index-reader lookup-paste)
  ((paste-time "The server-local timestamp when this was pasted.")
   :type integer
   :initform (error "Missing required slot."))
  ((privacy "A token indicating how to restrict access to this paste.")
   :type (member :unlisted :public)
   :initform :unlisted)
  ((pinned "T indicates this paste should not be deleted during a cleaning cycle.")
   :type boolean
   :initform nil)
  :metaclass db:persistent-class)


;;; ENDPOINTS

(defun santize-title (str)
  (with-output-to-string (*standard-output*)
    (loop :for char :across str
          :if (alphanumericp char)
            :do (write-char char)
          :else
            :do (write-char #\-))))

(defun make-paste-filename (content title)
  (format nil "~a-~a~a"
    (santize-title title)
    (sxhash content)
    (get-universal-time)))

(defun fully-qualified-route-to (paste)
  (format nil "~a://~a:~a~a"
          (service-protocol*)
          (service-domain*)
          (service-port*)
          (http:route-to 'view-paste :id (filename paste))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (def:const +paste-id-regex+ "(([a-zA-Z0-9]*-)+[0-9]+)"
    "A regular expression accepting paste file names, the sort returned
from make-paste-filename."))

(defun write-escaped-char (char &optional (stream *standard-output*))
  (case char
    (#\< (write-string "&lt;" stream))
    (#\> (write-string "&gt;" stream))
    (#\& (write-string "&amp;" stream))
    (#\' (write-string "&#39;" stream))
    (#\" (write-string "&quot;" stream))
    (t (write-char char stream))))

(defun escape-html-in-paste-content (str)
  (with-output-to-string (*standard-output*)
   (loop :for char :across str
         :do (write-escaped-char char))))

(http:defendpoint raw-paste
  :get :route "raw" "paste" (:id +paste-id-regex+)
  :returns "text/plain"
  :parameters
  (id string)
  :var instance
  :handle
  (do>
    paste :when= (or (lookup-paste id) (http:not-found instance))
    (a:read-file-into-string
     (merge-pathnames (filename paste) (paste-path*)))))


(http:defendpoint view-paste
  :get :route "paste" (:id +paste-id-regex+)
  :returns "text/html"
  :parameters
  (id string)
  :documentation "Show paste in an html page."
  :var instance
  :handle
  (do>
    paste :when= (or (lookup-paste id) (http:not-found instance))
    filename := (merge-pathnames (filename paste) (paste-path*))
    content := (a:read-file-into-string filename)
    page := (<html>
             (<body>
              (<a> (@ :href (http:route-to 'new-paste-form))
                   "new paste")
              <br>
              (<a> (@ :href (http:route-to 'raw-paste :id id))
                   "raw")
              (<h4> (title paste))
              (<pre>
               (escape-html-in-paste-content content))))

    (html:html-string page :pretty nil)))


(http:defendpoint create-paste
  :post :to "create" "paste"
  :returns "text/plain"
  :parameters
  (title string)
  (content string)
  :documentation "Create a new paste and return a URL to its content."
  :authenticate
  (< (length title) +paste-title-limit+)
  :handle
  (do>
    location := (make-paste-filename content title)
    qualified-location := (merge-pathnames location (paste-path*))

    (a:write-string-into-file
     content qualified-location
     :if-exists :supersede
     :if-does-not-exist :create)

    instance := (db:with-transaction ()
                  (make-instance 'paste
                    :pinned nil
                    :privacy :unlisted
                    :paste-time (get-universal-time)
                    :title title
                    :filename location))

    (fully-qualified-route-to instance)))

(http:defendpoint new-paste-form
  :get :route ""
  :returns "text/html"
  :handle
  (with-output-to-string (out)
    (html:html
     (html:<html>
      (html:<body>
       (html:<h1> "Paste something")
       (html:<form>
        (html:@ :method "POST" :action (http:route-to 'create-paste))
        (html:<input> (html:@ :name "title" :placeholder "title"))
        html:<br>
        (html:<textarea> (html:@ :name "content" :rows "20" :cols "88"))
        html:<br>
        (html:<button> "Paste"))))
     out)))