{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module OM.Socket (
AddressDescription(..),
resolveAddr,
openIngress,
openEgress,
openServer,
Responded,
connectServer,
) where
import Control.Applicative ((<|>))
import Control.Concurrent (Chan, MVar, forkIO, newChan, newEmptyMVar,
putMVar, readChan, takeMVar, throwTo, writeChan)
import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar,
retry, writeTVar)
import Control.Exception (SomeException, bracketOnError, throw)
import Control.Monad (join, void, when)
import Control.Monad.Catch (MonadCatch, MonadThrow, throwM, try)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger.CallStack (MonadLoggerIO, askLoggerIO,
logDebug, logError, logWarn, runLoggingT)
import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
import Data.Binary (Binary(get), encode)
import Data.Binary.Get (Decoder(Done, Fail, Partial), pushChunk,
runGetIncremental)
import Data.ByteString (ByteString)
import Data.Conduit ((.|), ConduitT, awaitForever, runConduit, transPipe,
yield)
import Data.Conduit.Network (sinkSocket, sourceSocket)
import Data.Conduit.Serialization.Binary (conduitDecode, conduitEncode)
import Data.Map (Map)
import Data.String (IsString)
import Data.Text (Text)
import Data.Time (diffUTCTime, getCurrentTime)
import Data.Void (Void)
import Data.Word (Word32)
import GHC.Generics (Generic)
import Network.Socket (Family(AF_INET, AF_INET6, AF_UNIX),
SockAddr(SockAddrInet, SockAddrInet6, SockAddrUnix),
SocketOption(ReuseAddr), SocketType(Stream), HostName, ServiceName,
Socket, accept, addrAddress, bind, close, connect, defaultProtocol,
getAddrInfo, listen, setSocketOption, socket)
import Network.Socket.ByteString (recv)
import Network.Socket.ByteString.Lazy (sendAll)
import Network.TLS (ClientParams, Context, ServerParams, contextNew,
handshake, recvData, sendData)
import OM.Show (showt)
import Text.Megaparsec (Parsec, eof, many, oneOf, parse, satisfy)
import Text.Megaparsec.Char (char)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Conduit.List as CL
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Text.Megaparsec as M
openIngress :: (Binary i, MonadIO m, MonadFail m)
=> AddressDescription
-> ConduitT () i m ()
openIngress :: forall i (m :: * -> *).
(Binary i, MonadIO m, MonadFail m) =>
AddressDescription -> ConduitT () i m ()
openIngress AddressDescription
bindAddr = do
Socket
so <- SockAddr -> ConduitT () i m Socket
forall (m :: * -> *). MonadIO m => SockAddr -> m Socket
listenSocket (SockAddr -> ConduitT () i m Socket)
-> ConduitT () i m SockAddr -> ConduitT () i m Socket
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AddressDescription -> ConduitT () i m SockAddr
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
AddressDescription -> m SockAddr
resolveAddr AddressDescription
bindAddr
MVar i
mvar <- IO (MVar i) -> ConduitT () i m (MVar i)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar i)
forall a. IO (MVar a)
newEmptyMVar
ConduitT () i m ThreadId -> ConduitT () i m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ConduitT () i m ThreadId -> ConduitT () i m ())
-> (IO () -> ConduitT () i m ThreadId)
-> IO ()
-> ConduitT () i m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ThreadId -> ConduitT () i m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> ConduitT () i m ThreadId)
-> (IO () -> IO ThreadId) -> IO () -> ConduitT () i m ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> ConduitT () i m ()) -> IO () -> ConduitT () i m ()
forall a b. (a -> b) -> a -> b
$ Socket -> MVar i -> IO ()
forall i. Binary i => Socket -> MVar i -> IO ()
acceptLoop Socket
so MVar i
mvar
MVar i -> ConduitT () i m ()
forall (m :: * -> *) a. MonadIO m => MVar a -> ConduitT () a m ()
mvarToSource MVar i
mvar
where
mvarToSource :: (MonadIO m) => MVar a -> ConduitT () a m ()
mvarToSource :: forall (m :: * -> *) a. MonadIO m => MVar a -> ConduitT () a m ()
mvarToSource MVar a
mvar = do
IO a -> ConduitT () a m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
mvar) ConduitT () a m a
-> (a -> ConduitT () a m ()) -> ConduitT () a m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> ConduitT () a m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield
MVar a -> ConduitT () a m ()
forall (m :: * -> *) a. MonadIO m => MVar a -> ConduitT () a m ()
mvarToSource MVar a
mvar
acceptLoop :: (Binary i) => Socket -> MVar i -> IO ()
acceptLoop :: forall i. Binary i => Socket -> MVar i -> IO ()
acceptLoop Socket
so MVar i
mvar = do
(Socket
conn, SockAddr
_) <- Socket -> IO (Socket, SockAddr)
accept Socket
so
IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Decoder i -> Socket -> MVar i -> IO ()
forall i. Binary i => Decoder i -> Socket -> MVar i -> IO ()
feed (Get i -> Decoder i
forall a. Get a -> Decoder a
runGetIncremental Get i
forall t. Binary t => Get t
get) Socket
conn MVar i
mvar
Socket -> MVar i -> IO ()
forall i. Binary i => Socket -> MVar i -> IO ()
acceptLoop Socket
so MVar i
mvar
feed :: (Binary i) => Decoder i -> Socket -> MVar i -> IO ()
feed :: forall i. Binary i => Decoder i -> Socket -> MVar i -> IO ()
feed (Done ByteString
leftover ByteOffset
_ i
i) Socket
conn MVar i
mvar = do
MVar i -> i -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar i
mvar i
i
Decoder i -> Socket -> MVar i -> IO ()
forall i. Binary i => Decoder i -> Socket -> MVar i -> IO ()
feed (Get i -> Decoder i
forall a. Get a -> Decoder a
runGetIncremental Get i
forall t. Binary t => Get t
get Decoder i -> ByteString -> Decoder i
forall a. Decoder a -> ByteString -> Decoder a
`pushChunk` ByteString
leftover) Socket
conn MVar i
mvar
feed (Partial Maybe ByteString -> Decoder i
k) Socket
conn MVar i
mvar = do
ByteString
bytes <- Socket -> Int -> IO ByteString
recv Socket
conn Int
4096
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
BS.null ByteString
bytes) ([Char] -> IO ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Socket closed by peer.")
Decoder i -> Socket -> MVar i -> IO ()
forall i. Binary i => Decoder i -> Socket -> MVar i -> IO ()
feed (Maybe ByteString -> Decoder i
k (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bytes)) Socket
conn MVar i
mvar
feed (Fail ByteString
_ ByteOffset
_ [Char]
err) Socket
_conn MVar i
_chan =
[Char] -> IO ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Socket crashed. Decoding error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
err
openEgress
:: ( Binary o
, MonadFail m
, MonadIO m
, MonadThrow m
)
=> AddressDescription
-> ConduitT o Void m ()
openEgress :: forall o (m :: * -> *).
(Binary o, MonadFail m, MonadIO m, MonadThrow m) =>
AddressDescription -> ConduitT o Void m ()
openEgress AddressDescription
addr = do
Socket
so <- SockAddr -> ConduitT o Void m Socket
forall (m :: * -> *). MonadIO m => SockAddr -> m Socket
connectSocket (SockAddr -> ConduitT o Void m Socket)
-> ConduitT o Void m SockAddr -> ConduitT o Void m Socket
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AddressDescription -> ConduitT o Void m SockAddr
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
AddressDescription -> m SockAddr
resolveAddr AddressDescription
addr
ConduitT o ByteString m ()
forall b (m :: * -> *).
(Binary b, MonadThrow m) =>
ConduitT b ByteString m ()
conduitEncode ConduitT o ByteString m ()
-> ConduitT ByteString Void m () -> ConduitT o Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Socket -> ConduitT ByteString Void m ()
forall (m :: * -> *) o.
MonadIO m =>
Socket -> ConduitT ByteString o m ()
sinkSocket Socket
so
fam :: SockAddr -> Family
fam :: SockAddr -> Family
fam SockAddrInet {} = Family
AF_INET
fam SockAddrInet6 {} = Family
AF_INET6
fam SockAddrUnix {} = Family
AF_UNIX
resolveAddr :: (MonadIO m, MonadFail m) => AddressDescription -> m SockAddr
resolveAddr :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
AddressDescription -> m SockAddr
resolveAddr AddressDescription
addr = do
([Char]
host, [Char]
port) <- AddressDescription -> m ([Char], [Char])
forall (m :: * -> *).
MonadFail m =>
AddressDescription -> m ([Char], [Char])
parseAddr AddressDescription
addr
IO [AddrInfo] -> m [AddrInfo]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO [AddrInfo]
getAddrInfo Maybe AddrInfo
forall a. Maybe a
Nothing ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
host) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
port)) m [AddrInfo] -> ([AddrInfo] -> m SockAddr) -> m SockAddr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] -> [Char] -> m SockAddr
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Address not found: (host, port)"
AddrInfo
sa:[AddrInfo]
_ -> SockAddr -> m SockAddr
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrInfo -> SockAddr
addrAddress AddrInfo
sa)
parseAddr :: (MonadFail m) => AddressDescription -> m (HostName, ServiceName)
parseAddr :: forall (m :: * -> *).
MonadFail m =>
AddressDescription -> m ([Char], [Char])
parseAddr AddressDescription
addr =
case Parsec Void Text ([Char], [Char])
-> [Char]
-> Text
-> Either (ParseErrorBundle Text Void) ([Char], [Char])
forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void Text ([Char], [Char])
parser [Char]
"$" (AddressDescription -> Text
unAddressDescription AddressDescription
addr) of
Left ParseErrorBundle Text Void
err -> [Char] -> m ([Char], [Char])
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail (ParseErrorBundle Text Void -> [Char]
forall a. Show a => a -> [Char]
show ParseErrorBundle Text Void
err)
Right ([Char]
host, [Char]
port) -> ([Char], [Char]) -> m ([Char], [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
host, [Char]
port)
where
parser :: Parsec Void Text (HostName, ServiceName)
parser :: Parsec Void Text ([Char], [Char])
parser = do
[Char]
host <- ParsecT Void Text Identity [Char]
-> ParsecT Void Text Identity [Char]
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
M.try ParsecT Void Text Identity [Char]
ipv6 ParsecT Void Text Identity [Char]
-> ParsecT Void Text Identity [Char]
-> ParsecT Void Text Identity [Char]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity [Char]
ipv4
ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':'
[Char]
port <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ([Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf ([Char]
"0123456789" :: String))
ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
([Char], [Char]) -> Parsec Void Text ([Char], [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
host, [Char]
port)
ipv6 :: Parsec Void Text HostName
ipv6 :: ParsecT Void Text Identity [Char]
ipv6 = do
ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'['
[Char]
host <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
']'))
ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
']'
[Char] -> ParsecT Void Text Identity [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
host
ipv4 :: Parsec Void Text HostName
ipv4 :: ParsecT Void Text Identity [Char]
ipv4 = ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':'))
connectSocket :: (MonadIO m) => SockAddr -> m Socket
connectSocket :: forall (m :: * -> *). MonadIO m => SockAddr -> m Socket
connectSocket SockAddr
addr = IO Socket -> m Socket
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Socket -> m Socket) -> IO Socket -> m Socket
forall a b. (a -> b) -> a -> b
$
IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
(Family -> SocketType -> ProtocolNumber -> IO Socket
socket (SockAddr -> Family
fam SockAddr
addr) SocketType
Stream ProtocolNumber
defaultProtocol)
Socket -> IO ()
close
(\Socket
so -> Socket -> SockAddr -> IO ()
connect Socket
so SockAddr
addr IO () -> IO Socket -> IO Socket
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
so)
listenSocket :: (MonadIO m) => SockAddr -> m Socket
listenSocket :: forall (m :: * -> *). MonadIO m => SockAddr -> m Socket
listenSocket SockAddr
addr = IO Socket -> m Socket
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Socket -> m Socket) -> IO Socket -> m Socket
forall a b. (a -> b) -> a -> b
$ do
Socket
so <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket (SockAddr -> Family
fam SockAddr
addr) SocketType
Stream ProtocolNumber
defaultProtocol
Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
so SocketOption
ReuseAddr Int
1
Socket -> SockAddr -> IO ()
bind Socket
so SockAddr
addr
Socket -> Int -> IO ()
listen Socket
so Int
5
Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
so
openServer
:: ( Binary request
, Binary response
, MonadFail m
, MonadLoggerIO m
, Show request
, Show response
)
=> AddressDescription
-> Maybe (IO ServerParams)
-> ConduitT Void (request, response -> m Responded) m ()
openServer :: forall request response (m :: * -> *).
(Binary request, Binary response, MonadFail m, MonadLoggerIO m,
Show request, Show response) =>
AddressDescription
-> Maybe (IO ServerParams)
-> ConduitT Void (request, response -> m Responded) m ()
openServer AddressDescription
bindAddr Maybe (IO ServerParams)
tls = do
Socket
so <- SockAddr
-> ConduitT Void (request, response -> m Responded) m Socket
forall (m :: * -> *). MonadIO m => SockAddr -> m Socket
listenSocket (SockAddr
-> ConduitT Void (request, response -> m Responded) m Socket)
-> ConduitT Void (request, response -> m Responded) m SockAddr
-> ConduitT Void (request, response -> m Responded) m Socket
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AddressDescription
-> ConduitT Void (request, response -> m Responded) m SockAddr
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
AddressDescription -> m SockAddr
resolveAddr AddressDescription
bindAddr
Chan (request, response -> m Responded)
requestChan <- IO (Chan (request, response -> m Responded))
-> ConduitT
Void
(request, response -> m Responded)
m
(Chan (request, response -> m Responded))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Chan (request, response -> m Responded))
forall a. IO (Chan a)
newChan
Loc -> Text -> LogLevel -> LogStr -> IO ()
logging <- ConduitT
Void
(request, response -> m Responded)
m
(Loc -> Text -> LogLevel -> LogStr -> IO ())
forall (m :: * -> *).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
ConduitT Void (request, response -> m Responded) m ThreadId
-> ConduitT Void (request, response -> m Responded) m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ConduitT Void (request, response -> m Responded) m ThreadId
-> ConduitT Void (request, response -> m Responded) m ())
-> (LoggingT IO ()
-> ConduitT Void (request, response -> m Responded) m ThreadId)
-> LoggingT IO ()
-> ConduitT Void (request, response -> m Responded) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ThreadId
-> ConduitT Void (request, response -> m Responded) m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId
-> ConduitT Void (request, response -> m Responded) m ThreadId)
-> (LoggingT IO () -> IO ThreadId)
-> LoggingT IO ()
-> ConduitT Void (request, response -> m Responded) m ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId)
-> (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LoggingT IO ()
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Loc -> Text -> LogLevel -> LogStr -> IO ()
logging) (LoggingT IO ()
-> ConduitT Void (request, response -> m Responded) m ())
-> LoggingT IO ()
-> ConduitT Void (request, response -> m Responded) m ()
forall a b. (a -> b) -> a -> b
$ Socket -> Chan (request, response -> m Responded) -> LoggingT IO ()
forall i o (m :: * -> *) (n :: * -> *).
(Binary i, Binary o, MonadIO m, MonadLoggerIO n, Show i, Show o) =>
Socket -> Chan (i, o -> m Responded) -> n ()
acceptLoop Socket
so Chan (request, response -> m Responded)
requestChan
Chan (request, response -> m Responded)
-> ConduitT Void (request, response -> m Responded) m ()
forall (m :: * -> *) a. MonadIO m => Chan a -> ConduitT Void a m ()
chanToSource Chan (request, response -> m Responded)
requestChan
where
acceptLoop
:: ( Binary i
, Binary o
, MonadIO m
, MonadLoggerIO n
, Show i
, Show o
)
=> Socket
-> Chan (i, o -> m Responded)
-> n ()
acceptLoop :: forall i o (m :: * -> *) (n :: * -> *).
(Binary i, Binary o, MonadIO m, MonadLoggerIO n, Show i, Show o) =>
Socket -> Chan (i, o -> m Responded) -> n ()
acceptLoop Socket
so Chan (i, o -> m Responded)
requestChan = do
(Socket
conn, SockAddr
ra) <- IO (Socket, SockAddr) -> n (Socket, SockAddr)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Socket -> IO (Socket, SockAddr)
accept Socket
so)
(ConduitT Void ByteString IO ()
inputSource, ConduitT ByteString Void IO ()
outputSink) <- Socket
-> n (ConduitT Void ByteString IO (),
ConduitT ByteString Void IO ())
forall (m :: * -> *).
MonadIO m =>
Socket
-> m (ConduitT Void ByteString IO (),
ConduitT ByteString Void IO ())
prepareConnection Socket
conn
Text -> n ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> n ()) -> Text -> n ()
forall a b. (a -> b) -> a -> b
$ Text
"New connection: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SockAddr -> Text
forall a b. (Show a, IsString b) => a -> b
showt SockAddr
ra
Chan (Response o)
responseChan <- IO (Chan (Response o)) -> n (Chan (Response o))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Chan (Response o))
forall a. IO (Chan a)
newChan
Loc -> Text -> LogLevel -> LogStr -> IO ()
logging <- n (Loc -> Text -> LogLevel -> LogStr -> IO ())
forall (m :: * -> *).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
ThreadId
rtid <-
IO ThreadId -> n ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(IO ThreadId -> n ThreadId)
-> (LoggingT IO () -> IO ThreadId) -> LoggingT IO () -> n ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO
(IO () -> IO ThreadId)
-> (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LoggingT IO ()
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Loc -> Text -> LogLevel -> LogStr -> IO ()
logging)
(LoggingT IO () -> n ThreadId) -> LoggingT IO () -> n ThreadId
forall a b. (a -> b) -> a -> b
$ Chan (Response o)
-> ConduitT ByteString Void IO () -> LoggingT IO ()
forall p (m :: * -> *).
(Binary p, MonadLoggerIO m, MonadThrow m, Show p) =>
Chan (Response p) -> ConduitT ByteString Void IO () -> m ()
responderThread Chan (Response o)
responseChan ConduitT ByteString Void IO ()
outputSink
n ThreadId -> n ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (n ThreadId -> n ())
-> (LoggingT IO () -> n ThreadId) -> LoggingT IO () -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ThreadId -> n ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> n ThreadId)
-> (LoggingT IO () -> IO ThreadId) -> LoggingT IO () -> n ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId)
-> (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LoggingT IO ()
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Loc -> Text -> LogLevel -> LogStr -> IO ()
logging) (LoggingT IO () -> n ()) -> LoggingT IO () -> n ()
forall a b. (a -> b) -> a -> b
$ do
Either SomeException ()
result <- LoggingT IO () -> LoggingT IO (Either SomeException ())
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (LoggingT IO () -> LoggingT IO (Either SomeException ()))
-> LoggingT IO () -> LoggingT IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ ConduitT () Void (LoggingT IO) () -> LoggingT IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (
() -> ConduitT () Void (LoggingT IO) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ConduitT () Void (LoggingT IO) ()
-> ConduitT Void Void (LoggingT IO) ()
-> ConduitT () Void (LoggingT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (forall a. IO a -> LoggingT IO a)
-> ConduitT Void ByteString IO ()
-> ConduitT Void ByteString (LoggingT IO) ()
forall (m :: * -> *) (n :: * -> *) i o r.
Monad m =>
(forall a. m a -> n a) -> ConduitT i o m r -> ConduitT i o n r
transPipe forall a. IO a -> LoggingT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ConduitT Void ByteString IO ()
inputSource
ConduitT Void ByteString (LoggingT IO) ()
-> ConduitT ByteString Void (LoggingT IO) ()
-> ConduitT Void Void (LoggingT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString (Request i) (LoggingT IO) ()
forall b (m :: * -> *).
(Binary b, MonadThrow m) =>
ConduitT ByteString b m ()
conduitDecode
ConduitT ByteString (Request i) (LoggingT IO) ()
-> ConduitT (Request i) Void (LoggingT IO) ()
-> ConduitT ByteString Void (LoggingT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Request i
-> ConduitT (Request i) (i, o -> m Responded) (LoggingT IO) ())
-> ConduitT (Request i) (i, o -> m Responded) (LoggingT IO) ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (\req :: Request i
req@Request {MessageId
messageId :: forall p. Request p -> MessageId
messageId :: MessageId
messageId, i
payload :: forall p. Request p -> p
payload :: i
payload} -> do
Text -> ConduitT (Request i) (i, o -> m Responded) (LoggingT IO) ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text
-> ConduitT (Request i) (i, o -> m Responded) (LoggingT IO) ())
-> Text
-> ConduitT (Request i) (i, o -> m Responded) (LoggingT IO) ()
forall a b. (a -> b) -> a -> b
$ SockAddr -> Text
forall a b. (Show a, IsString b) => a -> b
showt SockAddr
ra Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Got request: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Request i -> Text
forall a b. (Show a, IsString b) => a -> b
showt Request i
req
UTCTime
start <- IO UTCTime
-> ConduitT (Request i) (i, o -> m Responded) (LoggingT IO) UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
(i, o -> m Responded)
-> ConduitT (Request i) (i, o -> m Responded) (LoggingT IO) ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (
i
payload,
\o
res -> do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (o -> IO ()) -> o -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chan (Response o) -> Response o -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Response o)
responseChan (Response o -> IO ()) -> (o -> Response o) -> o -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageId -> o -> Response o
forall p. MessageId -> p -> Response p
Response MessageId
messageId (o -> m ()) -> o -> m ()
forall a b. (a -> b) -> a -> b
$ o
res
UTCTime
end <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Text -> IO ()) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LoggingT IO ()
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Loc -> Text -> LogLevel -> LogStr -> IO ()
logging) (LoggingT IO () -> IO ())
-> (Text -> LoggingT IO ()) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LoggingT IO ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug
(Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ SockAddr -> Text
forall a b. (Show a, IsString b) => a -> b
showt SockAddr
ra Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Responded to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MessageId -> Text
forall a b. (Show a, IsString b) => a -> b
showt MessageId
messageId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in ("
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Text
forall a b. (Show a, IsString b) => a -> b
showt (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
end UTCTime
start) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
Responded -> m Responded
forall (f :: * -> *) a. Applicative f => a -> f a
pure Responded
Responded
)
)
ConduitT (Request i) (i, o -> m Responded) (LoggingT IO) ()
-> ConduitT (i, o -> m Responded) Void (LoggingT IO) ()
-> ConduitT (Request i) Void (LoggingT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ((i, o -> m Responded) -> LoggingT IO ())
-> ConduitT (i, o -> m Responded) Void (LoggingT IO) ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (IO () -> LoggingT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LoggingT IO ())
-> ((i, o -> m Responded) -> IO ())
-> (i, o -> m Responded)
-> LoggingT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chan (i, o -> m Responded) -> (i, o -> m Responded) -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (i, o -> m Responded)
requestChan)
)
case Either SomeException ()
result of
Left SomeException
err -> IO () -> LoggingT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LoggingT IO ()) -> IO () -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> SomeException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
rtid (SomeException
err :: SomeException)
Right () -> () -> LoggingT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Text -> LoggingT IO ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> LoggingT IO ()) -> Text -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Closed connection: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SockAddr -> Text
forall a b. (Show a, IsString b) => a -> b
showt SockAddr
ra
Socket -> Chan (i, o -> m Responded) -> n ()
forall i o (m :: * -> *) (n :: * -> *).
(Binary i, Binary o, MonadIO m, MonadLoggerIO n, Show i, Show o) =>
Socket -> Chan (i, o -> m Responded) -> n ()
acceptLoop Socket
so Chan (i, o -> m Responded)
requestChan
prepareConnection
:: (MonadIO m)
=> Socket
-> m (ConduitT Void ByteString IO (), ConduitT ByteString Void IO ())
prepareConnection :: forall (m :: * -> *).
MonadIO m =>
Socket
-> m (ConduitT Void ByteString IO (),
ConduitT ByteString Void IO ())
prepareConnection Socket
conn =
case Maybe (IO ServerParams)
tls of
Maybe (IO ServerParams)
Nothing -> (ConduitT Void ByteString IO (), ConduitT ByteString Void IO ())
-> m (ConduitT Void ByteString IO (),
ConduitT ByteString Void IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Socket -> ConduitT Void ByteString IO ()
forall (m :: * -> *) i.
MonadIO m =>
Socket -> ConduitT i ByteString m ()
sourceSocket Socket
conn, Socket -> ConduitT ByteString Void IO ()
forall (m :: * -> *) o.
MonadIO m =>
Socket -> ConduitT ByteString o m ()
sinkSocket Socket
conn)
Just IO ServerParams
getParams ->
IO (ConduitT Void ByteString IO (), ConduitT ByteString Void IO ())
-> m (ConduitT Void ByteString IO (),
ConduitT ByteString Void IO ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
(ConduitT Void ByteString IO (), ConduitT ByteString Void IO ())
-> m (ConduitT Void ByteString IO (),
ConduitT ByteString Void IO ()))
-> IO
(ConduitT Void ByteString IO (), ConduitT ByteString Void IO ())
-> m (ConduitT Void ByteString IO (),
ConduitT ByteString Void IO ())
forall a b. (a -> b) -> a -> b
$ do
Context
ctx <- Socket -> ServerParams -> IO Context
forall (m :: * -> *) backend params.
(MonadIO m, HasBackend backend, TLSParams params) =>
backend -> params -> m Context
contextNew Socket
conn (ServerParams -> IO Context) -> IO ServerParams -> IO Context
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ServerParams
getParams
Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
handshake Context
ctx
(ConduitT Void ByteString IO (), ConduitT ByteString Void IO ())
-> IO
(ConduitT Void ByteString IO (), ConduitT ByteString Void IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ConduitT Void ByteString IO ()
input Context
ctx, Context -> ConduitT ByteString Void IO ()
output Context
ctx)
where
output :: Context -> ConduitT ByteString Void IO ()
output :: Context -> ConduitT ByteString Void IO ()
output Context
ctx = (ByteString -> ConduitT ByteString Void IO ())
-> ConduitT ByteString Void IO ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (Context -> ByteString -> ConduitT ByteString Void IO ()
forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
sendData Context
ctx (ByteString -> ConduitT ByteString Void IO ())
-> (ByteString -> ByteString)
-> ByteString
-> ConduitT ByteString Void IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict)
input :: Context -> ConduitT Void ByteString IO ()
input :: Context -> ConduitT Void ByteString IO ()
input Context
ctx = do
ByteString
bytes <- Context -> ConduitT Void ByteString IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
recvData Context
ctx
if ByteString -> Bool
BS.null ByteString
bytes then
() -> ConduitT Void ByteString IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else do
ByteString -> ConduitT Void ByteString IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bytes
Context -> ConduitT Void ByteString IO ()
input Context
ctx
responderThread :: (
Binary p,
MonadLoggerIO m,
MonadThrow m,
Show p
)
=> Chan (Response p)
-> ConduitT ByteString Void IO ()
-> m ()
responderThread :: forall p (m :: * -> *).
(Binary p, MonadLoggerIO m, MonadThrow m, Show p) =>
Chan (Response p) -> ConduitT ByteString Void IO () -> m ()
responderThread Chan (Response p)
chan ConduitT ByteString Void IO ()
outputSink = ConduitT () Void m () -> m ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (
() -> ConduitT () Void m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ConduitT () Void m ()
-> ConduitT Void Void m () -> ConduitT () Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Chan (Response p) -> ConduitT Void (Response p) m ()
forall (m :: * -> *) a. MonadIO m => Chan a -> ConduitT Void a m ()
chanToSource Chan (Response p)
chan
ConduitT Void (Response p) m ()
-> ConduitT (Response p) Void m () -> ConduitT Void Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Response p -> ConduitT (Response p) (Response p) m ())
-> ConduitT (Response p) (Response p) m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (\res :: Response p
res@Response {MessageId
responseTo :: forall p. Response p -> MessageId
responseTo :: MessageId
responseTo, p
response :: forall p. Response p -> p
response :: p
response} -> do
Text -> ConduitT (Response p) (Response p) m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug
(Text -> ConduitT (Response p) (Response p) m ())
-> Text -> ConduitT (Response p) (Response p) m ()
forall a b. (a -> b) -> a -> b
$ Text
"Responding to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MessageId -> Text
forall a b. (Show a, IsString b) => a -> b
showt MessageId
responseTo
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> p -> Text
forall a b. (Show a, IsString b) => a -> b
showt p
response
Response p -> ConduitT (Response p) (Response p) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Response p
res
)
ConduitT (Response p) (Response p) m ()
-> ConduitT (Response p) Void m ()
-> ConduitT (Response p) Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT (Response p) ByteString m ()
forall b (m :: * -> *).
(Binary b, MonadThrow m) =>
ConduitT b ByteString m ()
conduitEncode
ConduitT (Response p) ByteString m ()
-> ConduitT ByteString Void m () -> ConduitT (Response p) Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (forall a. IO a -> m a)
-> ConduitT ByteString Void IO () -> ConduitT ByteString Void m ()
forall (m :: * -> *) (n :: * -> *) i o r.
Monad m =>
(forall a. m a -> n a) -> ConduitT i o m r -> ConduitT i o n r
transPipe forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ConduitT ByteString Void IO ()
outputSink
)
connectServer
:: ( Binary request
, Binary response
, MonadIO m
, MonadLoggerIO n
, Show response
)
=> AddressDescription
-> Maybe ClientParams
-> n (request -> m response)
connectServer :: forall request response (m :: * -> *) (n :: * -> *).
(Binary request, Binary response, MonadIO m, MonadLoggerIO n,
Show response) =>
AddressDescription
-> Maybe ClientParams -> n (request -> m response)
connectServer AddressDescription
addr Maybe ClientParams
tls = do
Loc -> Text -> LogLevel -> LogStr -> IO ()
logging <- n (Loc -> Text -> LogLevel -> LogStr -> IO ())
forall (m :: * -> *).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
IO (request -> m response) -> n (request -> m response)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (request -> m response) -> n (request -> m response))
-> IO (request -> m response) -> n (request -> m response)
forall a b. (a -> b) -> a -> b
$ do
Socket
so <- SockAddr -> IO Socket
forall (m :: * -> *). MonadIO m => SockAddr -> m Socket
connectSocket (SockAddr -> IO Socket) -> IO SockAddr -> IO Socket
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AddressDescription -> IO SockAddr
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
AddressDescription -> m SockAddr
resolveAddr AddressDescription
addr
TVar (ClientState request response)
state <- STM (TVar (ClientState request response))
-> IO (TVar (ClientState request response))
forall a. STM a -> IO a
atomically (ClientState request response
-> STM (TVar (ClientState request response))
forall a. a -> STM (TVar a)
newTVar ClientState :: forall i o.
Bool
-> Map MessageId (o -> IO ())
-> MessageId
-> [(i, o -> IO ())]
-> ClientState i o
ClientState {
csAlive :: Bool
csAlive = Bool
True,
csResponders :: Map MessageId (response -> IO ())
csResponders = Map MessageId (response -> IO ())
forall k a. Map k a
Map.empty,
csMessageId :: MessageId
csMessageId = MessageId
forall a. Bounded a => a
minBound,
csMessageQueue :: [(request, response -> IO ())]
csMessageQueue = []
})
(ByteString -> IO ()
send, ConduitT Void ByteString (LoggingT IO) ()
reqSource) <- Socket
-> IO
(ByteString -> IO (), ConduitT Void ByteString (LoggingT IO) ())
forall (m :: * -> *) (f :: * -> *).
(MonadIO m, MonadIO f) =>
Socket -> f (ByteString -> IO (), ConduitT Void ByteString m ())
prepareConnection Socket
so
IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (LoggingT IO ()
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Loc -> Text -> LogLevel -> LogStr -> IO ()
logging) ((ByteString -> IO ())
-> TVar (ClientState request response) -> LoggingT IO ()
forall i (m :: * -> *) o.
(Binary i, MonadCatch m, MonadLoggerIO m) =>
(ByteString -> IO ()) -> TVar (ClientState i o) -> m ()
requestThread ByteString -> IO ()
send TVar (ClientState request response)
state)
IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (LoggingT IO ()
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO ()
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Loc -> Text -> LogLevel -> LogStr -> IO ()
logging) (ConduitT Void ByteString (LoggingT IO) ()
-> TVar (ClientState request response) -> LoggingT IO ()
forall o (m :: * -> *) i.
(Binary o, MonadLoggerIO m, MonadCatch m, Show o) =>
ConduitT Void ByteString m () -> TVar (ClientState i o) -> m ()
responseThread ConduitT Void ByteString (LoggingT IO) ()
reqSource TVar (ClientState request response)
state)
(request -> m response) -> IO (request -> m response)
forall (m :: * -> *) a. Monad m => a -> m a
return (\request
i -> IO response -> m response
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO response -> m response) -> IO response -> m response
forall a b. (a -> b) -> a -> b
$ do
MVar response
mvar <- IO (MVar response)
forall a. IO (MVar a)
newEmptyMVar
IO (IO response) -> IO response
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO response) -> IO response)
-> (STM (IO response) -> IO (IO response))
-> STM (IO response)
-> IO response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (IO response) -> IO (IO response)
forall a. STM a -> IO a
atomically (STM (IO response) -> IO response)
-> STM (IO response) -> IO response
forall a b. (a -> b) -> a -> b
$
TVar (ClientState request response)
-> STM (ClientState request response)
forall a. TVar a -> STM a
readTVar TVar (ClientState request response)
state STM (ClientState request response)
-> (ClientState request response -> STM (IO response))
-> STM (IO response)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ClientState {csAlive :: forall i o. ClientState i o -> Bool
csAlive = Bool
False} -> IO response -> STM (IO response)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO response -> STM (IO response))
-> IO response -> STM (IO response)
forall a b. (a -> b) -> a -> b
$
IOError -> IO response
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([Char] -> IOError
userError [Char]
"Server connection died.")
s :: ClientState request response
s@ClientState {[(request, response -> IO ())]
csMessageQueue :: [(request, response -> IO ())]
csMessageQueue :: forall i o. ClientState i o -> [(i, o -> IO ())]
csMessageQueue} -> do
TVar (ClientState request response)
-> ClientState request response -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (ClientState request response)
state ClientState request response
s {
csMessageQueue :: [(request, response -> IO ())]
csMessageQueue = [(request, response -> IO ())]
csMessageQueue [(request, response -> IO ())]
-> [(request, response -> IO ())] -> [(request, response -> IO ())]
forall a. Semigroup a => a -> a -> a
<> [(request
i, MVar response -> response -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar response
mvar)]
}
IO response -> STM (IO response)
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar response -> IO response
forall a. MVar a -> IO a
takeMVar MVar response
mvar)
)
where
prepareConnection
:: (MonadIO m, MonadIO f)
=> Socket
-> f (BSL.ByteString -> IO (), ConduitT Void ByteString m ())
prepareConnection :: forall (m :: * -> *) (f :: * -> *).
(MonadIO m, MonadIO f) =>
Socket -> f (ByteString -> IO (), ConduitT Void ByteString m ())
prepareConnection Socket
so =
case Maybe ClientParams
tls of
Maybe ClientParams
Nothing -> (ByteString -> IO (), ConduitT Void ByteString m ())
-> f (ByteString -> IO (), ConduitT Void ByteString m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Socket -> ByteString -> IO ()
sendAll Socket
so, Socket -> ConduitT Void ByteString m ()
forall (m :: * -> *) i.
MonadIO m =>
Socket -> ConduitT i ByteString m ()
sourceSocket Socket
so)
Just ClientParams
params -> do
Context
ctx <- Socket -> ClientParams -> f Context
forall (m :: * -> *) backend params.
(MonadIO m, HasBackend backend, TLSParams params) =>
backend -> params -> m Context
contextNew Socket
so ClientParams
params
Context -> f ()
forall (m :: * -> *). MonadIO m => Context -> m ()
handshake Context
ctx
(ByteString -> IO (), ConduitT Void ByteString m ())
-> f (ByteString -> IO (), ConduitT Void ByteString m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ByteString -> IO ()
send Context
ctx, Context -> ConduitT Void ByteString m ()
forall (m :: * -> *).
MonadIO m =>
Context -> ConduitT Void ByteString m ()
reqSource Context
ctx)
where
send :: Context -> BSL.ByteString -> IO ()
send :: Context -> ByteString -> IO ()
send = Context -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
sendData
reqSource :: (MonadIO m) => Context -> ConduitT Void ByteString m ()
reqSource :: forall (m :: * -> *).
MonadIO m =>
Context -> ConduitT Void ByteString m ()
reqSource Context
ctx = do
ByteString
bytes <- Context -> ConduitT Void ByteString m ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
recvData Context
ctx
if ByteString -> Bool
BS.null ByteString
bytes
then () -> ConduitT Void ByteString m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else do
ByteString -> ConduitT Void ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bytes
Context -> ConduitT Void ByteString m ()
forall (m :: * -> *).
MonadIO m =>
Context -> ConduitT Void ByteString m ()
reqSource Context
ctx
requestThread :: (
Binary i,
MonadCatch m,
MonadLoggerIO m
)
=> (BSL.ByteString -> IO ())
-> TVar (ClientState i o)
-> m ()
requestThread :: forall i (m :: * -> *) o.
(Binary i, MonadCatch m, MonadLoggerIO m) =>
(ByteString -> IO ()) -> TVar (ClientState i o) -> m ()
requestThread ByteString -> IO ()
send TVar (ClientState i o)
state =
m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ())
-> (STM (m ()) -> m (m ())) -> STM (m ()) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (m ()) -> m (m ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (m ()) -> m (m ()))
-> (STM (m ()) -> IO (m ())) -> STM (m ()) -> m (m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (m ()) -> IO (m ())
forall a. STM a -> IO a
atomically (STM (m ()) -> m ()) -> STM (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
TVar (ClientState i o) -> STM (ClientState i o)
forall a. TVar a -> STM a
readTVar TVar (ClientState i o)
state STM (ClientState i o)
-> (ClientState i o -> STM (m ())) -> STM (m ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ClientState {csAlive :: forall i o. ClientState i o -> Bool
csAlive = Bool
False} -> m () -> STM (m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
ClientState {csMessageQueue :: forall i o. ClientState i o -> [(i, o -> IO ())]
csMessageQueue = []} -> STM (m ())
forall a. STM a
retry
s :: ClientState i o
s@ClientState {
csMessageQueue :: forall i o. ClientState i o -> [(i, o -> IO ())]
csMessageQueue = (i
m, o -> IO ()
r):[(i, o -> IO ())]
remaining,
Map MessageId (o -> IO ())
csResponders :: Map MessageId (o -> IO ())
csResponders :: forall i o. ClientState i o -> Map MessageId (o -> IO ())
csResponders,
MessageId
csMessageId :: MessageId
csMessageId :: forall i o. ClientState i o -> MessageId
csMessageId
}
-> do
TVar (ClientState i o) -> ClientState i o -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (ClientState i o)
state ClientState i o
s {
csMessageQueue :: [(i, o -> IO ())]
csMessageQueue = [(i, o -> IO ())]
remaining,
csResponders :: Map MessageId (o -> IO ())
csResponders = MessageId
-> (o -> IO ())
-> Map MessageId (o -> IO ())
-> Map MessageId (o -> IO ())
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert MessageId
csMessageId o -> IO ()
r Map MessageId (o -> IO ())
csResponders,
csMessageId :: MessageId
csMessageId = MessageId -> MessageId
forall a. Enum a => a -> a
succ MessageId
csMessageId
}
m () -> STM (m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m () -> STM (m ())) -> m () -> STM (m ())
forall a b. (a -> b) -> a -> b
$ do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
send (Request i -> ByteString
forall a. Binary a => a -> ByteString
encode (MessageId -> i -> Request i
forall p. MessageId -> p -> Request p
Request MessageId
csMessageId i
m))
(ByteString -> IO ()) -> TVar (ClientState i o) -> m ()
forall i (m :: * -> *) o.
(Binary i, MonadCatch m, MonadLoggerIO m) =>
(ByteString -> IO ()) -> TVar (ClientState i o) -> m ()
requestThread ByteString -> IO ()
send TVar (ClientState i o)
state
responseThread :: (
Binary o,
MonadLoggerIO m,
MonadCatch m,
Show o
)
=> ConduitT Void ByteString m ()
-> TVar (ClientState i o)
-> m ()
responseThread :: forall o (m :: * -> *) i.
(Binary o, MonadLoggerIO m, MonadCatch m, Show o) =>
ConduitT Void ByteString m () -> TVar (ClientState i o) -> m ()
responseThread ConduitT Void ByteString m ()
reqSource TVar (ClientState i o)
state = do
(m () -> m (Either SomeException ())
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m () -> m (Either SomeException ()))
-> (ConduitT () Void m () -> m ())
-> ConduitT () Void m ()
-> m (Either SomeException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConduitT () Void m () -> m ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit) (
() -> ConduitT () Void m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ConduitT () Void m ()
-> ConduitT Void Void m () -> ConduitT () Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Void ByteString m ()
reqSource
ConduitT Void ByteString m ()
-> ConduitT ByteString Void m () -> ConduitT Void Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString (Response o) m ()
forall b (m :: * -> *).
(Binary b, MonadThrow m) =>
ConduitT ByteString b m ()
conduitDecode
ConduitT ByteString (Response o) m ()
-> ConduitT (Response o) Void m () -> ConduitT ByteString Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Response o -> m ()) -> ConduitT (Response o) Void m ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (\r :: Response o
r@Response {MessageId
responseTo :: MessageId
responseTo :: forall p. Response p -> MessageId
responseTo, o
response :: o
response :: forall p. Response p -> p
response} ->
m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ())
-> (STM (m ()) -> m (m ())) -> STM (m ()) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (m ()) -> m (m ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (m ()) -> m (m ()))
-> (STM (m ()) -> IO (m ())) -> STM (m ()) -> m (m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (m ()) -> IO (m ())
forall a. STM a -> IO a
atomically (STM (m ()) -> m ()) -> STM (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
TVar (ClientState i o) -> STM (ClientState i o)
forall a. TVar a -> STM a
readTVar TVar (ClientState i o)
state STM (ClientState i o)
-> (ClientState i o -> STM (m ())) -> STM (m ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ ClientState {Map MessageId (o -> IO ())
csResponders :: Map MessageId (o -> IO ())
csResponders :: forall i o. ClientState i o -> Map MessageId (o -> IO ())
csResponders} ->
case MessageId -> Map MessageId (o -> IO ()) -> Maybe (o -> IO ())
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MessageId
responseTo Map MessageId (o -> IO ())
csResponders of
Maybe (o -> IO ())
Nothing -> m () -> STM (m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (m () -> STM (m ())) -> m () -> STM (m ())
forall a b. (a -> b) -> a -> b
$
Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logWarn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Unexpected server response: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Response o -> Text
forall a b. (Show a, IsString b) => a -> b
showt Response o
r
Just o -> IO ()
respond -> m () -> STM (m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (m () -> STM (m ())) -> m () -> STM (m ())
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (o -> IO ()
respond o
response)
)
) m (Either SomeException ())
-> (Either SomeException () -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left SomeException
err ->
Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logError
(Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Socket receive error: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a b. (Show a, IsString b) => a -> b
showt (SomeException
err :: SomeException)
Right () -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ())
-> (STM (m ()) -> m (m ())) -> STM (m ()) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (m ()) -> m (m ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (m ()) -> m (m ()))
-> (STM (m ()) -> IO (m ())) -> STM (m ()) -> m (m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (m ()) -> IO (m ())
forall a. STM a -> IO a
atomically (STM (m ()) -> m ()) -> STM (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
TVar (ClientState i o) -> STM (ClientState i o)
forall a. TVar a -> STM a
readTVar TVar (ClientState i o)
state STM (ClientState i o)
-> (ClientState i o -> STM (m ())) -> STM (m ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \s :: ClientState i o
s@ClientState {Map MessageId (o -> IO ())
csResponders :: Map MessageId (o -> IO ())
csResponders :: forall i o. ClientState i o -> Map MessageId (o -> IO ())
csResponders, [(i, o -> IO ())]
csMessageQueue :: [(i, o -> IO ())]
csMessageQueue :: forall i o. ClientState i o -> [(i, o -> IO ())]
csMessageQueue} -> do
TVar (ClientState i o) -> ClientState i o -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (ClientState i o)
state ClientState i o
s {csAlive :: Bool
csAlive = Bool
False}
m () -> STM (m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (m () -> STM (m ())) -> ([IO ()] -> m ()) -> [IO ()] -> STM (m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> ([IO ()] -> IO ()) -> [IO ()] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> STM (m ())) -> [IO ()] -> STM (m ())
forall a b. (a -> b) -> a -> b
$ [
o -> IO ()
r (IOError -> o
forall a e. Exception e => e -> a
throw ([Char] -> IOError
userError [Char]
"Remote connection died."))
| o -> IO ()
r <-
((MessageId, o -> IO ()) -> o -> IO ())
-> [(MessageId, o -> IO ())] -> [o -> IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MessageId, o -> IO ()) -> o -> IO ()
forall a b. (a, b) -> b
snd (Map MessageId (o -> IO ()) -> [(MessageId, o -> IO ())]
forall k a. Map k a -> [(k, a)]
Map.toList Map MessageId (o -> IO ())
csResponders)
[o -> IO ()] -> [o -> IO ()] -> [o -> IO ()]
forall a. Semigroup a => a -> a -> a
<> ((i, o -> IO ()) -> o -> IO ())
-> [(i, o -> IO ())] -> [o -> IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (i, o -> IO ()) -> o -> IO ()
forall a b. (a, b) -> b
snd [(i, o -> IO ())]
csMessageQueue
]
data Endpoint = Endpoint {
Endpoint -> AddressDescription
bindAddr :: AddressDescription,
Endpoint -> Maybe (IO ServerParams)
tls :: Maybe (IO ServerParams)
}
deriving stock ((forall x. Endpoint -> Rep Endpoint x)
-> (forall x. Rep Endpoint x -> Endpoint) -> Generic Endpoint
forall x. Rep Endpoint x -> Endpoint
forall x. Endpoint -> Rep Endpoint x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Endpoint x -> Endpoint
$cfrom :: forall x. Endpoint -> Rep Endpoint x
Generic)
data Response p = Response {
forall p. Response p -> MessageId
responseTo :: MessageId,
forall p. Response p -> p
response :: p
}
deriving stock ((forall x. Response p -> Rep (Response p) x)
-> (forall x. Rep (Response p) x -> Response p)
-> Generic (Response p)
forall x. Rep (Response p) x -> Response p
forall x. Response p -> Rep (Response p) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall p x. Rep (Response p) x -> Response p
forall p x. Response p -> Rep (Response p) x
$cto :: forall p x. Rep (Response p) x -> Response p
$cfrom :: forall p x. Response p -> Rep (Response p) x
Generic, Int -> Response p -> [Char] -> [Char]
[Response p] -> [Char] -> [Char]
Response p -> [Char]
(Int -> Response p -> [Char] -> [Char])
-> (Response p -> [Char])
-> ([Response p] -> [Char] -> [Char])
-> Show (Response p)
forall p. Show p => Int -> Response p -> [Char] -> [Char]
forall p. Show p => [Response p] -> [Char] -> [Char]
forall p. Show p => Response p -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Response p] -> [Char] -> [Char]
$cshowList :: forall p. Show p => [Response p] -> [Char] -> [Char]
show :: Response p -> [Char]
$cshow :: forall p. Show p => Response p -> [Char]
showsPrec :: Int -> Response p -> [Char] -> [Char]
$cshowsPrec :: forall p. Show p => Int -> Response p -> [Char] -> [Char]
Show)
instance (Binary p) => Binary (Response p)
newtype AddressDescription = AddressDescription {
AddressDescription -> Text
unAddressDescription :: Text
}
deriving stock ((forall x. AddressDescription -> Rep AddressDescription x)
-> (forall x. Rep AddressDescription x -> AddressDescription)
-> Generic AddressDescription
forall x. Rep AddressDescription x -> AddressDescription
forall x. AddressDescription -> Rep AddressDescription x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AddressDescription x -> AddressDescription
$cfrom :: forall x. AddressDescription -> Rep AddressDescription x
Generic)
deriving newtype
( Get AddressDescription
[AddressDescription] -> Put
AddressDescription -> Put
(AddressDescription -> Put)
-> Get AddressDescription
-> ([AddressDescription] -> Put)
-> Binary AddressDescription
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [AddressDescription] -> Put
$cputList :: [AddressDescription] -> Put
get :: Get AddressDescription
$cget :: Get AddressDescription
put :: AddressDescription -> Put
$cput :: AddressDescription -> Put
Binary
, AddressDescription -> AddressDescription -> Bool
(AddressDescription -> AddressDescription -> Bool)
-> (AddressDescription -> AddressDescription -> Bool)
-> Eq AddressDescription
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AddressDescription -> AddressDescription -> Bool
$c/= :: AddressDescription -> AddressDescription -> Bool
== :: AddressDescription -> AddressDescription -> Bool
$c== :: AddressDescription -> AddressDescription -> Bool
Eq
, Value -> Parser [AddressDescription]
Value -> Parser AddressDescription
(Value -> Parser AddressDescription)
-> (Value -> Parser [AddressDescription])
-> FromJSON AddressDescription
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [AddressDescription]
$cparseJSONList :: Value -> Parser [AddressDescription]
parseJSON :: Value -> Parser AddressDescription
$cparseJSON :: Value -> Parser AddressDescription
FromJSON
, FromJSONKeyFunction [AddressDescription]
FromJSONKeyFunction AddressDescription
FromJSONKeyFunction AddressDescription
-> FromJSONKeyFunction [AddressDescription]
-> FromJSONKey AddressDescription
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
fromJSONKeyList :: FromJSONKeyFunction [AddressDescription]
$cfromJSONKeyList :: FromJSONKeyFunction [AddressDescription]
fromJSONKey :: FromJSONKeyFunction AddressDescription
$cfromJSONKey :: FromJSONKeyFunction AddressDescription
FromJSONKey
, [Char] -> AddressDescription
([Char] -> AddressDescription) -> IsString AddressDescription
forall a. ([Char] -> a) -> IsString a
fromString :: [Char] -> AddressDescription
$cfromString :: [Char] -> AddressDescription
IsString
, Semigroup AddressDescription
AddressDescription
Semigroup AddressDescription
-> AddressDescription
-> (AddressDescription -> AddressDescription -> AddressDescription)
-> ([AddressDescription] -> AddressDescription)
-> Monoid AddressDescription
[AddressDescription] -> AddressDescription
AddressDescription -> AddressDescription -> AddressDescription
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [AddressDescription] -> AddressDescription
$cmconcat :: [AddressDescription] -> AddressDescription
mappend :: AddressDescription -> AddressDescription -> AddressDescription
$cmappend :: AddressDescription -> AddressDescription -> AddressDescription
mempty :: AddressDescription
$cmempty :: AddressDescription
Monoid
, Eq AddressDescription
Eq AddressDescription
-> (AddressDescription -> AddressDescription -> Ordering)
-> (AddressDescription -> AddressDescription -> Bool)
-> (AddressDescription -> AddressDescription -> Bool)
-> (AddressDescription -> AddressDescription -> Bool)
-> (AddressDescription -> AddressDescription -> Bool)
-> (AddressDescription -> AddressDescription -> AddressDescription)
-> (AddressDescription -> AddressDescription -> AddressDescription)
-> Ord AddressDescription
AddressDescription -> AddressDescription -> Bool
AddressDescription -> AddressDescription -> Ordering
AddressDescription -> AddressDescription -> AddressDescription
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AddressDescription -> AddressDescription -> AddressDescription
$cmin :: AddressDescription -> AddressDescription -> AddressDescription
max :: AddressDescription -> AddressDescription -> AddressDescription
$cmax :: AddressDescription -> AddressDescription -> AddressDescription
>= :: AddressDescription -> AddressDescription -> Bool
$c>= :: AddressDescription -> AddressDescription -> Bool
> :: AddressDescription -> AddressDescription -> Bool
$c> :: AddressDescription -> AddressDescription -> Bool
<= :: AddressDescription -> AddressDescription -> Bool
$c<= :: AddressDescription -> AddressDescription -> Bool
< :: AddressDescription -> AddressDescription -> Bool
$c< :: AddressDescription -> AddressDescription -> Bool
compare :: AddressDescription -> AddressDescription -> Ordering
$ccompare :: AddressDescription -> AddressDescription -> Ordering
Ord
, NonEmpty AddressDescription -> AddressDescription
AddressDescription -> AddressDescription -> AddressDescription
(AddressDescription -> AddressDescription -> AddressDescription)
-> (NonEmpty AddressDescription -> AddressDescription)
-> (forall b.
Integral b =>
b -> AddressDescription -> AddressDescription)
-> Semigroup AddressDescription
forall b.
Integral b =>
b -> AddressDescription -> AddressDescription
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b.
Integral b =>
b -> AddressDescription -> AddressDescription
$cstimes :: forall b.
Integral b =>
b -> AddressDescription -> AddressDescription
sconcat :: NonEmpty AddressDescription -> AddressDescription
$csconcat :: NonEmpty AddressDescription -> AddressDescription
<> :: AddressDescription -> AddressDescription -> AddressDescription
$c<> :: AddressDescription -> AddressDescription -> AddressDescription
Semigroup
, [AddressDescription] -> Encoding
[AddressDescription] -> Value
AddressDescription -> Encoding
AddressDescription -> Value
(AddressDescription -> Value)
-> (AddressDescription -> Encoding)
-> ([AddressDescription] -> Value)
-> ([AddressDescription] -> Encoding)
-> ToJSON AddressDescription
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [AddressDescription] -> Encoding
$ctoEncodingList :: [AddressDescription] -> Encoding
toJSONList :: [AddressDescription] -> Value
$ctoJSONList :: [AddressDescription] -> Value
toEncoding :: AddressDescription -> Encoding
$ctoEncoding :: AddressDescription -> Encoding
toJSON :: AddressDescription -> Value
$ctoJSON :: AddressDescription -> Value
ToJSON
, ToJSONKeyFunction [AddressDescription]
ToJSONKeyFunction AddressDescription
ToJSONKeyFunction AddressDescription
-> ToJSONKeyFunction [AddressDescription]
-> ToJSONKey AddressDescription
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
toJSONKeyList :: ToJSONKeyFunction [AddressDescription]
$ctoJSONKeyList :: ToJSONKeyFunction [AddressDescription]
toJSONKey :: ToJSONKeyFunction AddressDescription
$ctoJSONKey :: ToJSONKeyFunction AddressDescription
ToJSONKey
)
instance Show AddressDescription where
show :: AddressDescription -> [Char]
show = Text -> [Char]
T.unpack (Text -> [Char])
-> (AddressDescription -> Text) -> AddressDescription -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddressDescription -> Text
unAddressDescription
data ClientState i o = ClientState {
forall i o. ClientState i o -> Bool
csAlive :: Bool,
forall i o. ClientState i o -> Map MessageId (o -> IO ())
csResponders :: Map MessageId (o -> IO ()),
forall i o. ClientState i o -> MessageId
csMessageId :: MessageId,
forall i o. ClientState i o -> [(i, o -> IO ())]
csMessageQueue :: [(i, o -> IO ())]
}
data Request p = Request {
forall p. Request p -> MessageId
messageId :: MessageId,
forall p. Request p -> p
payload :: p
}
deriving stock ((forall x. Request p -> Rep (Request p) x)
-> (forall x. Rep (Request p) x -> Request p)
-> Generic (Request p)
forall x. Rep (Request p) x -> Request p
forall x. Request p -> Rep (Request p) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall p x. Rep (Request p) x -> Request p
forall p x. Request p -> Rep (Request p) x
$cto :: forall p x. Rep (Request p) x -> Request p
$cfrom :: forall p x. Request p -> Rep (Request p) x
Generic, Int -> Request p -> [Char] -> [Char]
[Request p] -> [Char] -> [Char]
Request p -> [Char]
(Int -> Request p -> [Char] -> [Char])
-> (Request p -> [Char])
-> ([Request p] -> [Char] -> [Char])
-> Show (Request p)
forall p. Show p => Int -> Request p -> [Char] -> [Char]
forall p. Show p => [Request p] -> [Char] -> [Char]
forall p. Show p => Request p -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Request p] -> [Char] -> [Char]
$cshowList :: forall p. Show p => [Request p] -> [Char] -> [Char]
show :: Request p -> [Char]
$cshow :: forall p. Show p => Request p -> [Char]
showsPrec :: Int -> Request p -> [Char] -> [Char]
$cshowsPrec :: forall p. Show p => Int -> Request p -> [Char] -> [Char]
Show)
instance (Binary p) => Binary (Request p)
newtype MessageId = MessageId {
MessageId -> Word32
_unMessageId :: Word32
}
deriving newtype (Get MessageId
[MessageId] -> Put
MessageId -> Put
(MessageId -> Put)
-> Get MessageId -> ([MessageId] -> Put) -> Binary MessageId
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [MessageId] -> Put
$cputList :: [MessageId] -> Put
get :: Get MessageId
$cget :: Get MessageId
put :: MessageId -> Put
$cput :: MessageId -> Put
Binary, Integer -> MessageId
MessageId -> MessageId
MessageId -> MessageId -> MessageId
(MessageId -> MessageId -> MessageId)
-> (MessageId -> MessageId -> MessageId)
-> (MessageId -> MessageId -> MessageId)
-> (MessageId -> MessageId)
-> (MessageId -> MessageId)
-> (MessageId -> MessageId)
-> (Integer -> MessageId)
-> Num MessageId
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> MessageId
$cfromInteger :: Integer -> MessageId
signum :: MessageId -> MessageId
$csignum :: MessageId -> MessageId
abs :: MessageId -> MessageId
$cabs :: MessageId -> MessageId
negate :: MessageId -> MessageId
$cnegate :: MessageId -> MessageId
* :: MessageId -> MessageId -> MessageId
$c* :: MessageId -> MessageId -> MessageId
- :: MessageId -> MessageId -> MessageId
$c- :: MessageId -> MessageId -> MessageId
+ :: MessageId -> MessageId -> MessageId
$c+ :: MessageId -> MessageId -> MessageId
Num, MessageId
MessageId -> MessageId -> Bounded MessageId
forall a. a -> a -> Bounded a
maxBound :: MessageId
$cmaxBound :: MessageId
minBound :: MessageId
$cminBound :: MessageId
Bounded, MessageId -> MessageId -> Bool
(MessageId -> MessageId -> Bool)
-> (MessageId -> MessageId -> Bool) -> Eq MessageId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MessageId -> MessageId -> Bool
$c/= :: MessageId -> MessageId -> Bool
== :: MessageId -> MessageId -> Bool
$c== :: MessageId -> MessageId -> Bool
Eq, Eq MessageId
Eq MessageId
-> (MessageId -> MessageId -> Ordering)
-> (MessageId -> MessageId -> Bool)
-> (MessageId -> MessageId -> Bool)
-> (MessageId -> MessageId -> Bool)
-> (MessageId -> MessageId -> Bool)
-> (MessageId -> MessageId -> MessageId)
-> (MessageId -> MessageId -> MessageId)
-> Ord MessageId
MessageId -> MessageId -> Bool
MessageId -> MessageId -> Ordering
MessageId -> MessageId -> MessageId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MessageId -> MessageId -> MessageId
$cmin :: MessageId -> MessageId -> MessageId
max :: MessageId -> MessageId -> MessageId
$cmax :: MessageId -> MessageId -> MessageId
>= :: MessageId -> MessageId -> Bool
$c>= :: MessageId -> MessageId -> Bool
> :: MessageId -> MessageId -> Bool
$c> :: MessageId -> MessageId -> Bool
<= :: MessageId -> MessageId -> Bool
$c<= :: MessageId -> MessageId -> Bool
< :: MessageId -> MessageId -> Bool
$c< :: MessageId -> MessageId -> Bool
compare :: MessageId -> MessageId -> Ordering
$ccompare :: MessageId -> MessageId -> Ordering
Ord, Int -> MessageId -> [Char] -> [Char]
[MessageId] -> [Char] -> [Char]
MessageId -> [Char]
(Int -> MessageId -> [Char] -> [Char])
-> (MessageId -> [Char])
-> ([MessageId] -> [Char] -> [Char])
-> Show MessageId
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [MessageId] -> [Char] -> [Char]
$cshowList :: [MessageId] -> [Char] -> [Char]
show :: MessageId -> [Char]
$cshow :: MessageId -> [Char]
showsPrec :: Int -> MessageId -> [Char] -> [Char]
$cshowsPrec :: Int -> MessageId -> [Char] -> [Char]
Show, Int -> MessageId
MessageId -> Int
MessageId -> [MessageId]
MessageId -> MessageId
MessageId -> MessageId -> [MessageId]
MessageId -> MessageId -> MessageId -> [MessageId]
(MessageId -> MessageId)
-> (MessageId -> MessageId)
-> (Int -> MessageId)
-> (MessageId -> Int)
-> (MessageId -> [MessageId])
-> (MessageId -> MessageId -> [MessageId])
-> (MessageId -> MessageId -> [MessageId])
-> (MessageId -> MessageId -> MessageId -> [MessageId])
-> Enum MessageId
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: MessageId -> MessageId -> MessageId -> [MessageId]
$cenumFromThenTo :: MessageId -> MessageId -> MessageId -> [MessageId]
enumFromTo :: MessageId -> MessageId -> [MessageId]
$cenumFromTo :: MessageId -> MessageId -> [MessageId]
enumFromThen :: MessageId -> MessageId -> [MessageId]
$cenumFromThen :: MessageId -> MessageId -> [MessageId]
enumFrom :: MessageId -> [MessageId]
$cenumFrom :: MessageId -> [MessageId]
fromEnum :: MessageId -> Int
$cfromEnum :: MessageId -> Int
toEnum :: Int -> MessageId
$ctoEnum :: Int -> MessageId
pred :: MessageId -> MessageId
$cpred :: MessageId -> MessageId
succ :: MessageId -> MessageId
$csucc :: MessageId -> MessageId
Enum)
chanToSource :: (MonadIO m) => Chan a -> ConduitT Void a m ()
chanToSource :: forall (m :: * -> *) a. MonadIO m => Chan a -> ConduitT Void a m ()
chanToSource Chan a
chan = do
a -> ConduitT Void a m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (a -> ConduitT Void a m ())
-> ConduitT Void a m a -> ConduitT Void a m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a -> ConduitT Void a m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Chan a -> IO a
forall a. Chan a -> IO a
readChan Chan a
chan)
Chan a -> ConduitT Void a m ()
forall (m :: * -> *) a. MonadIO m => Chan a -> ConduitT Void a m ()
chanToSource Chan a
chan
data Responded = Responded