Allow mounting arbitrary binary blobs

borodust · Aug 6, 2019 · d638589 · d638589
1 parent da90e42
commit d638589
Show file tree

Hide file tree

Showing 3 changed files with 32 additions and 0 deletions.
diff --git a/resources/packages.lisp b/resources/packages.lisp
@@ -17,6 +17,7 @@
            open-resource-stream
            mount-resource-provider
            mount-filesystem
+           mount-binary-resource
            unmount-all
 
            defresource

diff --git a/resources/registry.lisp b/resources/registry.lisp
@@ -27,6 +27,13 @@
                            (make-filesystem-resource-provider filesystem-path)))
 
 
+(defun mount-binary-resource (resource-path byte-array)
+  (when (fad:directory-pathname-p resource-path)
+    (error "Binary resource cannot be a directory"))
+  (mount-resource-provider resource-path
+                           (make-binary-resource-provider byte-array)))
+
+
 (defun unmount-all ()
   (remount-root-node *resource-storage*))
 

diff --git a/resources/storage.lisp b/resources/storage.lisp
@@ -113,6 +113,30 @@
 
 
 
+;;;
+;;; Blob node
+;;;
+(defclass binary-resource-node (path-node)
+  ((data :initarg :data :initform (error ":data missing"))))
+
+
+(defmethod open-resource-stream ((this binary-resource-node) (path null))
+  (with-slots (data) this
+    (flex:make-in-memory-input-stream data)))
+
+
+(defmethod open-resource-stream ((this binary-resource-node) (path cons))
+  (error "Binary resource node has no children"))
+
+
+(defun make-binary-resource-provider (byte-array)
+  (assert (or (typep byte-array '(array (unsigned-byte 8)))
+              (typep byte-array '(array (signed-byte 8)))))
+  (lambda (node-name)
+    (make-instance 'binary-resource-node :name node-name :data byte-array)))
+
+
+
 ;;;
 ;;; Resource storage
 ;;;