{-# 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
{ _acHostname :: Maybe NS.HostName
, _acService :: Maybe NS.ServiceName
, _acListenQueue :: Int
, _acSocketOptions :: [(NS.SocketOption, Int)]
, _acClose :: Event t ()
}
$(makeLenses ''AcceptConfig)
data Accept t = Accept
{ _aAcceptSocket :: Event t (Socket, NS.SockAddr)
, _aClose :: Event t ()
, _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 mHost mService listenQueue options eClose) = do
(eAccept, onAccept) <- newTriggerEvent
(eClosed, onClosed) <- newTriggerEvent
(eError, onError) <- newTriggerEvent
isOpen <- liftIO STM.newEmptyTMVarIO
let
start = liftIO $ makeListenSocket >>= \case
Left exc -> pure $ Left exc
Right sock -> do
atomically $ STM.putTMVar isOpen sock
void $ forkIO acceptLoop
pure . Right $ Accept eAccept eClosed eError
where
makeListenSocket =
let
getAddrs :: ExceptT SetupError IO (NonEmpty AddrInfo)
getAddrs = withExceptT GetAddrInfoError . ExceptT . try $
fromList <$> NS.getAddrInfo (Just passiveHints) mHost mService
where passiveHints = NS.defaultHints { addrFlags = [AI_PASSIVE] }
tryListen
:: AddrInfo
-> ExceptT (NonEmpty (AddrInfo, IOException)) IO Socket
tryListen info = withExceptT (pure . (info,)) . ExceptT . try $ do
sock <- NS.socket (addrFamily info) NS.Stream NS.defaultProtocol
(`onException` NS.close sock) $ do
traverse_ (uncurry $ NS.setSocketOption sock) options
NS.bind sock (addrAddress info)
NS.listen sock listenQueue
pure sock
in runExceptT $ do
addrs <- getAddrs
let attempts = tryListen <$> addrs
withExceptT UseAddrInfoError $ asum1 attempts
acceptLoop =
let
exHandlerAccept e = atomically (STM.tryReadTMVar isOpen)
>>= maybe (pure ()) (const $ close *> onError e)
in
atomically (STM.tryReadTMVar isOpen) >>= \case
Nothing -> onClosed ()
Just sock -> do
try (NS.accept sock) >>= either exHandlerAccept onAccept
acceptLoop
close = atomically (STM.tryTakeTMVar isOpen) >>= traverse_ NS.close
performEvent_ $ eClose $> liftIO close
ePostBuild <- getPostBuild
performEvent $ ePostBuild $> start