{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.QUIC.Server.Reader (
Dispatch
, newDispatch
, clearDispatch
, runDispatcher
, tokenMgr
, accept
, Accept(..)
, RecvQ
, recvServer
, readerServer
, 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 Data.OrdPSQ (OrdPSQ)
import qualified Data.OrdPSQ as PSQ
import qualified GHC.IO.Exception as E
import Network.ByteOrder
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
data RecvQDict = RecvQDict Int (OrdPSQ CID Int RecvQ)
recvQDictSize :: Int
recvQDictSize :: Int
recvQDictSize = Int
100
emptyRecvQDict :: RecvQDict
emptyRecvQDict :: RecvQDict
emptyRecvQDict = Int -> OrdPSQ CID Int RecvQ -> RecvQDict
RecvQDict Int
0 forall k p v. OrdPSQ k p v
PSQ.empty
lookupRecvQDict :: IORef RecvQDict -> CID -> IO (Maybe RecvQ)
lookupRecvQDict :: IORef RecvQDict -> CID -> IO (Maybe RecvQ)
lookupRecvQDict IORef RecvQDict
ref CID
dcid = do
RecvQDict Int
_ OrdPSQ CID Int RecvQ
qt <- 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 p v. Ord k => k -> OrdPSQ k p v -> Maybe (p, v)
PSQ.lookup CID
dcid OrdPSQ CID Int RecvQ
qt of
Maybe (Int, RecvQ)
Nothing -> forall a. Maybe a
Nothing
Just (Int
_,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 Int
p OrdPSQ CID Int RecvQ
qt0) = let qt1 :: OrdPSQ CID Int RecvQ
qt1 | forall k p v. OrdPSQ k p v -> Int
PSQ.size OrdPSQ CID Int RecvQ
qt0 forall a. Ord a => a -> a -> Bool
<= Int
recvQDictSize = OrdPSQ CID Int RecvQ
qt0
| Bool
otherwise = forall k p v. (Ord k, Ord p) => OrdPSQ k p v -> OrdPSQ k p v
PSQ.deleteMin OrdPSQ CID Int RecvQ
qt0
qt2 :: OrdPSQ CID Int RecvQ
qt2 = forall k p v.
(Ord k, Ord p) =>
k -> p -> v -> OrdPSQ k p v -> OrdPSQ k p v
PSQ.insert CID
dcid Int
p RecvQ
q OrdPSQ CID Int RecvQ
qt1
p' :: Int
p' = Int
p forall a. Num a => a -> a -> a
+ Int
1
in Int -> OrdPSQ CID Int RecvQ -> RecvQDict
RecvQDict Int
p' OrdPSQ CID Int RecvQ
qt2
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
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
}
AcceptQ -> Accept -> IO ()
writeAcceptQ AcceptQ
acceptQ Accept
ent
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
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
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)
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 -> IO a -> IO (Maybe a)
timeout (Int -> Microseconds
Microseconds Int
100000) 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
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 :: 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 -> IO a -> IO (Maybe a)
timeout Microseconds
ito 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
migrating forall a b. (a -> b) -> a -> b
$ do
Connection -> IO ()
setMigrationStarted Connection
conn
Maybe CIDInfo
mcidinfo <- forall a. Microseconds -> IO a -> IO (Maybe a)
timeout (Int -> Microseconds
Microseconds Int
100000) 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
Connection -> CID -> IO ()
setMyCID Connection
conn CID
dCID
Connection -> Maybe CIDInfo -> IO ()
validatePath Connection
conn Maybe CIDInfo
mcidinfo
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)