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 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.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
import qualified Pipes

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

            let store :: Directory
store = FilePath -> HashFunction -> Directory
HashAddressed.Directory.Directory FilePath
optStoreDirectory (HashFunctionName -> HashFunction
resolveHashFunction HashFunctionName
hashFunction)

            ((), WriteResult{ FilePath
hashAddressedFile :: WriteResult -> FilePath
hashAddressedFile :: FilePath
hashAddressedFile, 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
$ forall commit (m :: * -> *).
MonadIO m =>
Directory
-> Producer ByteString IO commit -> m (commit, WriteResult)
HashAddressed.Directory.writeStream Directory
store forall a b. (a -> b) -> a -> b
$
                    let
                        loop :: Proxy x' x () ByteString IO ()
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
                            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.unless (ByteString -> Bool
Strict.ByteString.null ByteString
x) (forall (m :: * -> *) a x' x. Functor m => a -> Proxy x' x () a m ()
Pipes.yield ByteString
x forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Proxy x' x () ByteString IO ()
loop)
                    in
                        forall {x'} {x}. Proxy x' x () ByteString IO ()
loop

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

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