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