module HashAddressed.Directory
  (
    {- * Type -} Directory (..),
    {- * Write operations -}
            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)

{-| Specification of a hash-addressed directory

Note that the utilities in "HashAddressed.Directory" do not create the
directory; ensure that it already exists before attempting to write.

See "HashAddressed.HashFunction" for examples of hash functions. -}
data Directory = Directory
  { Directory -> FilePath
directoryPath :: FilePath
      {- ^ Directory where hash-addressed files are stored -}
  , Directory -> HashFunction
hashFunction :: HashFunction
      {- ^ Hash function to use for generating file names -}
  }

data WriteResult = WriteResult
  { WriteResult -> FilePath
hashAddressedFile :: FilePath
      {- ^ The file path where the contents written by the
           action now reside, including the store directory -}
  , WriteResult -> WriteType
writeType :: WriteType
  }

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

{-| Path of a file that we write to before moving it into the
    hash-addressed directory -}
newtype TemporaryFile = TemporaryFile{ TemporaryFile -> FilePath
temporaryFilePath :: FilePath }

{-| File path within a hash-addressed directory

This does no include the directory part, just the file name. -}
newtype HashName = HashName FilePath

{-| Write a stream of strict ByteStrings to a hash-addressed directory,
    possibly aborting mid-stream with an error value instead

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 IO (Either abort commit)
        -- ^ What to write
    -> 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
        {-  Where the system in general keeps its temporary files  -}
        FilePath
temporaryRoot <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
Temporary.getCanonicalTemporaryDirectory

        {-  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. -}

        {-  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.  -}
        (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 {- (🧹) -}

        {-  If the file never gets moved, then when the directory is removed
            recursively (🧹), the file will be destroyed along with it.

            If the file does get moved, the directory will be destroyed (🧹),
            but the file, which no longer resides within the directory, will remain. -}

        {-  The path of the file we're writing, in its temporary location  -}
        let temporaryFile :: TemporaryFile
temporaryFile = FilePath -> TemporaryFile
TemporaryFile (FilePath
temporaryDirectory FilePath -> FilePath -> FilePath
</> FilePath
"hash-addressed-file")

        {-  Create the file and open a handle to write to it  -}
        (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 {- (🍓) -}

        {-  Run the continuation, doing two things at once with the ByteString
            chunks it gives us: write the file, and update a hash context -}
        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

        {-  Once we're done writing the file, we no longer need the handle.  -}
        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

    -- Another file of the same name in the content-addressed directory might already exist.
    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

        -- In one atomic step, this action commits the file to the store and prevents it
        -- from being deleted by the directory cleanup action (🧹).
        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

        -- 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.
        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)

{-| 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 :: 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

{-| 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 :: 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