diff options
Diffstat (limited to 'pastiche.lisp')
| -rw-r--r-- | pastiche.lisp | 235 |
1 files changed, 235 insertions, 0 deletions
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:<body> + (html:<h2> (title paste)) + (html:<pre> 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:<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))) + + + + |