diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,7 +1,67 @@ -## 0.0.1.0 (2023-01-27) +0.1.0.0 (2023-01-31) +---------------------------------------------------------------- +### HashFunction + +`HashFunction` type is no longer opaque; any hash function can be supported. +The type is now a newtype for `Fold` from the `gambler` library. + +### Directory + +Renamed `ContentAddressedDirectory` to `Directory` + +`Directory` constructor is now exported + +Removed `init` function, which is redundant to `Directory` constructor + +### Pipes + +Now using the `pipes` library to express streams. + +Removed: + +```haskell +writeStreaming :: ContentAddressedDirectory + -> (forall m. MonadIO m => (ByteString -> m ()) -> m ()) + -> IO WriteResult +``` + +Added: + +```haskell +writeStream :: MonadIO m => + Directory -> Producer ByteString IO a -> m (a, WriteResult) +``` + +Removed: + +```haskell +writeEither :: ContentAddressedDirectory + -> (forall m. MonadIO m => (ByteString -> m ()) -> m (Either bad good)) + -> IO (Either bad (good, WriteResult)) +``` + +Added: + +```haskell +writeExcept :: (MonadIO m, MonadError abort m) => + Directory + -> Producer ByteString (ExceptT abort IO) commit + -> m (commit, WriteResult) +``` + +### WriteResult + +Renamed field from `contentAddressedFile` to `hashAddressedFile` + + +0.0.1.0 (2023-01-27) +---------------------------------------------------------------- + Add `HashAddressed.Directory.writeEither` -## 0.0.0.0 (2023-01-27) + +0.0.0.0 (2023-01-27) +---------------------------------------------------------------- Initial release diff --git a/hash-addressed.cabal b/hash-addressed.cabal --- a/hash-addressed.cabal +++ b/hash-addressed.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: hash-addressed -version: 0.0.1.0 +version: 0.1.0.0 synopsis: Hash-addressed file storage category: Hash, Filesystem @@ -34,7 +34,6 @@ default-language: GHC2021 ghc-options: -Wall default-extensions: - ApplicativeDo BlockArguments DerivingVia LambdaCase @@ -48,7 +47,9 @@ , cryptohash-sha256 ^>= 0.11.102 , directory ^>= 1.3.6 , filepath ^>= 1.4.2 + , gambler ^>= 0.0.0 , quaalude ^>= 0.0.0 + , mtl ^>= 2.2.2 + , pipes ^>= 4.3.16 , resourcet ^>= 1.2.6 || ^>= 1.3.0 , temporary ^>= 1.3 - , transformers ^>= 0.5.6 diff --git a/library/HashAddressed/Directory.hs b/library/HashAddressed/Directory.hs --- a/library/HashAddressed/Directory.hs +++ b/library/HashAddressed/Directory.hs @@ -1,8 +1,8 @@ module HashAddressed.Directory ( - {- * Type -} ContentAddressedDirectory, init, + {- * Type -} Directory (..), {- * Write operations -} - writeLazy, writeStreaming, writeEither, + writeLazy, writeStream, writeExcept, WriteResult (..), WriteType (..), ) where @@ -10,157 +10,184 @@ import Essentials import HashAddressed.HashFunction -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Except (ExceptT, MonadError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Resource (ResourceT) import Data.Either (Either) -import Data.Function (flip) -import Prelude (FilePath, IO) +import Pipes (Producer) import System.FilePath (()) +import System.IO (IO, FilePath, Handle) -import qualified Control.Monad.Trans.Class as Monad -import qualified Control.Monad.Trans.Resource as Resource -import qualified Control.Monad.Trans.State as Monad -import qualified Control.Monad.Trans.State as State -import qualified Crypto.Hash.SHA256 as Hash -import qualified Data.ByteString as Strict -import qualified Data.ByteString as Strict.ByteString -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Char8 as Strict.ByteString.Char8 -import qualified Data.ByteString.Lazy as Lazy -import qualified Data.ByteString.Lazy as Lazy.ByteString -import qualified Data.Either as Either -import qualified System.Directory as Directory -import qualified System.IO as IO -import qualified System.IO.Temp as Temporary +import qualified Control.Monad.Except as Except (liftEither, runExceptT) +import qualified Control.Monad.Trans.Resource as Resource (runResourceT, allocate, release) +import qualified Data.ByteString as Strict (ByteString) +import qualified Data.ByteString as Strict.ByteString (hPut) +import qualified Data.ByteString.Lazy as Lazy (ByteString, toChunks) +import qualified Data.Either as Either (Either (Left, Right)) +import qualified Fold.Effectful as Fold (EffectfulFold (..), effect, fold) +import qualified Pipes (hoist, each) +import qualified Pipes.Prelude as Pipes (foldM') +import qualified System.Directory as Directory (removeDirectoryRecursive, doesPathExist, renamePath) +import qualified System.IO as IO (openBinaryFile, IOMode (..), hClose) +import qualified System.IO.Temp as Temporary (getCanonicalTemporaryDirectory, createTempDirectory) -data ContentAddressedDirectory = - ContentAddressedDirectory - { directory :: FilePath - } +{-| Specification of a hash-addressed directory -data WriteResult = - WriteResult - { contentAddressedFile :: FilePath - {- ^ The file path where the contents written by the action - now reside. This path includes the store directory. -} - , writeType :: WriteType - } +Note that the utilities in "HashAddressed.Directory" do not create the +directory; ensure that it already exists before attempting to write. -data WriteType = AlreadyPresent | NewContent +See "HashAddressed.HashFunction" for examples of hash functions. -} +data Directory = Directory + { directoryPath :: FilePath + {- ^ Directory where hash-addressed files are stored -} + , hashFunction :: HashFunction + {- ^ Hash function to use for generating file names -} + } -{-| Specification of a content-addressed directory -} -init :: - HashFunction {- ^ Which hash function to use -} - -> FilePath {- ^ Directory where content-addressed files are stored -} - -> ContentAddressedDirectory -init SHA_256 = ContentAddressedDirectory +data WriteResult = WriteResult + { hashAddressedFile :: FilePath + {- ^ The file path where the contents written by the + action now reside, including the store directory -} + , writeType :: WriteType + } -{-| Write a stream of strict byte strings to a content-addressed directory -} -writeEither :: - ContentAddressedDirectory - {- ^ The content-addressed file store to write to; see 'init' -} - -> (forall m. MonadIO m => (Strict.ByteString -> m ()) -> m (Either bad good)) - {- ^ Monadic action which is allowed to emit 'Strict.ByteString's - and do I/O. The action should return 'Either.Right' once the content - has been successfully written. If the action returns 'Either.Left' or - throws an exception, then nothing will be committed to the store. -} - -> IO (Either bad (good, WriteResult)) -writeEither dir stream = Resource.runResourceT @IO - do - {- Where the system in general keeps its temporary files -} - temporaryRoot <- Monad.lift Temporary.getCanonicalTemporaryDirectory +data WriteType = + AlreadyPresent -- ^ No action was taken because the content + -- is already present in the directory + | NewContent -- ^ A new file was written into the directory - {- We do not yet know what the final file path will be, because that is - determined by the hash of the contents, which we have not computed yet. -} +{-| Path of a file that we write to before moving it into the + hash-addressed directory -} +newtype TemporaryFile = TemporaryFile{ temporaryFilePath :: FilePath } - {- We will write the file into this directory and then move it out in an - atomic rename operation that will commit the file to the store. -} - (_, temporaryDirectory) <- Resource.allocate - (Temporary.createTempDirectory temporaryRoot "hash-addressed") - Directory.removeDirectoryRecursive {- (๐Ÿงน) -} +{-| File path within a hash-addressed directory - {- If the file never gets moved, then when the directory is removed - recursively (๐Ÿงน), the file will be destroyed along with it. +This does no include the directory part, just the file name. -} +newtype HashName = HashName FilePath - If the file does get moved, the directory will be destroyed (๐Ÿงน), - but the file, which no longer resides within the directory, will remain. -} +{-| Write a stream of strict ByteStrings to a hash-addressed directory, + possibly aborting mid-stream with an error value instead - {- The path of the file we're writing, in its temporary location -} - let temporaryFile = temporaryDirectory "hash-addressed-file" +If the producer throws @abort@ or an 'IO' exception, nothing will be written. +An @abort@ thrown via 'Except.ExceptT' will be re-thrown via 'Except.MonadError', +and an exception thrown via 'IO' will be re-thrown via 'IO'. -} +writeExcept :: forall abort commit m. (MonadIO m, MonadError abort m) => + Directory -- ^ Where to write + -> Pipes.Producer Strict.ByteString (ExceptT abort IO) commit + -- ^ What to write + -> m (commit, WriteResult) +writeExcept dir stream = run action + where + run = Resource.runResourceT >>> liftIO >>> (>>= Except.liftEither) - {- Create the file and open a handle to write to it -} - (handleRelease, handle) <- Resource.allocate - (IO.openBinaryFile temporaryFile IO.WriteMode) - IO.hClose {- (๐Ÿ“) -} + action :: ResourceT IO (Either abort (commit, WriteResult)) + action = do + {- Where the system in general keeps its temporary files -} + temporaryRoot <- liftIO Temporary.getCanonicalTemporaryDirectory - {- Run the continuation, doing two things at once with the byte string - chunks it gives us: -} - (badOrGood, hashState :: Hash.Ctx) <- Monad.lift $ flip Monad.runStateT Hash.init $ - stream \chunk -> - do - {- 1. Write to the file -} - Monad.lift $ Strict.ByteString.hPut handle chunk + {- We do not yet know what the final file path will be, because that is + determined by the hash of the contents, which we have not computed yet. -} - {- 2. Update the state of the hash function -} - State.modify' \hashState -> Hash.update hashState chunk + {- We will write the file into this directory and then move it out in an + atomic rename operation that will commit the file to the store. -} + (_, temporaryDirectory) <- Resource.allocate + (Temporary.createTempDirectory temporaryRoot "hash-addressed") + Directory.removeDirectoryRecursive {- (๐Ÿงน) -} - {- Once we're done writing the file, we no longer need the handle. -} - Resource.release handleRelease {- (๐Ÿ“) -} + {- If the file never gets moved, then when the directory is removed + recursively (๐Ÿงน), the file will be destroyed along with it. - case badOrGood of - Either.Left bad -> pure $ Either.Left bad - Either.Right good -> do + If the file does get moved, the directory will be destroyed (๐Ÿงน), + but the file, which no longer resides within the directory, will remain. -} - {- The final location where the file will reside -} - let contentAddressedFile = directory dir - Strict.ByteString.Char8.unpack - (Base16.encode (Hash.finalize hashState)) + {- The path of the file we're writing, in its temporary location -} + let temporaryFile = TemporaryFile (temporaryDirectory "hash-addressed-file") - {- Another file of the same name in the content-addressed directory - might already exist. -} - writeType <- Monad.lift (Directory.doesPathExist contentAddressedFile) - <&> \case{ True -> AlreadyPresent; False -> NewContent } + {- Create the file and open a handle to write to it -} + (handleRelease, handle) <- Resource.allocate + (IO.openBinaryFile (temporaryFilePath temporaryFile) IO.WriteMode) + IO.hClose {- (๐Ÿ“) -} - case writeType of + {- Run the continuation, doing two things at once with the ByteString + chunks it gives us: write the file, and update a hash context -} + abortOrCommit :: Either abort (HashName, commit) <- + lift $ runStream (hashFunction dir) handle stream - {- In one atomic step, this action commits the file to the store - and prevents it from being deleted by the directory cleanup - action (๐Ÿงน). -} - NewContent -> Monad.lift $ - Directory.renamePath temporaryFile contentAddressedFile + {- Once we're done writing the file, we no longer need the handle. -} + Resource.release handleRelease {- (๐Ÿ“) -} - {- Since the store is content-addressed, we assume that two files - with the same name have the same contents. Therefore, if a file - already exists at this path, there is no reason to take any - action. -} - AlreadyPresent -> pure () + case abortOrCommit of + Either.Left abort -> pure (Either.Left abort) + Either.Right (name, commit) -> do + result <- finalize dir temporaryFile name + pure $ Either.Right (commit, result) - pure $ Either.Right (good, WriteResult{ contentAddressedFile, writeType }) +finalize :: MonadIO m => Directory -> TemporaryFile -> HashName -> m WriteResult +finalize dir temporaryFile (HashName name) = do -{-| Write a stream of strict byte strings to a content-addressed directory + let hashAddressedFile = directoryPath dir name -This is a simplified variant of 'writeEither'. -} -writeStreaming :: - ContentAddressedDirectory - {- ^ The content-addressed file store to write to; see 'init' -} - -> (forall m. MonadIO m => (Strict.ByteString -> m ()) -> m ()) - {- ^ Monadic action which is allowed to emit 'Strict.ByteString's - and do I/O. If this action throws an exception, nothing will - be written to the store. -} - -> IO WriteResult -writeStreaming dir stream = writeEither dir (fmap Either.Right . stream) <&> \case - Either.Left x -> absurd x - Either.Right ((), result) -> result + -- Another file of the same name in the content-addressed directory might already exist. + writeType <- liftIO $ + Directory.doesPathExist hashAddressedFile + <&> \case{ True -> AlreadyPresent; False -> NewContent } -{-| Write a lazy byte string to a content-addressed directory + case writeType of -This is a simplified variant of 'writeStreaming'. -} -writeLazy :: - ContentAddressedDirectory - {- ^ The content-addressed file store to write to; see 'init' -} - -> Lazy.ByteString - {- ^ The content to write to the store -} - -> IO WriteResult - {- ^ The file path where the contents of the lazy byte string - now reside. This path includes the store directory. -} -writeLazy dir lbs = writeStreaming dir \writeChunk -> - traverse_ writeChunk (Lazy.ByteString.toChunks lbs) + -- In one atomic step, this action commits the file to the store and prevents it + -- from being deleted by the directory cleanup action (๐Ÿงน). + NewContent -> liftIO $ + Directory.renamePath (temporaryFilePath temporaryFile) hashAddressedFile + + -- Since the store is content-addressed, we assume that two files with the same + -- name have the same contents. Therefore, if a file already exists at this path, + -- there is no reason to take any action. + AlreadyPresent -> pure () + + pure WriteResult{ hashAddressedFile, writeType } + +runStream :: forall abort commit. HashFunction -> Handle + -> Pipes.Producer Strict.ByteString (ExceptT abort IO) commit + -> IO (Either abort (HashName, commit)) +runStream hash handle stream = + case writeAndHash hash handle of + Fold.EffectfulFold{ Fold.initial, Fold.step, Fold.extract } -> + Except.runExceptT $ + Pipes.foldM' step initial extract stream + +writeAndHash :: HashFunction -> Handle + -> Fold.EffectfulFold (ExceptT abort IO) Strict.ByteString HashName +writeAndHash (HashFunction hash) handle = + (Fold.effect \chunk -> liftIO (Strict.ByteString.hPut handle chunk)) + *> (HashName <$> Fold.fold hash) + +{-| Write a stream of strict ByteStrings to a hash-addressed directory + +If the producer throws an exception, nothing will be written and the +exception will be re-thrown. + +This is a simplified variant of 'writeExcept'. -} +writeStream :: forall commit m. MonadIO m => + Directory -- ^ Where to write + -> Pipes.Producer Strict.ByteString IO commit -- ^ What to write + -> m (commit, WriteResult) +writeStream dir source = voidExcept $ writeExcept dir $ Pipes.hoist lift source + +voidLeft :: Either Void a -> a +voidLeft = \case{ Either.Left x -> absurd x; Either.Right x -> x } + +voidExcept :: Functor m => ExceptT Void m a -> m a +voidExcept = Except.runExceptT >>> fmap voidLeft + +{-| Write a lazy ByteString to a hash-addressed directory + +This is a simplified variant of 'writeStream'. -} +writeLazy :: forall m. MonadIO m => + Directory -- ^ Where to write + -> Lazy.ByteString -- ^ What to write + -> m WriteResult +writeLazy dir lbs = writeStream dir (lbsProducer lbs) <&> (\((), x) -> x) + +lbsProducer :: Lazy.ByteString -> Pipes.Producer Strict.ByteString IO () +lbsProducer = Lazy.toChunks >>> Pipes.each diff --git a/library/HashAddressed/HashFunction.hs b/library/HashAddressed/HashFunction.hs --- a/library/HashAddressed/HashFunction.hs +++ b/library/HashAddressed/HashFunction.hs @@ -1,12 +1,25 @@ -module HashAddressed.HashFunction where +module HashAddressed.HashFunction + ( + {- * Type -} HashFunction (..), + {- * Examples -} sha256, + ) + where import Essentials -{-| Hash function supported by the @hash-addressed@ library +import Fold.Pure (Fold (..)) +import System.IO (FilePath) - Currently only SHA-256 is supported, but others - may be added in the future. --} -data HashFunction = - SHA_256 -- ^ SHA-256 - deriving stock (Eq, Ord) +import qualified Crypto.Hash.SHA256 as Hash +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as Strict.ByteString.Char8 + +newtype HashFunction = HashFunction (Fold Strict.ByteString FilePath) + +sha256 :: HashFunction +sha256 = HashFunction Fold + { initial = Hash.init + , step = Hash.update + , extract = Strict.ByteString.Char8.unpack . Base16.encode . Hash.finalize + }