;;;; 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")) ((known-keys "List of known keys, these are included with pastes.") :type list :initform nil) :documentation "Application confiration, probably loaded from disk via LOAD-CONFIG.") (defun known-keys* () (known-keys *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 known-keys) (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 :known-keys known-keys)))) (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 "<" stream)) (#\> (write-string ">" stream)) (#\& (write-string "&" stream)) (#\' (write-string "'" stream)) (#\" (write-string """ 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*))))) (def:const +days-of-the-week+ #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) (defun dow-name (dow) (elt +days-of-the-week+ dow)) (def:const +months+ #("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December")) (defun month-name (month) (elt +months+ month)) (defun decoded-time (universal-time) (multiple-value-bind (sec min hr date month year dow) (decode-universal-time universal-time) (declare (ignore sec)) (format nil "~a, ~a ~:R ~d at ~2,'0d:~2,'0d ~:[AM~;PM~]" (dow-name dow) (month-name month) date year (mod hr 12) min (>= hr 12)))) (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 := ( ( ($ :padding "0" :margin "0" :background "#222222" :color "white") (html: ($ :padding "8px") ( ($ :color "lightgreen" :font-size "1.6em") (@ :href (http:route-to 'raw-paste :id id)) "raw") (
( ($ :text-decoration "underline" :font-size "2.1em" :font-weight "bold") ( (title paste))) ( ($ :font-style "italic" :margin-left "2em") (decoded-time (paste-time paste))))) (
               ($ :font-size "1.2em"
                  :color "#dfba3b"; "#22ee44"
                  :background "#111111")
               (escape-html-in-paste-content content))))

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

(eval-when (:compile-toplevel :load-toplevel :execute)
  (def:class has-known-key ()
    (key :type string :initform (error "key is required"))
    :documentation "Mixin for endpoint classes that require a known key")

  (defmethod http:authenticate ((ep has-known-key))
    (member (key ep) (known-keys*) :test #'equal)))

(def:const +paste-length-limit+ (* 1024 1024)
  "Limited to 1mb")

(http:defendpoint create-paste
  :using has-known-key
  :post :to "create" "paste"
  :returns "text/plain"
  :parameters
  (title string)
  (content string)
  :documentation "Create a new paste and return a URL to its content."
  :authorize
  (or (<= (length title) +paste-title-limit+)
      (http:err :content "Paste title must be shorter than 80 characters."))
  :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)))

(defmethod http:check-request-compliance ((class (eql (find-class 'create-paste))))
  (unless (< (parse-integer (http:get-header :content-length))
             +paste-length-limit+)
    (http:err :content (format nil "Paste bodies limited to 1MB"))))

(http:defendpoint new-paste-form
  :using has-known-key
  :get :route ""
  :returns "text/html"
  :handle
  (with-output-to-string (out)
    (html:html
     (
      (
       (
 "Paste something")
       (

        (@ :method "POST" :action (http:route-to 'create-paste))
        ( (@ :name "key" :value key :type "hidden"))
        ( (@ :name "title" :placeholder "title"))
        

        (