{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase       #-}
{-# LANGUAGE TemplateHaskell  #-}
{-# LANGUAGE TupleSections    #-}

{-|
Module      : Reflex.Backend.Socket.Accept
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 'accept' to create listen sockets, and get an @'Event' t 'Socket'@
of new connections.
-}

module Reflex.Backend.Socket.Accept
  ( accept

    -- * Listen socket configuration
  , AcceptConfig(..)

    -- * Results of @accept@
  , Accept(..)

    -- * Lenses
    -- ** 'AcceptConfig'
  , acHostname
  , acService
  , acListenQueue
  , acSocketOptions
  , acClose

    -- ** 'Accept'
  , aAcceptSocket
  , aClose
  , aError
  ) where

import           Control.Concurrent (forkIO)
import qualified Control.Concurrent.STM as STM
import           Control.Exception (IOException, onException, try)
import           Control.Lens.TH (makeLenses)
import           Control.Monad.Except (ExceptT(..), runExceptT, withExceptT)
import           Control.Monad.STM (atomically)
import           Control.Monad.Trans (MonadIO(..))
import           Data.Foldable (traverse_)
import           Data.Functor (($>), void)
import           Data.List.NonEmpty (NonEmpty, fromList)
import           Data.Semigroup.Foldable (asum1)
import           Network.Socket (AddrInfo(..), AddrInfoFlag(..), Socket)
import qualified Network.Socket as NS
import           Reflex
import           Reflex.Backend.Socket.Error (SetupError(..))

-- | Configuration of a listen socket.
data AcceptConfig t = AcceptConfig
  { AcceptConfig t -> Maybe HostName
_acHostname :: Maybe NS.HostName
    -- ^ The hostname to bind to. This will often be 'Nothing', to
    -- bind all interfaces.
  , AcceptConfig t -> Maybe HostName
_acService :: Maybe NS.ServiceName
    -- ^ The port number or service name to listen on. See the
    -- <https://linux.die.net/man/3/getaddrinfo manpage for getaddrinfo>.
  , AcceptConfig t -> Int
_acListenQueue :: Int
    -- ^ The length of the "pending connections" queue. See the
    -- <https://linux.die.net/man/2/listen manpage for listen>.
  , AcceptConfig t -> [(SocketOption, Int)]
_acSocketOptions :: [(NS.SocketOption, Int)]
    -- ^ List of socket options, passed one at a time to
    -- 'NS.setSocketOption'. Many people will want
    -- @[('NS.ReuseAddr', 1)]@ here.
  , AcceptConfig t -> Event t ()
_acClose :: Event t ()
    -- ^ Close the listen socket when this event fires. If you plan to
    -- run forever, use 'never'.
  }

$(makeLenses ''AcceptConfig)

-- | Events produced by a running listen socket.
data Accept t = Accept
  { Accept t -> Event t (Socket, SockAddr)
_aAcceptSocket :: Event t (Socket, NS.SockAddr)
    -- ^ A new connection was accepted, including its remote address.
  , Accept t -> Event t ()
_aClose :: Event t ()
    -- ^ The socket has closed. This will fire exactly once when the
    -- socket closes for any reason, including if your '_acClose'
    -- event fires or if the socket closes in response to a caught
    -- exception.
  , Accept t -> Event t IOException
_aError :: Event t IOException
    -- ^ An exception occurred. Treat the socket as closed after you
    -- see this. You will see the '_aClose' event fire as well, but
    -- not necessarily in the same frame.
  }

$(makeLenses ''Accept)

-- | Create a listening socket. Sockets are accepted in a background
-- thread.
accept
  :: ( Reflex t
     , PerformEvent t m
     , PostBuild t m
     , TriggerEvent t m
     , MonadIO (Performable m)
     , MonadIO m
     )
  => AcceptConfig t
  -> m (Event t (Either SetupError (Accept t)))
     -- ^ This event will fire exactly once.
accept :: AcceptConfig t -> m (Event t (Either SetupError (Accept t)))
accept (AcceptConfig Maybe HostName
mHost Maybe HostName
mService Int
listenQueue [(SocketOption, Int)]
options Event t ()
eClose) = do
  (Event t (Socket, SockAddr)
eAccept, (Socket, SockAddr) -> IO ()
onAccept) <- m (Event t (Socket, SockAddr), (Socket, SockAddr) -> IO ())
forall t (m :: * -> *) a.
TriggerEvent t m =>
m (Event t a, a -> IO ())
newTriggerEvent
  (Event t ()
eClosed, () -> IO ()
onClosed) <- m (Event t (), () -> IO ())
forall t (m :: * -> *) a.
TriggerEvent t m =>
m (Event t a, a -> IO ())
newTriggerEvent
  (Event t IOException
eError, IOException -> IO ()
onError) <- m (Event t IOException, IOException -> IO ())
forall t (m :: * -> *) a.
TriggerEvent t m =>
m (Event t a, a -> IO ())
newTriggerEvent

  TMVar Socket
isOpen <- IO (TMVar Socket) -> m (TMVar Socket)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TMVar Socket)
forall a. IO (TMVar a)
STM.newEmptyTMVarIO

  let
    start :: Performable m (Either SetupError (Accept t))
start = IO (Either SetupError (Accept t))
-> Performable m (Either SetupError (Accept t))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SetupError (Accept t))
 -> Performable m (Either SetupError (Accept t)))
