module HashAddressed.Directory
(
Directory (..),
writeLazy, writeStream, writeExcept,
WriteResult (..), WriteType (..),
)
where
import Essentials
import HashAddressed.HashFunction
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 Pipes (Producer)
import System.FilePath ((</>))
import System.IO (IO, FilePath, Handle)
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 Directory = Directory
{ Directory -> FilePath
directoryPath :: FilePath
, Directory -> HashFunction
hashFunction :: HashFunction
}
data WriteResult = WriteResult
{ WriteResult -> FilePath
hashAddressedFile :: FilePath
, WriteResult -> WriteType
writeType :: WriteType
}
data WriteType =
AlreadyPresent
| NewContent
newtype TemporaryFile = TemporaryFile{ TemporaryFile -> FilePath
temporaryFilePath :: FilePath }
newtype HashName = HashName FilePath
writeExcept :: forall abort commit m. (MonadIO m, MonadError abort m) =>
Directory
-> Pipes.Producer Strict.ByteString IO (Either abort commit)
-> m (commit, WriteResult)
writeExcept :: forall abort commit (m :: * -> *).
(MonadIO m, MonadError abort m) =>
Directory
-> Producer ByteString IO (Either abort commit)
-> m (commit, WriteResult)
writeExcept Directory
dir Producer ByteString IO (Either abort commit)
stream = forall {b}. ResourceT IO (Either abort b) -> m b
run ResourceT IO (Either abort (commit, WriteResult))
action
where
run :: ResourceT IO (Either abort b) -> m b
run = forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
Resource.runResourceT forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
Except.liftEither)
action :: ResourceT IO (Either abort (commit, WriteResult))
action :: ResourceT IO (Either abort (commit, WriteResult))
action = do
FilePath
temporaryRoot <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 :: TemporaryFile
temporaryFile = FilePath -> TemporaryFile
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 (TemporaryFile -> FilePath
temporaryFilePath TemporaryFile
temporaryFile) IOMode
IO.WriteMode)
Handle -> IO ()
IO.hClose
Either abort (HashName, commit)
abortOrCommit :: Either abort (HashName, commit) <-
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall abort commit.
HashFunction
-> Handle
-> Producer ByteString IO (Either abort commit)
-> IO (Either abort (HashName, commit))
runStream (Directory -> HashFunction
hashFunction Directory
dir) Handle
handle Producer ByteString IO (Either abort commit)
stream
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release ReleaseKey
handleRelease
case Either abort (HashName, commit)
abortOrCommit of
Either.Left abort
abort -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Either.Left abort
abort)
Either.Right (HashName
name, commit
commit) -> do
WriteResult
result <- forall (m :: * -> *).
MonadIO m =>
Directory -> TemporaryFile -> HashName -> m WriteResult
finalize Directory
dir TemporaryFile
temporaryFile HashName
name
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Either.Right (commit
commit, WriteResult
result)
finalize :: MonadIO m => Directory -> TemporaryFile -> HashName -> m WriteResult
finalize :: forall (m :: * -> *).
MonadIO m =>
Directory -> TemporaryFile -> HashName -> m WriteResult
finalize Directory
dir TemporaryFile
temporaryFile (HashName FilePath
name) = do
let hashAddressedFile :: FilePath
hashAddressedFile = Directory -> FilePath
directoryPath Directory
dir FilePath -> FilePath -> FilePath
</> FilePath
name
WriteType
writeType <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
FilePath -> IO Bool
Directory.doesPathExist FilePath
hashAddressedFile
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
FilePath -> FilePath -> IO ()
Directory.renamePath (TemporaryFile -> FilePath
temporaryFilePath TemporaryFile
temporaryFile) FilePath
hashAddressedFile
WriteType
AlreadyPresent -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure WriteResult{ FilePath
hashAddressedFile :: FilePath
hashAddressedFile :: FilePath
hashAddressedFile, WriteType
writeType :: WriteType
writeType :: WriteType
writeType }
runStream :: forall abort commit. HashFunction -> Handle
-> Pipes.Producer Strict.ByteString IO (Either abort commit)
-> IO (Either abort (HashName, commit))
runStream :: forall abort commit.
HashFunction
-> Handle
-> Producer ByteString IO (Either abort commit)
-> IO (Either abort (HashName, commit))
runStream HashFunction
hash Handle
handle Producer ByteString IO (Either abort commit)
stream =
case forall abort.
HashFunction
-> Handle -> EffectfulFold (ExceptT abort IO) ByteString HashName
writeAndHash HashFunction
hash Handle
handle of
Fold.EffectfulFold{ ExceptT abort IO x
initial :: ()
initial :: ExceptT abort IO x
Fold.initial, x -> ByteString -> ExceptT abort IO x
step :: ()
step :: x -> ByteString -> ExceptT abort IO x
Fold.step, x -> ExceptT abort IO HashName
extract :: ()
extract :: x -> ExceptT abort IO HashName
Fold.extract } ->
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) x a b r.
Monad m =>
(x -> a -> m x) -> m x -> (x -> m b) -> Producer a m r -> m (b, r)
Pipes.foldM' x -> ByteString -> ExceptT abort IO x
step ExceptT abort IO x
initial x -> ExceptT abort IO HashName
extract forall a b. (a -> b) -> a -> b
$
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
(b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
Pipes.hoist forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Producer ByteString IO (Either abort commit)
stream forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
Except.liftEither
writeAndHash :: HashFunction -> Handle
-> Fold.EffectfulFold (ExceptT abort IO) Strict.ByteString HashName
writeAndHash :: forall abort.
HashFunction
-> Handle -> EffectfulFold (ExceptT abort IO) ByteString HashName
writeAndHash (HashFunction Fold ByteString FilePath
hash) Handle
handle =
(forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> EffectfulFold m a ()
Fold.effect \ByteString
chunk -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> ByteString -> IO ()
Strict.ByteString.hPut Handle
handle ByteString
chunk))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (FilePath -> HashName
HashName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b.
Monad m =>
Fold a b -> EffectfulFold m a b
Fold.fold Fold ByteString FilePath
hash)
writeStream :: forall commit m. MonadIO m =>
Directory
-> Pipes.Producer Strict.ByteString IO commit
-> m (commit, WriteResult)
writeStream :: forall commit (m :: * -> *).
MonadIO m =>
Directory
-> Producer ByteString IO commit -> m (commit, WriteResult)
writeStream Directory
dir Producer ByteString IO commit
source = forall (m :: * -> *) a. Functor m => ExceptT X m a -> m a
voidExcept forall a b. (a -> b) -> a -> b
$ forall abort commit (m :: * -> *).
(MonadIO m, MonadError abort m) =>
Directory
-> Producer ByteString IO (Either abort commit)
-> m (commit, WriteResult)
writeExcept Directory
dir forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Either.Right Producer ByteString IO commit
source
voidLeft :: Either Void a -> a
voidLeft :: forall a. Either X a -> a
voidLeft = \case{ Either.Left X
x -> forall a. X -> a
absurd X
x; Either.Right a
x -> a
x }
voidExcept :: Functor m => ExceptT Void m a -> m a
voidExcept :: forall (m :: * -> *) a. Functor m => ExceptT X m a -> m a
voidExcept = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Either X a -> a
voidLeft
writeLazy :: forall m. MonadIO m =>
Directory
-> Lazy.ByteString
-> m WriteResult
writeLazy :: forall (m :: * -> *).
MonadIO m =>
Directory -> ByteString -> m WriteResult
writeLazy Directory
dir ByteString
lbs = forall commit (m :: * -> *).
MonadIO m =>
Directory
-> Producer ByteString IO commit -> m (commit, WriteResult)
writeStream Directory
dir (ByteString -> Producer ByteString IO ()
lbsProducer ByteString
lbs) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\((), WriteResult
x) -> WriteResult
x)
lbsProducer :: Lazy.ByteString -> Pipes.Producer Strict.ByteString IO ()
lbsProducer :: ByteString -> Producer ByteString IO ()
lbsProducer = ByteString -> [ByteString]
Lazy.toChunks forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (m :: * -> *) (f :: * -> *) a x' x.
(Functor m, Foldable f) =>
f a -> Proxy x' x () a m ()
Pipes.each