summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRobertFischer <>2019-06-11 02:31:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-06-11 02:31:00 (GMT)
commite7a1221a93955ee3578493b7ac19fcdfd45dbf42 (patch)
tree56f27ed17a1c7715caf9a4bd83c1a3d30e61f0c8
version 0.1.0.00.1.0.0
-rw-r--r--ChangeLog.md3
-rw-r--r--LICENSE30
-rw-r--r--README.md41
-rw-r--r--Setup.hs2
-rw-r--r--conduit-vfs.cabal92
-rw-r--r--src/Data/Conduit/VFS.hs6
-rw-r--r--src/Data/Conduit/VFS/Disk.hs132
-rw-r--r--src/Data/Conduit/VFS/Import.hs18
-rw-r--r--src/Data/Conduit/VFS/InMemory.hs250
-rw-r--r--src/Data/Conduit/VFS/Pure.hs161
-rw-r--r--src/Data/Conduit/VFS/Types.hs169
-rw-r--r--test/Spec.hs4
12 files changed, 908 insertions, 0 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
index 0000000..1cd491c
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,3 @@
+# Changelog for conduit-vfs
+
+## Unreleased changes
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..d79c773
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Robert Fischer (c) 2019
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Robert Fischer nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..755d708
--- /dev/null
+++ b/README.md
@@ -0,0 +1,41 @@
+Virtual File System (VFS) Conduit for Haskell
+===============================================
+
+Motivation
+-------------
+
+I was writing a Haskell program to process a _lot_ of JSON-formatted log records: far too many to hold in memory.
+This is a perfect situation for [conduits](https://hackage.haskell.org/package/conduit), so I built out my pipeline. However, I encountered a bit of a hitch: many of the
+files were stored in `.tar.gz` formats, so what I wanted was to recursively navigate into the `.tar.gz` file and feed its embedded files into my pipeline. What would be even
+cooler is if I could slurp in S3 files, or files from Dropbox, or any of that, and then process them all the same way.
+
+Concepts
+----------------
+
+This library is an abstraction of a _filesystem_ that operates via conduits. A _filesystem_ is defined as a particular kind of key-value store. The keys are hierarchical strings,
+with different levels of the hierarchy being seperated by [`</>`](https://hackage.haskell.org/package/filepath-1.4.2.1/docs/System-FilePath-Posix.html#v:-60--47--62-). These
+levels are referred to as _directories_. Directories may be listed and navigated, but are neither directly created nor directly destroyed. The leaf values are lazy
+[`ByteString`](https://hackage.haskell.org/package/bytestring-0.10.8.2/docs/Data-ByteString-Lazy.html) values. These values are referred to as _files_. Files can be listed,
+removed, and written. A file's _path_ consists of the names of its parent directories, from most distant to immediate, concatenated by `</>`. The directories and files
+of a filesystem are that filesystem's _nodes_. A directory that contains no child nodes (ie: an empty directory) may or may not be deleted, which may cause recursive
+deletes of ancestor directories if the ancestor is now empty. When a file is written, any missing directories in the file's path will be created.
+
+Provided Virtual File Systems
+----------------------------------
+
+There are three virtual file system implementations provided as a part of this library:
+
+* `InMemory` -- This filesystem uses an [`MVar`](https://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Concurrent-MVar.html) to store the state of the filesystem in memory. All the data for all the files are currently stored in-memory as the raw bytes: future versions of this library may persist larger files into compressed bytestrings or temp files.
+* `Pure` -- This filesystem uses [`StateT`](https://hackage.haskell.org/package/transformers-0.5.6.2/docs/Control-Monad-Trans-State-Lazy.html#t:StateT) to persist the state of the filesystem. Unlike `InMemory`, the state is not portable and changes in state are not persisted after the monad resolves. However, this implementation is pure, which means it can be used with pure conduits or as a way to make testing faster and idempotent.
+* `Disk` -- This virtual file system is the traditional disk-based filesystem, with folders persisted to the operating system's filesystem.
+
+Other Virtual File Systems
+-------------------------------
+
+There are other VFS implementations in the works:
+
+* `Zip` -- Treat a `.zip` file as a filesystem, and provide conduits that will auto-expand zip entries provided by upstream VFS conduits.
+* `Tar` -- Treat a `.tar` file as a filesystem, and provide conduits that will auto-expand tar entries provided by upstream VFS conduits.
+* `S3` -- Treat an AWS S3 bucket as a filesystem.
+
+In addition, we are looking to implement a conduit which automatically uncompresses or compresses `.xz`, `.lzma`, `.z`, and `.gz` files provided by upstream VFS conduits.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/conduit-vfs.cabal b/conduit-vfs.cabal
new file mode 100644
index 0000000..80e6b6f
--- /dev/null
+++ b/conduit-vfs.cabal
@@ -0,0 +1,92 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.1.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: d5ff2926f65d6c16492376bb9e8b49711141e501f5a901b216e1f103337b5dcf
+
+name: conduit-vfs
+version: 0.1.0.0
+synopsis: Virtual file system for Conduit; disk, pure, and in-memory impls.
+description: The goal of this package is to provide a common library and the core implementations for things that can be made to look like filesystems. In this package, a "filesystem" is tree of nodes, where the leaf nodes are files and the rest are directories. A "directory" is defined as a node that contains other nodes, and those other nodes are each keyed by a name. A "file" is defined as a collection of (possibly empty) bytes.
+ This package includes the core types for a Virtual File System (VFS) abstraction for conduit, along with three implementations. The implementations are "disk" (write to the underlying filesystem), "in-memory" (store files in an MVar), and "pure" (pass state in a State monad). Because of the nature of conduits, this library defaults to lazy implementations of various data structures, including lazy ByteStrings and lazy HashMaps. Any overhead in space should be more than warranted by the savings through just-in-time computations.
+ For more information, see the README on GitHub at <https://github.com/RobertFischer/vfs-conduit#README.md>
+category: Conduit, IO, Filesystem
+homepage: https://github.com/RobertFischer/vfs-conduit#readme
+bug-reports: https://github.com/RobertFischer/vfs-conduit/issues
+author: Robert Fischer
+maintainer: smokejumperit@gmail.com
+copyright: (c)2019 Robert Fischer. All Rights Reserved. See LICENSE for liscensing terms.
+license: BSD3
+license-file: LICENSE
+build-type: Simple
+extra-source-files:
+ README.md
+ ChangeLog.md
+
+source-repository head
+ type: git
+ location: https://github.com/RobertFischer/vfs-conduit
+
+library
+ exposed-modules:
+ Data.Conduit.VFS
+ Data.Conduit.VFS.Disk
+ Data.Conduit.VFS.Import
+ Data.Conduit.VFS.InMemory
+ Data.Conduit.VFS.Pure
+ Data.Conduit.VFS.Types
+ other-modules:
+ Paths_conduit_vfs
+ hs-source-dirs:
+ src
+ default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TypeFamilies TypeSynonymInstances ViewPatterns TemplateHaskell TupleSections UnboxedTuples QuasiQuotes DeriveLift ExtendedDefaultRules
+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -optP-Wno-nonportable-include-path -fno-warn-type-defaults -fno-warn-tabs -fno-warn-unused-top-binds
+ build-depends:
+ base >=4.7 && <5
+ , bytestring >=0.10.8.2 && <0.11
+ , classy-prelude >=1.5.0 && <1.6
+ , conduit >=1.3.1.1 && <1.4
+ , conduit-extra >=1.3.1.1 && <1.4
+ , directory >=1.3.3.0 && <1.4
+ , extra >=1.6.16 && <1.7
+ , filepath >=1.4.2.1 && <1.5
+ , monad-loops >=0.4.3 && <0.5
+ , mono-traversable >=1.0.11.0 && <1.1
+ , resourcet >=1.2.2 && <1.3
+ , text >=1.2.3.1 && <1.3
+ , transformers >=0.5.6.2 && <0.6
+ , unix >=2.7.2.2 && <2.8
+ , unliftio >=0.2.10 && <0.3
+ , unordered-containers >=0.2.10.0 && <0.3
+ default-language: Haskell2010
+
+test-suite conduit-vfs-test
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ other-modules:
+ Paths_conduit_vfs
+ hs-source-dirs:
+ test
+ default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TypeFamilies TypeSynonymInstances ViewPatterns TemplateHaskell TupleSections UnboxedTuples QuasiQuotes DeriveLift ExtendedDefaultRules
+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -optP-Wno-nonportable-include-path -fno-warn-type-defaults -fno-warn-tabs -fno-warn-unused-top-binds -threaded -rtsopts -with-rtsopts=-N
+ build-depends:
+ base >=4.7 && <5
+ , bytestring >=0.10.8.2 && <0.11
+ , classy-prelude >=1.5.0 && <1.6
+ , conduit >=1.3.1.1 && <1.4
+ , conduit-extra >=1.3.1.1 && <1.4
+ , conduit-vfs
+ , directory >=1.3.3.0 && <1.4
+ , extra >=1.6.16 && <1.7
+ , filepath >=1.4.2.1 && <1.5
+ , monad-loops >=0.4.3 && <0.5
+ , mono-traversable >=1.0.11.0 && <1.1
+ , resourcet >=1.2.2 && <1.3
+ , text >=1.2.3.1 && <1.3
+ , transformers >=0.5.6.2 && <0.6
+ , unix >=2.7.2.2 && <2.8
+ , unliftio >=0.2.10 && <0.3
+ , unordered-containers >=0.2.10.0 && <0.3
+ default-language: Haskell2010
diff --git a/src/Data/Conduit/VFS.hs b/src/Data/Conduit/VFS.hs
new file mode 100644
index 0000000..21b1038
--- /dev/null
+++ b/src/Data/Conduit/VFS.hs
@@ -0,0 +1,6 @@
+module Data.Conduit.VFS
+( module Data.Conduit.VFS.Types
+) where
+
+import Data.Conduit.VFS.Import
+import Data.Conduit.VFS.Types
diff --git a/src/Data/Conduit/VFS/Disk.hs b/src/Data/Conduit/VFS/Disk.hs
new file mode 100644
index 0000000..f2c95e5
--- /dev/null
+++ b/src/Data/Conduit/VFS/Disk.hs
@@ -0,0 +1,132 @@
+{-|
+Description: VFS interface to the local filesystem (conventionally but increasingly wrongly called "writing to disk").
+
+Read operations are not atomic, but write operations are probably atomic. Specifically, reads acquire a 'SharedLock' via 'hLock'. Writes first persist to a
+temporary file, and then perform a copy using 'copyFileWithMetadata'. If 'copyFileWithMetadata' is atomic on your implementation (it probably is), then
+writes are atomic.
+
+The 'FilePath' values used in this VFS are split using 'splitPath' and joined using '</>'. Relative paths are resolved relative to the current working
+directory: changing that directory is outside the scope of this module.
+
+-}
+module Data.Conduit.VFS.Disk
+ ( DiskVFS
+ , runDiskVFS
+ , runDiskVFS_
+ ) where
+
+
+import ClassyPrelude hiding (ByteString, handle, hash, bracket)
+import Control.Monad.Extra (ifM)
+import Control.Monad.Fail (MonadFail)
+import Control.Monad.Loops (whileM_)
+import Data.Conduit.VFS.Import
+import System.IO.Extra (openBinaryFile)
+import System.Posix (getFileStatus, isRegularFile, isDirectory)
+import System.Directory (removeFile)
+import UnliftIO.Directory (doesFileExist, listDirectory)
+import qualified Data.ByteString as SBS
+import qualified Data.ByteString.Lazy as LBS
+
+-- | The basic implementation of the VFS.
+newtype DiskVFS m a = DiskVFS { unDVFS :: m a }
+ deriving (Applicative, Functor, MonadFail, Monad)
+
+instance (MonadIO m) => MonadIO (DiskVFS m) where
+ liftIO = DiskVFS . liftIO
+ {-# INLINE liftIO #-}
+
+instance (MonadUnliftIO m) => MonadUnliftIO (DiskVFS m) where
+ askUnliftIO = do
+ (UnliftIO interiorUnliftIO) <- lift askUnliftIO
+ return $ UnliftIO $ \(DiskVFS interior) -> interiorUnliftIO interior
+ {-# INLINE askUnliftIO #-}
+
+instance MonadTrans DiskVFS where
+ lift = DiskVFS
+ {-# INLINE lift #-}
+
+-- | Given a 'DiskVFS', run it in the local monad and return the monadic return value.
+runDiskVFS :: DiskVFS m a -> m a
+runDiskVFS = unDVFS
+{-# INLINE runDiskVFS #-}
+
+-- | Given a 'DiskVFS', run it in the local monad and disregard any results.
+runDiskVFS_ :: (Monad m) => DiskVFS m a -> m ()
+runDiskVFS_ = void . runDiskVFS
+{-# INLINE runDiskVFS_ #-}
+
+instance (MonadUnliftIO m) => ReadVFSC (DiskVFS m) where
+
+ vfsTypeC = awaitForever $ \filepath -> fmap (filepath,) . liftIO $
+ ifM
+ (not <$> doesFileExist filepath)
+ (return Nothing)
+ $ getFileStatus filepath >>= \status ->
+ if isRegularFile status then
+ return $ Just VFile
+ else if isDirectory status then
+ return $ Just VDirectory
+ else
+ return Nothing
+ {-# INLINEABLE vfsTypeC #-}
+
+ vfsContentsEitherC = awaitForever $ \filepath ->
+ whenM (isExistingRegularFile filepath)
+ $ do
+ yield $ Left filepath
+ handle <- liftIO $ openBinaryFile filepath ReadMode
+ liftIO $ hSetBuffering handle (BlockBuffering Nothing)
+ whileM_
+ (hIsNotEOF handle)
+ (doRead handle >>= yield . Right . LBS.fromStrict)
+ where
+ hIsNotEOF handle = liftIO $ not <$> hIsEOF handle
+ doRead h = liftIO $ SBS.hGetSome h 1024
+ {-# INLINEABLE vfsContentsEitherC #-}
+
+ vfsChildrenC = awaitForever $ \filepath ->
+ whenM (liftIO $ doesFileExist filepath) $
+ ifM
+ (fileIsDirectory filepath)
+ (listChildren filepath >>= yieldMany)
+ (yield filepath)
+ where
+ fileIsDirectory filepath = liftIO $ isDirectory <$> getFileStatus filepath
+ listChildren filepath = liftIO $ do
+ (children::[FilePath]) <- listDirectory filepath
+ return $ (filepath </>) <$> children
+ {-# INLINEABLE vfsChildrenC #-}
+
+-- | A class denoting that the type is usable as VFS conduits for writing.
+instance (MonadUnliftIO m) => WriteVFSC (DiskVFS m) where
+
+ vfsWriteEitherSink = awaitForever $ \case
+ (Right _) -> fail "Encountered bytes without seeing a filename"
+ (Left filename) -> do
+ bytes <- readAllBytesFromUpstream
+ liftIO $ LBS.writeFile filename bytes
+ where
+ readAllBytesFromUpstream =
+ ifM
+ moreBytesFromUpstream
+ (readSomeBytesFromUpstream >>= \prev -> LBS.append prev <$> readAllBytesFromUpstream )
+ (return mempty)
+ moreBytesFromUpstream = peekC >>= \case
+ (Just (Right _)) -> return True
+ _ -> return False
+ readSomeBytesFromUpstream = await >>= \case
+ (Just (Right bytes)) -> return bytes
+ _ -> fail "Encountered a new filename when peeking said we had bytes"
+ {-# INLINEABLE vfsWriteEitherSink #-}
+
+ vfsRemoveSink = awaitForever $ \filename ->
+ whenM (isExistingRegularFile filename) (liftIO $ removeFile filename)
+ {-# INLINE vfsRemoveSink #-}
+
+isExistingRegularFile :: MonadIO m => FilePath -> m Bool
+isExistingRegularFile filepath = liftIO $ liftM2 (&&) (doesFileExist filepath) (isRegularFile <$> getFileStatus filepath)
+
+-- | A class denoting that the type is usable as VFS conduits for reading and writing.
+instance (MonadUnliftIO m) => VFSC (DiskVFS m)
+
diff --git a/src/Data/Conduit/VFS/Import.hs b/src/Data/Conduit/VFS/Import.hs
new file mode 100644
index 0000000..265d332
--- /dev/null
+++ b/src/Data/Conduit/VFS/Import.hs
@@ -0,0 +1,18 @@
+{-|
+
+Description: The common imports for this library's files.
+
+-}
+
+module Data.Conduit.VFS.Import
+( module Data.Conduit.VFS.Types
+, module Conduit
+, (&)
+) where
+
+import ClassyPrelude
+import Data.Conduit.VFS.Types
+import Conduit
+
+(&) :: a -> (a -> b) -> b
+(&) a f = f a
diff --git a/src/Data/Conduit/VFS/InMemory.hs b/src/Data/Conduit/VFS/InMemory.hs
new file mode 100644
index 0000000..057ed76
--- /dev/null
+++ b/src/Data/Conduit/VFS/InMemory.hs
@@ -0,0 +1,250 @@
+{-|
+Description: VFS persisted in-memory
+
+This is intended to demonstrate how a VFS can be defined, but is also entirely usable in code if you find its functionality useful.
+
+This VFS implementation stores its values in a lazy in-memory map, which is itself persisted into an 'MVar' and captured in the monadic state.
+This requires the monad to be in the class 'MonadUnliftIO', but that allows the state to be shared throughout the application, maintaining
+value consistency across threads and even across invocations.
+
+Individual read and write operations are atomic.
+
+The 'FilePath' values used in this VFS are split using 'splitPath' and joined using '</>', but are otherwise used directly: there is no concept of
+paths being "relative" or "absolute" for this VFS. It is also possible for a file and a directory to have the same name, since directories names
+are appended with @/@, as per 'splitPath'. (This implementation detail is up for debate and may be changed in a future major release: please file
+an issue if you want to have a discussion around it.)
+
+-}
+module Data.Conduit.VFS.InMemory
+ ( InMemoryVFS
+ , InMemoryVFSRoot
+ , runInMemoryVFS
+ , runInMemoryVFS'
+ , mkInMemoryVFSRoot
+ ) where
+
+import ClassyPrelude hiding (ByteString, handle)
+import Control.Monad.Extra (ifM)
+import Data.Conduit.VFS.Import
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.HashMap.Lazy as HashMap
+import Data.HashMap.Lazy (HashMap)
+import System.FilePath (splitPath)
+import Control.Monad.Fail (MonadFail)
+import qualified Data.Text as Text
+
+-- | The possible kinds of nodes
+data IMNode
+ = IMNodeDir IMDirectory -- ^ VDirectory
+ | IMNodeFile IMFile -- ^ VFile
+
+-- | How is the data stored?
+data IMFile
+ = Resident ByteString -- ^ Data is stored resident in memory
+ | EmptyFile -- ^ Data is empty
+
+-- | Definition of a directory
+newtype IMDirectory = IMDirectory
+ { imdNodes :: HashMap Text IMNode -- ^ The nodes contained within the directory
+ }
+
+instance Semigroup IMDirectory where
+ -- | Right-biased, but with directories recursively merged.
+ (<>) imdLeft imdRight =
+ IMDirectory { imdNodes = HashMap.unionWith mergeImpl nodeLeft nodeRight }
+ where
+ nodeLeft = imdNodes imdLeft
+ nodeRight = imdNodes imdRight
+ mergeImpl (IMNodeDir nodeDirLeft) (IMNodeDir nodeDirRight) = IMNodeDir $ nodeDirLeft <> nodeDirRight -- Recursively merge two dirs
+ mergeImpl _ right = right -- Default to the right if there's any other kind of conflict.
+ {-# INLINE (<>) #-}
+
+instance Monoid IMDirectory where
+ mempty = IMDirectory { imdNodes = mempty }
+ {-# INLINE mempty #-}
+
+type instance Element IMDirectory = (Text, IMNode)
+
+instance MonoFunctor IMDirectory where
+ omap f oldImd = IMDirectory{ imdNodes = HashMap.fromList (f <$> HashMap.toList (imdNodes oldImd)) }
+ {-# INLINE omap #-}
+
+{- TODO Implement the MonoFoldable methods.
+instance MonoFoldable IMDirectory where
+ otoList IMDirectory{imdNodes} = toList imdNodes
+ {-# INLINE otoList #-}
+-}
+
+instance MonoPointed IMDirectory where
+ opoint (k,v) = IMDirectory { imdNodes = HashMap.singleton k v }
+ {-# INLINE opoint #-}
+
+-- | The root of the VFS.
+newtype InMemoryVFSRoot = InMemoryVFSRoot { imvfsStore :: MVar IMDirectory }
+
+-- | The basic implementation of the VFS.
+newtype InMemoryVFS m a = InMemoryVFS
+ { unIMVFS :: ReaderT InMemoryVFSRoot m a }
+ deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadFail, MonadReader InMemoryVFSRoot)
+
+-- | Creates an 'InMemoryVFSRoot' that can be shared among many 'InMemoryVFS' invocations.
+mkInMemoryVFSRoot :: (MonadIO m) => m InMemoryVFSRoot
+mkInMemoryVFSRoot = do
+ mvar <- newMVar mempty
+ return $ InMemoryVFSRoot { imvfsStore = mvar }
+{-# INLINE mkInMemoryVFSRoot #-}
+
+-- | Given an 'InMemoryVFS', run it in the local monad.
+runInMemoryVFS :: (MonadUnliftIO m) => InMemoryVFS m a -> m a
+runInMemoryVFS imvfs = mkInMemoryVFSRoot >>= flip runInMemoryVFS' imvfs
+{-# INLINE runInMemoryVFS #-}
+
+-- | Runs an 'InMemoryVFS' using a provided 'InMemoryVFSRoot'.
+runInMemoryVFS' :: InMemoryVFSRoot -> InMemoryVFS m a -> m a
+runInMemoryVFS' root imvfs =
+ let monad = unIMVFS imvfs in
+ runReaderT monad root
+{-# INLINE runInMemoryVFS' #-}
+
+-- | Takes a function that consumes the root dir and produces a monadic action, and then returns that monadic
+-- action as an 'InMemoryVFS'.
+withIMVFSRootDir :: (MonadUnliftIO m) => ( IMDirectory -> m a ) -> InMemoryVFS m a
+withIMVFSRootDir f = do
+ mvar <- imvfsStore <$> ask
+ rootDir <- readMVar mvar
+ lift $ f rootDir
+{-# INLINE withIMVFSRootDir #-}
+
+-- | Takes a function that consumes the root dir, produces a new root dir as a monadic action, and then returns
+-- that monadic action as an 'InMemoryVFS'.
+modifyIMVFSRootDir :: (MonadUnliftIO m) => ( IMDirectory -> m IMDirectory ) -> InMemoryVFS m ()
+modifyIMVFSRootDir f = do
+ mvar <- imvfsStore <$> ask
+ lift $ modifyMVar_ mvar f
+{-# INLINE modifyIMVFSRootDir #-}
+
+instance (MonadUnliftIO m) => ReadVFSC (InMemoryVFS m) where
+
+ vfsTypeC = awaitForever $ \filepath -> do
+ result <- lift $ withIMVFSRootDir $ return . loop (splitPath filepath)
+ yield (filepath, result)
+ where
+ loop :: [FilePath] -> IMDirectory -> Maybe VFileType
+ loop [] (IMDirectory _) = Just VDirectory
+ loop ("/":rest) imd = loop rest imd
+ loop (nextDirPath:rest) IMDirectory{imdNodes} =
+ case HashMap.lookup (Text.pack nextDirPath) imdNodes of
+ Nothing -> Nothing
+ (Just imnode) ->
+ case imnode of
+ (IMNodeDir imd) -> loop rest imd
+ (IMNodeFile _)
+ | null rest -> Just VFile
+ | otherwise -> Nothing
+ {-# INLINEABLE vfsTypeC #-}
+
+ vfsContentsC = awaitForever $ \filepath -> do
+ result <- lift $ withIMVFSRootDir $ loop (splitPath filepath)
+ case result of
+ Nothing -> return ()
+ (Just resultLBS) -> yield (filepath, resultLBS)
+ where
+ loop :: [FilePath] -> IMDirectory -> m (Maybe ByteString)
+ loop [] _ = return Nothing
+ loop [filename] IMDirectory{imdNodes} =
+ case HashMap.lookup (Text.pack filename) imdNodes of
+ Nothing -> return Nothing
+ (Just (IMNodeDir _)) -> return Nothing
+ (Just (IMNodeFile fileData)) ->
+ case fileData of
+ (Resident bytes) -> return (Just bytes)
+ EmptyFile -> return (Just mempty)
+ loop (dirname:rest) IMDirectory{imdNodes} =
+ case HashMap.lookup (Text.pack dirname) imdNodes of
+ (Just (IMNodeDir imd)) -> loop rest imd
+ _ -> return Nothing
+ {-# INLINEABLE vfsContentsC #-}
+
+ vfsContentsEitherC = awaitForever $ \filepath -> do
+ maybeResult <- lift $ withIMVFSRootDir $ loop (splitPath filepath)
+ case maybeResult of
+ Nothing -> return ()
+ (Just bytes) -> do
+ yield $ Left filepath
+ yield $ Right bytes
+ where
+ loop :: [FilePath] -> IMDirectory -> m (Maybe ByteString)
+ loop [] _ = return Nothing
+ loop [filename] IMDirectory{imdNodes} =
+ case HashMap.lookup (Text.pack filename) imdNodes of
+ Nothing -> return Nothing
+ (Just (IMNodeDir _)) -> return Nothing
+ (Just (IMNodeFile filedata)) ->
+ case filedata of
+ (Resident bytes) -> return $ Just bytes
+ EmptyFile -> return $ Just mempty
+ loop (dirname:rest) IMDirectory{imdNodes} =
+ case HashMap.lookup (Text.pack dirname) imdNodes of
+ (Just (IMNodeDir imd)) -> loop rest imd
+ _ -> return Nothing
+ {-# INLINEABLE vfsContentsEitherC #-}
+
+ vfsChildrenC = awaitForever $ \filepath ->
+ lift ( withIMVFSRootDir $ return . loop filepath (splitPath filepath) ) >>= yieldMany
+ where
+ loop :: FilePath -> [FilePath] -> IMDirectory -> [FilePath]
+ loop _ [] IMDirectory{imdNodes} = Text.unpack <$> HashMap.keys imdNodes
+ loop filepath (foo:rest) IMDirectory{imdNodes} =
+ case HashMap.lookup (Text.pack foo) imdNodes of
+ (Just (IMNodeDir imd@(IMDirectory dir)))
+ | null rest -> (filepath </>) . Text.unpack <$> HashMap.keys dir
+ | otherwise -> loop filepath rest imd
+ _ -> mempty
+ {-# INLINEABLE vfsChildrenC #-}
+
+-- | A class denoting that the type is usable as VFS conduits for writing.
+instance (MonadUnliftIO m) => WriteVFSC (InMemoryVFS m) where
+
+ vfsWriteEitherSink = awaitForever $ \case
+ (Right _) -> return () -- Ignore: bytes without a file they belong to!
+ (Left filepath) -> awaitBytes >>= \bytes ->
+ let imfile =
+ if null bytes then
+ EmptyFile
+ else
+ Resident bytes
+ in
+ lift $ modifyIMVFSRootDir $ return . loop (IMNodeFile imfile) (splitPath filepath)
+ where
+ hasMoreBytes = peekC >>= \case
+ (Just (Right _)) -> return True
+ _ -> return False
+ awaitBytes =
+ flip (ifM hasMoreBytes) (return mempty) $
+ await >>= \case
+ (Just (Right bytes)) -> LBS.append bytes <$> awaitBytes
+ _ -> fail "We should have more bytes, but we don't."
+ loop _ [] imd = imd
+ loop node [filename] imd@IMDirectory{imdNodes} = imd { imdNodes = HashMap.insert (Text.pack filename) node imdNodes }
+ loop node (name:rest) imd@IMDirectory{imdNodes} = imd { imdNodes = HashMap.alter
+ (\case
+ Nothing -> Just . IMNodeDir . loop node rest $ IMDirectory { imdNodes=mempty }
+ (Just (IMNodeDir childImd)) -> Just . IMNodeDir $ loop node rest childImd
+ whatever -> whatever
+ ) (Text.pack name) imdNodes }
+ {-# INLINEABLE vfsWriteEitherSink #-}
+
+ vfsRemoveSink = awaitForever $ \filepath -> lift . modifyIMVFSRootDir $ return . loop (splitPath filepath)
+ where
+ loop [] imd = imd
+ loop [filename] imd@IMDirectory{imdNodes} = imd { imdNodes = HashMap.delete (Text.pack filename) imdNodes }
+ loop (name:rest) imd@IMDirectory{imdNodes} = imd
+ { imdNodes = HashMap.adjust
+ (\case
+ (IMNodeDir childImd) -> IMNodeDir $ loop rest childImd
+ whatever -> whatever
+ ) (Text.pack name) imdNodes
+ }
+ {-# INLINE vfsRemoveSink #-}
+
+instance (MonadUnliftIO m) => VFSC (InMemoryVFS m)
diff --git a/src/Data/Conduit/VFS/Pure.hs b/src/Data/Conduit/VFS/Pure.hs
new file mode 100644
index 0000000..ea5f2f5
--- /dev/null
+++ b/src/Data/Conduit/VFS/Pure.hs
@@ -0,0 +1,161 @@
+{-|
+Description: VFS persisted purely through 'StateT'
+
+This is intended primarily to be a drop-in testing mock for VFS implementations, but you may also find it useful within your program if you want to
+work with some hierarchically-organized data.
+
+Individual read and write operations are atomic.
+
+The 'FilePath' values used in this VFS are split using 'splitPath' and joined using '</>', but are otherwise used directly: there is no concept of
+paths being "relative" or "absolute" for this VFS. It is also possible for a file and a directory to have the same name, since directories names
+are appended with @/@, as per 'splitPath'. (This implementation detail is up for debate and may be changed in a future major release: please file
+an issue if you want to have a discussion around it.)
+
+-}
+module Data.Conduit.VFS.Pure
+ ( PureVFS
+ , runPureVFS
+ , runPureVFS'
+ , runPureVFS_
+ ) where
+
+import Control.Monad.Trans.State.Lazy
+import ClassyPrelude hiding (ByteString, handle, hash)
+import Data.Conduit.VFS.Import
+import qualified Data.HashMap.Lazy as HashMap
+import Data.HashMap.Lazy (HashMap)
+import Control.Monad.Extra (whenJust, maybeM)
+import Control.Monad.Fail (MonadFail)
+import System.FilePath (splitPath, (</>))
+import qualified Data.Text as Text
+
+-- | The possible kinds of nodes
+data PNode
+ = PNodeDir (HashMap Text PNode) -- ^ A directory
+ | PNodeFile ByteString -- ^ A file
+
+-- | The basic implementation of the VFS.
+newtype PureVFS m a = PureVFS
+ { unPVFS :: StateT PNode m a }
+ deriving (Applicative, Functor, MonadFail, Monad, MonadTrans)
+
+-- | Given a 'PureVFS', run it in the local monad and return both the monadic return value and the root node of the VFS.
+runPureVFS :: PureVFS m a -> m (a, PNode)
+runPureVFS pvfs = runStateT (unPVFS pvfs) (PNodeDir mempty)
+{-# INLINE runPureVFS #-}
+
+-- | Given a 'PureVFS', run it in the local monad and return the root node of the VFS.
+runPureVFS' :: (Monad m) => PureVFS m a -> m PNode
+runPureVFS' pvfs = execStateT (unPVFS pvfs) (PNodeDir mempty)
+{-# INLINE runPureVFS' #-}
+
+-- | Given a 'PureVFS', run it in the local monad and disregard any results.
+runPureVFS_ :: (Monad m) => PureVFS m a -> m ()
+runPureVFS_ = void . runPureVFS
+{-# INLINE runPureVFS_ #-}
+
+-- | Retrieves the root of the 'PureVFS'.
+getRoot :: (Monad m) => PureVFS m PNode
+getRoot = PureVFS get
+{-# INLINE getRoot #-}
+
+-- | Sets the root of the 'PureVFS' and returns the new root
+setRoot :: (Monad m) => PNode -> PureVFS m PNode
+setRoot newRoot = setRoot_ newRoot >> return newRoot
+{-# INLINE setRoot #-}
+
+-- | Sets the root of the 'PureVFS' without returning it
+setRoot_ :: (Monad m) => PNode -> PureVFS m ()
+setRoot_ = PureVFS . put
+{-# INLINE setRoot_ #-}
+
+-- | Changes the root without providing any return value
+modifyRoot_ :: (Monad m) => (PNode -> PureVFS m PNode) -> PureVFS m ()
+modifyRoot_ f = getRoot >>= f >>= PureVFS . put -- Oh, right: StateT doesn't have concurrency problems. Sweet!
+{-# INLINE modifyRoot_ #-}
+
+-- | Changes the root and provides the updated value.
+modifyRoot :: (Monad m) => (PNode -> PureVFS m PNode) -> PureVFS m PNode
+modifyRoot f = modifyRoot_ f >> getRoot
+{-# INLINE modifyRoot #-}
+
+getNodeC :: (Monad m) => FilePath -> ConduitT i o (PureVFS m) (Maybe PNode)
+getNodeC = lift . getNode
+{-# INLINE getNodeC #-}
+
+getNode :: (Monad m) => FilePath -> PureVFS m (Maybe PNode)
+getNode filepath = loop (splitPath filepath) <$> getRoot
+ where
+ loop [] _ = Nothing
+ loop _ (PNodeFile _) = Nothing
+ loop [filename] (PNodeDir hash) = HashMap.lookup (Text.pack filename) hash
+ loop (dirname:rest) (PNodeDir hash) = HashMap.lookup (Text.pack dirname) hash >>= loop rest
+{-# INLINE getNode #-}
+
+modifyNodeC_ :: (Monad m) => FilePath -> (Maybe PNode -> PureVFS m (Maybe PNode)) -> ConduitT i o (PureVFS m) ()
+modifyNodeC_ filepath f = lift $ modifyNode_ filepath f
+{-# INLINE modifyNodeC_ #-}
+
+modifyNode_ :: (Monad m) => FilePath -> (Maybe PNode -> PureVFS m (Maybe PNode)) -> PureVFS m ()
+modifyNode_ filepath f = modifyRoot_ $ loop (splitPath filepath)
+ where
+ loop [] node = return node
+ loop _ file@(PNodeFile _) = return file
+ loop (nodename:rest) dir@(PNodeDir hash) = case HashMap.lookup (Text.pack nodename) hash of
+ Nothing -> case rest of
+ [] ->
+ maybeM
+ (return dir)
+ (\result -> return . PNodeDir $ HashMap.insert (Text.pack nodename) result hash)
+ (f (Just dir))
+ (restHead:restTail) ->
+ loop restTail (PNodeDir mempty) >>= \result ->
+ return . PNodeDir $ HashMap.insert (Text.pack nodename) (PNodeDir $ HashMap.singleton (Text.pack restHead) result) hash
+ (Just node) -> loop rest node >>= \result -> return $ PNodeDir $ HashMap.insert (Text.pack nodename) result hash
+{-# INLINEABLE modifyNode_ #-}
+
+modifyNodeC :: (Monad m) => FilePath -> (Maybe PNode -> PureVFS m (Maybe PNode)) -> ConduitT i o (PureVFS m) (Maybe PNode)
+modifyNodeC filepath f = lift $ modifyNode filepath f
+{-# INLINE modifyNodeC #-}
+
+-- | Updates the node at the given filepath and then returns the updated node.
+modifyNode :: (Monad m) => FilePath -> (Maybe PNode -> PureVFS m (Maybe PNode)) -> PureVFS m (Maybe PNode)
+modifyNode filepath f = modifyNode_ filepath f >> getNode filepath
+{-# INLINE modifyNode #-}
+
+instance (Monad m) => ReadVFSC (PureVFS m) where
+
+ vfsTypeC = awaitForever $ \filepath -> do
+ maybeNode <- getNodeC filepath
+ yield (filepath, toType <$> maybeNode)
+ where
+ toType (PNodeDir _) = VDirectory
+ toType (PNodeFile _) = VFile
+ {-# INLINE vfsTypeC #-}
+
+ vfsContentsC = awaitForever $ \filepath -> do
+ maybeResult <- getNodeC filepath
+ whenJust maybeResult $ \case
+ (PNodeFile bytes) -> yield (filepath, bytes)
+ (PNodeDir _) -> return ()
+ {-# INLINE vfsContentsC #-}
+
+ vfsChildrenC = awaitForever $ \filepath -> do
+ maybeNode <- getNodeC filepath
+ case maybeNode of
+ Nothing -> yield filepath
+ (Just (PNodeFile _)) -> yield filepath
+ (Just (PNodeDir hash)) -> yieldMany $ (filepath </>) . Text.unpack <$> HashMap.keys hash
+ {-# INLINE vfsChildrenC #-}
+
+-- | A class denoting that the type is usable as VFS conduits for writing.
+instance (Monad m) => WriteVFSC (PureVFS m) where
+
+ vfsWriteSink = awaitForever $ \(filepath, bs) -> modifyNodeC_ filepath (const . return . Just $ PNodeFile bs)
+ {-# INLINE vfsWriteSink #-}
+
+ vfsRemoveSink = awaitForever $ flip modifyNodeC_ (const $ return Nothing)
+ {-# INLINE vfsRemoveSink #-}
+
+-- | A class denoting that the type is usable as VFS conduits for reading and writing.
+instance (Monad m) => VFSC (PureVFS m)
diff --git a/src/Data/Conduit/VFS/Types.hs b/src/Data/Conduit/VFS/Types.hs
new file mode 100644
index 0000000..71cf6f9
--- /dev/null
+++ b/src/Data/Conduit/VFS/Types.hs
@@ -0,0 +1,169 @@
+{-|
+
+Description: The types that make up this library.
+
+-}
+
+module Data.Conduit.VFS.Types
+( FilePath
+, ConduitT
+, VFSSource
+, VFSPipe
+, VFSSink
+, VFileType(..)
+, ReadVFSC(..)
+, WriteVFSC(..)
+, VFSC(..)
+, ByteString
+) where
+
+import ClassyPrelude hiding (ByteString)
+import System.FilePath (FilePath, takeDirectory)
+import Conduit
+import qualified Data.ByteString.Lazy as LBS
+import Data.Either (fromRight)
+import Control.Monad.Extra (ifM)
+
+type ByteString = LBS.ByteString
+
+-- | The type of conduits that generate file paths.
+type VFSSource m = ConduitT Void FilePath m ()
+
+-- | The type of conduits that consume file paths and generate file paths.
+type VFSPipe m = ConduitT FilePath FilePath m ()
+
+-- | The type of conduits that consume file paths.
+type VFSSink m r = ConduitT FilePath Void m r
+
+-- | The types that our virtual file system supports.
+data VFileType
+ = VFile -- ^ A node containing bytes
+ | VDirectory -- ^ A node containing zero or more other nodes
+ deriving (Eq, Ord, Show, Generic, Typeable, Enum, Bounded)
+
+-- | A class denoting that the type is usable as VFS conduits for reading.
+class (Monad m) => ReadVFSC m where
+
+ {-# MINIMAL ( vfsContentsEitherC | vfsContentsC ), vfsTypeC, ( vfsChildrenC | vfsDescendentsC ) #-}
+
+ -- | Given an input path, generates a tuple of the input path itself and the input path's 'VFileType' (or 'Nothing' if the node does not exist).
+ -- Note that a directory containing no elements may be reported by the VFS as not existing.
+ vfsTypeC :: ConduitT FilePath (FilePath, Maybe VFileType) m ()
+
+ -- | Given an input of 'FilePath' files, generates a tuple containing the input and the bytestring for the contents of the file.
+ -- Note that the entire contents of the file are pulled into memory. If the input 'FilePath' does not denote a 'VFile', it should be dropped.
+ vfsContentsC :: ConduitT FilePath (FilePath, LBS.ByteString) m ()
+ vfsContentsC = awaitForever $ \path -> do
+ bytes <- yield path .| vfsContentsEitherC .| mapC (fromRight mempty) .| foldC
+ yield (path, bytes)
+ {-# INLINEABLE vfsContentsC #-}
+
+ -- | Given an input of 'FilePath' files, generates a 'Left' of the input, followed by zero or more 'Right' values holding a bytestring. The concatenation of the
+ -- 'Right' values after a given 'Left' and before the next 'Left' (or EOS) are the bytes of the input value. If the input 'FilePath' does not denote a 'VFile',
+ -- it should be dropped.
+ vfsContentsEitherC :: ConduitT FilePath (Either FilePath LBS.ByteString) m ()
+ vfsContentsEitherC = awaitForever $ \path -> do
+ yield $ Left path
+ bytes <- yield path .| vfsContentsC .| mapC snd .| foldC
+ yield $ Right bytes
+ {-# INLINEABLE vfsContentsEitherC #-}
+
+ -- | Given an input of 'FilePath' directories, generates the non-special direct children, each path-prepended (using '</>') with the parent directory.
+ -- If an input 'FilePath' is not a 'VDirectory', it should be passed through directly.
+ vfsChildrenC :: VFSPipe m
+ vfsChildrenC = awaitForever $ \path -> do
+ children <- yield path .| vfsDescendentsC .| filterC (\it -> path == takeDirectory it ) .| sinkList -- TODO: Is this a bug if we encounter paths like /foo/bar/foo?
+ yieldMany children
+ {-# INLINEABLE vfsChildrenC #-}
+
+ -- | Given an input of 'FilePath' directories, generates the non-special direct children that are files, each path-prepended (using '</>') with the
+ -- parent directory. If an input 'FilePath' is not a 'VDirectory', it should be passed through directly.
+ vfsChildFilesC :: VFSPipe m
+ vfsChildFilesC = vfsChildrenC .| vfsTypeC .| filterC ( (Just VFile ==) . snd ) .| mapC fst
+ {-# INLINE vfsChildFilesC #-}
+
+ -- | Given an input of 'FilePath' directories, generates the non-special direct children that are files, each path-prepended (using '</>') with the
+ -- parent directory. If an input 'FilePath' is not a 'VDirectory', it should be dropped.
+ vfsChildDirsC :: VFSPipe m
+ vfsChildDirsC = vfsChildrenC .| vfsTypeC .| filterC ( (Just VDirectory ==) . snd ) .| mapC fst
+ {-# INLINE vfsChildDirsC #-}
+
+ -- | Given an input of 'FilePath' directories, generates all the paths in the VFS that have the input as a prefix, with the outputs being each
+ -- path-prepended (using '</>') with the corresponding input directory. If an input 'FilePath' is not a 'VDirectory', it should be passed through
+ -- directly.
+ vfsDescendentsC :: VFSPipe m
+ vfsDescendentsC = awaitForever $ \path -> do
+ yield path
+ loop path
+ where
+ loop path = do
+ children <- yield path .| vfsChildrenC .| sinkList
+ yieldMany children
+ unless (null children) (sequence_ $ loop <$> children)
+ {-# INLINEABLE vfsDescendentsC #-}
+
+ -- | Given an input 'FilePath' directories, generates all the paths in the VFS that are files and have the input as a prefix, with the outputs being
+ -- each path-prepended (using '</>') with the corresponding input directory. If an input 'FilePath' is not a 'VDirectory', it should be passed through directly.
+ vfsDescFilesC :: VFSPipe m
+ vfsDescFilesC = vfsDescendentsC .| vfsTypeC .| filterC (\(_, maybeFileType) -> Just VFile == maybeFileType) .| mapC fst
+ {-# INLINE vfsDescFilesC #-}
+
+ -- | Given an input of 'FilePath' directories, generates all the paths in the VFS that are directories and have the input as a prefix, with the outputs being
+ -- each path-prepended (using '</>') with the corresponding input directory. If an input 'FilePath' is not a 'VDirectory', it should be dropped.
+ vfsDescDirsC :: VFSPipe m
+ vfsDescDirsC = vfsDescendentsC .| vfsTypeC .| filterC ( (Just VDirectory ==) . snd ) .| mapC fst
+ {-# INLINE vfsDescDirsC #-}
+
+-- | A class denoting that the type is usable as VFS conduits for writing.
+class (Monad m) => WriteVFSC m where
+
+ {-# MINIMAL (vfsWriteSink | vfsWriteEitherSink), vfsRemoveSink #-}
+
+ -- | Given an input tuple of 'FilePath' files and their bytestring contents, writes the contents to the filepath. This write should be atomic if possible, and if
+ -- it is not an atomic operation, the implementation's documentation should make this clear. This write should also create any necessary directories that may
+ -- not have previously existed.
+ vfsWriteSink :: ConduitT (FilePath, LBS.ByteString) Void m ()
+ vfsWriteSink = awaitForever $ \(filepath, bs) -> yieldMany [Left filepath, Right bs] .| vfsWriteEitherSink
+ {-# INLINE vfsWriteSink #-}
+
+ -- | Given an input of either 'FilePath' files or bytestring contents, writes the contents to the filepath. The write is marked as complete when the next
+ -- 'FilePath' input or end-of-stream is reached. This write should be atomic at completion if possible, and if it is not an atomic operation, the
+ -- implementation's documentation should make this clear. This write should also create any necessary directories that may not have previously existed.
+ vfsWriteEitherSink :: ConduitT (Either FilePath LBS.ByteString) Void m ()
+ vfsWriteEitherSink = awaitForever $ \case
+ (Right _) -> return () -- WTF?
+ (Left filepath) -> do
+ bytes <- bytesLoop
+ yield (filepath, bytes) .| vfsWriteSink
+ where
+ bytesLoop = peekC >>= \case
+ (Just (Right bytes)) -> await >> (bytes <>) <$> bytesLoop
+ _ -> return mempty
+ {-# INLINEABLE vfsWriteEitherSink #-}
+
+ -- | Given 'FilePath' inputs, remove those nodes from the VFS. If the path denotes a directory, the directory is
+ -- removed along with all of its descendents. If the path denotes a file, the file itself is removed. After a removal,
+ -- any newly-empty directories may also be removed.
+ vfsRemoveSink :: VFSSink m ()
+
+-- | A class denoting that the type is usable as VFS conduits for both reading and writing.
+class (ReadVFSC m, WriteVFSC m) => VFSC m where
+
+ -- | Given an input tuple of a filetype and a filepath, ensure that a node exists at the filepath. If it does not exist, it should be created as either
+ -- a directory or a zero-length file, as denoted by the filetype, with any missing parent directories created. Note that a directory which does not
+ -- contain a node may be reported as not present by the VFS, and therefore an acceptable implementation for 'VDirectory' inputs is simply 'return ()'
+ vfsTouchSink :: ConduitT (VFileType, FilePath) Void m ()
+ vfsTouchSink = awaitForever $ \(filetype, filepath) ->
+ ifM
+ ( yield filepath .| vfsTypeC .| headC >>= \case
+ Nothing -> return False
+ (Just (_, Nothing)) -> return False
+ (Just (_, Just foundFileType)) -> return $ filetype == foundFileType
+ )
+ ( case filetype of
+ VFile -> yield (filepath, mempty) .| vfsWriteSink
+ VDirectory -> return ()
+ )
+ ( return () )
+ {-# INLINEABLE vfsTouchSink #-}
+
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
index 0000000..b5233df
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,4 @@
+import ClassyPrelude
+
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"