From 4be1a20fa252c43880b94d1a92cee00e822f1aa6 Mon Sep 17 00:00:00 2001 From: colin Date: Sun, 11 Aug 2024 19:52:19 -0700 Subject: initial commit --- pastiche.lisp | 235 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 235 insertions(+) create mode 100644 pastiche.lisp (limited to 'pastiche.lisp') diff --git a/pastiche.lisp b/pastiche.lisp new file mode 100644 index 0000000..1ca4807 --- /dev/null +++ b/pastiche.lisp @@ -0,0 +1,235 @@ +;;;; 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.") + (ttl "The default time-to-live, in milliseconds") + :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 ttl* () + (ttl *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 + :ttl 7776000)" + (destructuring-bind + (&key + service-domain + service-protocol + service-port + localhost-port + db-path + paste-path + ttl) + (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 + :ttl ttl)))) + +(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.") + (content "The text of this paste") + (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 'get-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.")) + +(http:defendpoint get-paste + :get :route "paste" (:id +paste-id-regex+) + :returns "text/html" + :parameters + (id string) + :properties + (paste paste) + :authenticate + (or (setf paste (lookup-paste id)) + (http:not-found instance)) + :documentation "Fetch a " + :var instance + :handle + (do> + filename := (merge-pathnames (filename paste) (paste-path*)) + content := (a:read-file-into-string filename) + (with-output-to-string (out) + (html:html + (html: + (html: + (html:

(title paste)) + (html:
 content)))
+       out))))
+
+
+(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)
+                    :content content
+                    :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:
 "Paste something")
+       (html:

+        (html:@ :method "POST" :action (http:route-to 'create-paste))
+        (html: (html:@ :name "title" :placeholder "title"))
+        html:

+        (html: