New HTTP backend.

1 files changed, 78 insertions, 0 deletions

diff --git a/extra/http/server.lisp b/extra/http/server.lisp
new file mode 100644
index 0000000..0ad85e4
--- /dev/null
+++ b/extra/http/server.lisp
@@ -0,0 +1,78 @@
+(in-package #:eris-http-server)
+
+(a:define-constant forbid '(403 (:content-type "text/plain") ("FORBIDDEN."))
+  :test #'equal)
+
+(a:define-constant unauth '(401 (:content-type "text/plain") ("Unauthorized."))
+  :test #'equal)
+
+(defmacro clack-write-stream (stream)
+  "Writes a stream as a response using Clack's responders."
+  `(lambda (responder)
+     (block lambda
+       ;; if errors out during stream creation, 404
+       (let ((stream (handler-case ,stream
+                       (error (c)
+                         (declare (ignore c))
+                         (funcall (funcall responder '(404 (:content-type "text/plain") nil) nil :close t))
+                         (return-from lambda)))))
+         (let ((writer (funcall responder '(200 (:content-type "application/octet-stream")))))
+           ;; read-sequence -> write
+           (loop with buffer = (serapeum:make-octet-vector 4096)
+                 for bytes-read = (read-sequence buffer stream)
+                 if (= bytes-read 4096)
+                   do (funcall writer buffer)
+                 else
+                   do (funcall writer (serapeum:nsubseq buffer 0 bytes-read) :close t)))))))
+
+
+(defun request-get (query-string directory file-backend)
+  (let ((uri (quri:uri query-string)))
+    (unless (quri:urn-p uri) (return-from request-get forbid))
+    (case-using #'equal (quri:urn-nid uri)
+      ("blake2b" (let ((f (merge-pathnames directory (string-upcase (quri:urn-nss uri)))))
+                   ;; Using merge-pathnames should prevent things like urn:...:/../../etc/passwd
+                   ;; since it'll only fill the filename. 
+                   (if (uiop:file-exists-p f)
+                       `(200 (:content-type "application/octet-stream") ,f)
+                       `(404 (:content-type "text/plain") ("Missing block.")))))
+      ("eris" (clack-write-stream
+               (eris:fetch-data (eris:urn-to-read-capability query-string) file-backend)))
+      (otherwise forbid))))
+
+(defun request-post (query body directory)
+  (let* ((uri (quri:uri query)))
+    ;; Using merge-pathnames should prevent things like urn:...:/../../blah
+    (unless (quri:urn-p uri) (return-from request-post forbid))
+    (let ((path (merge-pathnames directory (string-upcase (quri:urn-nss uri)))))
+      (unless (uiop:file-exists-p path)
+        (with-open-file (f path  :direction :output :if-does-not-exist :create :element-type 'octet)
+          (alexandria:copy-stream body f :element-type 'octet :buffer #.(make-octet-vector 4096)))))
+    '(200 (:content-type "text/plain") ("Unauthorized."))))
+
+
+(defun eris-handler (directory &key auth)
+  "Return a Clack handler for a file-backend based ERIS store.
+
+AUTH should be NIL or a list containing HTTP Basic Auth tokens (ie. base64
+encoded logic:pass strings). If NIL, all POST requests will be denied. Note that
+due to the limitations of ERIS, the server absolutely trusts the uploader,
+meaning that malicious users could potentially cause harm (as well as upload
+arbitrary files)."
+  (let ((file-backend (make-instance 'eris:file-backend :directory directory)))
+    (lambda (env)
+      (destructuring-bind (&key request-method query-string raw-body path-info (headers (make-hash-table))
+                             content-length &allow-other-keys) env
+        (if (not (equal path-info "/uri-res/N2R"))
+            '(404 (:content-type "text/plain") ("No resource."))
+            (case request-method
+              (:get (if (stringp query-string) (request-get query-string directory file-backend)
+                        forbid))
+              (:post (if (and
+                          auth ;; if no auth always deny
+                          (member (subseq (href headers "authorization") 6) auth :test #'equal) 
+                          (typep content-length '(member 1024 32768))
+                          (stringp query-string))
+                         (request-post query-string raw-body directory)
+                         unauth))
+              (t '(405 (:content-type "text/plain") ("Method not allowed.")))))))))