New HTTP backend.

9 files changed, 251 insertions, 0 deletions

diff --git a/extra/http/README b/extra/http/README
new file mode 100644
index 0000000..8dba5ab
--- /dev/null
+++ b/extra/http/README
@@ -0,0 +1,14 @@
+This is an implementation of ERIS over HTTP [https://eris.codeberg.page/eer/http.xml].
+
+In addition to the barebones specification, the following extensions are implemented:
+
+1. Uploading blocks. Users authorized with the standard basic HTTP authorization
+can POST a block in order to upload it to the server, remotely.
+
+2. When accessing entire URNs, one can also specify the MIMETYPE as an additional query parameter:
+
+GET /uri-res/N2R?urn:eris:...&type=text/html
+
+This can be used to directly access the content in a web browser.
+
+
diff --git a/extra/http/client.lisp b/extra/http/client.lisp
new file mode 100644
index 0000000..a694612
--- /dev/null
+++ b/extra/http/client.lisp
@@ -0,0 +1,33 @@
+(in-package #:eris-http-client)
+
+(defclass http-backend (eris:encoding-backend eris:decoding-backend)
+  ((endpoint :initarg :endpoint :type quri:uri
+             :documentation "HTTP endpoint to use.")
+   (auth :initarg :auth :type cons
+         :documentation "A login:password pair for HTTP Basic auth.")))
+
+(defmethod initialize-instance ((http-backend http-backend) &rest initargs
+                                &key (endpoint nil endpoint-p)
+                                  (auth nil)
+                                &allow-other-keys)
+  (declare (ignore initargs))
+  (unless endpoint-p
+    (error 'simple-error "An endpoint must be specified."))
+  (let ((uri (quri:uri endpoint)))
+    ;; To prevent confusion of what part of the endpoint should be included
+    (unless (string-suffix-p "/uri-res/" (quri:uri-path uri))
+      (error 'simple-error "Endpoint must end in /uri-res/."))
+    (with-slots (eris:output-function eris:fetch-function) http-backend
+      (setf (quri:uri-path uri) (concatenate 'string (quri:uri-path uri) "N2R"))
+      (setf eris:fetch-function
+            (lambda (reference)
+              (setf (quri:uri-query uri) (eris:reference-to-block-urn reference))
+              (mvlet ((body status (dexador:get uri)))
+                (if (eql status 404)
+                    (error 'eris:missing-block)
+                    body)))
+            eris:output-function
+            (lambda (block reference)
+              (setf (quri:uri-query uri) (eris:reference-to-block-urn reference))
+              (dexador:post uri :force-binary t :content block :basic-auth auth)
+              block)))))
diff --git a/extra/http/eris-http-client.asd b/extra/http/eris-http-client.asd
new file mode 100644
index 0000000..7adecbb
--- /dev/null
+++ b/extra/http/eris-http-client.asd
@@ -0,0 +1,8 @@
+(defsystem "eris-http-client"
+  :name "eris-http-client"
+  :author "mail@ykonai.net"
+  :license "LGPLv3 or later"
+  :depends-on ("ironclad" "alexandria" "serapeum" "dexador" "eris")
+  :serial t
+  :components ((:file "package-client")
+               (:file "client")))
diff --git a/extra/http/eris-http-server.asd b/extra/http/eris-http-server.asd
new file mode 100644
index 0000000..f7cafd6
--- /dev/null
+++ b/extra/http/eris-http-server.asd
@@ -0,0 +1,27 @@
+(defsystem "eris-http-server"
+  :name "eris-http-server"
+  :author "mail@ykonai.net"
+  :license "LGPLv3 or later"
+  :depends-on ("ironclad" "alexandria" "serapeum" "quri" "clack" "eris")
+  :serial t
+  :components ((:file "package")
+               (:file "server"))
+;;  :in-order-to ((test-op (test-op :eris/test)))
+  )
+
+
+;; (defsystem "eris/test"
+;;   :name "eris/test"
+;;   :depends-on ("eris" "fiveam" "ironclad" "alexandria" "serapeum")
+;;   :perform (test-op (op c) (symbol-call :fiveam :run!
+;;                                         (find-symbol* :eris-tests :eris/test)))
+;;   :components ((:module "tests"
+;;                 :serial t
+;;                 :components ((:file "package")
+;;                              (:file "common")
+;;                              (:file "encode-tests")
+;;                              (:file "decode-tests")
+;;                              (:file "rfc")
+;;                              (:file "autogenerated-tests")
+;;                              (:file "backend-tests")
+;;                              #+unix (:file "parallel-tests")))))
diff --git a/extra/http/eris-http-tests.asd b/extra/http/eris-http-tests.asd
new file mode 100644
index 0000000..5e99760
--- /dev/null
+++ b/extra/http/eris-http-tests.asd
@@ -0,0 +1,12 @@
+(defsystem "eris-http-tests"
+  :name "eris-http-tests"
+  :author "mail@ykonai.net"
+  :license "LGPLv3 or later"
+  :depends-on ("eris-http-server" "eris-http-client" "alexandria" "serapeum" "eris" "fiveam")
+  :serial t
+  :components ((:file "http-tests"))
+  :perform (test-op (op c) (symbol-call :fiveam :run! (find-symbol* :eris-http-tests :eris-http-tests))))
+
+
+
+
diff --git a/extra/http/http-tests.lisp b/extra/http/http-tests.lisp
new file mode 100644
index 0000000..38dfac8
--- /dev/null
+++ b/extra/http/http-tests.lisp
@@ -0,0 +1,72 @@
+(defpackage #:eris-http-tests
+  (:use #:common-lisp #:serapeum #:fiveam #:eris-http-server #:eris-http-client))
+
+(in-package :eris-http-tests)
+
+
+(defun make-temporary-dir ()
+  (let* ((tmpdir (uiop:temporary-directory))
+         (tmp-tmpdir (make-pathname
+                      :directory (serapeum:append1
+                                  (pathname-directory tmpdir)
+                                  (ironclad:byte-array-to-hex-string (ironclad:random-data 10)))
+                      :defaults tmpdir)))
+    (ensure-directories-exist tmp-tmpdir)
+    tmp-tmpdir))
+
+(defmacro with-temporary-dir (sym &body expr)
+  `(let ((,sym (make-temporary-dir)))
+     (unwind-protect
+          (progn ,@expr)
+       (uiop:delete-directory-tree ,sym :validate t))))
+
+(defmacro with-clack (handler &body expr)
+  (alexandria:with-gensyms (v)
+    `(let ((,v (clack:clackup ,handler)))
+       (unwind-protect (progn ,@expr)
+         (progn (format t "STOPPING CLACK ~%") (clack:stop ,v))))))
+
+;; (base64:string-to-base64-string "test:test")
+(alexandria:define-constant auth '("dGVzdDp0ZXN0") :test #'equal)
+
+(def-suite* eris-http-tests)
+
+(test basic-http-rw
+  (with-temporary-dir tdir
+    (with-clack (eris-handler tdir :auth auth)
+      (let ((backend (make-instance 'http-backend :endpoint "http://127.0.0.1:5000/uri-res/"
+                                                  :auth '("test" . "test"))))
+        (for-all ((buffer (gen-buffer :length (gen-integer :min 1 :max 80000))))
+          (is (equalp (alexandria:read-stream-content-into-byte-vector
+                       (eris:fetch-data 
+                        (eris:store-data buffer backend)
+                        backend))
+                      buffer))
+          (is (equalp (alexandria:read-stream-content-into-byte-vector
+                       (eris:fetch-data
+                        (eris:store-data (make-array 40000 :element-type 'octet :initial-element 2) backend)
+                        backend))
+                      (make-array 40000 :element-type 'octet :initial-element 2))))))))
+
+(test bad-inputs
+  (with-temporary-dir tdir
+    (with-clack (eris-handler tdir :auth auth)
+      (signals error
+        (dexador:get "http://127.0.0.1:5000/lole"))
+      (signals error
+        (dexador:get "http://127.0.0.1:5000/../../"))
+      (signals error
+        (dexador:get "http://127.0.0.1:5000/uri-res/N2R?urn:blake2b:../../passwd"))
+      (signals error
+        (dexador:get "http://127.0.0.1:5000/uri-res/N2R?urn:blake2b:not"))
+      (signals error
+        (dexador:get "http://127.0.0.1:5000/uri-res/random-data"))
+      (signals error
+        (dexador:get "http://127.0.0.1:5000/../../../shadow"))
+      (signals error
+        (dexador:get "http://127.0.0.1:5000/uri-res/../something")))))
+
+
+
+
+
diff --git a/extra/http/package-client.lisp b/extra/http/package-client.lisp
new file mode 100644
index 0000000..e31375b
--- /dev/null
+++ b/extra/http/package-client.lisp
@@ -0,0 +1,3 @@
+(defpackage #:eris-http-client
+  (:use #:common-lisp #:serapeum)
+  (:export #:http-backend))
diff --git a/extra/http/package.lisp b/extra/http/package.lisp
new file mode 100644
index 0000000..5c713ce
--- /dev/null
+++ b/extra/http/package.lisp
@@ -0,0 +1,4 @@
+(defpackage #:eris-http-server
+  (:use #:common-lisp #:serapeum)
+  (:local-nicknames (#:a #:alexandria))
+  (:export #:eris-handler))
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.")))))))))