module HashAddressed.Directory
  (
    {- * Type -} ContentAddressedDirectory, init,
    {- * Write operations -}
            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
        {- ^ The file path where the contents written by the action
             now reside. This path includes the store directory. -}
    , WriteResult -> WriteType
writeType :: WriteType
    }

data WriteType = AlreadyPresent | NewContent

{-| Specification of a content-addressed directory -}
init ::
    HashFunction {- ^ Which hash function to use -}
    -> FilePath {- ^ Directory where content-addressed files are stored -}
    -> ContentAddressedDirectory
init :: HashFunction -> FilePath -> ContentAddressedDirectory
init HashFunction
SHA_256 = FilePath -> ContentAddressedDirectory
ContentAddressedDirectory

{-| 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 :: 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
    {-  Where the system in general keeps its temporary files  -}
    FilePath
temporaryRoot <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Monad.lift 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 :: FilePath
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 FilePath
temporaryFile IOMode
IO.WriteMode)
        Handle -> IO ()
IO.hClose {- (🍓) -}

    {-  Run the continuation, doing two things at once with the byte string
        chunks it gives us:  -}
    (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
            {-  1. Write to the file  -}
            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

            {-  2. Update the state of the hash function  -}
            forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify' \Ctx
hashState -> Ctx -> ByteString -> Ctx
Hash.update Ctx
hashState ByteString
chunk

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

            {-  The final location where the file will reside  -}
            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))

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

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

                {-  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 ()

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

{-| Write a stream of strict byte strings to a content-addressed directory

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

{-| Write a lazy byte string to a content-addressed directory

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