{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}

module Simplex.FileTransfer.Client.Main
  ( SendOptions (..),
    CLIError (..),
    xftpClientCLI,
    cliSendFile,
    cliSendFileOpts,
    encodeWebURI,
    decodeWebURI,
    fileWebLink,
    singleChunkSize,
    prepareChunkSizes,
    prepareChunkSpecs,
    getChunkDigest,
  )
where

import qualified Codec.Compression.Zlib.Raw as Z
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (first)
import qualified Data.ByteString.Base64.URL as U
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (toLower)
import Data.Either (partitionEithers)
import Data.Int (Int64)
import Data.List (foldl', isPrefixOf, sortOn)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Word (Word32)
import GHC.Records (HasField (getField))
import Options.Applicative
import Simplex.FileTransfer.Chunks
import Simplex.FileTransfer.Client
import Simplex.FileTransfer.Client.Agent
import Simplex.FileTransfer.Client.Presets
import Simplex.FileTransfer.Crypto
import Simplex.FileTransfer.Description
import Simplex.FileTransfer.Protocol
import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
import Simplex.FileTransfer.Types
import Simplex.FileTransfer.Util (uniqueCombine)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), FTCryptoError (..))
import qualified Simplex.Messaging.Crypto.File as CF
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), SenderId, SndPrivateAuthKey, XFTPServer, XFTPServerWithAuth)
import Simplex.Messaging.Server.CLI (getCliCommand')
import Simplex.Messaging.Util (groupAllOn, ifM, tshow, whenM)
import System.Exit (exitFailure)
import System.FilePath (splitFileName, (</>))
import System.IO.Temp (getCanonicalTemporaryDirectory)
import System.Random (StdGen, newStdGen, randomR)
import UnliftIO
import UnliftIO.Directory

xftpClientVersion :: String
xftpClientVersion :: String
xftpClientVersion = String
"1.0.1"

newtype CLIError = CLIError String
  deriving (CLIError -> CLIError -> Bool
(CLIError -> CLIError -> Bool)
-> (CLIError -> CLIError -> Bool) -> Eq CLIError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CLIError -> CLIError -> Bool
== :: CLIError -> CLIError -> Bool
$c/= :: CLIError -> CLIError -> Bool
/= :: CLIError -> CLIError -> Bool
Eq, Int -> CLIError -> ShowS
[CLIError] -> ShowS
CLIError -> String
(Int -> CLIError -> ShowS)
-> (CLIError -> String) -> ([CLIError] -> ShowS) -> Show CLIError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CLIError -> ShowS
showsPrec :: Int -> CLIError -> ShowS
$cshow :: CLIError -> String
show :: CLIError -> String
$cshowList :: [CLIError] -> ShowS
showList :: [CLIError] -> ShowS
Show, Show CLIError
Typeable CLIError
(Typeable CLIError, Show CLIError) =>
(CLIError -> SomeException)
-> (SomeException -> Maybe CLIError)
-> (CLIError -> String)
-> Exception CLIError
SomeException -> Maybe CLIError
CLIError -> String
CLIError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: CLIError -> SomeException
toException :: CLIError -> SomeException
$cfromException :: SomeException -> Maybe CLIError
fromException :: SomeException -> Maybe CLIError
$cdisplayException :: CLIError -> String
displayException :: CLIError -> String
Exception)

cliCryptoError :: FTCryptoError -> CLIError
cliCryptoError :: FTCryptoError -> CLIError
cliCryptoError = \case
  FTCECryptoError CryptoError
e -> String -> CLIError
CLIError (String -> CLIError) -> String -> CLIError
forall a b. (a -> b) -> a -> b
$ String
"Error decrypting file: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CryptoError -> String
forall a. Show a => a -> String
show CryptoError
e
  FTCEInvalidHeader String
e -> String -> CLIError
CLIError (String -> CLIError) -> String -> CLIError
forall a b. (a -> b) -> a -> b
$ String
"Invalid file header: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
e
  FTCryptoError
FTCEInvalidAuthTag -> String -> CLIError
CLIError String
"Error decrypting file: incorrect auth tag"
  FTCryptoError
FTCEInvalidFileSize -> String -> CLIError
CLIError String
"Error decrypting file: incorrect file size"
  FTCEFileIOError String
e -> String -> CLIError
CLIError (String -> CLIError) -> String -> CLIError
forall a b. (a -> b) -> a -> b
$ String
"File IO error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> String
show String
e

data CliCommand
  = SendFile SendOptions
  | ReceiveFile ReceiveOptions
  | DeleteFile DeleteOptions
  | RandomFile RandomFileOptions
  | FileDescrInfo InfoOptions

data SendOptions = SendOptions
  { SendOptions -> String
filePath :: FilePath,
    SendOptions -> Maybe String
outputDir :: Maybe FilePath,
    SendOptions -> Int
numRecipients :: Int,
    SendOptions -> [XFTPServerWithAuth]
xftpServers :: [XFTPServerWithAuth],
    SendOptions -> Int
retryCount :: Int,
    SendOptions -> Maybe String
tempPath :: Maybe FilePath,
    SendOptions -> Bool
verbose :: Bool
  }
  deriving (Int -> SendOptions -> ShowS
[SendOptions] -> ShowS
SendOptions -> String
(Int -> SendOptions -> ShowS)
-> (SendOptions -> String)
-> ([SendOptions] -> ShowS)
-> Show SendOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SendOptions -> ShowS
showsPrec :: Int -> SendOptions -> ShowS
$cshow :: SendOptions -> String
show :: SendOptions -> String
$cshowList :: [SendOptions] -> ShowS
showList :: [SendOptions] -> ShowS
Show)

data ReceiveOptions = ReceiveOptions
  { ReceiveOptions -> String
fileDescription :: FilePath,
    ReceiveOptions -> Maybe String
filePath :: Maybe FilePath,
    ReceiveOptions -> Int
retryCount :: Int,
    ReceiveOptions -> Maybe String
tempPath :: Maybe FilePath,
    ReceiveOptions -> Bool
verbose :: Bool,
    ReceiveOptions -> Bool
yes :: Bool
  }
  deriving (Int -> ReceiveOptions -> ShowS
[ReceiveOptions] -> ShowS
ReceiveOptions -> String
(Int -> ReceiveOptions -> ShowS)
-> (ReceiveOptions -> String)
-> ([ReceiveOptions] -> ShowS)
-> Show ReceiveOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReceiveOptions -> ShowS
showsPrec :: Int -> ReceiveOptions -> ShowS
$cshow :: ReceiveOptions -> String
show :: ReceiveOptions -> String
$cshowList :: [ReceiveOptions] -> ShowS
showList :: [ReceiveOptions] -> ShowS
Show)

data DeleteOptions = DeleteOptions
  { DeleteOptions -> String
fileDescription :: FilePath,
    DeleteOptions -> Int
retryCount :: Int,
    DeleteOptions -> Bool
verbose :: Bool,
    DeleteOptions -> Bool
yes :: Bool
  }
  deriving (Int -> DeleteOptions -> ShowS
[DeleteOptions] -> ShowS
DeleteOptions -> String
(Int -> DeleteOptions -> ShowS)
-> (DeleteOptions -> String)
-> ([DeleteOptions] -> ShowS)
-> Show DeleteOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DeleteOptions -> ShowS
showsPrec :: Int -> DeleteOptions -> ShowS
$cshow :: DeleteOptions -> String
show :: DeleteOptions -> String
$cshowList :: [DeleteOptions] -> ShowS
showList :: [DeleteOptions] -> ShowS
Show)

newtype InfoOptions = InfoOptions
  { InfoOptions -> String
fileDescription :: FilePath
  }
  deriving (Int -> InfoOptions -> ShowS
[InfoOptions] -> ShowS
InfoOptions -> String
(Int -> InfoOptions -> ShowS)
-> (InfoOptions -> String)
-> ([InfoOptions] -> ShowS)
-> Show InfoOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InfoOptions -> ShowS
showsPrec :: Int -> InfoOptions -> ShowS
$cshow :: InfoOptions -> String
show :: InfoOptions -> String
$cshowList :: [InfoOptions] -> ShowS
showList :: [InfoOptions] -> ShowS
Show)

data RandomFileOptions = RandomFileOptions
  { RandomFileOptions -> String
filePath :: FilePath,
    RandomFileOptions -> FileSize Int64
fileSize :: FileSize Int64
  }
  deriving (Int -> RandomFileOptions -> ShowS
[RandomFileOptions] -> ShowS
RandomFileOptions -> String
(Int -> RandomFileOptions -> ShowS)
-> (RandomFileOptions -> String)
-> ([RandomFileOptions] -> ShowS)
-> Show RandomFileOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RandomFileOptions -> ShowS
showsPrec :: Int -> RandomFileOptions -> ShowS
$cshow :: RandomFileOptions -> String
show :: RandomFileOptions -> String
$cshowList :: [RandomFileOptions] -> ShowS
showList :: [RandomFileOptions] -> ShowS
Show)

defaultRetryCount :: Int
defaultRetryCount :: Int
defaultRetryCount = Int
3

cliCommandP :: Parser CliCommand
cliCommandP :: Parser CliCommand
cliCommandP =
  Mod CommandFields CliCommand -> Parser CliCommand
forall a. Mod CommandFields a -> Parser a
hsubparser
    ( String -> ParserInfo CliCommand -> Mod CommandFields CliCommand
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"send" (Parser CliCommand -> InfoMod CliCommand -> ParserInfo CliCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (SendOptions -> CliCommand
SendFile (SendOptions -> CliCommand)
-> Parser SendOptions -> Parser CliCommand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SendOptions
sendP) (String -> InfoMod CliCommand
forall a. String -> InfoMod a
progDesc String
"Send file"))
        Mod CommandFields CliCommand
-> Mod CommandFields CliCommand -> Mod CommandFields CliCommand
forall a. Semigroup a => a -> a -> a
<> String -> ParserInfo CliCommand -> Mod CommandFields CliCommand
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"recv" (Parser CliCommand -> InfoMod CliCommand -> ParserInfo CliCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (ReceiveOptions -> CliCommand
ReceiveFile (ReceiveOptions -> CliCommand)
-> Parser ReceiveOptions -> Parser CliCommand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ReceiveOptions
receiveP) (String -> InfoMod CliCommand
forall a. String -> InfoMod a
progDesc String
"Receive file"))
        Mod CommandFields CliCommand
-> Mod CommandFields CliCommand -> Mod CommandFields CliCommand
forall a. Semigroup a => a -> a -> a
<> String -> ParserInfo CliCommand -> Mod CommandFields CliCommand
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"del" (Parser CliCommand -> InfoMod CliCommand -> ParserInfo CliCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (DeleteOptions -> CliCommand
DeleteFile (DeleteOptions -> CliCommand)
-> Parser DeleteOptions -> Parser CliCommand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser DeleteOptions
deleteP) (String -> InfoMod CliCommand
forall a. String -> InfoMod a
progDesc String
"Delete file from server(s)"))
        Mod CommandFields CliCommand
-> Mod CommandFields CliCommand -> Mod CommandFields CliCommand
forall a. Semigroup a => a -> a -> a
<> String -> ParserInfo CliCommand -> Mod CommandFields CliCommand
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"info" (Parser CliCommand -> InfoMod CliCommand -> ParserInfo CliCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (InfoOptions -> CliCommand
FileDescrInfo (InfoOptions -> CliCommand)
-> Parser InfoOptions -> Parser CliCommand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser InfoOptions
infoP) (String -> InfoMod CliCommand
forall a. String -> InfoMod a
progDesc String
"Show file description"))
    )
    Parser CliCommand -> Parser CliCommand -> Parser CliCommand
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Mod CommandFields CliCommand -> Parser CliCommand
forall a. Mod CommandFields a -> Parser a
hsubparser (String -> ParserInfo CliCommand -> Mod CommandFields CliCommand
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"rand" (Parser CliCommand -> InfoMod CliCommand -> ParserInfo CliCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (RandomFileOptions -> CliCommand
RandomFile (RandomFileOptions -> CliCommand)
-> Parser RandomFileOptions -> Parser CliCommand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser RandomFileOptions
randomP) (String -> InfoMod CliCommand
forall a. String -> InfoMod a
progDesc String
"Generate a random file of a given size")) Mod CommandFields CliCommand
-> Mod CommandFields CliCommand -> Mod CommandFields CliCommand
forall a. Semigroup a => a -> a -> a
<> Mod CommandFields CliCommand
forall (f :: * -> *) a. Mod f a
internal)
  where
    sendP :: Parser SendOptions
    sendP :: Parser SendOptions
sendP =
      String
-> Maybe String
-> Int
-> [XFTPServerWithAuth]
-> Int
-> Maybe String
-> Bool
-> SendOptions
SendOptions
        (String
 -> Maybe String
 -> Int
 -> [XFTPServerWithAuth]
 -> Int
 -> Maybe String
 -> Bool
 -> SendOptions)
-> Parser String
-> Parser
     (Maybe String
      -> Int
      -> [XFTPServerWithAuth]
      -> Int
      -> Maybe String
      -> Bool
      -> SendOptions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM String -> Mod ArgumentFields String -> Parser String
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM String
forall s. IsString s => ReadM s
str (String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"FILE" Mod ArgumentFields String
-> Mod ArgumentFields String -> Mod ArgumentFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"File to send")
        Parser
  (Maybe String
   -> Int
   -> [XFTPServerWithAuth]
   -> Int
   -> Maybe String
   -> Bool
   -> SendOptions)
-> Parser (Maybe String)
-> Parser
     (Int
      -> [XFTPServerWithAuth]
      -> Int
      -> Maybe String
      -> Bool
      -> SendOptions)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ReadM String -> Mod ArgumentFields String -> Parser String
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM String
forall s. IsString s => ReadM s
str (Mod ArgumentFields String -> Parser String)
-> Mod ArgumentFields String -> Parser String
forall a b. (a -> b) -> a -> b
$ String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"DIR" Mod ArgumentFields String
-> Mod ArgumentFields String -> Mod ArgumentFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Directory to save file descriptions (default: current directory)")
        Parser
  (Int
   -> [XFTPServerWithAuth]
   -> Int
   -> Maybe String
   -> Bool
   -> SendOptions)
-> Parser Int
-> Parser
     ([XFTPServerWithAuth]
      -> Int -> Maybe String -> Bool -> SendOptions)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Int
forall a. Read a => ReadM a
auto (Char -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'n' Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"COUNT" Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. String -> Mod f a
help String
"Number of recipients" Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Int -> Mod OptionFields Int
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Int
1 Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields Int
forall a (f :: * -> *). Show a => Mod f a
showDefault)
        Parser
  ([XFTPServerWithAuth]
   -> Int -> Maybe String -> Bool -> SendOptions)
-> Parser [XFTPServerWithAuth]
-> Parser (Int -> Maybe String -> Bool -> SendOptions)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [XFTPServerWithAuth]
xftpServers
        Parser (Int -> Maybe String -> Bool -> SendOptions)
-> Parser Int -> Parser (Maybe String -> Bool -> SendOptions)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int
retryCountP
        Parser (Maybe String -> Bool -> SendOptions)
-> Parser (Maybe String) -> Parser (Bool -> SendOptions)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe String)
temp
        Parser (Bool -> SendOptions) -> Parser Bool -> Parser SendOptions
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
verboseP
    receiveP :: Parser ReceiveOptions
    receiveP :: Parser ReceiveOptions
receiveP =
      String
-> Maybe String
-> Int
-> Maybe String
-> Bool
-> Bool
-> ReceiveOptions
ReceiveOptions
        (String
 -> Maybe String
 -> Int
 -> Maybe String
 -> Bool
 -> Bool
 -> ReceiveOptions)
-> Parser String
-> Parser
     (Maybe String
      -> Int -> Maybe String -> Bool -> Bool -> ReceiveOptions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
fileDescrArg
        Parser
  (Maybe String
   -> Int -> Maybe String -> Bool -> Bool -> ReceiveOptions)
-> Parser (Maybe String)
-> Parser (Int -> Maybe String -> Bool -> Bool -> ReceiveOptions)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ReadM String -> Mod ArgumentFields String -> Parser String
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM String
forall s. IsString s => ReadM s
str (Mod ArgumentFields String -> Parser String)
-> Mod ArgumentFields String -> Parser String
forall a b. (a -> b) -> a -> b
$ String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"DIR" Mod ArgumentFields String
-> Mod ArgumentFields String -> Mod ArgumentFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Directory to save file (default: system Downloads directory)")
        Parser (Int -> Maybe String -> Bool -> Bool -> ReceiveOptions)
-> Parser Int
-> Parser (Maybe String -> Bool -> Bool -> ReceiveOptions)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int
retryCountP
        Parser (Maybe String -> Bool -> Bool -> ReceiveOptions)
-> Parser (Maybe String) -> Parser (Bool -> Bool -> ReceiveOptions)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe String)
temp
        Parser (Bool -> Bool -> ReceiveOptions)
-> Parser Bool -> Parser (Bool -> ReceiveOptions)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
verboseP
        Parser (Bool -> ReceiveOptions)
-> Parser Bool -> Parser ReceiveOptions
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
yesP
    deleteP :: Parser DeleteOptions
    deleteP :: Parser DeleteOptions
deleteP =
      String -> Int -> Bool -> Bool -> DeleteOptions
DeleteOptions
        (String -> Int -> Bool -> Bool -> DeleteOptions)
-> Parser String -> Parser (Int -> Bool -> Bool -> DeleteOptions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
fileDescrArg
        Parser (Int -> Bool -> Bool -> DeleteOptions)
-> Parser Int -> Parser (Bool -> Bool -> DeleteOptions)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int
retryCountP
        Parser (Bool -> Bool -> DeleteOptions)
-> Parser Bool -> Parser (Bool -> DeleteOptions)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
verboseP
        Parser (Bool -> DeleteOptions)
-> Parser Bool -> Parser DeleteOptions
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
yesP
    infoP :: Parser InfoOptions
    infoP :: Parser InfoOptions
infoP = String -> InfoOptions
InfoOptions (String -> InfoOptions) -> Parser String -> Parser InfoOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
fileDescrArg
    randomP :: Parser RandomFileOptions
    randomP :: Parser RandomFileOptions
randomP =
      String -> FileSize Int64 -> RandomFileOptions
RandomFileOptions
        (String -> FileSize Int64 -> RandomFileOptions)
-> Parser String -> Parser (FileSize Int64 -> RandomFileOptions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM String -> Mod ArgumentFields String -> Parser String
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM String
forall s. IsString s => ReadM s
str (String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"FILE" Mod ArgumentFields String
-> Mod ArgumentFields String -> Mod ArgumentFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Path to save file")
        Parser (FileSize Int64 -> RandomFileOptions)
-> Parser (FileSize Int64) -> Parser RandomFileOptions
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM (FileSize Int64)
-> Mod ArgumentFields (FileSize Int64) -> Parser (FileSize Int64)
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM (FileSize Int64)
forall s. IsString s => ReadM s
str (String -> Mod ArgumentFields (FileSize Int64)
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"SIZE" Mod ArgumentFields (FileSize Int64)
-> Mod ArgumentFields (FileSize Int64)
-> Mod ArgumentFields (FileSize Int64)
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields (FileSize Int64)
forall (f :: * -> *) a. String -> Mod f a
help String
"File size (bytes/kb/mb/gb)")
    fileDescrArg :: Parser String
fileDescrArg = ReadM String -> Mod ArgumentFields String -> Parser String
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM String
forall s. IsString s => ReadM s
str (String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"FILE" Mod ArgumentFields String
-> Mod ArgumentFields String -> Mod ArgumentFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"File description file")
    retryCountP :: Parser Int
retryCountP = ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Int
forall a. Read a => ReadM a
auto (String -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"retry" Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'r' Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"RETRY" Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. String -> Mod f a
help String
"Number of network retries" Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Int -> Mod OptionFields Int
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Int
defaultRetryCount Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields Int
forall a (f :: * -> *). Show a => Mod f a
showDefault)
    temp :: Parser (Maybe String)
temp = Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (Mod OptionFields String -> Parser String)
-> Mod OptionFields String -> Parser String
forall a b. (a -> b) -> a -> b
$ String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"tmp" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"TMP" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Directory for temporary encrypted file (default: system temp directory)")
    verboseP :: Parser Bool
verboseP = Mod FlagFields Bool -> Parser Bool
switch (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"verbose" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'v' Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Verbose output")
    yesP :: Parser Bool
yesP = Mod FlagFields Bool -> Parser Bool
switch (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"yes" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'y' Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Yes to questions")
    xftpServers :: Parser [XFTPServerWithAuth]
xftpServers =
      ReadM [XFTPServerWithAuth]
-> Mod OptionFields [XFTPServerWithAuth]
-> Parser [XFTPServerWithAuth]
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
        ReadM [XFTPServerWithAuth]
parseXFTPServers
        ( String -> Mod OptionFields [XFTPServerWithAuth]
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"servers"
            Mod OptionFields [XFTPServerWithAuth]
-> Mod OptionFields [XFTPServerWithAuth]
-> Mod OptionFields [XFTPServerWithAuth]
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields [XFTPServerWithAuth]
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
's'
            Mod OptionFields [XFTPServerWithAuth]
-> Mod OptionFields [XFTPServerWithAuth]
-> Mod OptionFields [XFTPServerWithAuth]
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields [XFTPServerWithAuth]
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"SERVER"
            Mod OptionFields [XFTPServerWithAuth]
-> Mod OptionFields [XFTPServerWithAuth]
-> Mod OptionFields [XFTPServerWithAuth]
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields [XFTPServerWithAuth]
forall (f :: * -> *) a. String -> Mod f a
help String
"Semicolon-separated list of XFTP server(s) to use (each server can have more than one hostname)"
            Mod OptionFields [XFTPServerWithAuth]
-> Mod OptionFields [XFTPServerWithAuth]
-> Mod OptionFields [XFTPServerWithAuth]
forall a. Semigroup a => a -> a -> a
<> [XFTPServerWithAuth] -> Mod OptionFields [XFTPServerWithAuth]
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value []
        )
    parseXFTPServers :: ReadM [XFTPServerWithAuth]
parseXFTPServers = (String -> Either String [XFTPServerWithAuth])
-> ReadM [XFTPServerWithAuth]
forall a. (String -> Either String a) -> ReadM a
eitherReader ((String -> Either String [XFTPServerWithAuth])
 -> ReadM [XFTPServerWithAuth])
-> (String -> Either String [XFTPServerWithAuth])
-> ReadM [XFTPServerWithAuth]
forall a b. (a -> b) -> a -> b
$ Parser [XFTPServerWithAuth]
-> ByteString -> Either String [XFTPServerWithAuth]
forall a. Parser a -> ByteString -> Either String a
parseAll Parser [XFTPServerWithAuth]
xftpServersP (ByteString -> Either String [XFTPServerWithAuth])
-> (String -> ByteString)
-> String
-> Either String [XFTPServerWithAuth]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B.pack
    xftpServersP :: Parser [XFTPServerWithAuth]
xftpServersP = Parser XFTPServerWithAuth
forall a. StrEncoding a => Parser a
strP Parser XFTPServerWithAuth
-> Parser ByteString Char -> Parser [XFTPServerWithAuth]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`A.sepBy1` Char -> Parser ByteString Char
A.char Char
';'

data SentFileChunk = SentFileChunk
  { SentFileChunk -> Int
chunkNo :: Int,
    SentFileChunk -> SenderId
sndId :: SenderId,
    SentFileChunk -> SndPrivateAuthKey
sndPrivateKey :: SndPrivateAuthKey,
    SentFileChunk -> FileSize Word32
chunkSize :: FileSize Word32,
    SentFileChunk -> FileDigest
digest :: FileDigest,
    SentFileChunk -> [SentFileChunkReplica]
replicas :: [SentFileChunkReplica]
  }
  deriving (Int -> SentFileChunk -> ShowS
[SentFileChunk] -> ShowS
SentFileChunk -> String
(Int -> SentFileChunk -> ShowS)
-> (SentFileChunk -> String)
-> ([SentFileChunk] -> ShowS)
-> Show SentFileChunk
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SentFileChunk -> ShowS
showsPrec :: Int -> SentFileChunk -> ShowS
$cshow :: SentFileChunk -> String
show :: SentFileChunk -> String
$cshowList :: [SentFileChunk] -> ShowS
showList :: [SentFileChunk] -> ShowS
Show)

data SentFileChunkReplica = SentFileChunkReplica
  { SentFileChunkReplica -> XFTPServer
server :: XFTPServer,
    SentFileChunkReplica -> [(ChunkReplicaId, SndPrivateAuthKey)]
recipients :: [(ChunkReplicaId, C.APrivateAuthKey)]
  }
  deriving (Int -> SentFileChunkReplica -> ShowS
[SentFileChunkReplica] -> ShowS
SentFileChunkReplica -> String
(Int -> SentFileChunkReplica -> ShowS)
-> (SentFileChunkReplica -> String)
-> ([SentFileChunkReplica] -> ShowS)
-> Show SentFileChunkReplica
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SentFileChunkReplica -> ShowS
showsPrec :: Int -> SentFileChunkReplica -> ShowS
$cshow :: SentFileChunkReplica -> String
show :: SentFileChunkReplica -> String
$cshowList :: [SentFileChunkReplica] -> ShowS
showList :: [SentFileChunkReplica] -> ShowS
Show)

logCfg :: LogConfig
logCfg :: LogConfig
logCfg = LogConfig {lc_file :: Maybe String
lc_file = Maybe String
forall a. Maybe a
Nothing, lc_stderr :: Bool
lc_stderr = Bool
True}

xftpClientCLI :: IO ()
xftpClientCLI :: IO ()
xftpClientCLI =
  Parser CliCommand -> String -> IO CliCommand
forall cmd. Parser cmd -> String -> IO cmd
getCliCommand' Parser CliCommand
cliCommandP String
clientVersion IO CliCommand -> (CliCommand -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    SendFile SendOptions
opts -> SendOptions -> ExceptT CLIError IO () -> IO ()
forall a.
HasField "verbose" a Bool =>
a -> ExceptT CLIError IO () -> IO ()
runLogE SendOptions
opts (ExceptT CLIError IO () -> IO ())
-> ExceptT CLIError IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SendOptions -> ExceptT CLIError IO ()
cliSendFile SendOptions
opts
    ReceiveFile ReceiveOptions
opts -> ReceiveOptions -> ExceptT CLIError IO () -> IO ()
forall a.
HasField "verbose" a Bool =>
a -> ExceptT CLIError IO () -> IO ()
runLogE ReceiveOptions
opts (ExceptT CLIError IO () -> IO ())
-> ExceptT CLIError IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ReceiveOptions -> ExceptT CLIError IO ()
cliReceiveFile ReceiveOptions
opts
    DeleteFile DeleteOptions
opts -> DeleteOptions -> ExceptT CLIError IO () -> IO ()
forall a.
HasField "verbose" a Bool =>
a -> ExceptT CLIError IO () -> IO ()
runLogE DeleteOptions
opts (ExceptT CLIError IO () -> IO ())
-> ExceptT CLIError IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DeleteOptions -> ExceptT CLIError IO ()
cliDeleteFile DeleteOptions
opts
    FileDescrInfo InfoOptions
opts -> ExceptT CLIError IO () -> IO ()
runE (ExceptT CLIError IO () -> IO ())
-> ExceptT CLIError IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ InfoOptions -> ExceptT CLIError IO ()
cliFileDescrInfo InfoOptions
opts
    RandomFile RandomFileOptions
opts -> RandomFileOptions -> IO ()
cliRandomFile RandomFileOptions
opts
  where
    clientVersion :: String
clientVersion = String
"SimpleX XFTP client v" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
xftpClientVersion

runLogE :: HasField "verbose" a Bool => a -> ExceptT CLIError IO () -> IO ()
runLogE :: forall a.
HasField "verbose" a Bool =>
a -> ExceptT CLIError IO () -> IO ()
runLogE a
opts ExceptT CLIError IO ()
a
  | forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @"verbose" a
opts = LogLevel -> IO ()
setLogLevel LogLevel
LogDebug IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LogConfig -> IO () -> IO ()
forall a. LogConfig -> IO a -> IO a
withGlobalLogging LogConfig
logCfg (ExceptT CLIError IO () -> IO ()
runE ExceptT CLIError IO ()
a)
  | Bool
otherwise = ExceptT CLIError IO () -> IO ()
runE ExceptT CLIError IO ()
a

runE :: ExceptT CLIError IO () -> IO ()
runE :: ExceptT CLIError IO () -> IO ()
runE ExceptT CLIError IO ()
a =
  ExceptT CLIError IO () -> IO (Either CLIError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT CLIError IO ()
a IO (Either CLIError ()) -> (Either CLIError () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left (CLIError String
e) -> String -> IO ()
putStrLn String
e IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitFailure
    Either CLIError ()
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

cliSendFile :: SendOptions -> ExceptT CLIError IO ()
cliSendFile :: SendOptions -> ExceptT CLIError IO ()
cliSendFile SendOptions
opts = SendOptions
-> Bool -> (Int64 -> Int64 -> IO ()) -> ExceptT CLIError IO ()
cliSendFileOpts SendOptions
opts Bool
True ((Int64 -> Int64 -> IO ()) -> ExceptT CLIError IO ())
-> (Int64 -> Int64 -> IO ()) -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ String -> Int64 -> Int64 -> IO ()
printProgress String
"Uploaded"

cliSendFileOpts :: SendOptions -> Bool -> (Int64 -> Int64 -> IO ()) -> ExceptT CLIError IO ()
cliSendFileOpts :: SendOptions
-> Bool -> (Int64 -> Int64 -> IO ()) -> ExceptT CLIError IO ()
cliSendFileOpts SendOptions {String
$sel:filePath:SendOptions :: SendOptions -> String
filePath :: String
filePath, Maybe String
$sel:outputDir:SendOptions :: SendOptions -> Maybe String
outputDir :: Maybe String
outputDir, Int
$sel:numRecipients:SendOptions :: SendOptions -> Int
numRecipients :: Int
numRecipients, [XFTPServerWithAuth]
$sel:xftpServers:SendOptions :: SendOptions -> [XFTPServerWithAuth]
xftpServers :: [XFTPServerWithAuth]
xftpServers, Int
$sel:retryCount:SendOptions :: SendOptions -> Int
retryCount :: Int
retryCount, Maybe String
$sel:tempPath:SendOptions :: SendOptions -> Maybe String
tempPath :: Maybe String
tempPath, Bool
$sel:verbose:SendOptions :: SendOptions -> Bool
verbose :: Bool
verbose} Bool
printInfo Int64 -> Int64 -> IO ()
notifyProgress = do
  let (String
_, String
fileNameStr) = String -> (String, String)
splitFileName String
filePath
      fileName :: Text
fileName = String -> Text
T.pack String
fileNameStr
  IO () -> ExceptT CLIError IO ()
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT CLIError IO ())
-> IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
printInfo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
printNoNewLine String
"Encrypting file..."
  TVar ChaChaDRG
g <- IO (TVar ChaChaDRG) -> ExceptT CLIError IO (TVar ChaChaDRG)
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TVar ChaChaDRG)
C.newRandom
  (String
encPath, FileDescription 'FRecipient
fdRcv, FileDescription 'FSender
fdSnd, [XFTPChunkSpec]
chunkSpecs, Int64
encSize) <- TVar ChaChaDRG
-> Text
-> ExceptT
     CLIError
     IO
     (String, FileDescription 'FRecipient, FileDescription 'FSender,
      [XFTPChunkSpec], Int64)
encryptFileForUpload TVar ChaChaDRG
g Text
fileName
  IO () -> ExceptT CLIError IO ()
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT CLIError IO ())
-> IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
printInfo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
printNoNewLine String
"Uploading file..."
  TVar [Int64]
uploadedChunks <- [Int64] -> ExceptT CLIError IO (TVar [Int64])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO []
  [SentFileChunk]
sentChunks <- TVar ChaChaDRG
-> [XFTPChunkSpec]
-> TVar [Int64]
-> Int64
-> ExceptT CLIError IO [SentFileChunk]
uploadFile TVar ChaChaDRG
g [XFTPChunkSpec]
chunkSpecs TVar [Int64]
uploadedChunks Int64
encSize
  ExceptT CLIError IO Bool
-> ExceptT CLIError IO () -> ExceptT CLIError IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> ExceptT CLIError IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
encPath) (ExceptT CLIError IO () -> ExceptT CLIError IO ())
-> ExceptT CLIError IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ String -> ExceptT CLIError IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeFile String
encPath
  -- TODO if only small chunks, use different default size
  IO () -> ExceptT CLIError IO ()
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT CLIError IO ())
-> IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ do
    let fdRcvs :: [FileDescription 'FRecipient]
fdRcvs = FileDescription 'FRecipient
-> [SentFileChunk] -> [FileDescription 'FRecipient]
createRcvFileDescriptions FileDescription 'FRecipient
fdRcv [SentFileChunk]
sentChunks
        fdSnd' :: FileDescription 'FSender
fdSnd' = FileDescription 'FSender
-> [SentFileChunk] -> FileDescription 'FSender
createSndFileDescription FileDescription 'FSender
fdSnd [SentFileChunk]
sentChunks
    ([String]
fdRcvPaths, String
fdSndPath) <- String
-> [FileDescription 'FRecipient]
-> FileDescription 'FSender
-> IO ([String], String)
writeFileDescriptions String
fileNameStr [FileDescription 'FRecipient]
fdRcvs FileDescription 'FSender
fdSnd'
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
printInfo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
printNoNewLine String
"File uploaded!"
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\nSender file description: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fdSndPath
      String -> IO ()
putStrLn String
"Pass file descriptions to the recipient(s):"
    [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
fdRcvPaths String -> IO ()
putStrLn
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
printInfo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ case [FileDescription 'FRecipient]
fdRcvs of
      FileDescription 'FRecipient
rcvFd : [FileDescription 'FRecipient]
_ -> Maybe (ByteString, ByteString)
-> ((ByteString, ByteString) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (FileDescription 'FRecipient -> Maybe (ByteString, ByteString)
fileWebLink FileDescription 'FRecipient
rcvFd) (((ByteString, ByteString) -> IO ()) -> IO ())
-> ((ByteString, ByteString) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ByteString
host, ByteString
fragment) ->
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\nWeb link:\nhttps://" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
B.unpack ByteString
host String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/#" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
B.unpack ByteString
fragment
      [FileDescription 'FRecipient]
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    encryptFileForUpload :: TVar ChaChaDRG -> Text -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64)
    encryptFileForUpload :: TVar ChaChaDRG
-> Text
-> ExceptT
     CLIError
     IO
     (String, FileDescription 'FRecipient, FileDescription 'FSender,
      [XFTPChunkSpec], Int64)
encryptFileForUpload TVar ChaChaDRG
g Text
fileName = do
      Int64
fileSize <- Integer -> Int64
forall a. Num a => Integer -> a
fromInteger (Integer -> Int64)
-> ExceptT CLIError IO Integer -> ExceptT CLIError IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ExceptT CLIError IO Integer
forall (m :: * -> *). MonadIO m => String -> m Integer
getFileSize String
filePath
      Bool -> ExceptT CLIError IO () -> ExceptT CLIError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
fileSize Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
maxFileSize) (ExceptT CLIError IO () -> ExceptT CLIError IO ())
-> ExceptT CLIError IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ CLIError -> ExceptT CLIError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (CLIError -> ExceptT CLIError IO ())
-> CLIError -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ String -> CLIError
CLIError (String -> CLIError) -> String -> CLIError
forall a b. (a -> b) -> a -> b
$ String
"Files bigger than " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
maxFileSizeStr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" are not supported"
      String
encPath <- Maybe String -> String -> ExceptT CLIError IO String
forall (m :: * -> *).
MonadIO m =>
Maybe String -> String -> m String
getEncPath Maybe String
tempPath String
"xftp"
      SbKey
key <- STM SbKey -> ExceptT CLIError IO SbKey
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM SbKey -> ExceptT CLIError IO SbKey)
-> STM SbKey -> ExceptT CLIError IO SbKey
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM SbKey
C.randomSbKey TVar ChaChaDRG
g
      CbNonce
nonce <- STM CbNonce -> ExceptT CLIError IO CbNonce
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM CbNonce -> ExceptT CLIError IO CbNonce)
-> STM CbNonce -> ExceptT CLIError IO CbNonce
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM CbNonce
C.randomCbNonce TVar ChaChaDRG
g
      let fileHdr :: ByteString
fileHdr = FileHeader -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode FileHeader {Text
fileName :: Text
$sel:fileName:FileHeader :: Text
fileName, $sel:fileExtra:FileHeader :: Maybe Text
fileExtra = Maybe Text
forall a. Maybe a
Nothing}
          fileSize' :: Int64
fileSize' = Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
fileHdr) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
fileSize
          chunkSizes :: [Word32]
chunkSizes = Int64 -> [Word32]
prepareChunkSizes (Int64 -> [Word32]) -> Int64 -> [Word32]
forall a b. (a -> b) -> a -> b
$ Int64
fileSize' Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
fileSizeLen Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
authTagSize
          defChunkSize :: Word32
defChunkSize = [Word32] -> Word32
forall a. (?callStack::CallStack) => [a] -> a
head [Word32]
chunkSizes
          chunkSizes' :: [Int64]
chunkSizes' = (Word32 -> Int64) -> [Word32] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word32]
chunkSizes
          encSize :: Int64
encSize = [Int64] -> Int64
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int64]
chunkSizes'
          srcFile :: CryptoFile
srcFile = String -> CryptoFile
CF.plain String
filePath
      (FTCryptoError -> CLIError)
-> ExceptT FTCryptoError IO () -> ExceptT CLIError IO ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (String -> CLIError
CLIError (String -> CLIError)
-> (FTCryptoError -> String) -> FTCryptoError -> CLIError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FTCryptoError -> String
forall a. Show a => a -> String
show) (ExceptT FTCryptoError IO () -> ExceptT CLIError IO ())
-> ExceptT FTCryptoError IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ CryptoFile
-> ByteString
-> SbKey
-> CbNonce
-> Int64
-> Int64
-> String
-> ExceptT FTCryptoError IO ()
encryptFile CryptoFile
srcFile ByteString
fileHdr SbKey
key CbNonce
nonce Int64
fileSize' Int64
encSize String
encPath
      ByteString
digest <- IO ByteString -> ExceptT CLIError IO ByteString
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT CLIError IO ByteString)
-> IO ByteString -> ExceptT CLIError IO ByteString
forall a b. (a -> b) -> a -> b
$ LazyByteString -> ByteString
LC.sha512Hash (LazyByteString -> ByteString)
-> IO LazyByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO LazyByteString
LB.readFile String
encPath
      let chunkSpecs :: [XFTPChunkSpec]
chunkSpecs = String -> [Word32] -> [XFTPChunkSpec]
prepareChunkSpecs String
encPath [Word32]
chunkSizes
          fdRcv :: FileDescription 'FRecipient
fdRcv = FileDescription {$sel:party:FileDescription :: SFileParty 'FRecipient
party = SFileParty 'FRecipient
SFRecipient, $sel:size:FileDescription :: FileSize Int64
size = Int64 -> FileSize Int64
forall a. a -> FileSize a
FileSize Int64
encSize, $sel:digest:FileDescription :: FileDigest
digest = ByteString -> FileDigest
FileDigest ByteString
digest, SbKey
key :: SbKey
$sel:key:FileDescription :: SbKey
key, CbNonce
nonce :: CbNonce
$sel:nonce:FileDescription :: CbNonce
nonce, $sel:chunkSize:FileDescription :: FileSize Word32
chunkSize = Word32 -> FileSize Word32
forall a. a -> FileSize a
FileSize Word32
defChunkSize, $sel:chunks:FileDescription :: [FileChunk]
chunks = [], $sel:redirect:FileDescription :: Maybe RedirectFileInfo
redirect = Maybe RedirectFileInfo
forall a. Maybe a
Nothing}
          fdSnd :: FileDescription 'FSender
fdSnd = FileDescription {$sel:party:FileDescription :: SFileParty 'FSender
party = SFileParty 'FSender
SFSender, $sel:size:FileDescription :: FileSize Int64
size = Int64 -> FileSize Int64
forall a. a -> FileSize a
FileSize Int64
encSize, $sel:digest:FileDescription :: FileDigest
digest = ByteString -> FileDigest
FileDigest ByteString
digest, SbKey
key :: SbKey
$sel:key:FileDescription :: SbKey
key, CbNonce
nonce :: CbNonce
$sel:nonce:FileDescription :: CbNonce
nonce, $sel:chunkSize:FileDescription :: FileSize Word32
chunkSize = Word32 -> FileSize Word32
forall a. a -> FileSize a
FileSize Word32
defChunkSize, $sel:chunks:FileDescription :: [FileChunk]
chunks = [], $sel:redirect:FileDescription :: Maybe RedirectFileInfo
redirect = Maybe RedirectFileInfo
forall a. Maybe a
Nothing}
      Text -> ExceptT CLIError IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug (Text -> ExceptT CLIError IO ()) -> Text -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ Text
"encrypted file to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
tshow String
encPath
      (String, FileDescription 'FRecipient, FileDescription 'FSender,
 [XFTPChunkSpec], Int64)
-> ExceptT
     CLIError
     IO
     (String, FileDescription 'FRecipient, FileDescription 'FSender,
      [XFTPChunkSpec], Int64)
forall a. a -> ExceptT CLIError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
encPath, FileDescription 'FRecipient
fdRcv, FileDescription 'FSender
fdSnd, [XFTPChunkSpec]
chunkSpecs, Int64
encSize)
    uploadFile :: TVar ChaChaDRG -> [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk]
    uploadFile :: TVar ChaChaDRG
-> [XFTPChunkSpec]
-> TVar [Int64]
-> Int64
-> ExceptT CLIError IO [SentFileChunk]
uploadFile TVar ChaChaDRG
g [XFTPChunkSpec]
chunks TVar [Int64]
uploadedChunks Int64
encSize = do
      XFTPClientAgent
a <- IO XFTPClientAgent -> ExceptT CLIError IO XFTPClientAgent
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO XFTPClientAgent -> ExceptT CLIError IO XFTPClientAgent)
-> IO XFTPClientAgent -> ExceptT CLIError IO XFTPClientAgent
forall a b. (a -> b) -> a -> b
$ XFTPClientAgentConfig -> IO XFTPClientAgent
newXFTPAgent XFTPClientAgentConfig
defaultXFTPClientAgentConfig
      TVar StdGen
gen <- StdGen -> ExceptT CLIError IO (TVar StdGen)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (StdGen -> ExceptT CLIError IO (TVar StdGen))
-> ExceptT CLIError IO StdGen -> ExceptT CLIError IO (TVar StdGen)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO StdGen -> ExceptT CLIError IO StdGen
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
      let xftpSrvs :: NonEmpty XFTPServerWithAuth
xftpSrvs = NonEmpty XFTPServerWithAuth
-> Maybe (NonEmpty XFTPServerWithAuth)
-> NonEmpty XFTPServerWithAuth
forall a. a -> Maybe a -> a
fromMaybe NonEmpty XFTPServerWithAuth
defaultXFTPServers ([XFTPServerWithAuth] -> Maybe (NonEmpty XFTPServerWithAuth)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [XFTPServerWithAuth]
xftpServers)
      [XFTPServerWithAuth]
srvs <- IO [XFTPServerWithAuth] -> ExceptT CLIError IO [XFTPServerWithAuth]
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [XFTPServerWithAuth]
 -> ExceptT CLIError IO [XFTPServerWithAuth])
-> IO [XFTPServerWithAuth]
-> ExceptT CLIError IO [XFTPServerWithAuth]
forall a b. (a -> b) -> a -> b
$ Int -> IO XFTPServerWithAuth -> IO [XFTPServerWithAuth]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([XFTPChunkSpec] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [XFTPChunkSpec]
chunks) (IO XFTPServerWithAuth -> IO [XFTPServerWithAuth])
-> IO XFTPServerWithAuth -> IO [XFTPServerWithAuth]
forall a b. (a -> b) -> a -> b
$ TVar StdGen -> NonEmpty XFTPServerWithAuth -> IO XFTPServerWithAuth
getXFTPServer TVar StdGen
gen NonEmpty XFTPServerWithAuth
xftpSrvs
      let thd3 :: (a, b, c) -> c
thd3 (a
_, b
_, c
x) = c
x
          chunks' :: [[(Int, XFTPChunkSpec, XFTPServerWithAuth)]]
chunks' = ((Int, XFTPChunkSpec, XFTPServerWithAuth) -> XFTPServerWithAuth)
-> [(Int, XFTPChunkSpec, XFTPServerWithAuth)]
-> [[(Int, XFTPChunkSpec, XFTPServerWithAuth)]]
forall k a. Ord k => (a -> k) -> [a] -> [[a]]
groupAllOn (Int, XFTPChunkSpec, XFTPServerWithAuth) -> XFTPServerWithAuth
forall {a} {b} {c}. (a, b, c) -> c
thd3 ([(Int, XFTPChunkSpec, XFTPServerWithAuth)]
 -> [[(Int, XFTPChunkSpec, XFTPServerWithAuth)]])
-> [(Int, XFTPChunkSpec, XFTPServerWithAuth)]
-> [[(Int, XFTPChunkSpec, XFTPServerWithAuth)]]
forall a b. (a -> b) -> a -> b
$ [Int]
-> [XFTPChunkSpec]
-> [XFTPServerWithAuth]
-> [(Int, XFTPChunkSpec, XFTPServerWithAuth)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
1 ..] [XFTPChunkSpec]
chunks [XFTPServerWithAuth]
srvs
      -- TODO shuffle/unshuffle chunks
      -- the reason we don't do pooled downloads here within one server is that http2 library doesn't handle cleint concurrency, even though
      -- upload doesn't allow other requests within the same client until complete (but download does allow).
      Text -> ExceptT CLIError IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug (Text -> ExceptT CLIError IO ()) -> Text -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ Text
"uploading " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow ([XFTPChunkSpec] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [XFTPChunkSpec]
chunks) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" chunks..."
      ([CLIError]
errs, [(Int, SentFileChunk)]
rs) <- [Either CLIError (Int, SentFileChunk)]
-> ([CLIError], [(Int, SentFileChunk)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either CLIError (Int, SentFileChunk)]
 -> ([CLIError], [(Int, SentFileChunk)]))
-> ([[Either CLIError (Int, SentFileChunk)]]
    -> [Either CLIError (Int, SentFileChunk)])
-> [[Either CLIError (Int, SentFileChunk)]]
-> ([CLIError], [(Int, SentFileChunk)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Either CLIError (Int, SentFileChunk)]]
-> [Either CLIError (Int, SentFileChunk)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Either CLIError (Int, SentFileChunk)]]
 -> ([CLIError], [(Int, SentFileChunk)]))
-> ExceptT CLIError IO [[Either CLIError (Int, SentFileChunk)]]
-> ExceptT CLIError IO ([CLIError], [(Int, SentFileChunk)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [[Either CLIError (Int, SentFileChunk)]]
-> ExceptT CLIError IO [[Either CLIError (Int, SentFileChunk)]]
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int
-> [[(Int, XFTPChunkSpec, XFTPServerWithAuth)]]
-> ([(Int, XFTPChunkSpec, XFTPServerWithAuth)]
    -> IO [Either CLIError (Int, SentFileChunk)])
-> IO [[Either CLIError (Int, SentFileChunk)]]
forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Traversable t) =>
Int -> t a -> (a -> m b) -> m (t b)
pooledForConcurrentlyN Int
16 [[(Int, XFTPChunkSpec, XFTPServerWithAuth)]]
chunks' (([(Int, XFTPChunkSpec, XFTPServerWithAuth)]
  -> IO [Either CLIError (Int, SentFileChunk)])
 -> IO [[Either CLIError (Int, SentFileChunk)]])
