{-# 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 :: IO Dispatch
newDispatch :: IO Dispatch
newDispatch = TokenManager
-> IORef ConnectionDict -> IORef RecvQDict -> AcceptQ -> Dispatch
Dispatch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> IO TokenManager
CT.spawnTokenManager Config
CT.defaultConfig
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (IORef a)
newIORef ConnectionDict
emptyConnectionDict
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (IORef a)
newIORef RecvQDict
emptyRecvQDict
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO AcceptQ
newAcceptQ

clearDispatch :: Dispatch -> IO ()
clearDispatch :: Dispatch -> IO ()
clearDispatch Dispatch
d = TokenManager -> IO ()
CT.killTokenManager 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 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 <- forall a. IORef a -> IO a
readIORef IORef ConnectionDict
ref
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 = forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'' IORef ConnectionDict
ref forall a b. (a -> b) -> a -> b
$
    \(ConnectionDict Map CID Connection
tbl) -> Map CID Connection -> ConnectionDict
ConnectionDict forall a b. (a -> b) -> a -> b
$ 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 = forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'' IORef ConnectionDict
ref forall a b. (a -> b) -> a -> b
$
    \(ConnectionDict Map CID Connection
tbl) -> Map CID Connection -> ConnectionDict
ConnectionDict forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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 <- forall a. IORef a -> IO a
readIORef IORef RecvQDict
ref
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall k v. Ord k => k -> LRUCache k v -> Maybe v
LRUCache.lookup CID
dcid LRUCache CID RecvQ
c of
      Maybe RecvQ
Nothing -> forall a. Maybe a
Nothing
      Just RecvQ
q -> 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 = 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 forall a b. (a -> b) -> a -> b
$ 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => m (TQueue a)
newTQueueIO

readAcceptQ :: AcceptQ -> IO Accept
readAcceptQ :: AcceptQ -> IO Accept
readAcceptQ (AcceptQ TQueue Accept
q) = forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ 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 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 =
    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) 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 forall a b. (a -> b) -> a -> b
$ do
    forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
        (Token
bs, ClientSockAddr
peersa) <- forall {b}. IO b -> IO b
safeRecv 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
        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 = forall a. Maybe a -> Bool
isJust 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): " forall a. Semigroup a => a -> a -> a
<> Builder
msg)
                  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()

    safeRecv :: IO b -> IO b
safeRecv IO b
rcv = do
        Either SomeException b
ex <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
E.tryAny 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return b
x
           Left SomeException
se -> case forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se of
              Just IOError
e | IOError -> IOErrorType
E.ioeGetErrorType IOError
e forall a. Eq a => a -> a -> Bool
== IOErrorType
E.InvalidArgument -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO SomeException
se
              Maybe IOError
_ -> do
                  DebugLogger
logAction forall a b. (a -> b) -> a -> b
$ Builder
"recv again: " forall a. Semigroup a => a -> a -> a
<> 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
acceptQ :: AcceptQ
srcTable :: IORef RecvQDict
dstTable :: IORef ConnectionDict
tokenMgr :: TokenManager
acceptQ :: Dispatch -> AcceptQ
srcTable :: Dispatch -> IORef RecvQDict
dstTable :: Dispatch -> IORef ConnectionDict
tokenMgr :: Dispatch -> TokenManager
..} ServerConfig{Bool
[(IP, PortNumber)]
[Cipher]
[Group]
[Version]
Maybe FilePath
Maybe (Version -> [Token] -> IO Token)
Credentials
SessionManager
Parameters
Hooks
FilePath -> IO ()
scSessionManager :: ServerConfig -> SessionManager
scRequireRetry :: ServerConfig -> Bool
scALPN :: ServerConfig -> Maybe (Version -> [Token] -> IO Token)
scAddresses :: ServerConfig -> [(IP, PortNumber)]
scUse0RTT :: ServerConfig -> Bool
scHooks :: ServerConfig -> Hooks
scCredentials :: ServerConfig -> Credentials
scQLog :: ServerConfig -> Maybe FilePath
scKeyLog :: ServerConfig -> FilePath -> IO ()
scParameters :: ServerConfig -> Parameters
scGroups :: ServerConfig -> [Group]
scCiphers :: ServerConfig -> [Cipher]
scVersions :: ServerConfig -> [Version]
scDebugLog :: Maybe FilePath
scSessionManager :: SessionManager
scRequireRetry :: Bool
scALPN :: Maybe (Version -> [Token] -> IO Token)
scAddresses :: [(IP, PortNumber)]
scUse0RTT :: Bool
scHooks :: Hooks
scCredentials :: Credentials
scQLog :: Maybe FilePath
scKeyLog :: FilePath -> IO ()
scParameters :: Parameters
scGroups :: [Group]
scCiphers :: [Cipher]
scVersions :: [Version]
scDebugLog :: ServerConfig -> Maybe FilePath
..} 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 forall a. Ord a => a -> a -> Bool
< Int
defaultQUICPacketSize = do
        DebugLogger
