module HashAddressed.App.Command.Examples.Write
  (
    writeCommand,
  )
  where

import Essentials
import HashAddressed.App.Command.Type
import HashAddressed.App.HashFunction.Naming
import HashAddressed.App.HashFunction.Options
import HashAddressed.App.Meta.Initialization
import HashAddressed.App.Meta.Paths
import HashAddressed.App.Meta.Reading
import HashAddressed.App.Verbosity.Options
import HashAddressed.App.Verbosity.Printing
import HashAddressed.App.Verbosity.Type
import HashAddressed.HashFunction

import Control.Monad.IO.Class (liftIO)
import HashAddressed.Directory (WriteResult (..), WriteType (..))
import Prelude (FilePath, IO)
import Data.Foldable (fold)

import qualified Control.Monad as Monad
import qualified Control.Monad.Trans.Except as Except
import qualified Control.Monad.Trans.Resource as Resource
import qualified Data.ByteString as Strict
import qualified Data.ByteString as Strict.ByteString
import qualified HashAddressed.Directory
import qualified Options.Applicative as Options
import qualified System.IO as IO
import qualified Data.Sequence as Seq
import qualified Control.Exception.Safe as Exception
import qualified Data.Either as Either
import qualified System.Directory as Directory

writeCommand :: Command
writeCommand :: Command
writeCommand = forall a. Parser a -> InfoMod a -> ParserInfo a
Options.info (Parser (CommandAction ())
parser forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> forall a. Parser (a -> a)
Options.helper) forall a b. (a -> b) -> a -> b
$ forall a. FilePath -> InfoMod a
Options.progDesc
    FilePath
"Copy from the standard input stream (or a file, see --source-file) \
    \to a hash-addressed store (see --target-directory)"
  where
    parser :: Options.Parser (CommandAction ())
    parser :: Parser (CommandAction ())
parser = do
        FilePath
optStoreDirectory :: FilePath <-
            forall s. IsString s => Mod OptionFields s -> Parser s
Options.strOption forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
Options.long FilePath
"target-directory" forall a. Semigroup a => a -> a -> a
<>
                forall (f :: * -> *) a. FilePath -> Mod f a
Options.help FilePath
"Where the hash-addressed files are located"

        Maybe FilePath
optSourceFile :: Maybe FilePath <-
            forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Options.optional forall a b. (a -> b) -> a -> b
$ forall s. IsString s => Mod OptionFields s -> Parser s
Options.strOption forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
Options.long FilePath
"source-file" forall a. Semigroup a => a -> a -> a
<>
                forall (f :: * -> *) a. FilePath -> Mod f a
Options.help FilePath
"Path of file to copy to the store; if this option is \
                    \not given, will read from standard input stream instead"

        [FilePath]
optLinks :: [FilePath] <-
            forall (f :: * -> *) a. Alternative f => f a -> f [a]
Options.many forall a b. (a -> b) -> a -> b
$ forall s. IsString s => Mod OptionFields s -> Parser s
Options.strOption forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
Options.long FilePath
"link" forall a. Semigroup a => a -> a -> a
<>
                forall (f :: * -> *) a. FilePath -> Mod f a
Options.help FilePath
"After writing, create a symbolic link at this path \
                    \that points to the hash-addressed file. \
                    \This option may be given more than once to create multiple links. \
                    \The destination path path must be empty and its parent directory \
                    \must already exist. The process returns a non-zero exit code if \
                    \any of the links cannot be created."

        Bool
optInitializeStore :: Bool <-
            Mod FlagFields Bool -> Parser Bool
Options.switch forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
Options.long FilePath
"initialize" forall a. Semigroup a => a -> a -> a
<>
                forall (f :: * -> *) a. FilePath -> Mod f a
Options.help FilePath
"Set up a hash-addressed store if one does not already exist. \
                \If this option is given, --hash-function is required."

        Maybe HashFunction
optHashFunction :: Maybe HashFunction <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Options.optional forall a b. (a -> b) -> a -> b
$
            forall a. ReadM a -> Mod OptionFields a -> Parser a
Options.option ReadM HashFunction
hashFunctionRead forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
Options.long FilePath
"hash-function" forall a. Semigroup a => a -> a -> a
<>
                forall (f :: * -> *) a. FilePath -> Mod f a
Options.help (FilePath
"If --initialize is given, use this flag to specify the hash \
                    \function. If a store exists, fail unless it used this hash function. "
                    forall a. Semigroup a => a -> a -> a
<> FilePath
hashFunctionInstructions)

        Verbosity
optVerbosity :: Verbosity <- Parser Verbosity
verbosityOption

        pure do
            HashFunction
hashFunction <-
                case Bool
optInitializeStore of
                    Bool
True -> case Maybe HashFunction
optHashFunction of
                        Maybe HashFunction
