diff options
Diffstat (limited to 'extra/http/server.lisp')
| -rw-r--r-- | extra/http/server.lisp | 78 |
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."))))))))) |