{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections    #-}

{-|
Module      : Reflex.Backend.Socket.Connect
Copyright   : (c) 2018-2019, Commonwealth Scientific and Industrial Research Organisation
License     : BSD3
Maintainer  : dave.laing.80@gmail.com, jack.kelly@data61.csiro.au
Stability   : experimental
Portability : non-portable

Use 'connect' to attempt a connection to a remote endpoint, and get an
@'Event' t ('Either' 'SetupError' 'Socket')@ that tells you whether or
not it worked.
-}

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 to a remote endpoint. The connection happens in a
-- background thread.
connect
  :: ( Reflex t
     , PerformEvent t m
     , TriggerEvent t m
     , PostBuild t m
     , MonadIO (Performable m)
     , MonadIO m
     )
  => Maybe NS.HostName
     -- ^ Host to connect to. If 'Nothing', connect via loopback.
  -> NS.ServiceName
     -- ^ Service (port number or service name). See the
     -- <https://linux.die.net/man/3/getaddrinfo manpage for getaddrinfo>.
  -> m (Event t (Either SetupError Socket))
     -- ^ This event will fire exactly once.
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
$
        -- fromList is OK here, as getaddrinfo(3) is required to
        -- return a nonempty list of addrinfos.
        --
        -- See: http://pubs.opengroup.org/onlinepubs/9699919799/functions/getaddrinfo.html
        -- And: https://github.com/haskell/network/issues/407
        [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