Nothing -> forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Except.throwE forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
Seq.singleton forall a b. (a -> b) -> a -> b
$ FilePath
"--initialize requires --hash-function"
                        Just HashFunction
hf -> do
                            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when Bool
optInitializeStore forall a b. (a -> b) -> a -> b
$ InitializationType
-> Verbosity -> HashFunction -> FilePath -> CommandAction ()
tryInitializeStore InitializationType
CreateIfNotPresent
                                Verbosity
optVerbosity HashFunction
hf FilePath
optStoreDirectory
                            pure HashFunction
hf
                    Bool
False -> do
                        HashFunction
configHashFunction <- FilePath -> ExceptT (Seq FilePath) IO HashFunction
readHashFunctionFromConfig FilePath
optStoreDirectory
                        case Maybe HashFunction
optHashFunction of
                            Just HashFunction
hf | HashFunction
hf forall a. Eq a => a -> a -> Bool
/= HashFunction
configHashFunction -> forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Except.throwE forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
Seq.singleton forall a b. (a -> b) -> a -> b
$
                                FilePath
"--hash-function " forall a. Semigroup a => a -> a -> a
<> HashFunction -> FilePath
showHashFunction HashFunction
hf forall a. Semigroup a => a -> a -> a
<>
                                FilePath
" does not match hash function " forall a. Semigroup a => a -> a -> a
<> HashFunction -> FilePath
showHashFunction HashFunction
configHashFunction
                                forall a. Semigroup a => a -> a -> a
<> FilePath
" in " forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
configFile FilePath
optStoreDirectory
                            Maybe HashFunction
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        pure HashFunction
configHashFunction

            forall (m :: * -> *). MonadIO m => Verbosity -> FilePath -> m ()
putVerboseLn Verbosity
optVerbosity forall a b. (a -> b) -> a -> b
$ FilePath
"The hash function is "
                forall a. Semigroup a => a -> a -> a
<> HashFunction -> FilePath
showHashFunction HashFunction
hashFunction

            let store :: ContentAddressedDirectory
store = HashFunction -> FilePath -> ContentAddressedDirectory
HashAddressed.Directory.init HashFunction
hashFunction FilePath
optStoreDirectory

            WriteResult{ FilePath
contentAddressedFile :: WriteResult -> FilePath
contentAddressedFile :: FilePath
contentAddressedFile, WriteType
writeType :: WriteResult -> WriteType
writeType :: WriteType
writeType } <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
Resource.runResourceT @IO do

                Handle
input <- case Maybe FilePath
optSourceFile of
                    Maybe FilePath
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
IO.stdin
                    Just FilePath
inputFile -> do
                        (ReleaseKey
_, Handle
h) <- forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate (FilePath -> IOMode -> IO Handle
IO.openBinaryFile FilePath
inputFile IOMode
IO.ReadMode) Handle -> IO ()
IO.hClose
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
h

                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ContentAddressedDirectory
-> (forall (m :: * -> *).
    MonadIO m =>
    (ByteString -> m ()) -> m ())
-> IO WriteResult
HashAddressed.Directory.writeStreaming ContentAddressedDirectory
store
                    \(ByteString -> m ()
writeChunk :: Strict.ByteString -> m ()) -> do
                        let
                          loop :: m ()
                          loop :: m ()
loop = do
                            ByteString
x <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
Strict.ByteString.hGetSome Handle
input Int
4096
                            case ByteString -> Bool
Strict.ByteString.null ByteString
x of
                                Bool
False -> ByteString -> m ()
writeChunk ByteString
x forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
loop
                                Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        m ()
loop

            forall (m :: * -> *). MonadIO m => Verbosity -> FilePath -> m ()
putNormalLn Verbosity
optVerbosity FilePath
contentAddressedFile

            forall (m :: * -> *). MonadIO m => Verbosity -> FilePath -> m ()
putVerboseLn Verbosity
optVerbosity case WriteType
writeType of
                WriteType
AlreadyPresent -> FilePath
"The file was already present in the store; no change was made."
                WriteType
NewContent -> FilePath
"One new file was added to the store."

            Seq FilePath
linkFailures <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [FilePath]
optLinks forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse \FilePath
linkToBeCreated ->
                forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
Exception.tryIO (FilePath -> FilePath -> IO ()
Directory.createFileLink FilePath
contentAddressedFile FilePath
linkToBeCreated) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                    Either.Left IOException
_ -> forall a. a -> Seq a
Seq.singleton forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to create link " forall a. Semigroup a => a -> a -> a
<> FilePath
linkToBeCreated
                    Either.Right () -> forall a. Seq a
Seq.empty

            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.unless (forall a. Seq a -> Bool
Seq.null Seq FilePath
linkFailures) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Except.throwE Seq FilePath
linkFailures