module HashAddressed.Directory
(
ContentAddressedDirectory, init,
writeLazy, writeStreaming, writeEither,
WriteResult (..), WriteType (..),
)
where
import Essentials
import HashAddressed.HashFunction
import Control.Monad.IO.Class (MonadIO)
import Data.Either (Either)
import Data.Function (flip)
import Prelude (FilePath, IO)
import System.FilePath ((</>))
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
data ContentAddressedDirectory =
ContentAddressedDirectory
{ ContentAddressedDirectory -> FilePath
directory :: FilePath
}
data WriteResult =
WriteResult
{ WriteResult -> FilePath
contentAddressedFile :: FilePath
, WriteResult -> WriteType
writeType :: WriteType
}
data WriteType = AlreadyPresent | NewContent
init ::
HashFunction
-> FilePath
-> ContentAddressedDirectory
init :: HashFunction -> FilePath -> ContentAddressedDirectory
init HashFunction
SHA_256 = FilePath -> ContentAddressedDirectory
ContentAddressedDirectory
writeEither ::
ContentAddressedDirectory
-> (forall m. MonadIO m => (Strict.ByteString -> m ()) -> m (Either bad good))
-> IO (Either bad (good, WriteResult))
writeEither :: forall bad good.
ContentAddressedDirectory
-> (forall (m :: * -> *).
MonadIO m =>
(ByteString -> m ()) -> m (Either bad good))
-> IO (Either bad (good, WriteResult))
writeEither ContentAddressedDirectory
dir forall (m :: * -> *).
MonadIO m =>
(ByteString -> m ()) -> m (Either bad good)
stream = forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
Resource.runResourceT @IO
do
FilePath
temporaryRoot <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Monad.lift IO FilePath
Temporary.getCanonicalTemporaryDirectory
(ReleaseKey
_, FilePath
temporaryDirectory) <- forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
(FilePath -> FilePath -> IO FilePath
Temporary.createTempDirectory FilePath
temporaryRoot FilePath
"hash-addressed")
FilePath -> IO ()
Directory.removeDirectoryRecursive
let temporaryFile :: FilePath
temporaryFile = FilePath
temporaryDirectory FilePath -> FilePath -> FilePath
</> FilePath
"hash-addressed-file"
(ReleaseKey
handleRelease, Handle
handle) <- forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
(FilePath -> IOMode -> IO Handle
IO.openBinaryFile FilePath
temporaryFile IOMode
IO.WriteMode)
Handle -> IO ()
IO.hClose
(Either bad good
badOrGood, Ctx
hashState :: Hash.Ctx) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Monad.lift forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Monad.runStateT Ctx
Hash.init forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
MonadIO m =>
(ByteString -> m ()) -> m (Either bad good)
stream \ByteString
chunk ->
do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Monad.lift forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
Strict.ByteString.hPut Handle
handle ByteString
chunk
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify' \Ctx
hashState -> Ctx -> ByteString -> Ctx
Hash.update Ctx
hashState ByteString
chunk
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release ReleaseKey
handleRelease
case Either bad good
badOrGood of
Either.Left bad
bad -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Either.Left bad
bad
Either.Right good
good -> do
let contentAddressedFile :: FilePath
contentAddressedFile = ContentAddressedDirectory -> FilePath
directory ContentAddressedDirectory
dir FilePath -> FilePath -> FilePath
</>
ByteString -> FilePath
Strict.ByteString.Char8.unpack
(ByteString -> ByteString
Base16.encode (Ctx -> ByteString
Hash.finalize Ctx
hashState))
WriteType
writeType <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Monad.lift (FilePath -> IO Bool
Directory.doesPathExist FilePath
contentAddressedFile)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case{ Bool
True -> WriteType
AlreadyPresent; Bool
False -> WriteType
NewContent }
case WriteType
writeType of
WriteType
NewContent -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Monad.lift forall a b. (a -> b) -> a -> b
$
FilePath -> FilePath -> IO ()
Directory.renamePath FilePath
temporaryFile FilePath
contentAddressedFile
WriteType
AlreadyPresent -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
pure $ forall a b. b -> Either a b
Either.Right (good
good, WriteResult{ FilePath
contentAddressedFile :: FilePath
contentAddressedFile :: FilePath
contentAddressedFile, WriteType
writeType :: WriteType
writeType :: WriteType
writeType })
writeStreaming ::
ContentAddressedDirectory
-> (forall m. MonadIO m => (Strict.ByteString -> m ()) -> m ())
-> IO WriteResult
writeStreaming :: ContentAddressedDirectory
-> (forall (m :: * -> *).
MonadIO m =>
(ByteString -> m ()) -> m ())
-> IO WriteResult
writeStreaming ContentAddressedDirectory
dir forall (m :: * -> *). MonadIO m => (ByteString -> m ()) -> m ()
stream = forall bad good.
ContentAddressedDirectory
-> (forall (m :: * -> *).
MonadIO m =>
(ByteString -> m ()) -> m (Either bad good))
-> IO (Either bad (good, WriteResult))
writeEither ContentAddressedDirectory
dir (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Either.Right forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *). MonadIO m => (ByteString -> m ()) -> m ()
stream) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
Either.Left Void
x -> forall a. Void -> a
absurd Void
x
Either.Right ((), WriteResult
result) -> WriteResult
result
writeLazy ::
ContentAddressedDirectory
-> Lazy.ByteString
-> IO WriteResult
writeLazy :: ContentAddressedDirectory -> ByteString -> IO WriteResult
writeLazy ContentAddressedDirectory
dir ByteString
lbs = ContentAddressedDirectory
-> (forall (m :: * -> *).
MonadIO m =>
(ByteString -> m ()) -> m ())
-> IO WriteResult
writeStreaming ContentAddressedDirectory
dir \ByteString -> m ()
writeChunk ->
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ByteString -> m ()
writeChunk (ByteString -> [ByteString]
Lazy.ByteString.toChunks ByteString
lbs)