-> (((Int, XFTPChunkSpec, XFTPServerWithAuth)
     -> IO (Either CLIError (Int, SentFileChunk)))
    -> [(Int, XFTPChunkSpec, XFTPServerWithAuth)]
    -> IO [Either CLIError (Int, SentFileChunk)])
-> ((Int, XFTPChunkSpec, XFTPServerWithAuth)
    -> IO (Either CLIError (Int, SentFileChunk)))
-> IO [[Either CLIError (Int, SentFileChunk)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, XFTPChunkSpec, XFTPServerWithAuth)
 -> IO (Either CLIError (Int, SentFileChunk)))
-> [(Int, XFTPChunkSpec, XFTPServerWithAuth)]
-> IO [Either CLIError (Int, SentFileChunk)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (((Int, XFTPChunkSpec, XFTPServerWithAuth)
  -> IO (Either CLIError (Int, SentFileChunk)))
 -> IO [[Either CLIError (Int, SentFileChunk)]])
-> ((Int, XFTPChunkSpec, XFTPServerWithAuth)
    -> IO (Either CLIError (Int, SentFileChunk)))
-> IO [[Either CLIError (Int, SentFileChunk)]]
forall a b. (a -> b) -> a -> b
$ ExceptT CLIError IO (Int, SentFileChunk)
-> IO (Either CLIError (Int, SentFileChunk))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT CLIError IO (Int, SentFileChunk)
 -> IO (Either CLIError (Int, SentFileChunk)))
