{-# 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 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
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
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
}
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 = 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
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)
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
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 :: 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
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
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
Connection -> CID -> IO ()
setMyCID Connection
conn CID
dCID
Connection -> Maybe CIDInfo -> IO ()
validatePath Connection
conn Maybe CIDInfo
mcidinfo
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)