initial commit

7 files changed, 547 insertions, 0 deletions

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 <your.name@example.com>"
+  :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:<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)))
+
+
+
+