-> ((Int, XFTPChunkSpec, XFTPServerWithAuth)
    -> ExceptT CLIError IO (Int, SentFileChunk))
-> (Int, XFTPChunkSpec, XFTPServerWithAuth)
-> IO (Either CLIError (Int, SentFileChunk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPClientAgent
-> (Int, XFTPChunkSpec, XFTPServerWithAuth)
-> ExceptT CLIError IO (Int, SentFileChunk)
uploadFileChunk XFTPClientAgent
a)
      (CLIError -> ExceptT CLIError IO Any)
-> [CLIError] -> ExceptT CLIError IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CLIError -> ExceptT CLIError IO Any
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE [CLIError]
errs
      [SentFileChunk] -> ExceptT CLIError IO [SentFileChunk]
forall a. a -> ExceptT CLIError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SentFileChunk] -> ExceptT CLIError IO [SentFileChunk])
-> [SentFileChunk] -> ExceptT CLIError IO [SentFileChunk]
forall a b. (a -> b) -> a -> b
$ ((Int, SentFileChunk) -> SentFileChunk)
-> [(Int, SentFileChunk)] -> [SentFileChunk]
forall a b. (a -> b) -> [a] -> [b]
map (Int, SentFileChunk) -> SentFileChunk
forall a b. (a, b) -> b
snd (((Int, SentFileChunk) -> Int)
-> [(Int, SentFileChunk)] -> [(Int, SentFileChunk)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int, SentFileChunk) -> Int
forall a b. (a, b) -> a
fst [(Int, SentFileChunk)]
rs)
      where
        uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec, XFTPServerWithAuth) -> ExceptT CLIError IO (Int, SentFileChunk)
        uploadFileChunk :: XFTPClientAgent
