From 1aa5acda7cbbfa00a6b4cde56c6963fa684f391b Mon Sep 17 00:00:00 2001
From: Piotr Szarmanski
Date: Fri, 4 Aug 2023 19:39:32 +0200
Subject: New HTTP backend.
---
extra/http/README | 14 ++++++++
extra/http/client.lisp | 33 +++++++++++++++++
extra/http/eris-http-client.asd | 8 +++++
extra/http/eris-http-server.asd | 27 ++++++++++++++
extra/http/eris-http-tests.asd | 12 +++++++
extra/http/http-tests.lisp | 72 +++++++++++++++++++++++++++++++++++++
extra/http/package-client.lisp | 3 ++
extra/http/package.lisp | 4 +++
extra/http/server.lisp | 78 +++++++++++++++++++++++++++++++++++++++++
9 files changed, 251 insertions(+)
create mode 100644 extra/http/README
create mode 100644 extra/http/client.lisp
create mode 100644 extra/http/eris-http-client.asd
create mode 100644 extra/http/eris-http-server.asd
create mode 100644 extra/http/eris-http-tests.asd
create mode 100644 extra/http/http-tests.lisp
create mode 100644 extra/http/package-client.lisp
create mode 100644 extra/http/package.lisp
create mode 100644 extra/http/server.lisp
(limited to 'extra')
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.")))))))))
--
cgit v1.2.3