module HashAddressed.Directory
  (
    {- * Type -} ContentAddressedDirectory, init,
    {- * Write operations -} writeStreaming, writeLazy,
            WriteResult (..), WriteType (..),
  )
  where

import Essentials
import HashAddressed.HashFunction

import Control.Monad.IO.Class (MonadIO)
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 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 -}
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 -}
    -> IO WriteResult
writeStreaming :: ContentAddressedDirectory
-> (forall (m :: * -> *).
    MonadIO m =>
    (ByteString -> m ()) -> m ())
-> IO WriteResult
writeStreaming ContentAddressedDirectory
cafs forall (m :: * -> *). MonadIO m => (ByteString -> m ()) -> m ()
continue = 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
"cafs")
        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
"cafs-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:  -}
    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 (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
Monad.execStateT Ctx
Hash.init forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). MonadIO m => (ByteString -> m ()) -> m ()
continue \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 {- (🍓) -}

    {-  The final location where the file will reside  -}
    let contentAddressedFile :: FilePath
contentAddressedFile = ContentAddressedDirectory -> FilePath
directory ContentAddressedDirectory
cafs 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 WriteResult{ FilePath
contentAddressedFile :: FilePath
contentAddressedFile :: FilePath
contentAddressedFile, WriteType
writeType :: WriteType
writeType :: WriteType
writeType }

{-| Write a lazy byte string to a content-addressed directory -}
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
cafs ByteString
lbs = ContentAddressedDirectory
-> (forall (m :: * -> *).
    MonadIO m =>
    (ByteString -> m ()) -> m ())
-> IO WriteResult
writeStreaming ContentAddressedDirectory
cafs \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)