-> (Int, XFTPChunkSpec, XFTPServerWithAuth)
-> ExceptT CLIError IO (Int, SentFileChunk)
uploadFileChunk XFTPClientAgent
a (Int
chunkNo, chunkSpec :: XFTPChunkSpec
chunkSpec@XFTPChunkSpec {Word32
chunkSize :: Word32
$sel:chunkSize:XFTPChunkSpec :: XFTPChunkSpec -> Word32
chunkSize}, ProtoServerWithAuth XFTPServer
xftpServer Maybe BasicAuth
auth) = do
          Text -> ExceptT CLIError IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug (Text -> ExceptT CLIError IO ()) -> Text -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ Text
"uploading chunk " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
chunkNo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> XFTPServer -> Text
showServer XFTPServer
xftpServer Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"..."
          (SndPublicAuthKey
sndKey, SndPrivateAuthKey
spKey) <- STM AAuthKeyPair -> ExceptT CLIError IO AAuthKeyPair
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM AAuthKeyPair -> ExceptT CLIError IO AAuthKeyPair)
-> STM AAuthKeyPair -> ExceptT CLIError IO AAuthKeyPair
forall a b. (a -> b) -> a -> b
$ SAlgorithm 'Ed25519 -> TVar ChaChaDRG -> STM AAuthKeyPair
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
C.generateAuthKeyPair SAlgorithm 'Ed25519
C.SEd25519 TVar ChaChaDRG
g
          NonEmpty (SndPublicAuthKey, SndPrivateAuthKey)
rKeys <- STM (NonEmpty (SndPublicAuthKey, SndPrivateAuthKey))
-> ExceptT
     CLIError IO (NonEmpty (SndPublicAuthKey, SndPrivateAuthKey))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (NonEmpty (SndPublicAuthKey, SndPrivateAuthKey))
 -> ExceptT
      CLIError IO (NonEmpty (SndPublicAuthKey, SndPrivateAuthKey)))
-> STM (NonEmpty (SndPublicAuthKey, SndPrivateAuthKey))
-> ExceptT
     CLIError IO (NonEmpty (SndPublicAuthKey, SndPrivateAuthKey))
forall a b. (a -> b) -> a -> b
$ [(SndPublicAuthKey, SndPrivateAuthKey)]
-> NonEmpty (SndPublicAuthKey, SndPrivateAuthKey)
forall a. (?callStack::CallStack) => [a] -> NonEmpty a
L.fromList ([(SndPublicAuthKey, SndPrivateAuthKey)]
 -> NonEmpty (SndPublicAuthKey, SndPrivateAuthKey))
-> STM [(SndPublicAuthKey, SndPrivateAuthKey)]
-> STM (NonEmpty (SndPublicAuthKey, SndPrivateAuthKey))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> STM (SndPublicAuthKey, SndPrivateAuthKey)
-> STM [(SndPublicAuthKey, SndPrivateAuthKey)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numRecipients (SAlgorithm 'Ed25519 -> TVar ChaChaDRG -> STM AAuthKeyPair
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair
C.generateAuthKeyPair SAlgorithm 'Ed25519
C.SEd25519 TVar ChaChaDRG
g)
          ByteString
digest <- IO ByteString -> ExceptT CLIError IO ByteString
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT CLIError IO ByteString)
-> IO ByteString -> ExceptT CLIError IO ByteString
forall a b. (a -> b) -> a -> b
$ XFTPChunkSpec -> IO ByteString
getChunkDigest XFTPChunkSpec
chunkSpec
          let ch :: FileInfo
ch = FileInfo {SndPublicAuthKey
sndKey :: SndPublicAuthKey
sndKey :: SndPublicAuthKey
sndKey, size :: Word32
size = Word32
chunkSize, ByteString
digest :: ByteString
digest :: ByteString
digest}
          XFTPClient
c <- Int
-> ExceptT XFTPClientAgentError IO XFTPClient
-> ExceptT CLIError IO XFTPClient
forall e a.
Show e =>
Int -> ExceptT e IO a -> ExceptT CLIError IO a
withRetry Int
retryCount (ExceptT XFTPClientAgentError IO XFTPClient
 -> ExceptT CLIError IO XFTPClient)
-> ExceptT XFTPClientAgentError IO XFTPClient
-> ExceptT CLIError IO XFTPClient
forall a b. (a -> b) -> a -> b
$ XFTPClientAgent
-> XFTPServer -> ExceptT XFTPClientAgentError IO XFTPClient
getXFTPServerClient XFTPClientAgent
a XFTPServer
xftpServer
          (SenderId
sndId, NonEmpty SenderId
rIds) <- Int
-> ExceptT XFTPClientError IO (SenderId, NonEmpty SenderId)
-> ExceptT CLIError IO (SenderId, NonEmpty SenderId)
forall e a.
Show e =>
Int -> ExceptT e IO a -> ExceptT CLIError IO a
withRetry Int
retryCount (ExceptT XFTPClientError IO (SenderId, NonEmpty SenderId)
 -> ExceptT CLIError IO (SenderId, NonEmpty SenderId))
-> ExceptT XFTPClientError IO (SenderId, NonEmpty SenderId)
-> ExceptT CLIError IO (SenderId, NonEmpty SenderId)
forall a b. (a -> b) -> a -> b
$ XFTPClient
-> SndPrivateAuthKey
-> FileInfo
-> NonEmpty SndPublicAuthKey
-> Maybe BasicAuth
-> ExceptT XFTPClientError IO (SenderId, NonEmpty SenderId)
createXFTPChunk XFTPClient
c SndPrivateAuthKey
spKey FileInfo
ch (((SndPublicAuthKey, SndPrivateAuthKey) -> SndPublicAuthKey)
-> NonEmpty (SndPublicAuthKey, SndPrivateAuthKey)
-> NonEmpty SndPublicAuthKey
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (SndPublicAuthKey, SndPrivateAuthKey) -> SndPublicAuthKey
forall a b. (a, b) -> a
fst NonEmpty (SndPublicAuthKey, SndPrivateAuthKey)
rKeys) Maybe BasicAuth
auth
          XFTPClientAgent
-> XFTPServer
-> Int
-> (XFTPClient -> ExceptT XFTPClientError IO ())
-> ExceptT CLIError IO ()
forall e a.
Show e =>
XFTPClientAgent
-> XFTPServer
-> Int
-> (XFTPClient -> ExceptT e IO a)
-> ExceptT CLIError IO a
withReconnect XFTPClientAgent
a XFTPServer
xftpServer Int
retryCount ((XFTPClient -> ExceptT XFTPClientError IO ())
 -> ExceptT CLIError IO ())
-> (XFTPClient -> ExceptT XFTPClientError IO ())
-> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ \XFTPClient
c' -> XFTPClient
-> SndPrivateAuthKey
-> SenderId
-> XFTPChunkSpec
-> ExceptT XFTPClientError IO ()
uploadXFTPChunk XFTPClient
c' SndPrivateAuthKey
spKey SenderId
sndId XFTPChunkSpec
chunkSpec
          Text -> ExceptT CLIError IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug (Text -> ExceptT CLIError IO ()) -> Text -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ Text
"uploaded chunk " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
chunkNo
          Int64
uploaded <- STM Int64 -> ExceptT CLIError IO Int64
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Int64 -> ExceptT CLIError IO Int64)
-> (([Int64] -> (Int64, [Int64])) -> STM Int64)
-> ([Int64] -> (Int64, [Int64]))
-> ExceptT CLIError IO Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar [Int64] -> ([Int64] -> (Int64, [Int64])) -> STM Int64
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar [Int64]
uploadedChunks (([Int64] -> (Int64, [Int64])) -> ExceptT CLIError IO Int64)
-> ([Int64] -> (Int64, [Int64])) -> ExceptT CLIError IO Int64
forall a b. (a -> b) -> a -> b
$ \[Int64]
cs ->
            let cs' :: [Int64]
cs' = Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
chunkSize Int64 -> [Int64] -> [Int64]
forall a. a -> [a] -> [a]
: [Int64]
cs in ([Int64] -> Int64
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int64]
cs', [Int64]
cs')
          IO () -> ExceptT CLIError IO ()
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT CLIError IO ())
-> IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ do
            Int64 -> Int64 -> IO ()
notifyProgress Int64
uploaded Int64
encSize
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
          let recipients :: [(ChunkReplicaId, SndPrivateAuthKey)]
recipients = NonEmpty (ChunkReplicaId, SndPrivateAuthKey)
-> [(ChunkReplicaId, SndPrivateAuthKey)]
forall a. NonEmpty a -> [a]
L.toList (NonEmpty (ChunkReplicaId, SndPrivateAuthKey)
 -> [(ChunkReplicaId, SndPrivateAuthKey)])
-> NonEmpty (ChunkReplicaId, SndPrivateAuthKey)
-> [(ChunkReplicaId, SndPrivateAuthKey)]
forall a b. (a -> b) -> a -> b
$ (SenderId -> ChunkReplicaId)
-> NonEmpty SenderId -> NonEmpty ChunkReplicaId
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map SenderId -> ChunkReplicaId
ChunkReplicaId NonEmpty SenderId
rIds NonEmpty ChunkReplicaId
-> NonEmpty SndPrivateAuthKey
-> NonEmpty (ChunkReplicaId, SndPrivateAuthKey)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
`L.zip` ((SndPublicAuthKey, SndPrivateAuthKey) -> SndPrivateAuthKey)
-> NonEmpty (SndPublicAuthKey, SndPrivateAuthKey)
-> NonEmpty SndPrivateAuthKey
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (SndPublicAuthKey, SndPrivateAuthKey) -> SndPrivateAuthKey
forall a b. (a, b) -> b
snd NonEmpty (SndPublicAuthKey, SndPrivateAuthKey)
rKeys
              replicas :: [SentFileChunkReplica]
replicas = [SentFileChunkReplica {$sel:server:SentFileChunkReplica :: XFTPServer
server = XFTPServer
xftpServer, [(ChunkReplicaId, SndPrivateAuthKey)]
$sel:recipients:SentFileChunkReplica :: [(ChunkReplicaId, SndPrivateAuthKey)]
recipients :: [(ChunkReplicaId, SndPrivateAuthKey)]
recipients}]
          (Int, SentFileChunk) -> ExceptT CLIError IO (Int, SentFileChunk)
forall a. a -> ExceptT CLIError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
chunkNo, SentFileChunk {Int
$sel:chunkNo:SentFileChunk :: Int
chunkNo :: Int
chunkNo, SenderId
$sel:sndId:SentFileChunk :: SenderId
sndId :: SenderId
sndId, $sel:sndPrivateKey:SentFileChunk :: SndPrivateAuthKey
sndPrivateKey = SndPrivateAuthKey
spKey, $sel:chunkSize:SentFileChunk :: FileSize Word32
chunkSize = Word32 -> FileSize Word32
forall a. a -> FileSize a
FileSize Word32
chunkSize, $sel:digest:SentFileChunk :: FileDigest
digest = ByteString -> FileDigest
FileDigest ByteString
digest, [SentFileChunkReplica]
$sel:replicas:SentFileChunk :: [SentFileChunkReplica]
replicas :: [SentFileChunkReplica]
replicas})
        getXFTPServer :: TVar StdGen -> NonEmpty XFTPServerWithAuth -> IO XFTPServerWithAuth
        getXFTPServer :: TVar StdGen -> NonEmpty XFTPServerWithAuth -> IO XFTPServerWithAuth
getXFTPServer TVar StdGen
gen = \case
          XFTPServerWithAuth
srv :| [] -> XFTPServerWithAuth -> IO XFTPServerWithAuth
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPServerWithAuth
srv
          NonEmpty XFTPServerWithAuth
servers -> do
            STM XFTPServerWithAuth -> IO XFTPServerWithAuth
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM XFTPServerWithAuth -> IO XFTPServerWithAuth)
-> STM XFTPServerWithAuth -> IO XFTPServerWithAuth
forall a b. (a -> b) -> a -> b
$ (NonEmpty XFTPServerWithAuth
servers NonEmpty XFTPServerWithAuth -> Int -> XFTPServerWithAuth
forall a. (?callStack::CallStack) => NonEmpty a -> Int -> a
L.!!) (Int -> XFTPServerWithAuth) -> STM Int -> STM XFTPServerWithAuth
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar StdGen -> (StdGen -> (Int, StdGen)) -> STM Int
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar StdGen
gen ((Int, Int) -> StdGen -> (Int, StdGen)
forall g. RandomGen g => (Int, Int) -> g -> (Int, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, NonEmpty XFTPServerWithAuth -> Int
forall a. NonEmpty a -> Int
L.length NonEmpty XFTPServerWithAuth
servers Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))

    -- M chunks, R replicas, N recipients
    -- rcvReplicas: M[SentFileChunk] -> M * R * N [SentRecipientReplica]
    -- rcvChunks: M * R * N [SentRecipientReplica] -> N[ M[FileChunk] ]
    createRcvFileDescriptions :: FileDescription 'FRecipient -> [SentFileChunk] -> [FileDescription 'FRecipient]
    createRcvFileDescriptions :: FileDescription 'FRecipient
-> [SentFileChunk] -> [FileDescription 'FRecipient]
createRcvFileDescriptions FileDescription 'FRecipient
fd [SentFileChunk]
sentChunks = ([FileChunk] -> FileDescription 'FRecipient)
-> [[FileChunk]] -> [FileDescription 'FRecipient]
forall a b. (a -> b) -> [a] -> [b]
map (\[FileChunk]
chunks -> (FileDescription 'FRecipient
fd :: (FileDescription 'FRecipient)) {chunks}) [[FileChunk]]
rcvChunks
      where
        rcvReplicas :: [SentRecipientReplica]
        rcvReplicas :: [SentRecipientReplica]
rcvReplicas =
          (SentFileChunk -> [SentRecipientReplica])
-> [SentFileChunk] -> [SentRecipientReplica]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
            ( \SentFileChunk {Int
$sel:chunkNo:SentFileChunk :: SentFileChunk -> Int
chunkNo :: Int
chunkNo, FileDigest
$sel:digest:SentFileChunk :: SentFileChunk -> FileDigest
digest :: FileDigest
digest, FileSize Word32
$sel:chunkSize:SentFileChunk :: SentFileChunk -> FileSize Word32
chunkSize :: FileSize Word32
chunkSize, [SentFileChunkReplica]
$sel:replicas:SentFileChunk :: SentFileChunk -> [SentFileChunkReplica]
replicas :: [SentFileChunkReplica]
replicas} ->
                (SentFileChunkReplica -> [SentRecipientReplica])
-> [SentFileChunkReplica] -> [SentRecipientReplica]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                  ( \SentFileChunkReplica {XFTPServer
$sel:server:SentFileChunkReplica :: SentFileChunkReplica -> XFTPServer
server :: XFTPServer
server, [(ChunkReplicaId, SndPrivateAuthKey)]
$sel:recipients:SentFileChunkReplica :: SentFileChunkReplica -> [(ChunkReplicaId, SndPrivateAuthKey)]
recipients :: [(ChunkReplicaId, SndPrivateAuthKey)]
recipients} ->
                      (Int
 -> (ChunkReplicaId, SndPrivateAuthKey) -> SentRecipientReplica)
-> [Int]
-> [(ChunkReplicaId, SndPrivateAuthKey)]
-> [SentRecipientReplica]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
rcvNo (ChunkReplicaId
replicaId, SndPrivateAuthKey
replicaKey) -> SentRecipientReplica {Int
chunkNo :: Int
$sel:chunkNo:SentRecipientReplica :: Int
chunkNo, XFTPServer
server :: XFTPServer
$sel:server:SentRecipientReplica :: XFTPServer
server, Int
rcvNo :: Int
$sel:rcvNo:SentRecipientReplica :: Int
rcvNo, ChunkReplicaId
replicaId :: ChunkReplicaId
$sel:replicaId:SentRecipientReplica :: ChunkReplicaId
replicaId, SndPrivateAuthKey
replicaKey :: SndPrivateAuthKey
$sel:replicaKey:SentRecipientReplica :: SndPrivateAuthKey
replicaKey, FileDigest
digest :: FileDigest
$sel:digest:SentRecipientReplica :: FileDigest
digest, FileSize Word32
chunkSize :: FileSize Word32
$sel:chunkSize:SentRecipientReplica :: FileSize Word32
chunkSize}) [Int
1 ..] [(ChunkReplicaId, SndPrivateAuthKey)]
recipients
                  )
                  [SentFileChunkReplica]
replicas
            )
            [SentFileChunk]
sentChunks
        rcvChunks :: [[FileChunk]]
        rcvChunks :: [[FileChunk]]
rcvChunks = (Map Int FileChunk -> [FileChunk])
-> [Map Int FileChunk] -> [[FileChunk]]
forall a b. (a -> b) -> [a] -> [b]
map ([FileChunk] -> [FileChunk]
sortChunks ([FileChunk] -> [FileChunk])
-> (Map Int FileChunk -> [FileChunk])
-> Map Int FileChunk
-> [FileChunk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Int FileChunk -> [FileChunk]
forall k a. Map k a -> [a]
M.elems) ([Map Int FileChunk] -> [[FileChunk]])
-> [Map Int FileChunk] -> [[FileChunk]]
forall a b. (a -> b) -> a -> b
$ Map Int (Map Int FileChunk) -> [Map Int FileChunk]
forall k a. Map k a -> [a]
M.elems (Map Int (Map Int FileChunk) -> [Map Int FileChunk])
-> Map Int (Map Int FileChunk) -> [Map Int FileChunk]
forall a b. (a -> b) -> a -> b
$ (Map Int (Map Int FileChunk)
 -> SentRecipientReplica -> Map Int (Map Int FileChunk))
-> Map Int (Map Int FileChunk)
-> [SentRecipientReplica]
-> Map Int (Map Int FileChunk)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map Int (Map Int FileChunk)
-> SentRecipientReplica -> Map Int (Map Int FileChunk)
addRcvChunk Map Int (Map Int FileChunk)
forall k a. Map k a
M.empty [SentRecipientReplica]
rcvReplicas
        sortChunks :: [FileChunk] -> [FileChunk]
        sortChunks :: [FileChunk] -> [FileChunk]
sortChunks = (FileChunk -> FileChunk) -> [FileChunk] -> [FileChunk]
forall a b. (a -> b) -> [a] -> [b]
map FileChunk -> FileChunk
reverseReplicas ([FileChunk] -> [FileChunk])
-> ([FileChunk] -> [FileChunk]) -> [FileChunk] -> [FileChunk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileChunk -> Int) -> [FileChunk] -> [FileChunk]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\FileChunk {Int
chunkNo :: Int
$sel:chunkNo:FileChunk :: FileChunk -> Int
chunkNo} -> Int
chunkNo)
        reverseReplicas :: FileChunk -> FileChunk
reverseReplicas ch :: FileChunk
ch@FileChunk {[FileChunkReplica]
replicas :: [FileChunkReplica]
$sel:replicas:FileChunk :: FileChunk -> [FileChunkReplica]
replicas} = (FileChunk
ch :: FileChunk) {replicas = reverse replicas}
        addRcvChunk :: Map Int (Map Int FileChunk) -> SentRecipientReplica -> Map Int (Map Int FileChunk)
        addRcvChunk :: Map Int (Map Int FileChunk)
-> SentRecipientReplica -> Map Int (Map Int FileChunk)
addRcvChunk Map Int (Map Int FileChunk)
m SentRecipientReplica {Int
$sel:chunkNo:SentRecipientReplica :: SentRecipientReplica -> Int
chunkNo :: Int
chunkNo, XFTPServer
$sel:server:SentRecipientReplica :: SentRecipientReplica -> XFTPServer
server :: XFTPServer
server, Int
$sel:rcvNo:SentRecipientReplica :: SentRecipientReplica -> Int
rcvNo :: Int
rcvNo, ChunkReplicaId
$sel:replicaId:SentRecipientReplica :: SentRecipientReplica -> ChunkReplicaId
replicaId :: ChunkReplicaId
replicaId, SndPrivateAuthKey
$sel:replicaKey:SentRecipientReplica :: SentRecipientReplica -> SndPrivateAuthKey
replicaKey :: SndPrivateAuthKey
replicaKey, FileDigest
$sel:digest:SentRecipientReplica :: SentRecipientReplica -> FileDigest
digest :: FileDigest
digest, FileSize Word32
$sel:chunkSize:SentRecipientReplica :: SentRecipientReplica -> FileSize Word32
chunkSize :: FileSize Word32
chunkSize} =
          (Maybe (Map Int FileChunk) -> Maybe (Map Int FileChunk))
-> Int
-> Map Int (Map Int FileChunk)
-> Map Int (Map Int FileChunk)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (Map Int FileChunk -> Maybe (Map Int FileChunk)
forall a. a -> Maybe a
Just (Map Int FileChunk -> Maybe (Map Int FileChunk))
-> (Maybe (Map Int FileChunk) -> Map Int FileChunk)
-> Maybe (Map Int FileChunk)
-> Maybe (Map Int FileChunk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Map Int FileChunk) -> Map Int FileChunk
addOrChangeRecipient) Int
rcvNo Map Int (Map Int FileChunk)
m
          where
            addOrChangeRecipient :: Maybe (Map Int FileChunk) -> Map Int FileChunk
            addOrChangeRecipient :: Maybe (Map Int FileChunk) -> Map Int FileChunk
addOrChangeRecipient = \case
              Just Map Int FileChunk
m' -> (Maybe FileChunk -> Maybe FileChunk)
-> Int -> Map Int FileChunk -> Map Int FileChunk
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (FileChunk -> Maybe FileChunk
forall a. a -> Maybe a
Just (FileChunk -> Maybe FileChunk)
-> (Maybe FileChunk -> FileChunk)
-> Maybe FileChunk
-> Maybe FileChunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FileChunk -> FileChunk
addOrChangeChunk) Int
chunkNo Map Int FileChunk
m'
              Maybe (Map Int FileChunk)
_ -> Int -> FileChunk -> Map Int FileChunk
forall k a. k -> a -> Map k a
M.singleton Int
chunkNo (FileChunk -> Map Int FileChunk) -> FileChunk -> Map Int FileChunk
forall a b. (a -> b) -> a -> b
$ FileChunk {Int
$sel:chunkNo:FileChunk :: Int
chunkNo :: Int
chunkNo, FileDigest
digest :: FileDigest
$sel:digest:FileChunk :: FileDigest
digest, FileSize Word32
chunkSize :: FileSize Word32
$sel:chunkSize:FileChunk :: FileSize Word32
chunkSize, $sel:replicas:FileChunk :: [FileChunkReplica]
replicas = [FileChunkReplica
replica]}
            addOrChangeChunk :: Maybe FileChunk -> FileChunk
            addOrChangeChunk :: Maybe FileChunk -> FileChunk
addOrChangeChunk = \case
              Just ch :: FileChunk
ch@FileChunk {[FileChunkReplica]
$sel:replicas:FileChunk :: FileChunk -> [FileChunkReplica]
replicas :: [FileChunkReplica]
replicas} -> FileChunk
ch {replicas = replica : replicas}
              Maybe FileChunk
_ -> FileChunk {Int
$sel:chunkNo:FileChunk :: Int
chunkNo :: Int
chunkNo, FileDigest
digest :: FileDigest
$sel:digest:FileChunk :: FileDigest
digest, FileSize Word32
chunkSize :: FileSize Word32
$sel:chunkSize:FileChunk :: FileSize Word32
chunkSize, $sel:replicas:FileChunk :: [FileChunkReplica]
replicas = [FileChunkReplica
replica]}
            replica :: FileChunkReplica
replica = FileChunkReplica {XFTPServer
server :: XFTPServer
$sel:server:FileChunkReplica :: XFTPServer
server, ChunkReplicaId
replicaId :: ChunkReplicaId
$sel:replicaId:FileChunkReplica :: ChunkReplicaId
replicaId, SndPrivateAuthKey
replicaKey :: SndPrivateAuthKey
$sel:replicaKey:FileChunkReplica :: SndPrivateAuthKey
replicaKey}
    createSndFileDescription :: FileDescription 'FSender -> [SentFileChunk] -> FileDescription 'FSender
    createSndFileDescription :: FileDescription 'FSender
-> [SentFileChunk] -> FileDescription 'FSender
createSndFileDescription FileDescription 'FSender
fd [SentFileChunk]
sentChunks = FileDescription 'FSender
fd {chunks = sndChunks}
      where
        sndChunks :: [FileChunk]
        sndChunks :: [FileChunk]
sndChunks =
          (SentFileChunk -> FileChunk) -> [SentFileChunk] -> [FileChunk]
forall a b. (a -> b) -> [a] -> [b]
map
            ( \SentFileChunk {Int
$sel:chunkNo:SentFileChunk :: SentFileChunk -> Int
chunkNo :: Int
chunkNo, SenderId
$sel:sndId:SentFileChunk :: SentFileChunk -> SenderId
sndId :: SenderId
sndId, SndPrivateAuthKey
$sel:sndPrivateKey:SentFileChunk :: SentFileChunk -> SndPrivateAuthKey
sndPrivateKey :: SndPrivateAuthKey
sndPrivateKey, FileSize Word32
$sel:chunkSize:SentFileChunk :: SentFileChunk -> FileSize Word32
chunkSize :: FileSize Word32
chunkSize, FileDigest
$sel:digest:SentFileChunk :: SentFileChunk -> FileDigest
digest :: FileDigest
digest, [SentFileChunkReplica]
$sel:replicas:SentFileChunk :: SentFileChunk -> [SentFileChunkReplica]
replicas :: [SentFileChunkReplica]
replicas} ->
                FileChunk {Int
$sel:chunkNo:FileChunk :: Int
chunkNo :: Int
chunkNo, FileDigest
$sel:digest:FileChunk :: FileDigest
digest :: FileDigest
digest, FileSize Word32
$sel:chunkSize:FileChunk :: FileSize Word32
chunkSize :: FileSize Word32
chunkSize, $sel:replicas:FileChunk :: [FileChunkReplica]
replicas = [SentFileChunkReplica]
-> ChunkReplicaId -> SndPrivateAuthKey -> [FileChunkReplica]
sndReplicas [SentFileChunkReplica]
replicas (SenderId -> ChunkReplicaId
ChunkReplicaId SenderId
sndId) SndPrivateAuthKey
sndPrivateKey}
            )
            [SentFileChunk]
sentChunks
        -- SentFileChunk having sndId and sndPrivateKey represents the current implementation's limitation
        -- that sender uploads each chunk only to one server, so we can use the first replica's server for FileChunkReplica
        sndReplicas :: [SentFileChunkReplica] -> ChunkReplicaId -> C.APrivateAuthKey -> [FileChunkReplica]
        sndReplicas :: [SentFileChunkReplica]
-> ChunkReplicaId -> SndPrivateAuthKey -> [FileChunkReplica]
sndReplicas [] ChunkReplicaId
_ SndPrivateAuthKey
_ = []
        sndReplicas (SentFileChunkReplica {XFTPServer
$sel:server:SentFileChunkReplica :: SentFileChunkReplica -> XFTPServer
server :: XFTPServer
server} : [SentFileChunkReplica]
_) ChunkReplicaId
replicaId SndPrivateAuthKey
replicaKey = [FileChunkReplica {XFTPServer
$sel:server:FileChunkReplica :: XFTPServer
server :: XFTPServer
server, ChunkReplicaId
$sel:replicaId:FileChunkReplica :: ChunkReplicaId
replicaId :: ChunkReplicaId
replicaId, SndPrivateAuthKey
$sel:replicaKey:FileChunkReplica :: SndPrivateAuthKey
replicaKey :: SndPrivateAuthKey
replicaKey}]
    writeFileDescriptions :: String -> [FileDescription 'FRecipient] -> FileDescription 'FSender -> IO ([FilePath], FilePath)
    writeFileDescriptions :: String
-> [FileDescription 'FRecipient]
-> FileDescription 'FSender
-> IO ([String], String)
writeFileDescriptions String
fileName [FileDescription 'FRecipient]
fdRcvs FileDescription 'FSender
fdSnd = do
      String
outDir <- String -> String -> IO String
forall (m :: * -> *). MonadIO m => String -> String -> m String
uniqueCombine (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"." Maybe String
outputDir) (String
fileName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".xftp")
      Bool -> String -> IO ()
forall (m :: * -> *). MonadIO m => Bool -> String -> m ()
createDirectoryIfMissing Bool
True String
outDir
      [String]
fdRcvPaths <- [(Int, FileDescription 'FRecipient)]
-> ((Int, FileDescription 'FRecipient) -> IO String) -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Int]
-> [FileDescription 'FRecipient]
-> [(Int, FileDescription 'FRecipient)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [FileDescription 'FRecipient]
fdRcvs) (((Int, FileDescription 'FRecipient) -> IO String) -> IO [String])
-> ((Int, FileDescription 'FRecipient) -> IO String) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \(Int
i :: Int, FileDescription 'FRecipient
fd) -> do
        let fdPath :: String
fdPath = String
outDir String -> ShowS
</> (String
"rcv" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".xftp")
        String -> ByteString -> IO ()
B.writeFile String
fdPath (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ FileDescription 'FRecipient -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode FileDescription 'FRecipient
fd
        String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
fdPath
      let fdSndPath :: String
fdSndPath = String
outDir String -> ShowS
</> String
"snd.xftp.private"
      String -> ByteString -> IO ()
B.writeFile String
fdSndPath (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ FileDescription 'FSender -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode FileDescription 'FSender
fdSnd
      ([String], String) -> IO ([String], String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String]
fdRcvPaths, String
fdSndPath)

cliReceiveFile :: ReceiveOptions -> ExceptT CLIError IO ()
cliReceiveFile :: ReceiveOptions -> ExceptT CLIError IO ()
cliReceiveFile ReceiveOptions {String
$sel:fileDescription:ReceiveOptions :: ReceiveOptions -> String
fileDescription :: String
fileDescription, Maybe String
$sel:filePath:ReceiveOptions :: ReceiveOptions -> Maybe String
filePath :: Maybe String
filePath, Int
$sel:retryCount:ReceiveOptions :: ReceiveOptions -> Int
retryCount :: Int
retryCount, Maybe String
$sel:tempPath:ReceiveOptions :: ReceiveOptions -> Maybe String
tempPath :: Maybe String
tempPath, Bool
$sel:verbose:ReceiveOptions :: ReceiveOptions -> Bool
verbose :: Bool
verbose, Bool
$sel:yes:ReceiveOptions :: ReceiveOptions -> Bool
yes :: Bool
yes} =
  ExceptT CLIError IO (ValidFileDescription 'FRecipient)
getInputFileDescription ExceptT CLIError IO (ValidFileDescription 'FRecipient)
-> (ValidFileDescription 'FRecipient -> ExceptT CLIError IO ())
-> ExceptT CLIError IO ()
forall a b.
ExceptT CLIError IO a
-> (a -> ExceptT CLIError IO b) -> ExceptT CLIError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> ValidFileDescription 'FRecipient -> ExceptT CLIError IO ()
receive Int
1
  where
    getInputFileDescription :: ExceptT CLIError IO (ValidFileDescription 'FRecipient)
getInputFileDescription
      | String
"http://" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
fileDescription Bool -> Bool -> Bool
|| String
"https://" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
fileDescription = do
          let fragment :: ByteString
fragment = String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#') String
fileDescription
          Bool -> ExceptT CLIError IO () -> ExceptT CLIError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
B.null ByteString
fragment) (ExceptT CLIError IO () -> ExceptT CLIError IO ())
-> ExceptT CLIError IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ CLIError -> ExceptT CLIError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (CLIError -> ExceptT CLIError IO ())
-> CLIError -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ String -> CLIError
CLIError String
"Invalid URL: no fragment"
          (String -> ExceptT CLIError IO (ValidFileDescription 'FRecipient))
-> (ValidFileDescription 'FRecipient
    -> ExceptT CLIError IO (ValidFileDescription 'FRecipient))
-> Either String (ValidFileDescription 'FRecipient)
-> ExceptT CLIError IO (ValidFileDescription 'FRecipient)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (CLIError -> ExceptT CLIError IO (ValidFileDescription 'FRecipient)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (CLIError
 -> ExceptT CLIError IO (ValidFileDescription 'FRecipient))
-> (String -> CLIError)
-> String
-> ExceptT CLIError IO (ValidFileDescription 'FRecipient)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CLIError
CLIError (String -> CLIError) -> ShowS -> String -> CLIError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Invalid web link: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>)) ValidFileDescription 'FRecipient
-> ExceptT CLIError IO (ValidFileDescription 'FRecipient)
forall a. a -> ExceptT CLIError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (ValidFileDescription 'FRecipient)
 -> ExceptT CLIError IO (ValidFileDescription 'FRecipient))
-> Either String (ValidFileDescription 'FRecipient)
-> ExceptT CLIError IO (ValidFileDescription 'FRecipient)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String (ValidFileDescription 'FRecipient)
decodeWebURI ByteString
fragment
      | Bool
otherwise = String -> ExceptT CLIError IO (ValidFileDescription 'FRecipient)
forall (p :: FileParty).
FilePartyI p =>
String -> ExceptT CLIError IO (ValidFileDescription p)
getFileDescription' String
fileDescription
    receive :: Int -> ValidFileDescription 'FRecipient -> ExceptT CLIError IO ()
    receive :: Int -> ValidFileDescription 'FRecipient -> ExceptT CLIError IO ()
receive Int
depth (ValidFileDescription FileDescription {FileSize Int64
$sel:size:FileDescription :: forall (p :: FileParty). FileDescription p -> FileSize Int64
size :: FileSize Int64
size, FileDigest
$sel:digest:FileDescription :: forall (p :: FileParty). FileDescription p -> FileDigest
digest :: FileDigest
digest, SbKey
$sel:key:FileDescription :: forall (p :: FileParty). FileDescription p -> SbKey
key :: SbKey
key, CbNonce
$sel:nonce:FileDescription :: forall (p :: FileParty). FileDescription p -> CbNonce
nonce :: CbNonce
nonce, [FileChunk]
$sel:chunks:FileDescription :: forall (p :: FileParty). FileDescription p -> [FileChunk]
chunks :: [FileChunk]
chunks, Maybe RedirectFileInfo
$sel:redirect:FileDescription :: forall (p :: FileParty).
FileDescription p -> Maybe RedirectFileInfo
redirect :: Maybe RedirectFileInfo
redirect}) = do
      String
encPath <- Maybe String -> String -> ExceptT CLIError IO String
forall (m :: * -> *).
MonadIO m =>
Maybe String -> String -> m String
getEncPath Maybe String
tempPath String
"xftp"
      String -> ExceptT CLIError IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
createDirectory String
encPath
      XFTPClientAgent
a <- IO XFTPClientAgent -> ExceptT CLIError IO XFTPClientAgent
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO XFTPClientAgent -> ExceptT CLIError IO XFTPClientAgent)
-> IO XFTPClientAgent -> ExceptT CLIError IO XFTPClientAgent
forall a b. (a -> b) -> a -> b
$ XFTPClientAgentConfig -> IO XFTPClientAgent
newXFTPAgent XFTPClientAgentConfig
defaultXFTPClientAgentConfig
      IO () -> ExceptT CLIError IO ()
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT CLIError IO ())
-> IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
printNoNewLine String
"Downloading file..."
      TVar [Int64]
downloadedChunks <- [Int64] -> ExceptT CLIError IO (TVar [Int64])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO []
      let srv :: FileChunk -> XFTPServer
srv FileChunk {[FileChunkReplica]
$sel:replicas:FileChunk :: FileChunk -> [FileChunkReplica]
replicas :: [FileChunkReplica]
replicas} = case [FileChunkReplica]
replicas of
            [] -> String -> XFTPServer
forall a. (?callStack::CallStack) => String -> a
error String
"empty FileChunk.replicas"
            FileChunkReplica {XFTPServer
$sel:server:FileChunkReplica :: FileChunkReplica -> XFTPServer
server :: XFTPServer
server} : [FileChunkReplica]
_ -> XFTPServer
server
          srvChunks :: [[FileChunk]]
srvChunks = (FileChunk -> XFTPServer) -> [FileChunk] -> [[FileChunk]]
forall k a. Ord k => (a -> k) -> [a] -> [[a]]
groupAllOn FileChunk -> XFTPServer
srv [FileChunk]
chunks
      TVar ChaChaDRG
g <- IO (TVar ChaChaDRG) -> ExceptT CLIError IO (TVar ChaChaDRG)
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TVar ChaChaDRG)
C.newRandom
      ([CLIError]
errs, [(Int, String)]
rs) <- [Either CLIError (Int, String)] -> ([CLIError], [(Int, String)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either CLIError (Int, String)] -> ([CLIError], [(Int, String)]))
-> ([[Either CLIError (Int, String)]]
    -> [Either CLIError (Int, String)])
-> [[Either CLIError (Int, String)]]
-> ([CLIError], [(Int, String)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Either CLIError (Int, String)]]
-> [Either CLIError (Int, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Either CLIError (Int, String)]]
 -> ([CLIError], [(Int, String)]))
-> ExceptT CLIError IO [[Either CLIError (Int, String)]]
-> ExceptT CLIError IO ([CLIError], [(Int, String)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [[Either CLIError (Int, String)]]
-> ExceptT CLIError IO [[Either CLIError (Int, String)]]
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int
-> [[FileChunk]]
-> ([FileChunk] -> IO [Either CLIError (Int, String)])
-> IO [[Either CLIError (Int, String)]]
forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Traversable t) =>
Int -> t a -> (a -> m b) -> m (t b)
pooledForConcurrentlyN Int
16 [[FileChunk]]
srvChunks (([FileChunk] -> IO [Either CLIError (Int, String)])
 -> IO [[Either CLIError (Int, String)]])
-> ([FileChunk] -> IO [Either CLIError (Int, String)])
-> IO [[Either CLIError (Int, String)]]
forall a b. (a -> b) -> a -> b
$ (FileChunk -> IO (Either CLIError (Int, String)))
-> [FileChunk] -> IO [Either CLIError (Int, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((FileChunk -> IO (Either CLIError (Int, String)))
 -> [FileChunk] -> IO [Either CLIError (Int, String)])
-> (FileChunk -> IO (Either CLIError (Int, String)))
-> [FileChunk]
-> IO [Either CLIError (Int, String)]
forall a b. (a -> b) -> a -> b
$ ExceptT CLIError IO (Int, String)
-> IO (Either CLIError (Int, String))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT CLIError IO (Int, String)
 -> IO (Either CLIError (Int, String)))
-> (FileChunk -> ExceptT CLIError IO (Int, String))
-> FileChunk
-> IO (Either CLIError (Int, String))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChaChaDRG
-> XFTPClientAgent
-> String
-> FileSize Int64
-> TVar [Int64]
-> FileChunk
-> ExceptT CLIError IO (Int, String)
downloadFileChunk TVar ChaChaDRG
g XFTPClientAgent
a String
encPath FileSize Int64
size TVar [Int64]
downloadedChunks)
      (CLIError -> ExceptT CLIError IO Any)
-> [CLIError] -> ExceptT CLIError IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CLIError -> ExceptT CLIError IO Any
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE [CLIError]
errs
      let chunkPaths :: [String]
chunkPaths = ((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, String) -> String
forall a b. (a, b) -> b
snd ([(Int, String)] -> [String]) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ ((Int, String) -> Int) -> [(Int, String)] -> [(Int, String)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int, String) -> Int
forall a b. (a, b) -> a
fst [(Int, String)]
rs
      ByteString
encDigest <- IO ByteString -> ExceptT CLIError IO ByteString
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT CLIError IO ByteString)
-> IO ByteString -> ExceptT CLIError IO ByteString
forall a b. (a -> b) -> a -> b
$ LazyByteString -> ByteString
LC.sha512Hash (LazyByteString -> ByteString)
-> IO LazyByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> IO LazyByteString
readChunks [String]
chunkPaths
      Bool -> ExceptT CLIError IO () -> ExceptT CLIError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
encDigest ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= FileDigest -> ByteString
unFileDigest FileDigest
digest) (ExceptT CLIError IO () -> ExceptT CLIError IO ())
-> ExceptT CLIError IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ CLIError -> ExceptT CLIError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (CLIError -> ExceptT CLIError IO ())
-> CLIError -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ String -> CLIError
CLIError String
"File digest mismatch"
      Int64
encSize <- IO Int64 -> ExceptT CLIError IO Int64
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int64 -> ExceptT CLIError IO Int64)
-> IO Int64 -> ExceptT CLIError IO Int64
forall a b. (a -> b) -> a -> b
$ (Int64 -> String -> IO Int64) -> Int64 -> [String] -> IO Int64
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Int64
s String
path -> (Int64
s Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+) (Int64 -> Int64) -> (Integer -> Int64) -> Integer -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int64) -> IO Integer -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Integer
forall (m :: * -> *). MonadIO m => String -> m Integer
getFileSize String
path) Int64
0 [String]
chunkPaths
      Bool -> ExceptT CLIError IO () -> ExceptT CLIError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64 -> FileSize Int64
forall a. a -> FileSize a
FileSize Int64
encSize FileSize Int64 -> FileSize Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= FileSize Int64
size) (ExceptT CLIError IO () -> ExceptT CLIError IO ())
-> ExceptT CLIError IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ CLIError -> ExceptT CLIError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (CLIError -> ExceptT CLIError IO ())
-> CLIError -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ String -> CLIError
CLIError String
"File size mismatch"
      case Maybe RedirectFileInfo
redirect of
        Just RedirectFileInfo
_
          | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> do
              CryptoFile String
tmpFile Maybe CryptoFileArgs
_ <- (FTCryptoError -> CLIError)
-> ExceptT FTCryptoError IO CryptoFile
-> ExceptT CLIError IO CryptoFile
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT FTCryptoError -> CLIError
cliCryptoError (ExceptT FTCryptoError IO CryptoFile
 -> ExceptT CLIError IO CryptoFile)
-> ExceptT FTCryptoError IO CryptoFile
-> ExceptT CLIError IO CryptoFile
forall a b. (a -> b) -> a -> b
$ Int64
-> [String]
-> SbKey
-> CbNonce
-> (Text -> ExceptT String IO CryptoFile)
-> ExceptT FTCryptoError IO CryptoFile
decryptChunks Int64
encSize [String]
chunkPaths SbKey
key CbNonce
nonce ((Text -> ExceptT String IO CryptoFile)
 -> ExceptT FTCryptoError IO CryptoFile)
-> (Text -> ExceptT String IO CryptoFile)
-> ExceptT FTCryptoError IO CryptoFile
forall a b. (a -> b) -> a -> b
$ \Text
_ ->
                (String -> CryptoFile)
-> ExceptT String IO String -> ExceptT String IO CryptoFile
forall a b. (a -> b) -> ExceptT String IO a -> ExceptT String IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> CryptoFile
CF.plain (ExceptT String IO String -> ExceptT String IO CryptoFile)
-> ExceptT String IO String -> ExceptT String IO CryptoFile
forall a b. (a -> b) -> a -> b
$ String -> String -> ExceptT String IO String
forall (m :: * -> *). MonadIO m => String -> String -> m String
uniqueCombine String
encPath String
"redirect.yaml"
              [FileChunk]
-> (FileChunk -> ExceptT CLIError IO ()) -> ExceptT CLIError IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FileChunk]
chunks ((FileChunk -> ExceptT CLIError IO ()) -> ExceptT CLIError IO ())
-> (FileChunk -> ExceptT CLIError IO ()) -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
acknowledgeFileChunk XFTPClientAgent
a
              ByteString
yaml <- IO ByteString -> ExceptT CLIError IO ByteString
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT CLIError IO ByteString)
-> IO ByteString -> ExceptT CLIError IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile String
tmpFile
              ExceptT CLIError IO Bool
-> ExceptT CLIError IO () -> ExceptT CLIError IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> ExceptT CLIError IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesPathExist String
encPath) (ExceptT CLIError IO () -> ExceptT CLIError IO ())
-> ExceptT CLIError IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ String -> ExceptT CLIError IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeDirectoryRecursive String
encPath
              ValidFileDescription 'FRecipient
innerVfd <- (String -> ExceptT CLIError IO (ValidFileDescription 'FRecipient))
-> (ValidFileDescription 'FRecipient
    -> ExceptT CLIError IO (ValidFileDescription 'FRecipient))
-> Either String (ValidFileDescription 'FRecipient)
-> ExceptT CLIError IO (ValidFileDescription 'FRecipient)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (CLIError -> ExceptT CLIError IO (ValidFileDescription 'FRecipient)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (CLIError
 -> ExceptT CLIError IO (ValidFileDescription 'FRecipient))
-> (String -> CLIError)
-> String
-> ExceptT CLIError IO (ValidFileDescription 'FRecipient)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CLIError
CLIError (String -> CLIError) -> ShowS -> String -> CLIError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Redirect: invalid file description: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>)) ValidFileDescription 'FRecipient
-> ExceptT CLIError IO (ValidFileDescription 'FRecipient)
forall a. a -> ExceptT CLIError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (ValidFileDescription 'FRecipient)
 -> ExceptT CLIError IO (ValidFileDescription 'FRecipient))
-> Either String (ValidFileDescription 'FRecipient)
-> ExceptT CLIError IO (ValidFileDescription 'FRecipient)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String (ValidFileDescription 'FRecipient)
forall a. StrEncoding a => ByteString -> Either String a
strDecode ByteString
yaml
              Int -> ValidFileDescription 'FRecipient -> ExceptT CLIError IO ()
receive Int
0 ValidFileDescription 'FRecipient
innerVfd
          | Bool
otherwise -> CLIError -> ExceptT CLIError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (CLIError -> ExceptT CLIError IO ())
-> CLIError -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ String -> CLIError
CLIError String
"Redirect chain too long"
        Maybe RedirectFileInfo
Nothing -> do
          IO () -> ExceptT CLIError IO ()
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT CLIError IO ())
-> IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
printNoNewLine String
"Decrypting file..."
          CryptoFile String
path Maybe CryptoFileArgs
_ <- (FTCryptoError -> CLIError)
-> ExceptT FTCryptoError IO CryptoFile
-> ExceptT CLIError IO CryptoFile
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT FTCryptoError -> CLIError
cliCryptoError (ExceptT FTCryptoError IO CryptoFile
 -> ExceptT CLIError IO CryptoFile)
-> ExceptT FTCryptoError IO CryptoFile
-> ExceptT CLIError IO CryptoFile
forall a b. (a -> b) -> a -> b
$ Int64
-> [String]
-> SbKey
-> CbNonce
-> (Text -> ExceptT String IO CryptoFile)
-> ExceptT FTCryptoError IO CryptoFile
decryptChunks Int64
encSize [String]
chunkPaths SbKey
key CbNonce
nonce ((Text -> ExceptT String IO CryptoFile)
 -> ExceptT FTCryptoError IO CryptoFile)
-> (Text -> ExceptT String IO CryptoFile)
-> ExceptT FTCryptoError IO CryptoFile
forall a b. (a -> b) -> a -> b
$ (String -> CryptoFile)
-> ExceptT String IO String -> ExceptT String IO CryptoFile
forall a b. (a -> b) -> ExceptT String IO a -> ExceptT String IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> CryptoFile
CF.plain (ExceptT String IO String -> ExceptT String IO CryptoFile)
-> (Text -> ExceptT String IO String)
-> Text
-> ExceptT String IO CryptoFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ExceptT String IO String
getFilePath
          [FileChunk]
-> (FileChunk -> ExceptT CLIError IO ()) -> ExceptT CLIError IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FileChunk]
chunks ((FileChunk -> ExceptT CLIError IO ()) -> ExceptT CLIError IO ())
-> (FileChunk -> ExceptT CLIError IO ()) -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
acknowledgeFileChunk XFTPClientAgent
a
          ExceptT CLIError IO Bool
-> ExceptT CLIError IO () -> ExceptT CLIError IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> ExceptT CLIError IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesPathExist String
encPath) (ExceptT CLIError IO () -> ExceptT CLIError IO ())
-> ExceptT CLIError IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ String -> ExceptT CLIError IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeDirectoryRecursive String
encPath
          IO () -> ExceptT CLIError IO ()
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT CLIError IO ())
-> IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ do
            String -> IO ()
printNoNewLine (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"File downloaded: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
path
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
"http://" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
fileDescription Bool -> Bool -> Bool
|| String
"https://" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
fileDescription) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              Bool -> String -> IO ()
removeFD Bool
yes String
fileDescription
    downloadFileChunk :: TVar ChaChaDRG -> XFTPClientAgent -> FilePath -> FileSize Int64 -> TVar [Int64] -> FileChunk -> ExceptT CLIError IO (Int, FilePath)
    downloadFileChunk :: TVar ChaChaDRG
-> XFTPClientAgent
-> String
-> FileSize Int64
-> TVar [Int64]
-> FileChunk
-> ExceptT CLIError IO (Int, String)
downloadFileChunk TVar ChaChaDRG
g XFTPClientAgent
a String
encPath (FileSize Int64
encSize) TVar [Int64]
downloadedChunks FileChunk {Int
$sel:chunkNo:FileChunk :: FileChunk -> Int
chunkNo :: Int
chunkNo, FileSize Word32
$sel:chunkSize:FileChunk :: FileChunk -> FileSize Word32
chunkSize :: FileSize Word32
chunkSize, FileDigest
$sel:digest:FileChunk :: FileChunk -> FileDigest
digest :: FileDigest
digest, $sel:replicas:FileChunk :: FileChunk -> [FileChunkReplica]
replicas = FileChunkReplica
replica : [FileChunkReplica]
_} = do
      let FileChunkReplica {XFTPServer
$sel:server:FileChunkReplica :: FileChunkReplica -> XFTPServer
server :: XFTPServer
server, ChunkReplicaId
$sel:replicaId:FileChunkReplica :: FileChunkReplica -> ChunkReplicaId
replicaId :: ChunkReplicaId
replicaId, SndPrivateAuthKey
$sel:replicaKey:FileChunkReplica :: FileChunkReplica -> SndPrivateAuthKey
replicaKey :: SndPrivateAuthKey
replicaKey} = FileChunkReplica
replica
      Text -> ExceptT CLIError IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug (Text -> ExceptT CLIError IO ()) -> Text -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ Text
"downloading chunk " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
chunkNo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> XFTPServer -> Text
showServer XFTPServer
server Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"..."
      String
chunkPath <- String -> String -> ExceptT CLIError IO String
forall (m :: * -> *). MonadIO m => String -> String -> m String
uniqueCombine String
encPath (String -> ExceptT CLIError IO String)
-> String -> ExceptT CLIError IO String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
chunkNo
      let chunkSpec :: XFTPRcvChunkSpec
chunkSpec = String -> Word32 -> ByteString -> XFTPRcvChunkSpec
XFTPRcvChunkSpec String
chunkPath (FileSize Word32 -> Word32
forall a. FileSize a -> a
unFileSize FileSize Word32
chunkSize) (FileDigest -> ByteString
unFileDigest FileDigest
digest)
      XFTPClientAgent
-> XFTPServer
-> Int
-> (XFTPClient -> ExceptT XFTPClientError IO ())
-> ExceptT CLIError IO ()
forall e a.
Show e =>
XFTPClientAgent
-> XFTPServer
-> Int
-> (XFTPClient -> ExceptT e IO a)
-> ExceptT CLIError IO a
withReconnect XFTPClientAgent
a XFTPServer
server Int
retryCount ((XFTPClient -> ExceptT XFTPClientError IO ())
 -> ExceptT CLIError IO ())
-> (XFTPClient -> ExceptT XFTPClientError IO ())
-> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ \XFTPClient
c -> TVar ChaChaDRG
-> XFTPClient
-> SndPrivateAuthKey
-> SenderId
-> XFTPRcvChunkSpec
-> ExceptT XFTPClientError IO ()
downloadXFTPChunk TVar ChaChaDRG
g XFTPClient
c SndPrivateAuthKey
replicaKey (ChunkReplicaId -> SenderId
unChunkReplicaId ChunkReplicaId
replicaId) XFTPRcvChunkSpec
chunkSpec
      Text -> ExceptT CLIError IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug (Text -> ExceptT CLIError IO ()) -> Text -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ Text
"downloaded chunk " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
chunkNo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
chunkPath
      Int64
downloaded <- STM Int64 -> ExceptT CLIError IO Int64
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Int64 -> ExceptT CLIError IO Int64)
-> (([Int64] -> (Int64, [Int64])) -> STM Int64)
-> ([Int64] -> (Int64, [Int64]))
-> ExceptT CLIError IO Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar [Int64] -> ([Int64] -> (Int64, [Int64])) -> STM Int64
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar [Int64]
downloadedChunks (([Int64] -> (Int64, [Int64])) -> ExceptT CLIError IO Int64)
-> ([Int64] -> (Int64, [Int64])) -> ExceptT CLIError IO Int64
forall a b. (a -> b) -> a -> b
$ \[Int64]
cs ->
        let cs' :: [Int64]
cs' = Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileSize Word32 -> Word32
forall a. FileSize a -> a
unFileSize FileSize Word32
chunkSize) Int64 -> [Int64] -> [Int64]
forall a. a -> [a] -> [a]
: [Int64]
cs in ([Int64] -> Int64
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int64]
cs', [Int64]
cs')
      IO () -> ExceptT CLIError IO ()
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT CLIError IO ())
-> IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ do
        String -> Int64 -> Int64 -> IO ()
printProgress String
"Downloaded" Int64
downloaded Int64
encSize
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
      (Int, String) -> ExceptT CLIError IO (Int, String)
forall a. a -> ExceptT CLIError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
chunkNo, String
chunkPath)
    downloadFileChunk TVar ChaChaDRG
_ XFTPClientAgent
_ String
_ FileSize Int64
_ TVar [Int64]
_ FileChunk
_ = CLIError -> ExceptT CLIError IO (Int, String)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (CLIError -> ExceptT CLIError IO (Int, String))
-> CLIError -> ExceptT CLIError IO (Int, String)
forall a b. (a -> b) -> a -> b
$ String -> CLIError
CLIError String
"chunk has no replicas"
    getFilePath :: Text -> ExceptT String IO FilePath
    getFilePath :: Text -> ExceptT String IO String
getFilePath Text
name = case Maybe String
filePath of
      Just String
path ->
        ExceptT String IO Bool
-> ExceptT String IO String
-> ExceptT String IO String
-> ExceptT String IO String
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (String -> ExceptT String IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesDirectoryExist String
path) (String -> String -> ExceptT String IO String
forall (m :: * -> *). MonadIO m => String -> String -> m String
uniqueCombine String
path String
name') (ExceptT String IO String -> ExceptT String IO String)
-> ExceptT String IO String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$
          ExceptT String IO Bool
-> ExceptT String IO String
-> ExceptT String IO String
-> ExceptT String IO String
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (String -> ExceptT String IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
path) (String -> ExceptT String IO String
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"File already exists") (String -> ExceptT String IO String
forall a. a -> ExceptT String IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
path)
      Maybe String
_ -> (String -> String -> ExceptT String IO String
forall (m :: * -> *). MonadIO m => String -> String -> m String
`uniqueCombine` String
name') (String -> ExceptT String IO String)
-> ShowS -> String -> ExceptT String IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
</> String
"Downloads") (String -> ExceptT String IO String)
-> ExceptT String IO String -> ExceptT String IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT String IO String
forall (m :: * -> *). MonadIO m => m String
getHomeDirectory
      where
        name' :: String
name' = Text -> String
T.unpack Text
name
    acknowledgeFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
    acknowledgeFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
acknowledgeFileChunk XFTPClientAgent
a FileChunk {$sel:replicas:FileChunk :: FileChunk -> [FileChunkReplica]
replicas = FileChunkReplica
replica : [FileChunkReplica]
_} = do
      let FileChunkReplica {XFTPServer
$sel:server:FileChunkReplica :: FileChunkReplica -> XFTPServer
server :: XFTPServer
server, ChunkReplicaId
$sel:replicaId:FileChunkReplica :: FileChunkReplica -> ChunkReplicaId
replicaId :: ChunkReplicaId
replicaId, SndPrivateAuthKey
$sel:replicaKey:FileChunkReplica :: FileChunkReplica -> SndPrivateAuthKey
replicaKey :: SndPrivateAuthKey
replicaKey} = FileChunkReplica
replica
      XFTPClient
c <- Int
-> ExceptT XFTPClientAgentError IO XFTPClient
-> ExceptT CLIError IO XFTPClient
forall e a.
Show e =>
Int -> ExceptT e IO a -> ExceptT CLIError IO a
withRetry Int
retryCount (ExceptT XFTPClientAgentError IO XFTPClient
 -> ExceptT CLIError IO XFTPClient)
-> ExceptT XFTPClientAgentError IO XFTPClient
-> ExceptT CLIError IO XFTPClient
forall a b. (a -> b) -> a -> b
$ XFTPClientAgent
-> XFTPServer -> ExceptT XFTPClientAgentError IO XFTPClient
getXFTPServerClient XFTPClientAgent
a XFTPServer
server
      Int -> ExceptT XFTPClientError IO () -> ExceptT CLIError IO ()
forall e a.
Show e =>
Int -> ExceptT e IO a -> ExceptT CLIError IO a
withRetry Int
retryCount (ExceptT XFTPClientError IO () -> ExceptT CLIError IO ())
-> ExceptT XFTPClientError IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ XFTPClient
-> SndPrivateAuthKey -> SenderId -> ExceptT XFTPClientError IO ()
ackXFTPChunk XFTPClient
c SndPrivateAuthKey
replicaKey (ChunkReplicaId -> SenderId
unChunkReplicaId ChunkReplicaId
replicaId)
    acknowledgeFileChunk XFTPClientAgent
_ FileChunk
_ = CLIError -> ExceptT CLIError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (CLIError -> ExceptT CLIError IO ())
-> CLIError -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ String -> CLIError
CLIError String
"chunk has no replicas"

printProgress :: String -> Int64 -> Int64 -> IO ()
printProgress :: String -> Int64 -> Int64 -> IO ()
printProgress String
s Int64
part Int64
total = String -> IO ()
printNoNewLine (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
forall a. Show a => a -> String
show ((Int64
part Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
100) Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
total) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"%"

printNoNewLine :: String -> IO ()
printNoNewLine :: String -> IO ()
printNoNewLine String
s = do
  String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
25 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
' ' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\r"
  Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout

cliDeleteFile :: DeleteOptions -> ExceptT CLIError IO ()
cliDeleteFile :: DeleteOptions -> ExceptT CLIError IO ()
cliDeleteFile DeleteOptions {String
$sel:fileDescription:DeleteOptions :: DeleteOptions -> String
fileDescription :: String
fileDescription, Int
$sel:retryCount:DeleteOptions :: DeleteOptions -> Int
retryCount :: Int
retryCount, Bool
$sel:yes:DeleteOptions :: DeleteOptions -> Bool
yes :: Bool
yes} = do
  String -> ExceptT CLIError IO (ValidFileDescription 'FSender)
forall (p :: FileParty).
FilePartyI p =>
String -> ExceptT CLIError IO (ValidFileDescription p)
getFileDescription' String
fileDescription ExceptT CLIError IO (ValidFileDescription 'FSender)
-> (ValidFileDescription 'FSender -> ExceptT CLIError IO ())
-> ExceptT CLIError IO ()
forall a b.
ExceptT CLIError IO a
-> (a -> ExceptT CLIError IO b) -> ExceptT CLIError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ValidFileDescription 'FSender -> ExceptT CLIError IO ()
deleteFile
  where
    deleteFile :: ValidFileDescription 'FSender -> ExceptT CLIError IO ()
    deleteFile :: ValidFileDescription 'FSender -> ExceptT CLIError IO ()
deleteFile (ValidFileDescription FileDescription {[FileChunk]
$sel:chunks:FileDescription :: forall (p :: FileParty). FileDescription p -> [FileChunk]
chunks :: [FileChunk]
chunks}) = do
      XFTPClientAgent
a <- IO XFTPClientAgent -> ExceptT CLIError IO XFTPClientAgent
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO XFTPClientAgent -> ExceptT CLIError IO XFTPClientAgent)
-> IO XFTPClientAgent -> ExceptT CLIError IO XFTPClientAgent
forall a b. (a -> b) -> a -> b
$ XFTPClientAgentConfig -> IO XFTPClientAgent
newXFTPAgent XFTPClientAgentConfig
defaultXFTPClientAgentConfig
      [FileChunk]
-> (FileChunk -> ExceptT CLIError IO ()) -> ExceptT CLIError IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FileChunk]
chunks ((FileChunk -> ExceptT CLIError IO ()) -> ExceptT CLIError IO ())
-> (FileChunk -> ExceptT CLIError IO ()) -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
deleteFileChunk XFTPClientAgent
a
      IO () -> ExceptT CLIError IO ()
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT CLIError IO ())
-> IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
printNoNewLine String
"File deleted!"
        Bool -> String -> IO ()
removeFD Bool
yes String
fileDescription
    deleteFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
    deleteFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
deleteFileChunk XFTPClientAgent
a FileChunk {Int
$sel:chunkNo:FileChunk :: FileChunk -> Int
chunkNo :: Int
chunkNo, $sel:replicas:FileChunk :: FileChunk -> [FileChunkReplica]
replicas = FileChunkReplica
replica : [FileChunkReplica]
_} = do
      let FileChunkReplica {XFTPServer
$sel:server:FileChunkReplica :: FileChunkReplica -> XFTPServer
server :: XFTPServer
server, ChunkReplicaId
$sel:replicaId:FileChunkReplica :: FileChunkReplica -> ChunkReplicaId
replicaId :: ChunkReplicaId
replicaId, SndPrivateAuthKey
$sel:replicaKey:FileChunkReplica :: FileChunkReplica -> SndPrivateAuthKey
replicaKey :: SndPrivateAuthKey
replicaKey} = FileChunkReplica
replica
      XFTPClientAgent
-> XFTPServer
-> Int
-> (XFTPClient -> ExceptT XFTPClientError IO ())
-> ExceptT CLIError IO ()
forall e a.
Show e =>
XFTPClientAgent
-> XFTPServer
-> Int
-> (XFTPClient -> ExceptT e IO a)
-> ExceptT CLIError IO a
withReconnect XFTPClientAgent
a XFTPServer
server Int
retryCount ((XFTPClient -> ExceptT XFTPClientError IO ())
 -> ExceptT CLIError IO ())
-> (XFTPClient -> ExceptT XFTPClientError IO ())
-> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ \XFTPClient
c -> XFTPClient
-> SndPrivateAuthKey -> SenderId -> ExceptT XFTPClientError IO ()
deleteXFTPChunk XFTPClient
c SndPrivateAuthKey
replicaKey (ChunkReplicaId -> SenderId
unChunkReplicaId ChunkReplicaId
replicaId)
      Text -> ExceptT CLIError IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logDebug (Text -> ExceptT CLIError IO ()) -> Text -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ Text
"deleted chunk " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
chunkNo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> XFTPServer -> Text
showServer XFTPServer
server
    deleteFileChunk XFTPClientAgent
_ FileChunk
_ = CLIError -> ExceptT CLIError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (CLIError -> ExceptT CLIError IO ())
-> CLIError -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ String -> CLIError
CLIError String
"chunk has no replicas"

cliFileDescrInfo :: InfoOptions -> ExceptT CLIError IO ()
cliFileDescrInfo :: InfoOptions -> ExceptT CLIError IO ()
cliFileDescrInfo InfoOptions {String
$sel:fileDescription:InfoOptions :: InfoOptions -> String
fileDescription :: String
fileDescription} = do
  String -> ExceptT CLIError IO AValidFileDescription
getFileDescription String
fileDescription ExceptT CLIError IO AValidFileDescription
-> (AValidFileDescription -> ExceptT CLIError IO ())
-> ExceptT CLIError IO ()
forall a b.
ExceptT CLIError IO a
-> (a -> ExceptT CLIError IO b) -> ExceptT CLIError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    AVFD (ValidFileDescription FileDescription {SFileParty p
$sel:party:FileDescription :: forall (p :: FileParty). FileDescription p -> SFileParty p
party :: SFileParty p
party, FileSize Int64
$sel:size:FileDescription :: forall (p :: FileParty). FileDescription p -> FileSize Int64
size :: FileSize Int64
size, FileSize Word32
$sel:chunkSize:FileDescription :: forall (p :: FileParty). FileDescription p -> FileSize Word32
chunkSize :: FileSize Word32
chunkSize, [FileChunk]
$sel:chunks:FileDescription :: forall (p :: FileParty). FileDescription p -> [FileChunk]
chunks :: [FileChunk]
chunks}) -> do
      let replicas :: [NonEmpty FileServerReplica]
replicas = FileSize Word32 -> [FileChunk] -> [NonEmpty FileServerReplica]
groupReplicasByServer FileSize Word32
chunkSize [FileChunk]
chunks
      IO () -> ExceptT CLIError IO ()
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT CLIError IO ())
-> IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ do
        IO ()
printParty
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"File download size: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> FileSize Int64 -> String
forall a. StrEncoding a => a -> String
strEnc FileSize Int64
size
        String -> IO ()
putStrLn String
"File server(s):"
        [NonEmpty FileServerReplica]
-> (NonEmpty FileServerReplica -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [NonEmpty FileServerReplica]
replicas ((NonEmpty FileServerReplica -> IO ()) -> IO ())
-> (NonEmpty FileServerReplica -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \srvReplicas :: NonEmpty FileServerReplica
srvReplicas@(FileServerReplica {XFTPServer
server :: XFTPServer
$sel:server:FileServerReplica :: FileServerReplica -> XFTPServer
server} :| [FileServerReplica]
_) -> do
          let chSizes :: NonEmpty Word32
chSizes = (FileServerReplica -> Word32)
-> NonEmpty FileServerReplica -> NonEmpty Word32
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FileServerReplica {$sel:chunkSize:FileServerReplica :: FileServerReplica -> Maybe (FileSize Word32)
chunkSize = Maybe (FileSize Word32)
chSize_} -> FileSize Word32 -> Word32
forall a. FileSize a -> a
unFileSize (FileSize Word32 -> Word32) -> FileSize Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ FileSize Word32 -> Maybe (FileSize Word32) -> FileSize Word32
forall a. a -> Maybe a -> a
fromMaybe FileSize Word32
chunkSize Maybe (FileSize Word32)
chSize_) NonEmpty FileServerReplica
srvReplicas
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ XFTPServer -> String
forall a. StrEncoding a => a -> String
strEnc XFTPServer
server String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> FileSize Word32 -> String
forall a. StrEncoding a => a -> String
strEnc (Word32 -> FileSize Word32
forall a. a -> FileSize a
FileSize (Word32 -> FileSize Word32) -> Word32 -> FileSize Word32
forall a b. (a -> b) -> a -> b
$ NonEmpty Word32 -> Word32
forall a. Num a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum NonEmpty Word32
chSizes)
      where
        printParty :: IO ()
        printParty :: IO ()
printParty = case SFileParty p
party of
          SFileParty p
SFRecipient -> String -> IO ()
putStrLn String
"Recipient file description"
          SFileParty p
SFSender -> String -> IO ()
putStrLn String
"Sender file description"

strEnc :: StrEncoding a => a -> String
strEnc :: forall a. StrEncoding a => a -> String
strEnc = ByteString -> String
B.unpack (ByteString -> String) -> (a -> ByteString) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode

getFileDescription :: FilePath -> ExceptT CLIError IO AValidFileDescription
getFileDescription :: String -> ExceptT CLIError IO AValidFileDescription
getFileDescription String
path =
  IO (Either CLIError AValidFileDescription)
-> ExceptT CLIError IO AValidFileDescription
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either CLIError AValidFileDescription)
 -> ExceptT CLIError IO AValidFileDescription)
-> IO (Either CLIError AValidFileDescription)
-> ExceptT CLIError IO AValidFileDescription
forall a b. (a -> b) -> a -> b
$ (String -> CLIError)
-> Either String AValidFileDescription
-> Either CLIError AValidFileDescription
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> CLIError
CLIError (String -> CLIError) -> ShowS -> String -> CLIError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Failed to parse file description: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>)) (Either String AValidFileDescription
 -> Either CLIError AValidFileDescription)
-> (ByteString -> Either String AValidFileDescription)
-> ByteString
-> Either CLIError AValidFileDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String AValidFileDescription
forall a. StrEncoding a => ByteString -> Either String a
strDecode (ByteString -> Either CLIError AValidFileDescription)
-> IO ByteString -> IO (Either CLIError AValidFileDescription)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
path

getFileDescription' :: FilePartyI p => FilePath -> ExceptT CLIError IO (ValidFileDescription p)
getFileDescription' :: forall (p :: FileParty).
FilePartyI p =>
String -> ExceptT CLIError IO (ValidFileDescription p)
getFileDescription' String
path =
  String -> ExceptT CLIError IO AValidFileDescription
getFileDescription String
path ExceptT CLIError IO AValidFileDescription
-> (AValidFileDescription
    -> ExceptT CLIError IO (ValidFileDescription p))
-> ExceptT CLIError IO (ValidFileDescription p)
forall a b.
ExceptT CLIError IO a
-> (a -> ExceptT CLIError IO b) -> ExceptT CLIError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    AVFD ValidFileDescription p
fd -> (String -> ExceptT CLIError IO (ValidFileDescription p))
-> (ValidFileDescription p
    -> ExceptT CLIError IO (ValidFileDescription p))
-> Either String (ValidFileDescription p)
-> ExceptT CLIError IO (ValidFileDescription p)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (CLIError -> ExceptT CLIError IO (ValidFileDescription p)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (CLIError -> ExceptT CLIError IO (ValidFileDescription p))
-> (String -> CLIError)
-> String
-> ExceptT CLIError IO (ValidFileDescription p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CLIError
CLIError) ValidFileDescription p
-> ExceptT CLIError IO (ValidFileDescription p)
forall a. a -> ExceptT CLIError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (ValidFileDescription p)
 -> ExceptT CLIError IO (ValidFileDescription p))
-> Either String (ValidFileDescription p)
-> ExceptT CLIError IO (ValidFileDescription p)
forall a b. (a -> b) -> a -> b
$ ValidFileDescription p -> Either String (ValidFileDescription p)
forall (t :: FileParty -> *) (p :: FileParty) (p' :: FileParty).
(FilePartyI p, FilePartyI p') =>
t p' -> Either String (t p)
checkParty ValidFileDescription p
fd

getEncPath :: MonadIO m => Maybe FilePath -> String -> m FilePath
getEncPath :: forall (m :: * -> *).
MonadIO m =>
Maybe String -> String -> m String
getEncPath Maybe String
path String
name = (String -> String -> m String
forall (m :: * -> *). MonadIO m => String -> String -> m String
`uniqueCombine` (String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".encrypted")) (String -> m String) -> m String -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m String -> (String -> m String) -> Maybe String -> m String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getCanonicalTemporaryDirectory) String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
path

withReconnect :: Show e => XFTPClientAgent -> XFTPServer -> Int -> (XFTPClient -> ExceptT e IO a) -> ExceptT CLIError IO a
withReconnect :: forall e a.
Show e =>
XFTPClientAgent
-> XFTPServer
-> Int
-> (XFTPClient -> ExceptT e IO a)
-> ExceptT CLIError IO a
withReconnect XFTPClientAgent
a XFTPServer
srv Int
n XFTPClient -> ExceptT e IO a
run = Int -> ExceptT CLIError IO a -> ExceptT CLIError IO a
forall e a.
Show e =>
Int -> ExceptT e IO a -> ExceptT CLIError IO a
withRetry Int
n (ExceptT CLIError IO a -> ExceptT CLIError IO a)
-> ExceptT CLIError IO a -> ExceptT CLIError IO a
forall a b. (a -> b) -> a -> b
$ do
  XFTPClient
c <- Int
-> ExceptT XFTPClientAgentError IO XFTPClient
-> ExceptT CLIError IO XFTPClient
forall e a.
Show e =>
Int -> ExceptT e IO a -> ExceptT CLIError IO a
withRetry Int
n (ExceptT XFTPClientAgentError IO XFTPClient
 -> ExceptT CLIError IO XFTPClient)
-> ExceptT XFTPClientAgentError IO XFTPClient
-> ExceptT CLIError IO XFTPClient
forall a b. (a -> b) -> a -> b
$ XFTPClientAgent
-> XFTPServer -> ExceptT XFTPClientAgentError IO XFTPClient
getXFTPServerClient XFTPClientAgent
a XFTPServer
srv
  (e -> CLIError) -> ExceptT e IO a -> ExceptT CLIError IO a
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (String -> CLIError
CLIError (String -> CLIError) -> (e -> String) -> e -> CLIError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall a. Show a => a -> String
show) (XFTPClient -> ExceptT e IO a
run XFTPClient
c) ExceptT CLIError IO a
-> (CLIError -> ExceptT CLIError IO a) -> ExceptT CLIError IO a
forall a.
ExceptT CLIError IO a
-> (CLIError -> ExceptT CLIError IO a) -> ExceptT CLIError IO a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \CLIError
e -> do
    IO () -> ExceptT CLIError IO ()
forall a. IO a -> ExceptT CLIError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT CLIError IO ())
-> IO () -> ExceptT CLIError IO ()
forall a b. (a -> b) -> a -> b
$ XFTPClientAgent -> XFTPServer -> IO ()
closeXFTPServerClient XFTPClientAgent
a XFTPServer
srv
    CLIError -> ExceptT CLIError IO a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE CLIError
e

withRetry :: Show e => Int -> ExceptT e IO a -> ExceptT CLIError IO a
withRetry :: forall e a.
Show e =>
Int -> ExceptT e IO a -> ExceptT CLIError IO a
withRetry Int
retryCount = Int -> ExceptT CLIError IO a -> ExceptT CLIError IO a
forall a. Int -> ExceptT CLIError IO a -> ExceptT CLIError IO a
withRetry' Int
retryCount (ExceptT CLIError IO a -> ExceptT CLIError IO a)
-> (ExceptT e IO a -> ExceptT CLIError IO a)
-> ExceptT e IO a
-> ExceptT CLIError IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> CLIError) -> ExceptT e IO a -> ExceptT CLIError IO a
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (String -> CLIError
CLIError (String -> CLIError) -> (e -> String) -> e -> CLIError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall a. Show a => a -> String
show)
  where
    withRetry' :: Int -> ExceptT CLIError IO a -> ExceptT CLIError IO a
    withRetry' :: forall a. Int -> ExceptT CLIError IO a -> ExceptT CLIError IO a
withRetry' Int
0 ExceptT CLIError IO a
_ = CLIError -> ExceptT CLIError IO a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (CLIError -> ExceptT CLIError IO a)
-> CLIError -> ExceptT CLIError IO a
forall a b. (a -> b) -> a -> b
$ String -> CLIError
CLIError String
"internal: no retry attempts"
    withRetry' Int
1 ExceptT CLIError IO a
a = ExceptT CLIError IO a
a
    withRetry' Int
n ExceptT CLIError IO a
a =
      ExceptT CLIError IO a
a ExceptT CLIError IO a
-> (CLIError -> ExceptT CLIError IO a) -> ExceptT CLIError IO a
forall a.
ExceptT CLIError IO a
-> (CLIError -> ExceptT CLIError IO a) -> ExceptT CLIError IO a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \CLIError
e -> do
        Text -> ExceptT CLIError IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn (Text
"retrying: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CLIError -> Text
forall a. Show a => a -> Text
tshow CLIError
e)
        Int -> ExceptT CLIError IO a -> ExceptT CLIError IO a
forall a. Int -> ExceptT CLIError IO a -> ExceptT CLIError IO a
withRetry' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ExceptT CLIError IO a
a

removeFD :: Bool -> FilePath -> IO ()
removeFD :: Bool -> String -> IO ()
removeFD Bool
yes String
fd
  | Bool
yes = do
      String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeFile String
fd
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\nFile description " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fd String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is deleted."
  | Bool
otherwise = do
      Bool
y <- IO Bool -> IO Bool
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> (String -> IO Bool) -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Bool
getConfirmation (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ String
"\nFile description " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fd String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" can't be used again. Delete it"
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
y (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeFile String
fd

getConfirmation :: String -> IO Bool
getConfirmation :: String -> IO Bool
getConfirmation String
prompt = do
  String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
prompt String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" (Y/n): "
  Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
  String
s <- IO String
getLine
  case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s of
    String
"y" -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    String
"" -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    String
"n" -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    String
_ -> String -> IO Bool
getConfirmation String
prompt

cliRandomFile :: RandomFileOptions -> IO ()
cliRandomFile :: RandomFileOptions -> IO ()
cliRandomFile RandomFileOptions {String
$sel:filePath:RandomFileOptions :: RandomFileOptions -> String
filePath :: String
filePath, $sel:fileSize:RandomFileOptions :: RandomFileOptions -> FileSize Int64
fileSize = FileSize Int64
size} = do
  String -> IOMode -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withFile String
filePath IOMode
WriteMode (Handle -> Int64 -> IO ()
`saveRandomFile` Int64
size)
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"File created: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
filePath
  where
    saveRandomFile :: Handle -> Int64 -> IO ()
saveRandomFile Handle
h Int64
sz = do
      TVar ChaChaDRG
g <- IO (TVar ChaChaDRG)
C.newRandom
      ByteString
bytes <- STM ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM ByteString -> IO ByteString)
-> STM ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Int -> TVar ChaChaDRG -> STM ByteString
C.randomBytes (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
min Int64
mb' Int64
sz) TVar ChaChaDRG
g
      Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
bytes
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
sz Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
mb') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Int64 -> IO ()
saveRandomFile Handle
h (Int64
sz Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
mb')
    mb' :: Int64
mb' = Int64 -> Int64
forall a. Integral a => a -> a
mb Int64
1

-- | Encode file description as web-compatible URI fragment.
-- Result is base64url(deflateRaw(YAML)), no leading '#'.
encodeWebURI :: FileDescription 'FRecipient -> B.ByteString
encodeWebURI :: FileDescription 'FRecipient -> ByteString
encodeWebURI FileDescription 'FRecipient
fd = ByteString -> ByteString
U.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ LazyByteString -> ByteString
LB.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ LazyByteString -> LazyByteString
Z.compress (LazyByteString -> LazyByteString)
-> LazyByteString -> LazyByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> LazyByteString
LB.fromStrict (ByteString -> LazyByteString) -> ByteString -> LazyByteString
forall a b. (a -> b) -> a -> b
$ FileDescription 'FRecipient -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode FileDescription 'FRecipient
fd

-- | Decode web URI fragment to validated file description.
-- Input is base64url-encoded DEFLATE-compressed YAML, no leading '#'.
decodeWebURI :: B.ByteString -> Either String (ValidFileDescription 'FRecipient)
decodeWebURI :: ByteString -> Either String (ValidFileDescription 'FRecipient)
decodeWebURI ByteString
fragment = do
  ByteString
compressed <- ByteString -> Either String ByteString
U.decode ByteString
fragment
  let yaml :: ByteString
yaml = LazyByteString -> ByteString
LB.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ LazyByteString -> LazyByteString
Z.decompress (LazyByteString -> LazyByteString)
-> LazyByteString -> LazyByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> LazyByteString
LB.fromStrict ByteString
compressed
  ByteString -> Either String (FileDescription 'FRecipient)
forall a. StrEncoding a => ByteString -> Either String a
strDecode ByteString
yaml Either String (FileDescription 'FRecipient)
-> (FileDescription 'FRecipient
    -> Either String (ValidFileDescription 'FRecipient))
-> Either String (ValidFileDescription 'FRecipient)
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FileDescription 'FRecipient
-> Either String (ValidFileDescription 'FRecipient)
forall (p :: FileParty).
FileDescription p -> Either String (ValidFileDescription p)
validateFileDescription

-- | Extract web link host and URI fragment from a file description.
-- Returns (hostname, uriFragment) for https://hostname/#uriFragment.
fileWebLink :: FileDescription 'FRecipient -> Maybe (B.ByteString, B.ByteString)
fileWebLink :: FileDescription 'FRecipient -> Maybe (ByteString, ByteString)
fileWebLink fd :: FileDescription 'FRecipient
fd@FileDescription {[FileChunk]
$sel:chunks:FileDescription :: forall (p :: FileParty). FileDescription p -> [FileChunk]
chunks :: [FileChunk]
chunks} = case [FileChunk]
chunks of
  (FileChunk {$sel:replicas:FileChunk :: FileChunk -> [FileChunkReplica]
replicas = FileChunkReplica {$sel:server:FileChunkReplica :: FileChunkReplica -> XFTPServer
server = ProtocolServer {NonEmpty TransportHost
host :: NonEmpty TransportHost
$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host}} : [FileChunkReplica]
_} : [FileChunk]
_) ->
    (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (TransportHost -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (NonEmpty TransportHost -> TransportHost
forall a. NonEmpty a -> a
L.head NonEmpty TransportHost
host), FileDescription 'FRecipient -> ByteString
encodeWebURI FileDescription 'FRecipient
fd)
  [FileChunk]
_ -> Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing