{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}

module Simplex.FileTransfer.Client.Agent
  ( XFTPClientVar,
    XFTPClientAgent (..),
    XFTPClientAgentConfig (..),
    XFTPClientAgentError (..),
    defaultXFTPClientAgentConfig,
    newXFTPAgent,
    getXFTPServerClient,
    showServer,
    closeXFTPServerClient,
  ) where

import Control.Logger.Simple (logInfo)
import Control.Monad
import Control.Monad.Except
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Except
import Data.Bifunctor (first)
import qualified Data.ByteString.Char8 as B
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock (UTCTime, getCurrentTime)
import Simplex.FileTransfer.Client
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode (..), ProtocolClientError (..), netTimeoutInt, temporaryClientError)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer)
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (catchAll_)
import UnliftIO

type XFTPClientVar = TMVar (Either XFTPClientAgentError XFTPClient)

data XFTPClientAgent = XFTPClientAgent
  { XFTPClientAgent -> TMap XFTPServer XFTPClientVar
xftpClients :: TMap XFTPServer XFTPClientVar,
    XFTPClientAgent -> UTCTime
startedAt :: UTCTime,
    XFTPClientAgent -> XFTPClientAgentConfig
config :: XFTPClientAgentConfig
  }

data XFTPClientAgentConfig = XFTPClientAgentConfig
  { XFTPClientAgentConfig -> XFTPClientConfig
xftpConfig :: XFTPClientConfig,
    XFTPClientAgentConfig -> RetryInterval
reconnectInterval :: RetryInterval
  }

defaultXFTPClientAgentConfig :: XFTPClientAgentConfig
defaultXFTPClientAgentConfig :: XFTPClientAgentConfig
defaultXFTPClientAgentConfig =
  XFTPClientAgentConfig
    { $sel:xftpConfig:XFTPClientAgentConfig :: XFTPClientConfig
xftpConfig = XFTPClientConfig
defaultXFTPClientConfig,
      $sel:reconnectInterval:XFTPClientAgentConfig :: RetryInterval
reconnectInterval =
        RetryInterval
          { initialInterval :: UserId
initialInterval = UserId
5_000000,
            increaseAfter :: UserId
increaseAfter = UserId
10_000000,
            maxInterval :: UserId
maxInterval = UserId
60_000000
          }
    }

data XFTPClientAgentError = XFTPClientAgentError XFTPServer XFTPClientError
  deriving (Int -> XFTPClientAgentError -> ShowS
[XFTPClientAgentError] -> ShowS
XFTPClientAgentError -> String
(Int -> XFTPClientAgentError -> ShowS)
-> (XFTPClientAgentError -> String)
-> ([XFTPClientAgentError] -> ShowS)
-> Show XFTPClientAgentError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XFTPClientAgentError -> ShowS
showsPrec :: Int -> XFTPClientAgentError -> ShowS
$cshow :: XFTPClientAgentError -> String
show :: XFTPClientAgentError -> String
$cshowList :: [XFTPClientAgentError] -> ShowS
showList :: [XFTPClientAgentError] -> ShowS
Show, Show XFTPClientAgentError
Typeable XFTPClientAgentError
(Typeable XFTPClientAgentError, Show XFTPClientAgentError) =>
(XFTPClientAgentError -> SomeException)
-> (SomeException -> Maybe XFTPClientAgentError)
-> (XFTPClientAgentError -> String)
-> Exception XFTPClientAgentError
SomeException -> Maybe XFTPClientAgentError
XFTPClientAgentError -> String
XFTPClientAgentError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: XFTPClientAgentError -> SomeException
toException :: XFTPClientAgentError -> SomeException
$cfromException :: SomeException -> Maybe XFTPClientAgentError
fromException :: SomeException -> Maybe XFTPClientAgentError
$cdisplayException :: XFTPClientAgentError -> String
displayException :: XFTPClientAgentError -> String
Exception)

newXFTPAgent :: XFTPClientAgentConfig -> IO XFTPClientAgent
newXFTPAgent :: XFTPClientAgentConfig -> IO XFTPClientAgent
newXFTPAgent XFTPClientAgentConfig
config = do
  TMap XFTPServer XFTPClientVar
xftpClients <- IO (TMap XFTPServer XFTPClientVar)
forall k a. IO (TMap k a)
TM.emptyIO
  UTCTime
startedAt <- IO UTCTime
getCurrentTime
  XFTPClientAgent -> IO XFTPClientAgent
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPClientAgent {TMap XFTPServer XFTPClientVar
$sel:xftpClients:XFTPClientAgent :: TMap XFTPServer XFTPClientVar
xftpClients :: TMap XFTPServer XFTPClientVar
xftpClients, UTCTime
$sel:startedAt:XFTPClientAgent :: UTCTime
startedAt :: UTCTime
startedAt, XFTPClientAgentConfig
$sel:config:XFTPClientAgent :: XFTPClientAgentConfig
config :: XFTPClientAgentConfig
config}

type ME a = ExceptT XFTPClientAgentError IO a

getXFTPServerClient :: XFTPClientAgent -> XFTPServer -> ME XFTPClient
getXFTPServerClient :: XFTPClientAgent -> XFTPServer -> ME XFTPClient
getXFTPServerClient XFTPClientAgent {TMap XFTPServer XFTPClientVar
$sel:xftpClients:XFTPClientAgent :: XFTPClientAgent -> TMap XFTPServer XFTPClientVar
xftpClients :: TMap XFTPServer XFTPClientVar
xftpClients, UTCTime
$sel:startedAt:XFTPClientAgent :: XFTPClientAgent -> UTCTime
startedAt :: UTCTime
startedAt, XFTPClientAgentConfig
$sel:config:XFTPClientAgent :: XFTPClientAgent -> XFTPClientAgentConfig
config :: XFTPClientAgentConfig
config} XFTPServer
srv = do
  STM (Either XFTPClientVar XFTPClientVar)
-> ExceptT
     XFTPClientAgentError IO (Either XFTPClientVar XFTPClientVar)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically STM (Either XFTPClientVar XFTPClientVar)
getClientVar ExceptT
  XFTPClientAgentError IO (Either XFTPClientVar XFTPClientVar)
-> (Either XFTPClientVar XFTPClientVar -> ME XFTPClient)
-> ME XFTPClient
forall a b.
ExceptT XFTPClientAgentError IO a
-> (a -> ExceptT XFTPClientAgentError IO b)
-> ExceptT XFTPClientAgentError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (XFTPClientVar -> ME XFTPClient)
-> (XFTPClientVar -> ME XFTPClient)
-> Either XFTPClientVar XFTPClientVar
-> ME XFTPClient
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either XFTPClientVar -> ME XFTPClient
newXFTPClient XFTPClientVar -> ME XFTPClient
waitForXFTPClient
  where
    connectClient :: ME XFTPClient
    connectClient :: ME XFTPClient
connectClient =
      IO (Either XFTPClientAgentError XFTPClient) -> ME XFTPClient
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XFTPClientAgentError XFTPClient) -> ME XFTPClient)
-> IO (Either XFTPClientAgentError XFTPClient) -> ME XFTPClient
forall a b. (a -> b) -> a -> b
$
        (XFTPClientError -> XFTPClientAgentError)
-> Either XFTPClientError XFTPClient
-> Either XFTPClientAgentError XFTPClient
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 (XFTPServer -> XFTPClientError -> XFTPClientAgentError
XFTPClientAgentError XFTPServer
srv)
          (Either XFTPClientError XFTPClient
 -> Either XFTPClientAgentError XFTPClient)
-> IO (Either XFTPClientError XFTPClient)
-> IO (Either XFTPClientAgentError XFTPClient)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TransportSession FileResponse
-> XFTPClientConfig
-> [String]
-> UTCTime
-> (XFTPClient -> IO ())
-> IO (Either XFTPClientError XFTPClient)
getXFTPClient (UserId
1, ProtocolServer (ProtoType FileResponse)
XFTPServer
srv, Maybe ByteString
forall a. Maybe a
Nothing) (XFTPClientAgentConfig -> XFTPClientConfig
xftpConfig XFTPClientAgentConfig
config) [] UTCTime
startedAt XFTPClient -> IO ()
clientDisconnected

    clientDisconnected :: XFTPClient -> IO ()
    clientDisconnected :: XFTPClient -> IO ()
clientDisconnected XFTPClient
_ = do
      STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ XFTPServer -> TMap XFTPServer XFTPClientVar -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete XFTPServer
srv TMap XFTPServer XFTPClientVar
xftpClients
      Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"disconnected from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> XFTPServer -> Text
showServer XFTPServer
srv

    getClientVar :: STM (Either XFTPClientVar XFTPClientVar)
    getClientVar :: STM (Either XFTPClientVar XFTPClientVar)
getClientVar = STM (Either XFTPClientVar XFTPClientVar)
-> (XFTPClientVar -> STM (Either XFTPClientVar XFTPClientVar))
-> Maybe XFTPClientVar
-> STM (Either XFTPClientVar XFTPClientVar)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (XFTPClientVar -> Either XFTPClientVar XFTPClientVar
forall a b. a -> Either a b
Left (XFTPClientVar -> Either XFTPClientVar XFTPClientVar)
-> STM XFTPClientVar -> STM (Either XFTPClientVar XFTPClientVar)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM XFTPClientVar
newClientVar) (Either XFTPClientVar XFTPClientVar
-> STM (Either XFTPClientVar XFTPClientVar)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPClientVar XFTPClientVar
 -> STM (Either XFTPClientVar XFTPClientVar))
-> (XFTPClientVar -> Either XFTPClientVar XFTPClientVar)
-> XFTPClientVar
-> STM (Either XFTPClientVar XFTPClientVar)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPClientVar -> Either XFTPClientVar XFTPClientVar
forall a b. b -> Either a b
Right) (Maybe XFTPClientVar -> STM (Either XFTPClientVar XFTPClientVar))
-> STM (Maybe XFTPClientVar)
-> STM (Either XFTPClientVar XFTPClientVar)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< XFTPServer
-> TMap XFTPServer XFTPClientVar -> STM (Maybe XFTPClientVar)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup XFTPServer
srv TMap XFTPServer XFTPClientVar
xftpClients
      where
        newClientVar :: STM XFTPClientVar
        newClientVar :: STM XFTPClientVar
newClientVar = do
          XFTPClientVar
var <- STM XFTPClientVar
forall a. STM (TMVar a)
newEmptyTMVar
          XFTPServer
-> XFTPClientVar -> TMap XFTPServer XFTPClientVar -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert XFTPServer
srv XFTPClientVar
var TMap XFTPServer XFTPClientVar
xftpClients
          XFTPClientVar -> STM XFTPClientVar
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPClientVar
var

    waitForXFTPClient :: XFTPClientVar -> ME XFTPClient
    waitForXFTPClient :: XFTPClientVar -> ME XFTPClient
waitForXFTPClient XFTPClientVar
clientVar = do
      let XFTPClientConfig {$sel:xftpNetworkConfig:XFTPClientConfig :: XFTPClientConfig -> NetworkConfig
xftpNetworkConfig = NetworkConfig {NetworkTimeout
tcpConnectTimeout :: NetworkTimeout
$sel:tcpConnectTimeout:NetworkConfig :: NetworkConfig -> NetworkTimeout
tcpConnectTimeout}} = XFTPClientAgentConfig -> XFTPClientConfig
xftpConfig XFTPClientAgentConfig
config
      Maybe (Either XFTPClientAgentError XFTPClient)
client_ <- IO (Maybe (Either XFTPClientAgentError XFTPClient))
-> ExceptT
     XFTPClientAgentError
     IO
     (Maybe (Either XFTPClientAgentError XFTPClient))
forall a. IO a -> ExceptT XFTPClientAgentError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Either XFTPClientAgentError XFTPClient))
 -> ExceptT
      XFTPClientAgentError
      IO
      (Maybe (Either XFTPClientAgentError XFTPClient)))
-> IO (Maybe (Either XFTPClientAgentError XFTPClient))
-> ExceptT
     XFTPClientAgentError
     IO
     (Maybe (Either XFTPClientAgentError XFTPClient))
forall a b. (a -> b) -> a -> b
$ NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt NetworkTimeout
tcpConnectTimeout NetworkRequestMode
NRMBackground Int
-> IO (Either XFTPClientAgentError XFTPClient)
-> IO (Maybe (Either XFTPClientAgentError XFTPClient))
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
`timeout` STM (Either XFTPClientAgentError XFTPClient)
-> IO (Either XFTPClientAgentError XFTPClient)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (XFTPClientVar -> STM (Either XFTPClientAgentError XFTPClient)
forall a. TMVar a -> STM a
readTMVar XFTPClientVar
clientVar)
      Either XFTPClientAgentError XFTPClient -> ME XFTPClient
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either XFTPClientAgentError XFTPClient -> ME XFTPClient)
-> Either XFTPClientAgentError XFTPClient -> ME XFTPClient
forall a b. (a -> b) -> a -> b
$ case Maybe (Either XFTPClientAgentError XFTPClient)
client_ of
        Just (Right XFTPClient
c) -> XFTPClient -> Either XFTPClientAgentError XFTPClient
forall a b. b -> Either a b
Right XFTPClient
c
        Just (Left XFTPClientAgentError
e) -> XFTPClientAgentError -> Either XFTPClientAgentError XFTPClient
forall a b. a -> Either a b
Left XFTPClientAgentError
e
        Maybe (Either XFTPClientAgentError XFTPClient)
Nothing -> XFTPClientAgentError -> Either XFTPClientAgentError XFTPClient
forall a b. a -> Either a b
Left (XFTPClientAgentError -> Either XFTPClientAgentError XFTPClient)
-> XFTPClientAgentError -> Either XFTPClientAgentError XFTPClient
forall a b. (a -> b) -> a -> b
$ XFTPServer -> XFTPClientError -> XFTPClientAgentError
XFTPClientAgentError XFTPServer
srv XFTPClientError
forall err. ProtocolClientError err
PCEResponseTimeout

    newXFTPClient :: XFTPClientVar -> ME XFTPClient
    newXFTPClient :: XFTPClientVar -> ME XFTPClient
newXFTPClient XFTPClientVar
clientVar = ME () -> ME XFTPClient
tryConnectClient ME ()
tryConnectAsync
      where
        tryConnectClient :: ME () -> ME XFTPClient
        tryConnectClient :: ME () -> ME XFTPClient
tryConnectClient ME ()
retryAction =
          ME XFTPClient
-> ExceptT
     XFTPClientAgentError IO (Either XFTPClientAgentError XFTPClient)
forall e (m :: * -> *) a. MonadError e m => m a -> m (Either e a)
tryError ME XFTPClient
connectClient ExceptT
  XFTPClientAgentError IO (Either XFTPClientAgentError XFTPClient)
-> (Either XFTPClientAgentError XFTPClient -> ME XFTPClient)
-> ME XFTPClient
forall a b.
ExceptT XFTPClientAgentError IO a
-> (a -> ExceptT XFTPClientAgentError IO b)
-> ExceptT XFTPClientAgentError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either XFTPClientAgentError XFTPClient
r -> case Either XFTPClientAgentError XFTPClient
r of
            Right XFTPClient
client -> do
              Text -> ME ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> ME ()) -> Text -> ME ()
forall a b. (a -> b) -> a -> b
$ Text
"connected to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> XFTPServer -> Text
showServer XFTPServer
srv
              STM () -> ME ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ME ()) -> STM () -> ME ()
forall a b. (a -> b) -> a -> b
$ XFTPClientVar -> Either XFTPClientAgentError XFTPClient -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar XFTPClientVar
clientVar Either XFTPClientAgentError XFTPClient
r
              XFTPClient -> ME XFTPClient
forall a. a -> ExceptT XFTPClientAgentError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPClient
client
            Left e :: XFTPClientAgentError
e@(XFTPClientAgentError XFTPServer
_ XFTPClientError
e') -> do
              if XFTPClientError -> Bool
forall err. ProtocolClientError err -> Bool
temporaryClientError XFTPClientError
e'
                then ME ()
retryAction
                else STM () -> ME ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ME ()) -> STM () -> ME ()
forall a b. (a -> b) -> a -> b
$ do
                  XFTPClientVar -> Either XFTPClientAgentError XFTPClient -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar XFTPClientVar
clientVar Either XFTPClientAgentError XFTPClient
r
                  XFTPServer -> TMap XFTPServer XFTPClientVar -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete XFTPServer
srv TMap XFTPServer XFTPClientVar
xftpClients
              XFTPClientAgentError -> ME XFTPClient
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE XFTPClientAgentError
e
        tryConnectAsync :: ME ()
        tryConnectAsync :: ME ()
tryConnectAsync = ExceptT
  XFTPClientAgentError IO (Async (Either XFTPClientAgentError ()))
-> ME ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   XFTPClientAgentError IO (Async (Either XFTPClientAgentError ()))
 -> ME ())
-> (ME ()
    -> ExceptT
         XFTPClientAgentError IO (Async (Either XFTPClientAgentError ())))
-> ME ()
-> ME ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Async (Either XFTPClientAgentError ()))
-> ExceptT
     XFTPClientAgentError IO (Async (Either XFTPClientAgentError ()))
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT XFTPClientAgentError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Async (Either XFTPClientAgentError ()))
 -> ExceptT
      XFTPClientAgentError IO (Async (Either XFTPClientAgentError ())))
-> (ME () -> IO (Async (Either XFTPClientAgentError ())))
-> ME ()
-> ExceptT
     XFTPClientAgentError IO (Async (Either XFTPClientAgentError ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either XFTPClientAgentError ())
-> IO (Async (Either XFTPClientAgentError ()))
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO (Either XFTPClientAgentError ())
 -> IO (Async (Either XFTPClientAgentError ())))
