{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Network.QUIC.Server.Run (
    run,
    runWithSockets,
    stop,
) where

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import qualified Control.Exception as E
import qualified Network.Socket as NS
import System.Log.FastLogger hiding (check)

import Network.QUIC.Closer
import Network.QUIC.Common
import Network.QUIC.Config
import Network.QUIC.Connection
import Network.QUIC.Crypto
import Network.QUIC.Exception
import Network.QUIC.Handshake
import Network.QUIC.Imports
import Network.QUIC.Logger
import Network.QUIC.Packet
import Network.QUIC.Parameters
import Network.QUIC.QLogger
import Network.QUIC.Qlog
import Network.QUIC.Receiver
import Network.QUIC.Recovery
import Network.QUIC.Sender
import Network.QUIC.Server.Reader
import Network.QUIC.Socket
import Network.QUIC.Types

----------------------------------------------------------------

-- | Running a QUIC server.
--   The action is executed with a new connection
--   in a new lightweight thread.
run :: ServerConfig -> (Connection -> IO ()) -> IO ()
run :: ServerConfig -> (Connection -> IO ()) -> IO ()
run ServerConfig
conf Connection -> IO ()
server = DebugLogger -> IO () -> IO ()
handleLogUnit DebugLogger
debugLog (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
labelMe String
"QUIC run"
    TVar ServerState
stvar <- ServerState -> IO (TVar ServerState)
forall a. a -> IO (TVar a)
newTVarIO ServerState
Running
    IO (Dispatch, [ThreadId], [Socket])
-> ((Dispatch, [ThreadId], [Socket]) -> IO ())
-> ((Dispatch, [ThreadId], [Socket]) -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (TVar ServerState -> IO (Dispatch, [ThreadId], [Socket])
setup TVar ServerState
stvar) (Dispatch, [ThreadId], [Socket]) -> IO ()
forall {t :: * -> *} {t :: * -> *}.
(Foldable t, Foldable t) =>
(Dispatch, t ThreadId, t Socket) -> IO ()
teardown (((Dispatch, [ThreadId], [Socket]) -> IO ()) -> IO ())
-> ((Dispatch, [ThreadId], [Socket]) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Dispatch
_, [ThreadId]
_, [Socket]
_) -> do
        Hooks -> IO ()
onServerReady (Hooks -> IO ()) -> Hooks -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerConfig -> Hooks
scHooks ServerConfig
conf
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ServerState
st <- TVar ServerState -> STM ServerState
forall a. TVar a -> STM a
readTVar TVar ServerState
stvar
            Bool -> STM ()
check (Bool -> STM ()) -> Bool -> STM ()
forall a b. (a -> b) -> a -> b
$ ServerState
st ServerState -> ServerState -> Bool
forall a. Eq a => a -> a -> Bool
== ServerState
Stopped
  where
    doDebug :: Bool
doDebug = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ ServerConfig -> Maybe String
scDebugLog ServerConfig
conf
    debugLog :: DebugLogger
debugLog Builder
msg
        | Bool
doDebug = DebugLogger
stdoutLogger (Builder
"run: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
msg)
        | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    setup :: TVar ServerState -> IO (Dispatch, [ThreadId], [Socket])
setup TVar ServerState
stvar = do
        Dispatch
dispatch <- ServerConfig -> IO Dispatch
newDispatch ServerConfig
conf
        let forkConn :: Accept -> IO ()
forkConn Accept
acc = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (ServerConfig
-> (Connection -> IO ())
-> Dispatch
-> TVar ServerState
-> Accept
-> IO ()
runServer ServerConfig
conf Connection -> IO ()
server Dispatch
dispatch TVar ServerState
stvar Accept
acc)
        -- fixme: the case where sockets cannot be created.
        [Socket]
ssas <- ((IP, PortNumber) -> IO Socket)
-> [(IP, PortNumber)] -> IO [Socket]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IP, PortNumber) -> IO Socket
serverSocket ([(IP, PortNumber)] -> IO [Socket])
-> [(IP, PortNumber)] -> IO [Socket]
forall a b. (a -> b) -> a -> b
$ ServerConfig -> [(IP, PortNumber)]
scAddresses ServerConfig
conf
        [ThreadId]
tids <- (Socket -> IO ThreadId) -> [Socket] -> IO [ThreadId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Dispatch
-> ServerConfig
-> TVar ServerState
-> (Accept -> IO ())
-> Socket
-> IO ThreadId
runDispatcher Dispatch
dispatch ServerConfig
conf TVar ServerState
stvar Accept -> IO ()
forkConn) [Socket]
ssas
        (Dispatch, [ThreadId], [Socket])
-> IO (Dispatch, [ThreadId], [Socket])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dispatch
dispatch, [ThreadId]
tids, [Socket]
ssas)
    teardown :: (Dispatch, t ThreadId, t Socket) -> IO ()
teardown (Dispatch
dispatch, t ThreadId
tids, t Socket
ssas) = do
        Dispatch -> IO ()
clearDispatch Dispatch
dispatch
        (ThreadId -> IO ()) -> t ThreadId -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread t ThreadId
tids
        (Socket -> IO ()) -> t Socket -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Socket -> IO ()
NS.close t Socket
ssas

-- | Running a QUIC server.
--   The action is executed with a new connection
--   in a new lightweight thread.
runWithSockets :: [NS.Socket] -> ServerConfig -> (Connection -> IO ()) -> IO ()
runWithSockets :: [Socket] -> ServerConfig -> (Connection -> IO ()) -> IO ()
runWithSockets [Socket]
ssas ServerConfig
conf Connection -> IO ()
server = DebugLogger -> IO () -> IO ()
handleLogUnit DebugLogger
debugLog (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
labelMe String
"QUIC runWithSockets"
    TVar ServerState
stvar <- ServerState -> IO (TVar ServerState)
forall a. a -> IO (TVar a)
newTVarIO ServerState
Running
    IO (Dispatch, [ThreadId])
-> ((Dispatch, [ThreadId]) -> IO ())
-> ((Dispatch, [ThreadId]) -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (TVar ServerState -> IO (Dispatch, [ThreadId])
setup TVar ServerState
stvar) (Dispatch, [ThreadId]) -> IO ()
forall {t :: * -> *}. Foldable t => (Dispatch, t ThreadId) -> IO ()
teardown (((Dispatch, [ThreadId]) -> IO ()) -> IO ())
-> ((Dispatch, [ThreadId]) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Dispatch
_, [ThreadId]
_) -> do
        Hooks -> IO ()
onServerReady (Hooks -> IO ()) -> Hooks -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerConfig -> Hooks
scHooks ServerConfig
conf
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ServerState
st <- TVar ServerState -> STM ServerState
forall a. TVar a -> STM a
readTVar TVar ServerState
stvar
            Bool -> STM ()
check (Bool -> STM ()) -> Bool -> STM ()
forall a b. (a -> b) -> a -> b
$ ServerState
st ServerState -> ServerState -> Bool
forall a. Eq a => a -> a -> Bool
== ServerState
Stopped
  where
    doDebug :: Bool
doDebug = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ ServerConfig -> Maybe String
scDebugLog ServerConfig
conf
    debugLog :: DebugLogger
debugLog Builder
msg
        | Bool
doDebug = DebugLogger
stdoutLogger (Builder
"run: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
msg)
        | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    setup :: TVar ServerState -> IO (Dispatch, [ThreadId])
setup TVar ServerState
stvar = do
        Dispatch
dispatch <- ServerConfig -> IO Dispatch
newDispatch ServerConfig
conf
        let forkConn :: Accept -> IO ()
forkConn Accept
acc = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (ServerConfig
-> (Connection -> IO ())
-> Dispatch
-> TVar ServerState
-> Accept
-> IO ()
runServer ServerConfig
conf Connection -> IO ()
server Dispatch
dispatch TVar ServerState
stvar Accept
acc)
        -- fixme: the case where sockets cannot be created.
        [ThreadId]
tids <- (Socket -> IO ThreadId) -> [Socket] -> IO [ThreadId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Dispatch
-> ServerConfig
-> TVar ServerState
-> (Accept -> IO ())
-> Socket
-> IO ThreadId
runDispatcher Dispatch
dispatch ServerConfig
conf TVar ServerState
stvar Accept -> IO ()
forkConn) [Socket]
ssas
        (Dispatch, [ThreadId]) -> IO (Dispatch, [ThreadId])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dispatch
dispatch, [ThreadId]
tids)
    teardown :: (Dispatch, t ThreadId) -> IO ()
teardown (Dispatch
dispatch, t ThreadId
tids) = do
        Dispatch -> IO ()
clearDispatch Dispatch
dispatch
        (ThreadId -> IO ()) -> t ThreadId -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread t ThreadId
tids

-- Typically, ConnectionIsClosed breaks acceptStream.
-- And the exception should be ignored.
runServer
    :: ServerConfig
    -> (Connection -> IO ())
    -> Dispatch
    -> TVar ServerState
    -> Accept
    -> IO ()
runServer :: ServerConfig
-> (Connection -> IO ())
-> Dispatch
-> TVar ServerState
-> Accept
-> IO ()
runServer ServerConfig
conf Connection -> IO ()
server0 Dispatch
dispatch TVar ServerState
stvar Accept
acc = do
    String -> IO ()
labelMe String
"QUIC runServer"
    IO ConnRes -> (ConnRes -> IO ()) -> (ConnRes -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket IO ConnRes
open ConnRes -> IO ()
clse ((ConnRes -> IO ()) -> IO ()) -> (ConnRes -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ConnRes Connection
conn AuthCIDs
myAuthCIDs IO ()
_reader) ->
        DebugLogger -> IO () -> IO ()
handleLogUnit (Connection -> DebugLogger
debugLog Connection
conn) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            let conf' :: ServerConfig
conf' =
                    ServerConfig
conf
                        { scParameters =
                            (scParameters conf)
                                { versionInformation = Just $ accVersionInfo acc
                                }
                        }
            let srt :: StatelessResetToken
srt = Dispatch -> CID -> StatelessResetToken
genStatelessReset Dispatch
dispatch (CID -> StatelessResetToken) -> CID -> StatelessResetToken
forall a b. (a -> b) -> a -> b
$ Maybe CID -> CID
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CID -> CID) -> Maybe CID -> CID
forall a b. (a -> b) -> a -> b
$ AuthCIDs -> Maybe CID
initSrcCID AuthCIDs
myAuthCIDs
            IO ()
handshaker <- ServerConfig
-> Connection -> AuthCIDs -> StatelessResetToken -> IO (IO ())
handshakeServer ServerConfig
conf' Connection
conn AuthCIDs
myAuthCIDs StatelessResetToken
srt
            let server :: IO ()
server = do
                    Connection -> IO ()
wait1RTTReady Connection
conn
                    ServerConfig -> Connection -> IO ()
afterHandshakeServer ServerConfig
conf Connection
conn
                    Connection -> IO ()
server0 Connection
conn
                ldcc :: LDCC
ldcc = Connection -> LDCC
connLDCC Connection
conn
            let s1 :: IO ()
s1 = String -> IO ()
labelMe String
"handshaker" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
handshaker
                s2 :: IO ()
s2 = String -> IO ()
labelMe String
"sender" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Connection -> IO ()
sender Connection
conn
                s3 :: IO ()
s3 = String -> IO ()
labelMe String
"receiver" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Connection -> IO ()
receiver Connection
conn
                s4 :: IO ()
s4 = String -> IO ()
labelMe String
"resender" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LDCC -> IO ()
resender LDCC
ldcc
                s5 :: IO ()
s5 = String -> IO ()
labelMe String
"ldccTimer" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LDCC -> IO ()
ldccTimer LDCC
ldcc
                c1 :: IO ()
c1 = String -> IO ()
labelMe String
"concurrently1" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
concurrently_ IO ()
s1 IO ()
s2
                c2 :: IO ()
c2 = String -> IO ()
labelMe String
"concurrently2" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
concurrently_ IO ()
c1 IO ()
s3
                c3 :: IO ()
c3 = String -> IO ()
labelMe String
"concurrently3" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
concurrently_ IO ()
c2 IO ()
s4
                c4 :: IO ()
c4 = String -> IO ()
labelMe String
"concurrently4" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
concurrently_ IO ()
c3 IO ()
s5
                supporters :: IO ()
supporters = IO ()
c4
                runThreads :: IO ()
runThreads = do
                    Either () ()
er <- IO () -> IO () -> IO (Either () ())
forall a b. IO a -> IO b -> IO (Either a b)
race IO ()
supporters (String -> IO ()
labelMe String
"QUIC server" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
server)
                    case Either () ()
er of
                        Left () -> InternalControl -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO InternalControl
MustNotReached
                        Right ()
r -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
r
            Either SomeException ()
ex <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
E.try IO ()
runThreads
            Connection -> IO ()
sendFinal Connection
conn
            Connection -> LDCC -> Either SomeException () -> IO ()
forall a. Connection -> LDCC -> Either SomeException a -> IO a
closure Connection
conn LDCC
ldcc Either SomeException ()
ex
  where
    open :: IO ConnRes
open = ServerConfig
-> Dispatch -> Accept -> TVar ServerState -> IO ConnRes
createServerConnection ServerConfig
conf Dispatch
dispatch Accept
acc TVar ServerState
stvar
    clse :: ConnRes -> IO ()
clse ConnRes
connRes = do
        let conn :: Connection
conn = ConnRes -> Connection
connResConnection ConnRes
connRes
        Connection -> IO ()
setDead Connection
conn
        Connection -> IO ()
freeResources Connection
conn
    debugLog :: Connection -> DebugLogger
debugLog Connection
conn Builder
msg = do
        Connection -> DebugLogger
connDebugLog Connection
conn (Builder
"runServer: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
msg)
        Connection -> Debug -> IO ()
forall q. KeepQlog q => q -> Debug -> IO ()
qlogDebug Connection
conn (Debug -> IO ()) -> Debug -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr -> Debug
Debug (LogStr -> Debug) -> LogStr -> Debug
forall a b. (a -> b) -> a -> b
$ Builder -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr Builder
msg

createServerConnection
    :: ServerConfig
    -> Dispatch
    -> Accept
    -> TVar ServerState
    -> IO ConnRes
createServerConnection :: ServerConfig
-> Dispatch -> Accept -> TVar ServerState -> IO ConnRes
createServerConnection conf :: ServerConfig
conf@ServerConfig{Bool
Int
[(IP, PortNumber)]
[Group]
[Cipher]
[Version]
Maybe String
Maybe (Version -> [ByteString] -> IO ByteString)
SessionManager
Credentials
ServerHooks
Parameters
Hooks
String -> IO ()
scHooks :: ServerConfig -> Hooks
scDebugLog :: ServerConfig -> Maybe String
scAddresses :: ServerConfig -> [(IP, PortNumber)]
scParameters :: ServerConfig -> Parameters
scVersions :: [Version]
scCiphers :: [Cipher]
scGroups :: [Group]
scParameters :: Parameters
scKeyLog :: String -> IO ()
scQLog :: Maybe String
scCredentials :: Credentials
scHooks :: Hooks
scTlsHooks :: ServerHooks
scUse0RTT :: Bool
scAddresses :: [(IP, PortNumber)]
scALPN :: Maybe (Version -> [ByteString] -> IO ByteString)
scRequireRetry :: Bool
scSessionManager :: SessionManager
scDebugLog :: Maybe String
scTicketLifetime :: Int
scTicketLifetime :: ServerConfig -> Int
scSessionManager :: ServerConfig -> SessionManager
scRequireRetry :: ServerConfig -> Bool
scALPN :: ServerConfig -> Maybe (Version -> [ByteString] -> IO ByteString)
scUse0RTT :: ServerConfig -> Bool
scTlsHooks :: ServerConfig -> ServerHooks
scCredentials :: ServerConfig -> Credentials
scQLog :: ServerConfig -> Maybe String
scKeyLog :: ServerConfig -> String -> IO ()
scGroups :: ServerConfig -> [Group]
scCiphers :: ServerConfig -> [Cipher]
scVersions :: ServerConfig -> [Version]
..} Dispatch
dispatch Accept{Bool
Int
SockAddr
Socket
TimeMicrosecond
VersionInfo
RecvQ
AuthCIDs
CID -> IO ()
CID -> Connection -> IO ()
accVersionInfo :: Accept -> VersionInfo
accVersionInfo :: VersionInfo
accMyAuthCIDs :: AuthCIDs
accPeerAuthCIDs :: AuthCIDs
accMySocket :: Socket
accPeerSockAddr :: SockAddr
accRecvQ :: RecvQ
accPacketSize :: Int
accRegister :: CID -> Connection -> IO ()
accUnregister :: CID -> IO ()
accAddressValidated :: Bool
accTime :: TimeMicrosecond
accTime :: Accept -> TimeMicrosecond
accAddressValidated :: Accept -> Bool
accUnregister :: Accept -> CID -> IO ()
accRegister :: Accept -> CID -> Connection -> IO ()
accPacketSize :: Accept -> Int
accRecvQ :: Accept -> RecvQ
accPeerSockAddr :: Accept -> SockAddr
accMySocket :: Accept -> Socket
accPeerAuthCIDs :: Accept -> AuthCIDs
accMyAuthCIDs :: Accept -> AuthCIDs
..} TVar ServerState
stvar = do
    IORef Socket
sref <- Socket -> IO (IORef Socket)
forall a. a -> IO (IORef a)
newIORef Socket
accMySocket
    PathInfo
pathInfo <- SockAddr -> IO PathInfo
newPathInfo SockAddr
accPeerSockAddr
    IORef PeerInfo
piref <- PeerInfo -> IO (IORef PeerInfo)
forall a. a -> IO (IORef a)
newIORef (PeerInfo -> IO (IORef PeerInfo))
-> PeerInfo -> IO (IORef PeerInfo)
forall a b. (a -> b) -> a -> b
$ PathInfo -> Maybe PathInfo -> PeerInfo
PeerInfo PathInfo
pathInfo Maybe PathInfo
forall a. Maybe a
Nothing
    let send :: Ptr a -> Int -> IO ()
send Ptr a
buf Int
siz = IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Socket
sock <- IORef Socket -> IO Socket
forall a. IORef a -> IO a
readIORef IORef Socket
sref
            PeerInfo PathInfo
pinfo Maybe PathInfo
_ <- IORef PeerInfo -> IO PeerInfo
forall a. IORef a -> IO a
readIORef IORef PeerInfo
piref
            Socket -> Ptr a -> Int -> SockAddr -> IO Int
forall a. Socket -> Ptr a -> Int -> SockAddr -> IO Int
NS.sendBufTo Socket
sock Ptr a
buf Int
siz (SockAddr -> IO Int) -> SockAddr -> IO Int
forall a b. (a -> b) -> a -> b
$ PathInfo -> SockAddr
peerSockAddr PathInfo
pinfo
        recv :: IO ReceivedPacket
recv = RecvQ -> IO ReceivedPacket
recvServer RecvQ
accRecvQ
    let myCID :: CID
myCID = Maybe CID -> CID
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CID -> CID) -> Maybe CID -> CID
forall a b. (a -> b) -> a -> b
$ AuthCIDs -> Maybe CID
initSrcCID AuthCIDs
accMyAuthCIDs
        ocid :: CID
ocid = Maybe CID -> CID
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CID -> CID) -> Maybe CID -> CID
forall a b. (a -> b) -> a -> b
$ AuthCIDs -> Maybe CID
origDstCID AuthCIDs
accMyAuthCIDs
    (QLogger
qLog, IO ()
qclean) <- Maybe String
-> TimeMicrosecond -> CID -> ByteString -> IO (QLogger, IO ())
dirQLogger Maybe String
scQLog TimeMicrosecond
accTime CID
ocid ByteString
"server"
    (DebugLogger
debugLog, IO ()
dclean) <- Maybe String -> CID -> IO (DebugLogger, IO ())
dirDebugLogger Maybe String
scDebugLog CID
ocid
    DebugLogger
debugLog DebugLogger -> DebugLogger
forall a b. (a -> b) -> a -> b
$ Builder
"Original CID: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> CID -> Builder
forall a. Show a => a -> Builder
bhow CID
ocid
    Connection
conn <-
        ServerConfig
-> VersionInfo
-> AuthCIDs
-> AuthCIDs
-> DebugLogger
-> QLogger
-> Hooks
-> IORef Socket
-> IORef PeerInfo
-> RecvQ
-> Send
-> IO ReceivedPacket
-> (CID -> StatelessResetToken)
-> IO Connection
serverConnection
            ServerConfig
conf
            VersionInfo
accVersionInfo
            AuthCIDs
accMyAuthCIDs
            AuthCIDs
accPeerAuthCIDs
            DebugLogger
debugLog
            QLogger
qLog
            Hooks
scHooks
            IORef Socket
sref
            IORef PeerInfo
piref
            RecvQ
accRecvQ
            Send
forall {a}. Ptr a -> Int -> IO ()
send
            IO ReceivedPacket
recv
            (Dispatch -> CID -> StatelessResetToken
genStatelessReset Dispatch
dispatch)
    Connection -> IO () -> IO ()
addResource Connection
conn IO ()
qclean
    Connection -> IO () -> IO ()
addResource Connection
conn IO ()
dclean
    let cid :: CID
cid = CID -> Maybe CID -> CID
forall a. a -> Maybe a -> a
fromMaybe CID
ocid (Maybe CID -> CID) -> Maybe CID -> CID
forall a b. (a -> b) -> a -> b
$ AuthCIDs -> Maybe CID
retrySrcCID AuthCIDs
accMyAuthCIDs
        ver :: Version
ver = VersionInfo -> Version
chosenVersion VersionInfo
accVersionInfo
    Connection
-> EncryptionLevel -> TrafficSecrets InitialSecret -> IO ()
forall a.
Connection -> EncryptionLevel -> TrafficSecrets a -> IO ()
initializeCoder Connection
conn EncryptionLevel
InitialLevel (TrafficSecrets InitialSecret -> IO ())
-> TrafficSecrets InitialSecret -> IO ()
forall a b. (a -> b) -> a -> b
$ Version -> CID -> TrafficSecrets InitialSecret
initialSecrets Version
ver CID
cid
    Connection -> IO ()
setupCryptoStreams Connection
conn -- fixme: cleanup
    let peersa :: SockAddr
peersa = SockAddr
accPeerSockAddr
        pktSiz :: Int
pktSiz =
            (SockAddr -> Int
defaultPacketSize SockAddr
peersa Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int
accPacketSize)
                Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` SockAddr -> Int
maximumPacketSize SockAddr
peersa
    Connection -> Int -> IO ()
setMaxPacketSize Connection
conn Int
pktSiz
    LDCC -> Int -> IO ()
setInitialCongestionWindow (Connection -> LDCC
connLDCC Connection
conn) Int
pktSiz
    DebugLogger
debugLog DebugLogger -> DebugLogger
forall a b. (a -> b) -> a -> b
$ Builder
"Packet size: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall a. Show a => a -> Builder
bhow Int
pktSiz Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" (" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall a. Show a => a -> Builder
bhow Int
accPacketSize Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")"
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
accAddressValidated (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ PathInfo -> IO ()
setAddressValidated PathInfo
pathInfo
    --
    let retried :: Bool
retried = Maybe CID -> Bool
forall a. Maybe a -> Bool
isJust (Maybe CID -> Bool) -> Maybe CID -> Bool
forall a b. (a -> b) -> a -> b
$ AuthCIDs -> Maybe CID
retrySrcCID AuthCIDs
accMyAuthCIDs
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
retried (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Connection -> IO ()
forall q. KeepQlog q => q -> IO ()
qlogRecvInitial Connection
conn
        Connection -> IO ()
forall q. KeepQlog q => q -> IO ()
qlogSentRetry Connection
conn
    --
    let mgr :: TokenManager
mgr = Dispatch -> TokenManager
tokenMgr Dispatch
dispatch
    Connection -> TokenManager -> IO ()
setTokenManager Connection
conn TokenManager
mgr
    --
    Connection -> IO () -> IO ()
setStopServer Connection
conn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar ServerState -> ServerState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ServerState
stvar ServerState
Stopped
    --
    Connection
-> (CID -> Connection -> IO ()) -> (CID -> IO ()) -> IO ()
setRegister Connection
conn CID -> Connection -> IO ()
accRegister CID -> IO ()
accUnregister
    CID -> Connection -> IO ()
accRegister CID
myCID Connection
conn
    Connection -> IO () -> IO ()
addResource Connection
conn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        [CID]
myCIDs <- Connection -> IO [CID]
getMyCIDs Connection
conn
        (CID -> IO ()) -> [CID] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CID -> IO ()
accUnregister [CID]
myCIDs

    --
    ConnRes -> IO ConnRes
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnRes -> IO ConnRes) -> ConnRes -> IO ConnRes
forall a b. (a -> b) -> a -> b
$ Connection -> AuthCIDs -> IO () -> ConnRes
ConnRes Connection
conn AuthCIDs
accMyAuthCIDs IO ()
forall a. HasCallStack => a
undefined

afterHandshakeServer :: ServerConfig -> Connection -> IO ()
afterHandshakeServer :: ServerConfig -> Connection -> IO ()
afterHandshakeServer ServerConfig{Bool
Int
[(IP, PortNumber)]
[Group]
[Cipher]
[Version]
Maybe String
Maybe (Version -> [ByteString] -> IO ByteString)
SessionManager
Credentials
ServerHooks
Parameters
Hooks
String -> IO ()
scHooks :: ServerConfig -> Hooks
scDebugLog :: ServerConfig -> Maybe String
scAddresses :: ServerConfig -> [(IP, PortNumber)]
scParameters :: ServerConfig -> Parameters
scTicketLifetime :: ServerConfig -> Int
scSessionManager :: ServerConfig -> SessionManager
scRequireRetry :: ServerConfig -> Bool
scALPN :: ServerConfig -> Maybe (Version -> [ByteString] -> IO ByteString)
scUse0RTT :: ServerConfig -> Bool
scTlsHooks :: ServerConfig -> ServerHooks
scCredentials :: ServerConfig -> Credentials
scQLog :: ServerConfig -> Maybe String
scKeyLog :: ServerConfig -> String -> IO ()
scGroups :: ServerConfig -> [Group]
scCiphers :: ServerConfig -> [Cipher]
scVersions :: ServerConfig -> [Version]
scVersions :: [Version]
scCiphers :: [Cipher]
scGroups :: [Group]
scParameters :: Parameters
scKeyLog :: String -> IO ()
scQLog :: Maybe String
scCredentials :: Credentials
scHooks :: Hooks
scTlsHooks :: ServerHooks
scUse0RTT :: Bool
scAddresses :: [(IP, PortNumber)]
scALPN :: Maybe (Version -> [ByteString] -> IO ByteString)
scRequireRetry :: Bool
scSessionManager :: SessionManager
scDebugLog :: Maybe String
scTicketLifetime :: Int
..} Connection
conn = DebugLogger -> IO () -> IO ()
forall a. DebugLogger -> IO a -> IO a
handleLogT DebugLogger
logAction (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    --
    CIDInfo
cidInfo <- Connection -> IO CIDInfo
getNewMyCID Connection
conn
    CID -> Connection -> IO ()
register <- Connection -> IO (CID -> Connection -> IO ())
getRegister Connection
conn
    CID -> Connection -> IO ()
register (CIDInfo -> CID
cidInfoCID CIDInfo
cidInfo) Connection
conn
    --
    Version
ver <- Connection -> IO Version
getVersion Connection
conn
    CryptoToken
cryptoToken <- Version -> Int -> IO CryptoToken
generateToken Version
ver Int
scTicketLifetime
    TokenManager
mgr <- Connection -> IO TokenManager
getTokenManager Connection
conn
    ByteString
token <- TokenManager -> CryptoToken -> IO ByteString
encryptToken TokenManager
mgr CryptoToken
cryptoToken
    let ncid :: Frame
ncid = CIDInfo -> Int -> Frame
NewConnectionID CIDInfo
cidInfo Int
0
    Connection -> EncryptionLevel -> [Frame] -> IO ()
sendFrames Connection
conn EncryptionLevel
RTT1Level [ByteString -> Frame
NewToken ByteString
token, Frame
ncid, Frame
HandshakeDone]
  where
    logAction :: DebugLogger
logAction Builder
msg = Connection -> DebugLogger
connDebugLog Connection
conn DebugLogger -> DebugLogger
forall a b. (a -> b) -> a -> b
$ Builder
"afterHandshakeServer: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
msg

-- | Stopping the base thread of the server.
stop :: Connection -> IO ()
stop :: Connection -> IO ()
stop Connection
conn = do
    IO ()
action <- Connection -> IO (IO ())
getStopServer Connection
conn
    IO ()
action