logAction forall a b. (a -> b) -> a -> b
$ Builder
"too small " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Builder
bhow Int
bytes forall a. Semigroup a => a -> a -> a
<> Builder
", " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Builder
bhow ClientSockAddr
peersa
  | Version
peerVer forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Version]
myVersions = do
        let offerVersions :: [Version]
offerVersions
                | Version
peerVer forall a. Eq a => a -> a -> Bool
== Version
GreasingVersion = Version
GreasingVersion2 forall a. a -> [a] -> [a]
: [Version]
myVersions
                | Bool
otherwise                  = Version
GreasingVersion  forall a. a -> [a] -> [a]
: [Version]
myVersions
        Token
bss <- VersionNegotiationPacket -> IO Token
encodeVersionNegotiationPacket 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 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
_                  -> 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
_       -> 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 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 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 :: Maybe CID
initSrcCID  = forall a. a -> Maybe a
Just CID
newdCID
              , origDstCID :: Maybe CID
origDstCID  = forall a. a -> Maybe a
Just CID
dCID
              }
            peerAuthCIDs :: AuthCIDs
peerAuthCIDs = AuthCIDs
defaultAuthCIDs {
                initSrcCID :: Maybe CID
initSrcCID = forall a. a -> Maybe a
Just CID
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
_ TimeMicrosecond
_ (Just (CID
_,CID
_,CID
o))) = do
        let myAuthCIDs :: AuthCIDs
myAuthCIDs = AuthCIDs
defaultAuthCIDs {
                initSrcCID :: Maybe CID
initSrcCID  = forall a. a -> Maybe a
Just CID
dCID
              , origDstCID :: Maybe CID
origDstCID  = forall a. a -> Maybe a
Just CID
o
              , retrySrcCID :: Maybe CID
retrySrcCID = forall a. a -> Maybe a
Just CID
dCID
              }
            peerAuthCIDs :: AuthCIDs
peerAuthCIDs = AuthCIDs
defaultAuthCIDs {
                initSrcCID :: Maybe CID
initSrcCID = forall a. a -> Maybe a
Just CID
sCID
              }
        AuthCIDs -> AuthCIDs -> CID -> Bool -> IO ()
pushToAcceptQ AuthCIDs
myAuthCIDs AuthCIDs
peerAuthCIDs CID
o Bool
True
    pushToAcceptRetried CryptoToken
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    isRetryTokenValid :: CryptoToken -> IO Bool
isRetryTokenValid (CryptoToken Version
_tver TimeMicrosecond
etim (Just (CID
l,CID
r,CID
_))) = do
        Microseconds
diff <- TimeMicrosecond -> IO Microseconds
getElapsedTimeMicrosecond TimeMicrosecond
etim
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Microseconds
diff forall a. Ord a => a -> a -> Bool
<= Int -> Microseconds
Microseconds Int
30000000 -- fixme
              Bool -> Bool -> Bool
&& CID
dCID forall a. Eq a => a -> a -> Bool
== CID
l
              Bool -> Bool -> Bool
&& CID
sCID 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 forall a. Eq a => a -> a -> Bool
== Version
peerVer
#endif
    isRetryTokenValid CryptoToken
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    sendRetry :: IO ()
sendRetry = do
        CID
newdCID <- IO CID
newCID
        CryptoToken
retryToken <- Version -> CID -> CID -> CID -> IO CryptoToken
generateRetryToken Version
peerVer CID
newdCID CID
sCID CID
dCID
        Maybe Token
