From 4be1a20fa252c43880b94d1a92cee00e822f1aa6 Mon Sep 17 00:00:00 2001 From: colin Date: Sun, 11 Aug 2024 19:52:19 -0700 Subject: initial commit --- README.org | 49 ++++++++++ build.lisp | 24 +++++ emacs/http-post-simple.el | 207 ++++++++++++++++++++++++++++++++++++++++ package.lisp | 10 ++ pastiche.asd | 16 ++++ pastiche.conf | 6 ++ pastiche.lisp | 235 ++++++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 547 insertions(+) create mode 100644 README.org create mode 100644 build.lisp create mode 100644 emacs/http-post-simple.el create mode 100644 package.lisp create mode 100644 pastiche.asd create mode 100644 pastiche.conf create mode 100644 pastiche.lisp diff --git a/README.org b/README.org new file mode 100644 index 0000000..afadb0a --- /dev/null +++ b/README.org @@ -0,0 +1,49 @@ + +** Build and Run + +There is a =build.lisp= file in this repo, build an executable like so: + + +#+begin_src shell + +sbcl --load build.lisp + +#+end_src + +Run the pastiche executable like so: + +#+begin_src shell + +./pastiche /path/to/pastiche.conf + +#+end_src + +There is an example of what =pastiche.conf= looks like in this directory. + + +** Using With Emacs + +First, this uses ~http-post-simple.el~, a copy of which can be found in the ~emacs/~ subdirectory. + +Make sure that is loaded, then: + +#+begin_src elisp + +(defvar pastiche-paste-url "the real url here") + +(defun pastiche-paste-current-buffer () + (interactive) + (let* ((content + (buffer-string)) + (title + (buffer-name)) + (result + (http-post-simple + pastiche-paste-url + (list (cons 'title title) + (cons 'content content))))) + (let ((url (first result))) + (kill-new url) + (message url)))) + +#+end_src diff --git a/build.lisp b/build.lisp new file mode 100644 index 0000000..98920ea --- /dev/null +++ b/build.lisp @@ -0,0 +1,24 @@ +(require 'asdf) + +(asdf:load-system :pastiche) + +(defun get-option (name &optional default) + (or + (let ((args (uiop:command-line-arguments))) + (when-let ((pos (position name args :test #'string-equal))) + (nth (1+ pos) args))) + default)) + +(defun run () + (let ((config-path (get-option "--config"))) + (truname config-path) + (pastiche::load-config config-path) + (pastiche::start) + (loop (sleep 30)))) + +(ensure-directories-exist #P"./bin/") +(sb-ext:save-lisp-and-die + "bin/pastiche" + :toplevel #'run + :executable t + :compression t) diff --git a/emacs/http-post-simple.el b/emacs/http-post-simple.el new file mode 100644 index 0000000..cf86cb4 --- /dev/null +++ b/emacs/http-post-simple.el @@ -0,0 +1,207 @@ +;;; http-post-simple.el --- HTTP POST requests using the url library + +;; Author: Tom Schutzer-Weissmann +;; Keywords: comm, data, processes, hypermedia + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as1 +;; published by the Free Software Foundation; either version 2 of +;; the License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be +;; useful, but WITHOUT ANY WARRANTY; without even the implied +;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. See the GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public +;; License along with this program; if not, write to the Free +;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, +;; MA 02111-1307 USA + +;;; Commentary: + +;; Provides ways to use the url library to perform HTTP POST requests. +;; See the documentation to `http-post-simple' for more information. +;; +;; The `url-http' library does not handle 1xx response codes. + +;; However, as RFC 2616 puts it: +;; a server MAY send a 100 (Continue) +;; status in response to an HTTP/1.1 PUT or POST request that does +;; not include an Expect request-header field with the "100-continue" +;; expectation. +;; +;; -- and some servers do, giving you annoying errors. To avoid these errors, +;; you can either set `url-http-version' to "1.0", in which case any compliant +;; server will not send the 100 (Continue) code, or call +;; `http-post-finesse-code-100'. Note that the latter advises +;; 'url-http-parse-response' +;; +;;; Change Log: + +;; 11/06/2008 Set `url-http-version' to "1.0" when posting. +;; 19/07/2008 Don't set special variables like `url-http-version' and +;; `url-http-attempt-keepalives'. +;; 03/11/2008 Tell the server what charset we're using & accepting. + +;;; Code: +(require 'url) +(require 'url-http) + +(defvar url-http-response-status nil) ; url-http + +(defun http-post-simple (url fields &optional charset) + "Send FIELDS to URL as an HTTP POST request, returning the response +and response headers. +FIELDS is an alist, eg ((field-name . \"value\")); all values +need to be strings, and they are encoded using CHARSET, +which defaults to 'utf-8" + (http-post-simple-internal + url + (http-post-encode-fields fields charset) + charset + `(("Content-Type" + . + ,(http-post-content-type + "application/x-www-form-urlencoded" + charset))))) + + +(defun http-post-simple-multipart (url fields files &optional charset) + "Send FIELDS and FILES to URL as a multipart HTTP POST, returning the +response and response headers. +FIELDS is an alist, as for `http-post-simple', FILES is an a list of +\(fieldname \"filename\" \"file MIME type\" \"file data\")*" + (let ((boundary (http-post-multipart-boundary))) + (http-post-simple-internal + url + (http-post-encode-multipart-data fields files charset) + charset + `(("Content-Type" + . + ,(http-post-content-type + (format "multipart/form-data; boundary=%S" boundary) + charset)))))) + + +(defun http-post-content-type (content-type &optional charset) + (if charset + (format "%s; charset=%s" content-type (http-post-charset-name charset)) + content-type)) + + +(defun http-post-charset-name (charset) + (symbol-name charset)) + + +;; based on `http-url-encode' from the from http-get package +;; http://savannah.nongnu.org/projects/http-emacs +(defun http-post-encode-string (str content-type) + "URL encode STR using CONTENT-TYPE as the coding system." + (apply 'concat + (mapcar (lambda (c) + (if (or (and (>= c ?a) (<= c ?z)) + (and (>= c ?A) (<= c ?Z)) + (and (>= c ?0) (<= c ?9))) + (string c) + (format "%%%02x" c))) + (encode-coding-string str content-type)))) + + +(defun http-post-encode-fields (fields &optional charset) + "Encode FIELDS using `http-post-encode-string', where +FIELDS is an alist of \( + \(field-name-as-symbol . \"field value as string\"\) | + \(field-name \"value1\" \"value2\" ...\) + \)* + +CHARSET defaults to 'utf-8" + (let ((charset (or charset 'utf-8))) + (mapconcat #'identity + (mapcar (lambda (field) + (concat (symbol-name (car field)) + "=" + (http-post-encode-string (cdr field) charset))) + (cl-mapcan (lambda (field) + (if (atom (cdr field)) (list field) + ;; unpack the list + (mapcar (lambda (value) + `(,(car field) . ,value)) + (cdr field)))) + fields)) + "&"))) + + +(defun http-post-simple-internal (url data charset extra-headers) + (let ((url-request-method "POST") + (url-request-data data) + (url-request-extra-headers extra-headers) + (url-mime-charset-string (http-post-charset-name charset))) + (let (header + data + status) + (with-current-buffer + (url-retrieve-synchronously url) + ;; status + (setq status url-http-response-status) + ;; return the header and the data separately + (goto-char (point-min)) + (if (search-forward-regexp "^$" nil t) + (setq header (buffer-substring (point-min) (point)) + data (buffer-substring (1+ (point)) (point-max))) + ;; unexpected situation, return the whole buffer + (setq data (buffer-string)))) + (values data header status)))) + + +(defun http-post-multipart-boundary () + "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=") + + +(defun http-post-bound-field (&rest parts) + (let ((boundary (format "--%s" (http-post-multipart-boundary)))) + (http-post-join-lines boundary parts))) + + +(defun http-post-encode-multipart-data (fields files charset) + "Return FIELDS and FILES encoded for use as the data for a multipart HTTP POST request" + (http-post-join-lines + (mapcar (lambda (field) + (http-post-bound-field + (format "Content-Disposition: form-data; name=%S" (symbol-name (car field))) + "" + (cdr field))) + fields) + (cl-mapcan (lambda (file) + (destructuring-bind (fieldname filename mime-type data) file + (http-post-bound-field + (format "Content-Disposition: form-data; name=%S; filename=%S" fieldname filename) + (format "Content-type: %s" (http-post-content-type mime-type charset)) + "" + data))) + files) + (format "--%s--" (http-post-multipart-boundary)))) + + +(defun http-post-join-lines (&rest bits) + (let ((sep "\r\n")) + (mapconcat (lambda (bit) + (if (listp bit) + (apply 'http-post-join-lines bit) + bit)) + bits sep))) + + +(defun http-post-finesse-code-100 () + "Transforms response code 100 into 200, to avoid errors when the +server sends code 100 in response to a POST request." + (defadvice url-http-parse-response (after url-http-parse-response-100 activate) + "Turns any HTTP 100 response code to 200, to avoid getting an error." + (declare (special url-http-response-status + url-request-method)) + (when (and (= 100 url-http-response-status) + (string-equal "POST" url-request-method) + (string-equal "1.1" url-http-version)) + (setf url-http-response-status 200)))) + +(provide 'http-post-simple) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..8bce337 --- /dev/null +++ b/package.lisp @@ -0,0 +1,10 @@ +;;;; package.lisp + +(defpackage #:pastiche + (:use #:cl) + (:import-from #:flatbind #:do>) + (:local-nicknames + (#:a #:alexandria-2) + (#:db #:bknr.datastore) + (#:http #:weekend) + (#:html #:hypnotisml))) diff --git a/pastiche.asd b/pastiche.asd new file mode 100644 index 0000000..8fb0f7c --- /dev/null +++ b/pastiche.asd @@ -0,0 +1,16 @@ +;;;; pastiche.asd + +(asdf:defsystem #:pastiche + :description "Describe pastiche here" + :author "Your Name " + :license "Specify license here" + :version "0.0.1" + :serial t + :depends-on (#:weekend + #:hypnotisml + #:alexandria + #:def + #:bknr.datastore + #:flatbind) + :components ((:file "package") + (:file "pastiche"))) diff --git a/pastiche.conf b/pastiche.conf new file mode 100644 index 0000000..aaf3fd4 --- /dev/null +++ b/pastiche.conf @@ -0,0 +1,6 @@ +(:service-domain "paste.cicadas.surf" + :service-protocol "https" + :service-port 80 + :localhost-port 9911 + :db-path "/home/pastiche/db/" + :paste-path "/home/pastiche/pastes/") \ No newline at end of file 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: