{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
module Reflex.Backend.Socket.Connect (connect) where
import Control.Concurrent (forkIO)
import Control.Exception (IOException, onException, try)
import Control.Monad.Except (ExceptT(..), runExceptT, withExceptT)
import Control.Monad.Trans (MonadIO(..))
import Data.Functor (($>), void)
import Data.List.NonEmpty (NonEmpty, fromList)
import Data.Semigroup.Foldable (asum1)
import Network.Socket (Socket, AddrInfo(..), defaultProtocol)
import qualified Network.Socket as NS
import Reflex
import Reflex.Backend.Socket.Error (SetupError(..))
connect
:: ( Reflex t
, PerformEvent t m
, TriggerEvent t m
, PostBuild t m
, MonadIO (Performable m)
, MonadIO m
)
=> Maybe NS.HostName
-> NS.ServiceName
-> m (Event t (Either SetupError Socket))
connect :: Maybe HostName
-> HostName -> m (Event t (Either SetupError Socket))
connect Maybe HostName
mHost HostName
service = do
Event t ()
ePostBuild <- m (Event t ())
forall t (m :: * -> *). PostBuild t m => m (Event t ())
getPostBuild
Event t ((Either SetupError Socket -> IO ()) -> Performable m ())
-> m (Event t (Either SetupError Socket))
forall t (m :: * -> *) a.
(TriggerEvent t m, PerformEvent t m) =>
Event t ((a -> IO ()) -> Performable m ()) -> m (Event t a)
performEventAsync (Event t ((Either SetupError Socket -> IO ()) -> Performable m ())
-> m (Event t (Either SetupError Socket)))
-> Event
t ((Either SetupError Socket -> IO ()) -> Performable m ())
-> m (Event t (Either SetupError Socket))
forall a b. (a -> b) -> a -> b
$ Event t ()
ePostBuild Event t ()
-> ((Either SetupError Socket -> IO ()) -> Performable m ())
-> Event
t ((Either SetupError Socket -> IO ()) -> Performable m ())
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> \Either SetupError Socket -> IO ()
onRes -> Performable m ThreadId -> Performable m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Performable m ThreadId -> Performable m ())
-> (IO () -> Performable m ThreadId) -> IO () -> Performable m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ThreadId -> Performable m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> Performable m ThreadId)
-> (IO () -> IO ThreadId) -> IO () -> Performable m ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> Performable m ()) -> IO () -> Performable m ()
forall a b. (a -> b) -> a -> b
$
let
getAddrs :: ExceptT SetupError IO (NonEmpty AddrInfo)
getAddrs :: ExceptT SetupError IO (NonEmpty AddrInfo)
getAddrs = (IOException -> SetupError)
-> ExceptT IOException IO (NonEmpty AddrInfo)
-> ExceptT SetupError IO (NonEmpty AddrInfo)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT IOException -> SetupError
GetAddrInfoError (ExceptT IOException IO (NonEmpty AddrInfo)
-> ExceptT SetupError IO (NonEmpty AddrInfo))
-> (IO (NonEmpty AddrInfo)
-> ExceptT IOException IO (NonEmpty AddrInfo))
-> IO (NonEmpty AddrInfo)
-> ExceptT SetupError IO (NonEmpty AddrInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either IOException (NonEmpty AddrInfo))
-> ExceptT IOException IO (NonEmpty AddrInfo)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either IOException (NonEmpty AddrInfo))
-> ExceptT IOException IO (NonEmpty AddrInfo))
-> (IO (NonEmpty AddrInfo)
-> IO (Either IOException (NonEmpty AddrInfo)))
-> IO (NonEmpty AddrInfo)
-> ExceptT IOException IO (NonEmpty AddrInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (NonEmpty AddrInfo)
-> IO (Either IOException (NonEmpty AddrInfo))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (NonEmpty AddrInfo)
-> ExceptT SetupError IO (NonEmpty AddrInfo))
-> IO (NonEmpty AddrInfo)
-> ExceptT SetupError IO (NonEmpty AddrInfo)
forall a b. (a -> b) -> a -> b
$
[AddrInfo] -> NonEmpty AddrInfo
forall a. [a] -> NonEmpty a
fromList ([AddrInfo] -> NonEmpty AddrInfo)
-> IO [AddrInfo] -> IO (NonEmpty AddrInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe HostName -> Maybe HostName -> IO [AddrInfo]
NS.getAddrInfo Maybe AddrInfo
forall a. Maybe a
Nothing Maybe HostName
mHost (HostName -> Maybe HostName
forall a. a -> Maybe a
Just HostName
service)
tryConnect
:: AddrInfo
-> ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket
tryConnect :: AddrInfo -> ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket
tryConnect AddrInfo
info = (IOException -> NonEmpty (AddrInfo, IOException))
-> ExceptT IOException IO Socket
-> ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ((AddrInfo, IOException) -> NonEmpty (AddrInfo, IOException)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((AddrInfo, IOException) -> NonEmpty (AddrInfo, IOException))
-> (IOException -> (AddrInfo, IOException))
-> IOException
-> NonEmpty (AddrInfo, IOException)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AddrInfo
info,)) (ExceptT IOException IO Socket
-> ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket)
-> (IO Socket -> ExceptT IOException IO Socket)
-> IO Socket
-> ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either IOException Socket) -> ExceptT IOException IO Socket
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either IOException Socket) -> ExceptT IOException IO Socket)
-> (IO Socket -> IO (Either IOException Socket))
-> IO Socket
-> ExceptT IOException IO Socket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Socket -> IO (Either IOException Socket)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Socket -> ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket)
-> IO Socket
-> ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket
forall a b. (a -> b) -> a -> b
$ do
Socket
sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
NS.socket (AddrInfo -> Family
addrFamily AddrInfo
info) SocketType
NS.Stream ProtocolNumber
defaultProtocol
Socket -> SockAddr -> IO ()
NS.connect Socket
sock (AddrInfo -> SockAddr
addrAddress AddrInfo
info) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`onException` Socket -> IO ()
NS.close Socket
sock
Socket -> IO Socket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Socket
sock
in do
Either SetupError Socket
res <- ExceptT SetupError IO Socket -> IO (Either SetupError Socket)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SetupError IO Socket -> IO (Either SetupError Socket))
-> ExceptT SetupError IO Socket -> IO (Either SetupError Socket)
forall a b. (a -> b) -> a -> b
$ do
NonEmpty AddrInfo
addrs <- ExceptT SetupError IO (NonEmpty AddrInfo)
getAddrs
let attempts :: NonEmpty (ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket)
attempts = AddrInfo -> ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket
tryConnect (AddrInfo -> ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket)
-> NonEmpty AddrInfo
-> NonEmpty (ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty AddrInfo
addrs
(NonEmpty (AddrInfo, IOException) -> SetupError)
-> ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket
-> ExceptT SetupError IO Socket
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT NonEmpty (AddrInfo, IOException) -> SetupError
UseAddrInfoError (ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket
-> ExceptT SetupError IO Socket)
-> ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket
-> ExceptT SetupError IO Socket
forall a b. (a -> b) -> a -> b
$ NonEmpty (ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket)
-> ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket
forall (t :: * -> *) (m :: * -> *) a.
(Foldable1 t, Alt m) =>
t (m a) -> m a
asum1 NonEmpty (ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket)
attempts
Either SetupError Socket -> IO ()
onRes Either SetupError Socket
res