-> (ME () -> IO (Either XFTPClientAgentError ()))
-> ME ()
-> IO (Async (Either XFTPClientAgentError ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ME () -> IO (Either XFTPClientAgentError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ME () -> ME ()) -> ME () -> ME ()
forall a b. (a -> b) -> a -> b
$ do
          RetryInterval -> (UserId -> ME () -> ME ()) -> ME ()
forall (m :: * -> *) a.
MonadIO m =>
RetryInterval -> (UserId -> m a -> m a) -> m a
withRetryInterval (XFTPClientAgentConfig -> RetryInterval
reconnectInterval XFTPClientAgentConfig
config) ((UserId -> ME () -> ME ()) -> ME ())
-> (UserId -> ME () -> ME ()) -> ME ()
forall a b. (a -> b) -> a -> b
$ \UserId
_ ME ()
loop -> ME XFTPClient -> ME ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ME XFTPClient -> ME ()) -> ME XFTPClient -> ME ()
forall a b. (a -> b) -> a -> b
$ ME () -> ME XFTPClient
tryConnectClient ME ()
loop

showServer :: XFTPServer -> Text
showServer :: XFTPServer -> Text
showServer ProtocolServer {NonEmpty TransportHost
host :: NonEmpty TransportHost
$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host, String
port :: String
$sel:port:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> String
port} =
  ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ NonEmpty TransportHost -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode NonEmpty TransportHost
host ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
B.pack (if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
port then String
"" else Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: String
port)

closeXFTPServerClient :: XFTPClientAgent -> XFTPServer -> IO ()
closeXFTPServerClient :: XFTPClientAgent -> XFTPServer -> IO ()
closeXFTPServerClient XFTPClientAgent {TMap XFTPServer XFTPClientVar
$sel:xftpClients:XFTPClientAgent :: XFTPClientAgent -> TMap XFTPServer XFTPClientVar
xftpClients :: TMap XFTPServer XFTPClientVar
xftpClients, XFTPClientAgentConfig
$sel:config:XFTPClientAgent :: XFTPClientAgent -> XFTPClientAgentConfig
config :: XFTPClientAgentConfig
config} XFTPServer
srv =
  STM (Maybe XFTPClientVar) -> IO (Maybe XFTPClientVar)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (XFTPServer
-> TMap XFTPServer XFTPClientVar -> STM (Maybe XFTPClientVar)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookupDelete XFTPServer
srv TMap XFTPServer XFTPClientVar
xftpClients) IO (Maybe XFTPClientVar) -> (Maybe XFTPClientVar -> 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
>>= (XFTPClientVar -> IO ()) -> Maybe XFTPClientVar -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ XFTPClientVar -> IO ()
forall {a}. TMVar (Either a XFTPClient) -> IO ()
closeClient
  where
    closeClient :: TMVar (Either a XFTPClient) -> IO ()
closeClient TMVar (Either a XFTPClient)
cVar = do
      let NetworkConfig {NetworkTimeout
$sel:tcpConnectTimeout:NetworkConfig :: NetworkConfig -> NetworkTimeout
tcpConnectTimeout :: NetworkTimeout
tcpConnectTimeout} = XFTPClientConfig -> NetworkConfig
xftpNetworkConfig (XFTPClientConfig -> NetworkConfig)
-> XFTPClientConfig -> NetworkConfig
forall a b. (a -> b) -> a -> b
$ XFTPClientAgentConfig -> XFTPClientConfig
xftpConfig XFTPClientAgentConfig
config
      NetworkTimeout -> NetworkRequestMode -> Int
netTimeoutInt NetworkTimeout
tcpConnectTimeout NetworkRequestMode
NRMBackground Int -> IO (Either a XFTPClient) -> IO (Maybe (Either a XFTPClient))
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
`timeout` STM (Either a XFTPClient) -> IO (Either a XFTPClient)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar (Either a XFTPClient) -> STM (Either a XFTPClient)
forall a. TMVar a -> STM a
readTMVar TMVar (Either a XFTPClient)
cVar) IO (Maybe (Either a XFTPClient))
-> (Maybe (Either a XFTPClient) -> 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
        Just (Right XFTPClient
client) -> XFTPClient -> IO ()
closeXFTPClient XFTPClient
client IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchAll_` () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Maybe (Either a XFTPClient)
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()