mnewtoken <- forall a. Microseconds -> FilePath -> IO a -> IO (Maybe a)
timeout (Int -> Microseconds
Microseconds Int
100000) FilePath
"sendRetry" 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 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 (forall a b. a -> Either a b
Left CID
dCID)
              Token -> IO ()
send' Token
bss
----------------------------------------------------------------
dispatch Dispatch{IORef RecvQDict
IORef ConnectionDict
TokenManager
AcceptQ
acceptQ :: AcceptQ
srcTable :: IORef RecvQDict
dstTable :: IORef ConnectionDict
tokenMgr :: TokenManager
acceptQ :: Dispatch -> AcceptQ
srcTable :: Dispatch -> IORef RecvQDict
dstTable :: Dispatch -> IORef ConnectionDict
tokenMgr :: Dispatch -> TokenManager
..} 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 forall a b. (a -> b) -> a -> b
$ CryptPacket
-> TimeMicrosecond -> Int -> EncryptionLevel -> ReceivedPacket
mkReceivedPacket CryptPacket
cpkt TimeMicrosecond
tim Int
siz EncryptionLevel
lvl
      Maybe RecvQ
Nothing -> 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
acceptQ :: AcceptQ
srcTable :: IORef RecvQDict
dstTable :: IORef ConnectionDict
tokenMgr :: TokenManager
acceptQ :: Dispatch -> AcceptQ
srcTable :: Dispatch -> IORef RecvQDict
dstTable :: Dispatch -> IORef ConnectionDict
tokenMgr :: Dispatch -> TokenManager
..} 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 forall a b. (a -> b) -> a -> b
$ Builder
"CID no match: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Builder
bhow CID
dCID forall a. Semigroup a => a -> a -> a
<> Builder
", " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Builder
bhow ClientSockAddr
peersa
      Just Connection
conn -> do
            Bool
alive <- forall a. Connector a => a -> IO Bool
getAlive Connection
conn
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
alive 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 :: Maybe MigrationInfo
cryptMigraionInfo = forall a. a -> Maybe a
Just MigrationInfo
miginfo }
                    cpkt :: CryptPacket
cpkt = Header -> Crypt -> CryptPacket
CryptPacket Header
hdr Crypt
crypt'
                RecvQ -> ReceivedPacket -> IO ()
writeRecvQ (Connection -> RecvQ
connRecvQ Connection
conn) 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)
_ = 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 <- forall a. Microseconds -> FilePath -> IO a -> IO (Maybe a)
timeout Microseconds
ito FilePath
"readerServer" 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
              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: " 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 forall a b. (a -> b) -> a -> b
$ do
    Bool
migrating <- Connection -> IO Bool
isPathValidating Connection
conn -- fixme: test and set
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
migrating forall a b. (a -> b) -> a -> b
$ do
        Connection -> IO ()
setMigrationStarted Connection
conn
        -- fixme: should not block
        Maybe CIDInfo
mcidinfo <- forall a. Microseconds -> FilePath -> IO a -> IO (Maybe a)
timeout (Int -> Microseconds
Microseconds Int
100000) FilePath
"runNewServerReader" forall a b. (a -> b) -> a -> b
$ Connection -> IO CIDInfo
waitPeerCID Connection
conn
        let msg :: Builder
msg = Builder
"Migration: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Builder
bhow ClientSockAddr
peersa forall a. Semigroup a => a -> a -> a
<> Builder
" (" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Builder
bhow CID
dCID forall a. Semigroup a => a -> a -> a
<> Builder
")"
        forall q. KeepQlog q => q -> Debug -> IO ()
qlogDebug Connection
conn forall a b. (a -> b) -> a -> b
$ LogStr -> Debug
Debug forall a b. (a -> b) -> a -> b
$ forall msg. ToLogStr msg => msg -> LogStr
toLogStr Builder
msg
        Connection -> DebugLogger
connDebugLog Connection
conn forall a b. (a -> b) -> a -> b
$ Builder
"debug: runNewServerReader: " forall a. Semigroup a => a -> a -> a
<> Builder
msg
        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 forall a b. (a -> b) -> a -> b
$ \UDPSocket
s1 ->
            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 forall a b. (a -> b) -> a -> b
$ \UDPSocket
_ -> do
                forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO 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 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: " forall a. Semigroup a => a -> a -> a
<> Builder
msg)