new file mode 100644

@@ -0,0 +1 @@

+*.fasl

new file mode 100644

@@ -0,0 +1,25 @@

+;;;; package.lisp

+

+(in-package :fwoar.sp-user)

+

+(defmacro define-package (name &body arguments)

+  (let ((uses (cons :use

+		    (union '(:cl :alexandria :serapeum)

+			   (cdr (assoc :use arguments))))))

+    `(eval-when (:compile-toplevel :load-toplevel :execute)

+       (defpackage ,name

+	 ,uses

+	 ,@(remove :use arguments :key 'car)))))

+

+(define-package :stream-provider

+  (:use :fw.lu)

+  (:export

+   #:get-stream-for

+   #:stream-provider

+   #:string-provider

+   #:file-provider

+   #:stream-key

+   #:root

+   #:streams

+   #:with-storage-stream))

+

new file mode 100644

@@ -0,0 +1,35 @@

+;;;; stream-provider.asd

+

+(cl:defpackage :fwoar.sp-system

+  (:use :cl :asdf))

+(in-package :fwoar.sp-system)

+

+(asdf:defsystem #:stream-provider

+  :description "A class library for interacting with groups of related resources"

+  :author "Edward Langley <el-streamprovider@elangley.org"

+  :license "MIT"

+  :in-order-to ((test-op (test-op "stream-provider.test")))

+  :depends-on (#:fwoar.lisputils

+               #:alexandria

+               #:serapeum

+	       #:uiop

+	       #:flexi-streams

+	       #:vector-update-stream)

+  :serial t

+  :components ((:file "package")

+               (:file "stream-provider")))

+

+(asdf:defsystem #:stream-provider.test

+  :depends-on (#:stream-provider

+	       #:should-test)

+  :serial t

+  :components ((:file "package")

+	       (:file "tests"))

+  :perform (asdf:test-op (o s)

+		    (let ((*package* (find-package :stream-provider.tests)))

+		      (uiop:symbol-call :should-test

+					:test))))

+

+(defpackage :fwoar.sp-user

+  (:use cl)

+  (:export #:define-package))

new file mode 100644

Binary files /dev/null and b/stream-provider.fasl differ

new file mode 100644

@@ -0,0 +1,70 @@

+(fwoar.sp-user:define-package :stream-provider

+  (:use :fw.lu)

+  (:export #:get-stream-for

+	   #:stream-provider

+	   #:string-provider

+	   #:file-provider

+	   #:stream-key

+	   #:root

+	   #:streams

+	   #:with-storage-stream))

+(cl:in-package :stream-provider)

+

+(defclass stream-provider ()

+  ())

+

+(defvar *store-root* *default-pathname-defaults*)

+

+(defgeneric stream-key (provider item)

+  (:documentation "return a key for an item: must be able to be compared with EQUAL

+

+If you override on provider, make sure to CALL-NEXT-METHOD"))

+

+(defgeneric get-stream-for (provider streamable &rest extra-args)

+  (:documentation "get a stream for a given streamable object"))

+

+(defgeneric root (provider)

+  (:documentation "get the base path for the streams"))

+

+

+(defclass string-provider (stream-provider)

+  ((%streams :reader streams :initform (make-hash-table :test 'equal))))

+

+(defmethod root ((provider string-provider))

+  #p "/")

+

+(defmethod stream-key :around (provider item)

+  (let ((key (call-next-method)))

+    (check-type key (or string pathname))

+    (uiop:enough-pathname key (root provider))))

+

+(defmethod get-stream-for ((provider string-provider) streamable &rest extra-args)

+  (declare (ignore extra-args))

+  (with-accessors* (streams) provider

+    (vector-update-stream:make-update-stream 

+     (setf (gethash (stream-key provider streamable) streams)

+	   (make-array 10

+		       :element-type 'octet

+		       :adjustable t

+		       :fill-pointer 0)))))

+

+(defclass file-provider (stream-provider)

+  ((%root :initarg :root :initform (error "need a root for a file-provider") :reader root)

+   (%if-exists :initarg :if-exists :initform :supersede :reader if-exists)))

+

+(defmethod get-stream-for ((provider file-provider) streamable &rest extra-args)

+  (declare (ignore extra-args))

+  (with-accessors* (if-exists root) provider

+    (let ((stream-key (merge-pathnames (stream-key provider streamable)

+				       root)))

+      (when (eql if-exists :if-exists)

+	(ensure-directories-exist stream-key))

+      (open stream-key :direction :output :if-exists if-exists

+	    :element-type 'octet))))

+

+(defmacro with-storage-stream ((stream-sym object provider &rest extra-args) &body body)

+  (once-only (object)

+    `(let ((,stream-sym (flexi-streams:make-flexi-stream (get-stream-for ,provider ,object ,@extra-args)

+							 :external-format :utf-8)))

+       (unwind-protect (progn ,@body)

+	 (close ,stream-sym)))))

new file mode 100644

@@ -0,0 +1,56 @@

+(fwoar.sp-user:define-package :stream-provider.tests

+  (:use :cl :stream-provider :should-test))

+(in-package :stream-provider.tests)

+

+(defparameter *test-string-provider* (make-instance 'string-provider))

+(defparameter *test-file-provider* (make-instance 'file-provider :root #p"/nowhere/"))

+

+(defmethod stream-key ((provider (eql *test-string-provider*)) (item string))

+  item)

+

+(defmethod stream-key ((provider (eql *test-file-provider*)) (item string))

+  item)

+

+(deftest stream-key-returns-specified-pathname ()

+    (let* ((stored-item "foo")

+	   (expected-pathname (pathname "foo")))

+      (should be equal

+	      (stream-key *test-string-provider* stored-item)

+	      expected-pathname)))

+

+

+

+(deftest stream-key-for-file-provider-is-relative-to-root ()

+    (let* ((stored-item "/nowhere/foo")

+	   (expected-pathname (pathname "foo")))

+      (should be equal

+	      expected-pathname

+	      (stream-key *test-file-provider* stored-item))))

+

+(defclass object-to-store ()

+  ((%name :reader name :initarg :name :initform (error "need a name"))

+   (%value :reader value :initarg :value :initform (error "need a value"))))

+

+(defclass test-provider (string-provider)

+  ())

+

+(defmethod stream-key ((provider test-provider) (item object-to-store))

+  (name item))

+

+(defun store (provider item)

+  (with-storage-stream (s item provider)

+    (write-sequence (value item) s)))

+

+(deftest with-storage-stream-writes-to-right-place ()

+    (let* ((name "foo")

+	   (value "bar bar")

+	   (object (make-instance 'object-to-store

+				  :name name

+				  :value value))

+	   (provider (make-instance 'test-provider)))

+      (should be equal

+	      (store provider object)

+	      value

+	      (babel:octets-to-string

+	       (gethash (stream-key provider object)

+			(streams provider))))))