{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Reflex.Backend.Socket.Accept
( accept
, AcceptConfig(..)
, Accept(..)
, acHostname
, acService
, acListenQueue
, acSocketOptions
, acClose
, 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(..))
data AcceptConfig t = AcceptConfig
{ AcceptConfig t -> Maybe HostName
_acHostname :: Maybe NS.HostName
, AcceptConfig t -> Maybe HostName
_acService :: Maybe NS.ServiceName
, AcceptConfig t -> Int
_acListenQueue :: Int
, AcceptConfig t -> [(SocketOption, Int)]
_acSocketOptions :: [(NS.SocketOption, Int)]
, AcceptConfig t -> Event t ()
_acClose :: Event t ()
}
$(makeLenses ''AcceptConfig)
data Accept t = Accept
{ Accept t -> Event t (Socket, SockAddr)
_aAcceptSocket :: Event t (Socket, NS.SockAddr)
, Accept t -> Event t ()
_aClose :: Event t ()
, Accept t -> Event t IOException
_aError :: Event t IOException
}
$(makeLenses ''Accept)
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)))
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
$
[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
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