{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.QUIC.Server.Reader (
    Dispatch
  , newDispatch
  , clearDispatch
  , runDispatcher
  , tokenMgr
  -- * Accepting
  , accept
  , Accept(..)
  -- * Receiving and reading
  , RecvQ
  , recvServer
  , readerServer
  -- * Misc
  , runNewServerReader
  ) where

import qualified Crypto.Token as CT
import qualified Data.ByteString as BS
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import qualified GHC.IO.Exception as E
import Network.ByteOrder
import Network.Control (LRUCache)
import qualified Network.Control as LRUCache
import Network.UDP (ListenSocket, UDPSocket, ClientSockAddr)
import qualified Network.UDP as UDP
import qualified System.IO.Error as E
import System.Log.FastLogger
import UnliftIO.Concurrent
import qualified UnliftIO.Exception as E
import UnliftIO.STM

import Network.QUIC.Config
import Network.QUIC.Connection
import Network.QUIC.Exception
import Network.QUIC.Imports
import Network.QUIC.Logger
import Network.QUIC.Packet
import Network.QUIC.Parameters
import Network.QUIC.Qlog
import Network.QUIC.Types
#if defined(mingw32_HOST_OS)
import Network.QUIC.Windows
#else
import Network.QUIC.Connector
#endif

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

data Dispatch = Dispatch {
    Dispatch -> TokenManager
tokenMgr :: CT.TokenManager
  , Dispatch -> IORef ConnectionDict
dstTable :: IORef ConnectionDict
  , Dispatch -> IORef RecvQDict
srcTable :: IORef RecvQDict
  , Dispatch -> AcceptQ
acceptQ  :: AcceptQ
  }

newDispatch :: ServerConfig -> IO Dispatch
newDispatch :: ServerConfig -> IO Dispatch
newDispatch ServerConfig{Bool
Int
[(IP, PortNumber)]
[Group]
[Cipher]
[Version]
Maybe FilePath
Maybe (Version -> [Token] -> IO Token)
SessionManager
Credentials
ServerHooks
Parameters
Hooks
FilePath -> IO ()
scVersions :: [Version]
scCiphers :: [Cipher]
scGroups :: [Group]
scParameters :: Parameters
scKeyLog :: FilePath -> IO ()
scQLog :: Maybe FilePath
scCredentials :: Credentials
scHooks :: Hooks
scTlsHooks :: ServerHooks
scUse0RTT :: Bool
scAddresses :: [(IP, PortNumber)]
scALPN :: Maybe (Version -> [Token] -> IO Token)
scRequireRetry :: Bool
scSessionManager :: SessionManager
scDebugLog :: Maybe FilePath
scTicketLifetime :: Int
scVersions :: ServerConfig -> [Version]
scCiphers :: ServerConfig -> [Cipher]
scGroups :: ServerConfig -> [Group]
scParameters :: ServerConfig -> Parameters
scKeyLog :: ServerConfig -> FilePath -> IO ()
scQLog :: ServerConfig -> Maybe FilePath
scCredentials :: ServerConfig -> Credentials
scHooks :: ServerConfig -> Hooks
scTlsHooks :: ServerConfig -> ServerHooks
scUse0RTT :: ServerConfig -> Bool
scAddresses :: ServerConfig -> [(IP, PortNumber)]
scALPN :: ServerConfig -> Maybe (Version -> [Token] -> IO Token)
scRequireRetry :: ServerConfig -> Bool
scSessionManager :: ServerConfig -> SessionManager
scDebugLog :: ServerConfig -> Maybe FilePath
scTicketLifetime :: ServerConfig -> Int
..} =
    TokenManager
-> IORef ConnectionDict -> IORef RecvQDict -> AcceptQ -> Dispatch
Dispatch (TokenManager
 -> IORef ConnectionDict -> IORef RecvQDict -> AcceptQ -> Dispatch)
-> IO TokenManager
-> IO
     (IORef ConnectionDict -> IORef RecvQDict -> AcceptQ -> Dispatch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> IO TokenManager
CT.spawnTokenManager Config
conf
             IO (IORef ConnectionDict -> IORef RecvQDict -> AcceptQ -> Dispatch)
-> IO (IORef ConnectionDict)
-> IO (IORef RecvQDict -> AcceptQ -> Dispatch)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConnectionDict -> IO (IORef ConnectionDict)
forall a. a -> IO (IORef a)
newIORef ConnectionDict
emptyConnectionDict
             IO (IORef RecvQDict -> AcceptQ -> Dispatch)
-> IO (IORef RecvQDict) -> IO (AcceptQ -> Dispatch)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RecvQDict -> IO (IORef RecvQDict)
forall a. a -> IO (IORef a)
newIORef RecvQDict
emptyRecvQDict
             IO (AcceptQ -> Dispatch) -> IO AcceptQ -> IO Dispatch
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO AcceptQ
newAcceptQ
  where
    conf :: Config
conf = Config
CT.defaultConfig { CT.tokenLifetime = scTicketLifetime }

clearDispatch :: Dispatch -> IO ()
clearDispatch :: Dispatch -> IO ()
clearDispatch Dispatch
d = TokenManager -> IO ()
CT.killTokenManager (TokenManager -> IO ()) -> TokenManager -> IO ()
forall a b. (a -> b) -> a -> b
$ Dispatch -> TokenManager
tokenMgr Dispatch
d

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

newtype ConnectionDict = ConnectionDict (Map CID Connection)

emptyConnectionDict :: ConnectionDict
emptyConnectionDict :: ConnectionDict
emptyConnectionDict = Map CID Connection -> ConnectionDict
ConnectionDict Map CID Connection
forall k a. Map k a
M.empty

lookupConnectionDict :: IORef ConnectionDict -> CID -> IO (Maybe Connection)
lookupConnectionDict :: IORef ConnectionDict -> CID -> IO (Maybe Connection)
lookupConnectionDict IORef ConnectionDict
ref CID
cid = do
    ConnectionDict Map CID Connection
tbl <- IORef ConnectionDict -> IO ConnectionDict
forall a. IORef a -> IO a
readIORef IORef ConnectionDict
ref
    Maybe Connection -> IO (Maybe Connection)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Connection -> IO (Maybe Connection))
-> Maybe Connection -> IO (Maybe Connection)
forall a b. (a -> b) -> a -> b
$ CID -> Map CID Connection -> Maybe Connection
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup CID
cid Map CID Connection
tbl

registerConnectionDict :: IORef ConnectionDict -> CID -> Connection -> IO ()
registerConnectionDict :: IORef ConnectionDict -> CID -> Connection -> IO ()
registerConnectionDict IORef ConnectionDict
ref CID
cid Connection
conn = IORef ConnectionDict -> (ConnectionDict -> ConnectionDict) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'' IORef ConnectionDict
ref ((ConnectionDict -> ConnectionDict) -> IO ())
-> (ConnectionDict -> ConnectionDict) -> IO ()
forall a b. (a -> b) -> a -> b
$
    \(ConnectionDict Map CID Connection
tbl) -> Map CID Connection -> ConnectionDict
ConnectionDict (Map CID Connection -> ConnectionDict)
-> Map CID Connection -> ConnectionDict
forall a b. (a -> b) -> a -> b
$ CID -> Connection -> Map CID Connection -> Map CID Connection
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert CID
cid Connection
conn Map CID Connection
tbl

unregisterConnectionDict :: IORef ConnectionDict -> CID -> IO ()
unregisterConnectionDict :: IORef ConnectionDict -> CID -> IO ()
unregisterConnectionDict IORef ConnectionDict
ref CID
cid = IORef ConnectionDict -> (ConnectionDict -> ConnectionDict) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'' IORef ConnectionDict
ref ((ConnectionDict -> ConnectionDict) -> IO ())
-> (ConnectionDict -> ConnectionDict) -> IO ()
forall a b. (a -> b) -> a -> b
$
    \(ConnectionDict Map CID Connection
tbl) -> Map CID Connection -> ConnectionDict
ConnectionDict (Map CID Connection -> ConnectionDict)
-> Map CID Connection -> ConnectionDict
forall a b. (a -> b) -> a -> b
$ CID -> Map CID Connection -> Map CID Connection
forall k a. Ord k => k -> Map k a -> Map k a
M.delete CID
cid Map CID Connection
tbl

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

-- Original destination CID -> RecvQ
data RecvQDict = RecvQDict(LRUCache CID RecvQ)

recvQDictSize :: Int
recvQDictSize :: Int
recvQDictSize = Int
100

emptyRecvQDict :: RecvQDict
emptyRecvQDict :: RecvQDict
emptyRecvQDict = LRUCache CID RecvQ -> RecvQDict
RecvQDict (LRUCache CID RecvQ -> RecvQDict)
-> LRUCache CID RecvQ -> RecvQDict
forall a b. (a -> b) -> a -> b
$ Int -> LRUCache CID RecvQ
forall k v. Int -> LRUCache k v
LRUCache.empty Int
recvQDictSize

lookupRecvQDict :: IORef RecvQDict -> CID -> IO (Maybe RecvQ)
lookupRecvQDict :: IORef RecvQDict -> CID -> IO (Maybe RecvQ)
lookupRecvQDict IORef RecvQDict
ref CID
dcid = do
    RecvQDict LRUCache CID RecvQ
c <- IORef RecvQDict -> IO RecvQDict
forall a. IORef a -> IO a
readIORef IORef RecvQDict
ref
    Maybe RecvQ -> IO (Maybe RecvQ)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe RecvQ -> IO (Maybe RecvQ))
-> Maybe RecvQ -> IO (Maybe RecvQ)
forall a b. (a -> b) -> a -> b
$ case CID -> LRUCache CID RecvQ -> Maybe RecvQ
forall k v. Ord k => k -> LRUCache k v -> Maybe v
LRUCache.lookup CID
dcid LRUCache CID RecvQ
c of
      Maybe RecvQ
Nothing -> Maybe RecvQ
forall a. Maybe a
Nothing
      Just RecvQ
q -> RecvQ -> Maybe RecvQ
forall a. a -> Maybe a
Just RecvQ
q

insertRecvQDict :: IORef RecvQDict -> CID -> RecvQ -> IO ()
insertRecvQDict :: IORef RecvQDict -> CID -> RecvQ -> IO ()
insertRecvQDict IORef RecvQDict
ref CID
dcid RecvQ
q = IORef RecvQDict -> (RecvQDict -> RecvQDict) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'' IORef RecvQDict
ref RecvQDict -> RecvQDict
ins
  where
    ins :: RecvQDict -> RecvQDict
ins (RecvQDict LRUCache CID RecvQ
c) = LRUCache CID RecvQ -> RecvQDict
RecvQDict (LRUCache CID RecvQ -> RecvQDict)
-> LRUCache CID RecvQ -> RecvQDict
forall a b. (a -> b) -> a -> b
$ CID -> RecvQ -> LRUCache CID RecvQ -> LRUCache CID RecvQ
forall k v. Ord k => k -> v -> LRUCache k v -> LRUCache k v
LRUCache.insert CID
dcid RecvQ
q LRUCache CID RecvQ
c

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

data Accept = Accept {
    Accept -> VersionInfo
accVersionInfo  :: VersionInfo
  , Accept -> AuthCIDs
accMyAuthCIDs   :: AuthCIDs
  , Accept -> AuthCIDs
accPeerAuthCIDs :: AuthCIDs
  , Accept -> ListenSocket
accMySocket     :: ListenSocket
  , Accept -> ClientSockAddr
accPeerSockAddr :: ClientSockAddr
  , Accept -> RecvQ
accRecvQ        :: RecvQ
  , Accept -> Int
accPacketSize   :: Int
  , Accept -> CID -> Connection -> IO ()
accRegister     :: CID -> Connection -> IO ()
  , Accept -> CID -> IO ()
accUnregister   :: CID -> IO ()
  , Accept -> Bool
accAddressValidated :: Bool
  , Accept -> TimeMicrosecond
accTime         :: TimeMicrosecond
  }

newtype AcceptQ = AcceptQ (TQueue Accept)

newAcceptQ :: IO AcceptQ
newAcceptQ :: IO AcceptQ
newAcceptQ = TQueue Accept -> AcceptQ
AcceptQ (TQueue Accept -> AcceptQ) -> IO (TQueue Accept) -> IO AcceptQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (TQueue Accept)
forall (m :: * -> *) a. MonadIO m => m (TQueue a)
newTQueueIO

readAcceptQ :: AcceptQ -> IO Accept
readAcceptQ :: AcceptQ -> IO Accept
readAcceptQ (AcceptQ TQueue Accept
q) = STM Accept -> IO Accept
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Accept -> IO Accept) -> STM Accept -> IO Accept
forall a b. (a -> b) -> a -> b
$ TQueue Accept -> STM Accept
forall a. TQueue a -> STM a
readTQueue TQueue Accept
q

writeAcceptQ :: AcceptQ -> Accept -> IO ()
writeAcceptQ :: AcceptQ -> Accept -> IO ()
writeAcceptQ (AcceptQ TQueue Accept
q) Accept
x = STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue Accept -> Accept -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Accept
q Accept
x

accept :: Dispatch -> IO Accept
accept :: Dispatch -> IO Accept
accept = AcceptQ -> IO Accept
readAcceptQ (AcceptQ -> IO Accept)
-> (Dispatch -> AcceptQ) -> Dispatch -> IO Accept
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dispatch -> AcceptQ
acceptQ

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

runDispatcher :: Dispatch -> ServerConfig -> ListenSocket -> IO ThreadId
runDispatcher :: Dispatch -> ServerConfig -> ListenSocket -> IO ThreadId
runDispatcher Dispatch
d ServerConfig
conf ListenSocket
mysock =
    IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally (Dispatch -> ServerConfig -> ListenSocket -> IO ()
dispatcher Dispatch
d ServerConfig
conf ListenSocket
mysock) ((Either SomeException () -> IO ()) -> IO ThreadId)
-> (Either SomeException () -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \Either SomeException ()
_ -> ListenSocket -> IO ()
UDP.stop ListenSocket
mysock

dispatcher :: Dispatch -> ServerConfig -> ListenSocket -> IO ()
dispatcher :: Dispatch -> ServerConfig -> ListenSocket -> IO ()
dispatcher Dispatch
d ServerConfig
conf ListenSocket
mysock = DebugLogger -> IO () -> IO ()
handleLogUnit DebugLogger
logAction (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        (Token
bs, ClientSockAddr
peersa) <- IO (Token, ClientSockAddr) -> IO (Token, ClientSockAddr)
forall {b}. IO b -> IO b
safeRecv (IO (Token, ClientSockAddr) -> IO (Token, ClientSockAddr))
-> IO (Token, ClientSockAddr) -> IO (Token, ClientSockAddr)
forall a b. (a -> b) -> a -> b
$ ListenSocket -> IO (Token, ClientSockAddr)
UDP.recvFrom ListenSocket
mysock
        TimeMicrosecond
now <- IO TimeMicrosecond
getTimeMicrosecond
        let send' :: Token -> IO ()
send' Token
b = ListenSocket -> Token -> ClientSockAddr -> IO ()
UDP.sendTo ListenSocket
mysock Token
b ClientSockAddr
peersa
        [(CryptPacket, EncryptionLevel, Int)]
cpckts <- Token -> IO [(CryptPacket, EncryptionLevel, Int)]
decodeCryptPackets Token
bs
        let bytes :: Int
bytes = Token -> Int
BS.length Token
bs
            switch :: (CryptPacket, EncryptionLevel, Int) -> IO ()
switch = Dispatch
-> ServerConfig
-> DebugLogger
-> ListenSocket
-> ClientSockAddr
-> (Token -> IO ())
-> Int
-> TimeMicrosecond
-> (CryptPacket, EncryptionLevel, Int)
-> IO ()
dispatch Dispatch
d ServerConfig
conf DebugLogger
logAction ListenSocket
mysock ClientSockAddr
peersa Token -> IO ()
send' Int
bytes TimeMicrosecond
now
        ((CryptPacket, EncryptionLevel, Int) -> IO ())
-> [(CryptPacket, EncryptionLevel, Int)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (CryptPacket, EncryptionLevel, Int) -> IO ()
switch [(CryptPacket, EncryptionLevel, Int)]
cpckts
  where
    doDebug :: Bool
doDebug = Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust (Maybe FilePath -> Bool) -> Maybe FilePath -> Bool
forall a b. (a -> b) -> a -> b
$ ServerConfig -> Maybe FilePath
scDebugLog ServerConfig
conf
    logAction :: DebugLogger
logAction Builder
msg | Bool
doDebug   = DebugLogger
stdoutLogger (Builder
"dispatch(er): " 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 ()

    safeRecv :: IO b -> IO b
safeRecv IO b
rcv = do
        Either SomeException b
ex <- IO b -> IO (Either SomeException b)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
E.tryAny (IO b -> IO (Either SomeException b))
-> IO b -> IO (Either SomeException b)
forall a b. (a -> b) -> a -> b
$
#if defined(mingw32_HOST_OS)
                windowsThreadBlockHack $
#endif
                  IO b
rcv
        case Either SomeException b
ex of
           Right b
x -> b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
x
           Left SomeException
se -> case SomeException -> Maybe IOError
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se of
              Just IOError
e | IOError -> IOErrorType
E.ioeGetErrorType IOError
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
E.InvalidArgument -> SomeException -> IO b
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO SomeException
se
              Maybe IOError
_ -> do
                  DebugLogger
logAction DebugLogger -> DebugLogger
forall a b. (a -> b) -> a -> b
$ Builder
"recv again: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> SomeException -> Builder
forall a. Show a => a -> Builder
bhow SomeException
se
                  IO b
rcv

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

-- If client initial is fragmented into multiple packets,
-- there is no way to put the all packets into a single queue.
-- Rather, each fragment packet is put into its own queue.
-- For the first fragment, handshake would successif others are
-- retransmitted.
-- For the other fragments, handshake will fail since its socket
-- cannot be connected.
dispatch :: Dispatch -> ServerConfig -> DebugLogger
         -> ListenSocket -> ClientSockAddr -> (ByteString -> IO ()) -> Int -> TimeMicrosecond
         -> (CryptPacket,EncryptionLevel,Int)
         -> IO ()
dispatch :: Dispatch
-> ServerConfig
-> DebugLogger
-> ListenSocket
-> ClientSockAddr
-> (Token -> IO ())
-> Int
-> TimeMicrosecond
-> (CryptPacket, EncryptionLevel, Int)
-> IO ()
dispatch Dispatch{IORef RecvQDict
IORef ConnectionDict
TokenManager
AcceptQ
tokenMgr :: Dispatch -> TokenManager
dstTable :: Dispatch -> IORef ConnectionDict
srcTable :: Dispatch -> IORef RecvQDict
acceptQ :: Dispatch -> AcceptQ
tokenMgr :: TokenManager
dstTable :: IORef ConnectionDict
srcTable :: IORef RecvQDict
acceptQ :: AcceptQ
..} ServerConfig{Bool
Int
[(IP, PortNumber)]
[Group]
[Cipher]
[Version]
Maybe FilePath
Maybe (Version -> [Token] -> IO Token)
SessionManager
Credentials
ServerHooks
Parameters
Hooks
FilePath -> IO ()
scVersions :: ServerConfig -> [Version]
scCiphers :: ServerConfig -> [Cipher]
scGroups :: ServerConfig -> [Group]
scParameters :: ServerConfig -> Parameters
scKeyLog :: ServerConfig -> FilePath -> IO ()
scQLog :: ServerConfig -> Maybe FilePath
scCredentials :: ServerConfig -> Credentials
scHooks :: ServerConfig -> Hooks
scTlsHooks :: ServerConfig -> ServerHooks
scUse0RTT :: ServerConfig -> Bool
scAddresses :: ServerConfig -> [(IP, PortNumber)]
scALPN :: ServerConfig -> Maybe (Version -> [Token] -> IO Token)
scRequireRetry :: ServerConfig -> Bool
scSessionManager :: ServerConfig -> SessionManager
scDebugLog :: ServerConfig -> Maybe FilePath
scTicketLifetime :: ServerConfig -> Int
scVersions :: [Version]
scCiphers :: [Cipher]
scGroups :: [Group]
scParameters :: Parameters
scKeyLog :: FilePath -> IO ()
scQLog :: Maybe FilePath
scCredentials :: Credentials
scHooks :: Hooks
scTlsHooks :: ServerHooks
scUse0RTT :: Bool
scAddresses :: [(IP, PortNumber)]
scALPN :: Maybe (Version -> [Token] -> IO Token)
scRequireRetry :: Bool
scSessionManager :: SessionManager
scDebugLog :: Maybe FilePath
scTicketLifetime :: Int
..} DebugLogger
logAction
         ListenSocket
mysock ClientSockAddr
peersa Token -> IO ()
send' Int
bytes TimeMicrosecond
tim
         (cpkt :: CryptPacket
cpkt@(CryptPacket (Initial Version
peerVer CID
dCID CID
sCID Token
token) Crypt
_),EncryptionLevel
lvl,Int
siz)
  | Int
bytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
defaultQUICPacketSize = do
        DebugLogger
logAction DebugLogger -> DebugLogger
forall a b. (a -> b) -> a -> b
$ Builder
"too small " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall a. Show a => a -> Builder
bhow Int
bytes Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
", " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ClientSockAddr -> Builder
forall a. Show a => a -> Builder
bhow ClientSockAddr
peersa
  | Version
peerVer Version -> [Version] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Version]
myVersions = do
        let offerVersions :: [Version]
offerVersions
                | Version
peerVer Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
GreasingVersion = Version
GreasingVersion2 Version -> [Version] -> [Version]
forall a. a -> [a] -> [a]
: [Version]
myVersions
                | Bool
otherwise                  = Version
GreasingVersion  Version -> [Version] -> [Version]
forall a. a -> [a] -> [a]
: [Version]
myVersions
        Token
bss <- VersionNegotiationPacket -> IO Token
encodeVersionNegotiationPacket (VersionNegotiationPacket -> IO Token)
-> VersionNegotiationPacket -> IO Token
forall a b. (a -> b) -> a -> b
$ CID -> CID -> [Version] -> VersionNegotiationPacket
VersionNegotiationPacket CID
sCID CID
dCID [Version]
offerVersions
        Token -> IO ()
send' Token
bss
  | Token
token Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
"" = do
        Maybe Connection
mconn <- IORef ConnectionDict -> CID -> IO (Maybe Connection)
lookupConnectionDict IORef ConnectionDict
dstTable CID
dCID
        case Maybe Connection
mconn of
          Maybe Connection
Nothing
            | Bool
scRequireRetry -> IO ()
sendRetry
            | Bool
otherwise      -> Bool -> IO ()
pushToAcceptFirst Bool
False
#if defined(mingw32_HOST_OS)
          Just conn          -> writeRecvQ (connRecvQ conn) $ mkReceivedPacket cpkt tim siz lvl
#else
          Maybe Connection
_                  -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif
  | Bool
otherwise = do
        Maybe CryptoToken
mct <- TokenManager -> Token -> IO (Maybe CryptoToken)
decryptToken TokenManager
tokenMgr Token
token
        case Maybe CryptoToken
mct of
          Just CryptoToken
ct
            | CryptoToken -> Bool
isRetryToken CryptoToken
ct -> do
                  Bool
ok <- CryptoToken -> IO Bool
isRetryTokenValid CryptoToken
ct
                  if Bool
ok then CryptoToken -> IO ()
pushToAcceptRetried CryptoToken
ct else IO ()
sendRetry
            | Bool
otherwise -> do
                  Maybe Connection
mconn <- IORef ConnectionDict -> CID -> IO (Maybe Connection)
lookupConnectionDict IORef ConnectionDict
dstTable CID
dCID
                  case Maybe Connection
mconn of
                    Maybe Connection
Nothing   -> Bool -> IO ()
pushToAcceptFirst Bool
True
#if defined(mingw32_HOST_OS)
                    Just conn -> writeRecvQ (connRecvQ conn) $ mkReceivedPacket cpkt tim siz lvl
#else
                    Maybe Connection
_       -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif
          Maybe CryptoToken
_ -> IO ()
sendRetry
  where
    myVersions :: [Version]
myVersions = [Version]
scVersions
    pushToAcceptQ :: AuthCIDs -> AuthCIDs -> CID -> Bool -> IO ()
pushToAcceptQ AuthCIDs
myAuthCIDs AuthCIDs
peerAuthCIDs CID
key Bool
addrValid = do
        Maybe RecvQ
mq <- IORef RecvQDict -> CID -> IO (Maybe RecvQ)
lookupRecvQDict IORef RecvQDict
srcTable CID
key
        case Maybe RecvQ
mq of
          Just RecvQ
q  -> RecvQ -> ReceivedPacket -> IO ()
writeRecvQ RecvQ
q (ReceivedPacket -> IO ()) -> ReceivedPacket -> IO ()
forall a b. (a -> b) -> a -> b
$ CryptPacket
-> TimeMicrosecond -> Int -> EncryptionLevel -> ReceivedPacket
mkReceivedPacket CryptPacket
cpkt TimeMicrosecond
tim Int
siz EncryptionLevel
lvl
          Maybe RecvQ
Nothing -> do
              RecvQ
q <- IO RecvQ
newRecvQ
              IORef RecvQDict -> CID -> RecvQ -> IO ()
insertRecvQDict IORef RecvQDict
srcTable CID
key RecvQ
q
              RecvQ -> ReceivedPacket -> IO ()
writeRecvQ RecvQ
q (ReceivedPacket -> IO ()) -> ReceivedPacket -> IO ()
forall a b. (a -> b) -> a -> b
$ CryptPacket
-> TimeMicrosecond -> Int -> EncryptionLevel -> ReceivedPacket
mkReceivedPacket CryptPacket
cpkt TimeMicrosecond
tim Int
siz EncryptionLevel
lvl
              let reg :: CID -> Connection -> IO ()
reg = IORef ConnectionDict -> CID -> Connection -> IO ()
registerConnectionDict IORef ConnectionDict
dstTable
                  unreg :: CID -> IO ()
unreg = IORef ConnectionDict -> CID -> IO ()
unregisterConnectionDict IORef ConnectionDict
dstTable
                  ent :: Accept
ent = Accept {
                      accVersionInfo :: VersionInfo
accVersionInfo  = Version -> [Version] -> VersionInfo
VersionInfo Version
peerVer [Version]
myVersions
                    , accMyAuthCIDs :: AuthCIDs
accMyAuthCIDs   = AuthCIDs
myAuthCIDs
                    , accPeerAuthCIDs :: AuthCIDs
accPeerAuthCIDs = AuthCIDs
peerAuthCIDs
                    , accMySocket :: ListenSocket
accMySocket     = ListenSocket
mysock
                    , accPeerSockAddr :: ClientSockAddr
accPeerSockAddr = ClientSockAddr
peersa
                    , accRecvQ :: RecvQ
accRecvQ        = RecvQ
q
                    , accPacketSize :: Int
accPacketSize   = Int
bytes
                    , accRegister :: CID -> Connection -> IO ()
accRegister     = CID -> Connection -> IO ()
reg
                    , accUnregister :: CID -> IO ()
accUnregister   = CID -> IO ()
unreg
                    , accAddressValidated :: Bool
accAddressValidated = Bool
addrValid
                    , accTime :: TimeMicrosecond
accTime         = TimeMicrosecond
tim
                    }
              -- fixme: check acceptQ length
              AcceptQ -> Accept -> IO ()
writeAcceptQ AcceptQ
acceptQ Accept
ent
    -- Initial: DCID=S1, SCID=C1 ->
    --                                     <- Initial: DCID=C1, SCID=S2
    --                               ...
    -- 1-RTT: DCID=S2 ->
    --                                                <- 1-RTT: DCID=C1
    --
    -- initial_source_connection_id       = S2   (newdCID)
    -- original_destination_connection_id = S1   (dCID)
    -- retry_source_connection_id         = Nothing
    pushToAcceptFirst :: Bool -> IO ()
pushToAcceptFirst Bool
addrValid = do
        CID
newdCID <- IO CID
newCID
        let myAuthCIDs :: AuthCIDs
myAuthCIDs = AuthCIDs
defaultAuthCIDs {
                initSrcCID  = Just newdCID
              , origDstCID  = Just dCID
              }
            peerAuthCIDs :: AuthCIDs
peerAuthCIDs = AuthCIDs
defaultAuthCIDs {
                initSrcCID = Just sCID
              }
        AuthCIDs -> AuthCIDs -> CID -> Bool -> IO ()
pushToAcceptQ AuthCIDs
myAuthCIDs AuthCIDs
peerAuthCIDs CID
dCID Bool
addrValid
    -- Initial: DCID=S1, SCID=C1 ->
    --                                       <- Retry: DCID=C1, SCID=S2
    -- Initial: DCID=S2, SCID=C1 ->
    --                                     <- Initial: DCID=C1, SCID=S3
    --                               ...
    -- 1-RTT: DCID=S3 ->
    --                                                <- 1-RTT: DCID=C1
    --
    -- initial_source_connection_id       = S3   (dCID)  S2 in our server
    -- original_destination_connection_id = S1   (o)
    -- retry_source_connection_id         = S2   (dCID)
    pushToAcceptRetried :: CryptoToken -> IO ()
pushToAcceptRetried (CryptoToken Version
_ Word32
_ TimeMicrosecond
_ (Just (CID
_,CID
_,CID
o))) = do
        let myAuthCIDs :: AuthCIDs
myAuthCIDs = AuthCIDs
defaultAuthCIDs {
                initSrcCID  = Just dCID
              , origDstCID  = Just o
              , retrySrcCID = Just dCID
              }
            peerAuthCIDs :: AuthCIDs
peerAuthCIDs = AuthCIDs
defaultAuthCIDs {
                initSrcCID = Just sCID
              }
        AuthCIDs -> AuthCIDs -> CID -> Bool -> IO ()
pushToAcceptQ AuthCIDs
myAuthCIDs AuthCIDs
peerAuthCIDs CID
o Bool
True
    pushToAcceptRetried CryptoToken
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    isRetryTokenValid :: CryptoToken -> IO Bool
isRetryTokenValid (CryptoToken Version
_tver Word32
life TimeMicrosecond
etim (Just (CID
l,CID
r,CID
_))) = do
        Microseconds
diff <- TimeMicrosecond -> IO Microseconds
getElapsedTimeMicrosecond TimeMicrosecond
etim
        Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Microseconds
diff Microseconds -> Microseconds -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Microseconds
Microseconds (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
life Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000)
              Bool -> Bool -> Bool
&& CID
dCID CID -> CID -> Bool
forall a. Eq a => a -> a -> Bool
== CID
l
              Bool -> Bool -> Bool
&& CID
sCID CID -> CID -> Bool
forall a. Eq a => a -> a -> Bool
== CID
r
#if !defined(mingw32_HOST_OS)
              -- Initial for ACK contains the retry token but
              -- the version would be already version 2, sigh.
              Bool -> Bool -> Bool
&& Version
_tver Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
peerVer
#endif
    isRetryTokenValid CryptoToken
_ = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    sendRetry :: IO ()
sendRetry = do
        CID
newdCID <- IO CID
newCID
        CryptoToken
retryToken <- Version -> Int -> CID -> CID -> CID -> IO CryptoToken
generateRetryToken Version
peerVer Int
scTicketLifetime CID
newdCID CID
sCID CID
dCID
        Maybe Token
mnewtoken <- Microseconds -> FilePath -> IO Token -> IO (Maybe Token)
forall a. Microseconds -> FilePath -> IO a -> IO (Maybe a)
timeout (Int -> Microseconds
Microseconds Int
100000) FilePath
"sendRetry" (IO Token -> IO (Maybe Token)) -> IO Token -> IO (Maybe Token)
forall a b. (a -> b) -> a -> b
$ TokenManager -> CryptoToken -> IO Token
encryptToken TokenManager
tokenMgr CryptoToken
retryToken
        case Maybe Token
mnewtoken of
          Maybe Token
Nothing       -> DebugLogger
logAction Builder
"retry token stacked"
          Just Token
newtoken -> do
              Token
bss <- RetryPacket -> IO Token
encodeRetryPacket (RetryPacket -> IO Token) -> RetryPacket -> IO Token
forall a b. (a -> b) -> a -> b
$ Version
-> CID -> CID -> Token -> Either CID (Token, Token) -> RetryPacket
RetryPacket Version
peerVer CID
sCID CID
newdCID Token
newtoken (CID -> Either CID (Token, Token)
forall a b. a -> Either a b
Left CID
dCID)
              Token -> IO ()
send' Token
bss
----------------------------------------------------------------
dispatch Dispatch{IORef RecvQDict
IORef ConnectionDict
TokenManager
AcceptQ
tokenMgr :: Dispatch -> TokenManager
dstTable :: Dispatch -> IORef ConnectionDict
srcTable :: Dispatch -> IORef RecvQDict
acceptQ :: Dispatch -> AcceptQ
tokenMgr :: TokenManager
dstTable :: IORef ConnectionDict
srcTable :: IORef RecvQDict
acceptQ :: AcceptQ
..} ServerConfig
_ DebugLogger
_
         ListenSocket
_ ClientSockAddr
_peersa Token -> IO ()
_ Int
_ TimeMicrosecond
tim
         (cpkt :: CryptPacket
cpkt@(CryptPacket (RTT0 Version
_ CID
o CID
_) Crypt
_), EncryptionLevel
lvl, Int
siz) = do
    Maybe RecvQ
mq <- IORef RecvQDict -> CID -> IO (Maybe RecvQ)
lookupRecvQDict IORef RecvQDict
srcTable CID
o
    case Maybe RecvQ
mq of
      Just RecvQ
q  -> RecvQ -> ReceivedPacket -> IO ()
writeRecvQ RecvQ
q (ReceivedPacket -> IO ()) -> ReceivedPacket -> IO ()
forall a b. (a -> b) -> a -> b
$ CryptPacket
-> TimeMicrosecond -> Int -> EncryptionLevel -> ReceivedPacket
mkReceivedPacket CryptPacket
cpkt TimeMicrosecond
tim Int
siz EncryptionLevel
lvl
      Maybe RecvQ
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#if defined(mingw32_HOST_OS)
----------------------------------------------------------------
dispatch Dispatch{..} _ logAction
         _mysock peersa _ _ tim
         (cpkt@(CryptPacket hdr _crypt),lvl,siz) = do
    let dCID = headerMyCID hdr
    mconn <- lookupConnectionDict dstTable dCID
    case mconn of
      Nothing   -> logAction $ "CID no match: " <> bhow dCID <> ", " <> bhow peersa
      Just conn -> writeRecvQ (connRecvQ conn) $ mkReceivedPacket cpkt tim siz lvl
#else
----------------------------------------------------------------
dispatch Dispatch{IORef RecvQDict
IORef ConnectionDict
TokenManager
AcceptQ
tokenMgr :: Dispatch -> TokenManager
dstTable :: Dispatch -> IORef ConnectionDict
srcTable :: Dispatch -> IORef RecvQDict
acceptQ :: Dispatch -> AcceptQ
tokenMgr :: TokenManager
dstTable :: IORef ConnectionDict
srcTable :: IORef RecvQDict
acceptQ :: AcceptQ
..} ServerConfig
_ DebugLogger
logAction
         ListenSocket
mysock ClientSockAddr
peersa Token -> IO ()
_ Int
_ TimeMicrosecond
tim
         ((CryptPacket hdr :: Header
hdr@(Short CID
dCID) Crypt
crypt),EncryptionLevel
lvl,Int
siz)= do
    -- fixme: packets for closed connections also match here.
    Maybe Connection
mconn <- IORef ConnectionDict -> CID -> IO (Maybe Connection)
lookupConnectionDict IORef ConnectionDict
dstTable CID
dCID
    case Maybe Connection
mconn of
      Maybe Connection
Nothing -> do
          DebugLogger
logAction DebugLogger -> DebugLogger
forall a b. (a -> b) -> a -> b
$ Builder
"CID no match: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> CID -> Builder
forall a. Show a => a -> Builder
bhow CID
dCID Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
", " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ClientSockAddr -> Builder
forall a. Show a => a -> Builder
bhow ClientSockAddr
peersa
      Just Connection
conn -> do
            Bool
alive <- Connection -> IO Bool
forall a. Connector a => a -> IO Bool
getAlive Connection
conn
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
alive (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                let miginfo :: MigrationInfo
miginfo = ListenSocket -> ClientSockAddr -> CID -> MigrationInfo
MigrationInfo ListenSocket
mysock ClientSockAddr
peersa CID
dCID
                    crypt' :: Crypt
crypt' = Crypt
crypt { cryptMigraionInfo = Just miginfo }
                    cpkt :: CryptPacket
cpkt = Header -> Crypt -> CryptPacket
CryptPacket Header
hdr Crypt
crypt'
                RecvQ -> ReceivedPacket -> IO ()
writeRecvQ (Connection -> RecvQ
connRecvQ Connection
conn) (ReceivedPacket -> IO ()) -> ReceivedPacket -> IO ()
forall a b. (a -> b) -> a -> b
$ CryptPacket
-> TimeMicrosecond -> Int -> EncryptionLevel -> ReceivedPacket
mkReceivedPacket CryptPacket
cpkt TimeMicrosecond
tim Int
siz EncryptionLevel
lvl
----------------------------------------------------------------
dispatch Dispatch
_ ServerConfig
_ DebugLogger
_ ListenSocket
_ ClientSockAddr
_ Token -> IO ()
_ Int
_ TimeMicrosecond
_ (CryptPacket, EncryptionLevel, Int)
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif

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

-- | readerServer dies when the socket is closed.
readerServer :: UDPSocket -> Connection -> IO ()
readerServer :: UDPSocket -> Connection -> IO ()
readerServer UDPSocket
us Connection
conn = DebugLogger -> IO () -> IO ()
handleLogUnit DebugLogger
logAction IO ()
loop
  where
    loop :: IO ()
loop = do
        Microseconds
ito <- Connection -> IO Microseconds
readMinIdleTimeout Connection
conn
        Maybe Token
mbs <- Microseconds -> FilePath -> IO Token -> IO (Maybe Token)
forall a. Microseconds -> FilePath -> IO a -> IO (Maybe a)
timeout Microseconds
ito FilePath
"readerServer" (IO Token -> IO (Maybe Token)) -> IO Token -> IO (Maybe Token)
forall a b. (a -> b) -> a -> b
$ UDPSocket -> IO Token
UDP.recv UDPSocket
us
        case Maybe Token
mbs of
          Maybe Token
Nothing -> UDPSocket -> IO ()
UDP.close UDPSocket
us
          Just Token
bs -> do
              TimeMicrosecond
now <- IO TimeMicrosecond
getTimeMicrosecond
              [(CryptPacket, EncryptionLevel, Int)]
pkts <- Token -> IO [(CryptPacket, EncryptionLevel, Int)]
decodeCryptPackets Token
bs
              ((CryptPacket, EncryptionLevel, Int) -> IO ())
-> [(CryptPacket, EncryptionLevel, Int)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(CryptPacket
p,EncryptionLevel
l,Int
siz) -> RecvQ -> ReceivedPacket -> IO ()
writeRecvQ (Connection -> RecvQ
connRecvQ Connection
conn) (CryptPacket
-> TimeMicrosecond -> Int -> EncryptionLevel -> ReceivedPacket
mkReceivedPacket CryptPacket
p TimeMicrosecond
now Int
siz EncryptionLevel
l)) [(CryptPacket, EncryptionLevel, Int)]
pkts
              IO ()
loop
    logAction :: DebugLogger
logAction Builder
msg = Connection -> DebugLogger
connDebugLog Connection
conn (Builder
"debug: readerServer: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
msg)

recvServer :: RecvQ -> IO ReceivedPacket
recvServer :: RecvQ -> IO ReceivedPacket
recvServer = RecvQ -> IO ReceivedPacket
readRecvQ

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

runNewServerReader :: Connection -> MigrationInfo -> IO ()
runNewServerReader :: Connection -> MigrationInfo -> IO ()
runNewServerReader Connection
conn (MigrationInfo ListenSocket
mysock ClientSockAddr
peersa CID
dCID) = DebugLogger -> IO () -> IO ()
handleLogUnit DebugLogger
logAction (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
migrating <- Connection -> IO Bool
isPathValidating Connection
conn -- fixme: test and set
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
migrating (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Connection -> IO ()
setMigrationStarted Connection
conn
        -- fixme: should not block
        Maybe CIDInfo
mcidinfo <- Microseconds -> FilePath -> IO CIDInfo -> IO (Maybe CIDInfo)
forall a. Microseconds -> FilePath -> IO a -> IO (Maybe a)
timeout (Int -> Microseconds
Microseconds Int
100000) FilePath
"runNewServerReader" (IO CIDInfo -> IO (Maybe CIDInfo))
-> IO CIDInfo -> IO (Maybe CIDInfo)
forall a b. (a -> b) -> a -> b
$ Connection -> IO CIDInfo
waitPeerCID Connection
conn
        let msg :: Builder
msg = Builder
"Migration: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ClientSockAddr -> Builder
forall a. Show a => a -> Builder
bhow ClientSockAddr
peersa Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" (" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> CID -> Builder
forall a. Show a => a -> Builder
bhow CID
dCID Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")"
        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
        Connection -> DebugLogger
connDebugLog Connection
conn DebugLogger -> DebugLogger
forall a b. (a -> b) -> a -> b
$ Builder
"debug: runNewServerReader: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
msg
        IO UDPSocket
-> (UDPSocket -> IO ()) -> (UDPSocket -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracketOnError IO UDPSocket
setup UDPSocket -> IO ()
UDP.close ((UDPSocket -> IO ()) -> IO ()) -> (UDPSocket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \UDPSocket
s1 ->
            IO UDPSocket
-> (UDPSocket -> IO ()) -> (UDPSocket -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket (Connection -> UDPSocket -> IO UDPSocket
setSocket Connection
conn UDPSocket
s1) UDPSocket -> IO ()
UDP.close ((UDPSocket -> IO ()) -> IO ()) -> (UDPSocket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \UDPSocket
_ -> do
                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
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ UDPSocket -> Connection -> IO ()
readerServer UDPSocket
s1 Connection
conn
                -- fixme: if cannot set
                Connection -> CID -> IO ()
setMyCID Connection
conn CID
dCID
                Connection -> Maybe CIDInfo -> IO ()
validatePath Connection
conn Maybe CIDInfo
mcidinfo
                -- holding the old socket for a while
                Microseconds -> IO ()
delay (Microseconds -> IO ()) -> Microseconds -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Microseconds
Microseconds Int
20000
  where
    setup :: IO UDPSocket
setup = ListenSocket -> ClientSockAddr -> IO UDPSocket
UDP.accept ListenSocket
mysock ClientSockAddr
peersa
    logAction :: DebugLogger
logAction Builder
msg = Connection -> DebugLogger
connDebugLog Connection
conn (Builder
"debug: runNewServerReader: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
msg)