{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

{- | Socket utilities. -}
module OM.Socket (
  -- * Socket Addresses
  AddressDescription(..),
  resolveAddr,

  -- * Ingress-only sockets
  openIngress,

  -- * Egress-only sockets
  openEgress,

  -- * Bidirection request/resposne servers.
  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


{- |
  Opens an "ingress" socket, which is a socket that accepts a stream of
  messages without responding.
-}
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


{- |
  Open an "egress" socket, which is a socket that sends a stream of messages
  without receiving responses.
-}
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


{- | Guess the family of a `SockAddr`. -}
fam :: SockAddr -> Family
fam :: SockAddr -> Family
fam SockAddrInet {} = Family
AF_INET
fam SockAddrInet6 {} = Family
AF_INET6
fam SockAddrUnix {} = Family
AF_UNIX


{- | Resolve a host:port address into a 'SockAddr'. -}
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)


{- | Parse a host:port address. -}
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
':'))


{- | Create a connected socket. -}
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
$
  {-
    Make sure to close the socket if an error happens during
    connection, because if not, we could easily run out of file
    descriptors in the case where we rapidly try to send thousands
    of message to the same peer, which could happen when one object
    is a hotspot.
  -}
  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)


{- | Create a listening socket. -}
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


{- |
  Open a "server" socket, which is a socket that accepts incoming requests
  and provides a way to respond to those requests.
-}
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
      )


{- |
  Connect to a server. Returns a function in 'MonadIO' that can be used
  to submit requests to (and returns the corresponding response from)
  the server.
-}
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
    {- |
      Returns the (output, input) communication channels, either prepared
      for TSL or not depending on the configuration.
    -}
    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

    {- | Receive requests and send them to the server. -}
    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

    {- |
      Receive responses from the server and send then them back to the
      client responder.
    -}
    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
            ]


{- | A server endpoint configuration. -}
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)


{- | Response to a request. -}
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)


{- |
  A description of a socket address on which a socket is or should be
  listening. Supports both IPv4 and IPv6.

  Examples:

  > AddressDescription "[::1]:80" -- IPv6 localhost, port 80
  > AddressDescription "127.0.0.1:80" -- IPv4 localhost, port 80
  > AddressDescription "somehost:80" -- IPv4 or IPv6 (depending on what name resolution returns), port 80
-}
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


{- | Client connection state. -}
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 ())]
  }


{- | A Request message type. -}
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)


{- | A message identifier. -}
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)


{- | Construct a coundiut source by reading forever from a 'Chan'. -}
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


{- |
  Proof that a response function was called on the server. Mainly
  useful for including in a type signature somewhere in your server
  implementation to help ensure that you actually responded to the
  request in all cases.
-}
data Responded = Responded