-> IO (Either SetupError (Accept t))
-> Performable m (Either SetupError (Accept t))
forall a b. (a -> b) -> a -> b
$ IO (Either SetupError Socket)
makeListenSocket IO (Either SetupError Socket)
-> (Either SetupError Socket -> IO (Either SetupError (Accept t)))
-> IO (Either SetupError (Accept t))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left SetupError
exc -> Either SetupError (Accept t) -> IO (Either SetupError (Accept t))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SetupError (Accept t) -> IO (Either SetupError (Accept t)))
-> Either SetupError (Accept t)
-> IO (Either SetupError (Accept t))
forall a b. (a -> b) -> a -> b
$ SetupError -> Either SetupError (Accept t)
forall a b. a -> Either a b
Left SetupError
exc
      Right Socket
sock -> do
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar Socket -> Socket -> STM ()
forall a. TMVar a -> a -> STM ()
STM.putTMVar TMVar Socket
isOpen Socket
sock
        IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO IO ()
acceptLoop
        Either SetupError (Accept t) -> IO (Either SetupError (Accept t))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SetupError (Accept t) -> IO (Either SetupError (Accept t)))
-> (Accept t -> Either SetupError (Accept t))
-> Accept t
-> IO (Either SetupError (Accept t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Accept t -> Either SetupError (Accept t)
forall a b. b -> Either a b
Right (Accept t -> IO (Either SetupError (Accept t)))
-> Accept t -> IO (Either SetupError (Accept t))
forall a b. (a -> b) -> a -> b
$ Event t (Socket, SockAddr)
-> Event t () -> Event t IOException -> Accept t
forall t.
Event t (Socket, SockAddr)
-> Event t () -> Event t IOException -> Accept t
Accept Event t (Socket, SockAddr)
eAccept Event t ()
eClosed Event t IOException
eError

      where
        makeListenSocket :: IO (Either SetupError Socket)
makeListenSocket =
          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 (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
passiveHints) Maybe HostName
mHost Maybe HostName
mService
              where passiveHints :: AddrInfo
passiveHints = AddrInfo
NS.defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_PASSIVE] }

            tryListen
              :: AddrInfo
              -> ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket
            tryListen :: AddrInfo -> ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket
tryListen 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
NS.defaultProtocol
              (IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`onException` Socket -> IO ()
NS.close Socket
sock) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                ((SocketOption, Int) -> IO ()) -> [(SocketOption, Int)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((SocketOption -> Int -> IO ()) -> (SocketOption, Int) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((SocketOption -> Int -> IO ()) -> (SocketOption, Int) -> IO ())
-> (SocketOption -> Int -> IO ()) -> (SocketOption, Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> SocketOption -> Int -> IO ()
NS.setSocketOption Socket
sock) [(SocketOption, Int)]
options
                Socket -> SockAddr -> IO ()
NS.bind Socket
sock (AddrInfo -> SockAddr
addrAddress AddrInfo
info)
                Socket -> Int -> IO ()
NS.listen Socket
sock Int
listenQueue
              Socket -> IO Socket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Socket
sock

          in 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
tryListen (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

        acceptLoop :: IO ()
acceptLoop =
          let
            -- If we receive an exception when trying to accept, check
            -- the TMVar that's meant to hold our socket. If it's
            -- empty, then 'eClose' must have fired (and the socket
            -- closed under us) and we should go quietly. Otherwise,
            -- close the socket ourselves and signal 'eError'.
            exHandlerAccept :: IOException -> IO ()
exHandlerAccept IOException
e = STM (Maybe Socket) -> IO (Maybe Socket)
forall a. STM a -> IO a
atomically (TMVar Socket -> STM (Maybe Socket)
forall a. TMVar a -> STM (Maybe a)
STM.tryReadTMVar TMVar Socket
isOpen)
              IO (Maybe Socket) -> (Maybe Socket -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> (Socket -> IO ()) -> Maybe Socket -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> Socket -> IO ()
forall a b. a -> b -> a
const (IO () -> Socket -> IO ()) -> IO () -> Socket -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
close IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IOException -> IO ()
onError IOException
e)
          in
            STM (Maybe Socket) -> IO (Maybe Socket)
forall a. STM a -> IO a
atomically (TMVar Socket -> STM (Maybe Socket)
forall a. TMVar a -> STM (Maybe a)
STM.tryReadTMVar TMVar Socket
isOpen) IO (Maybe Socket) -> (Maybe Socket -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Maybe Socket
Nothing -> () -> IO ()
onClosed ()
              Just Socket
sock -> do
                IO (Socket, SockAddr) -> IO (Either IOException (Socket, SockAddr))
forall e a. Exception e => IO a -> IO (Either e a)
try (Socket -> IO (Socket, SockAddr)
NS.accept Socket
sock) IO (Either IOException (Socket, SockAddr))
-> (Either IOException (Socket, SockAddr) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IOException -> IO ())
-> ((Socket, SockAddr) -> IO ())
-> Either IOException (Socket, SockAddr)
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IOException -> IO ()
exHandlerAccept (Socket, SockAddr) -> IO ()
onAccept
                IO ()
acceptLoop

    close :: IO ()
close = STM (Maybe Socket) -> IO (Maybe Socket)
forall a. STM a -> IO a
atomically (TMVar Socket -> STM (Maybe Socket)
forall a. TMVar a -> STM (Maybe a)
STM.tryTakeTMVar TMVar Socket
isOpen) IO (Maybe Socket) -> (Maybe Socket -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Socket -> IO ()) -> Maybe Socket -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Socket -> IO ()
NS.close

  Event t (Performable m ()) -> m ()
forall t (m :: * -> *).
PerformEvent t m =>
Event t (Performable m ()) -> m ()
performEvent_ (Event t (Performable m ()) -> m ())
-> Event t (Performable m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Event t ()
eClose Event t () -> Performable m () -> Event t (Performable m ())
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> IO () -> Performable m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
close

  Event t ()
ePostBuild <- m (Event t ())
forall t (m :: * -> *). PostBuild t m => m (Event t ())
getPostBuild
  Event t (Performable m (Either SetupError (Accept t)))
-> m (Event t (Either SetupError (Accept t)))
forall t (m :: * -> *) a.
PerformEvent t m =>
Event t (Performable m a) -> m (Event t a)
performEvent (Event t (Performable m (Either SetupError (Accept t)))
 -> m (Event t (Either SetupError (Accept t))))
-> Event t (Performable m (Either SetupError (Accept t)))
-> m (Event t (Either SetupError (Accept t)))
forall a b. (a -> b) -> a -> b
$ Event t ()
ePostBuild Event t ()
-> Performable m (Either SetupError (Accept t))
-> Event t (Performable m (Either SetupError (Accept t)))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Performable m (Either SetupError (Accept t))
start