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

module Network.QUIC.Server.Reader (
    Dispatch,
    newDispatch,
    clearDispatch,
    runDispatcher,
    tokenMgr,

    -- * Accepting
    Accept (..),

    -- * Receiving and reading
    RecvQ,
    recvServer,
    ServerState (..),
) where

import Control.Concurrent
import Control.Concurrent.STM
import qualified Control.Exception as E
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.Socket (Socket, waitReadSocketSTM)
import qualified Network.Socket.ByteString as NSB
import qualified System.IO.Error as E

import Network.QUIC.Common
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.Types
import Network.QUIC.Windows

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

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

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 -> Dispatch
Dispatch
        (TokenManager
 -> IORef ConnectionDict -> IORef RecvQDict -> Dispatch)
-> IO TokenManager
-> IO (IORef ConnectionDict -> IORef RecvQDict -> 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 -> Dispatch)
-> IO (IORef ConnectionDict) -> IO (IORef RecvQDict -> 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 -> Dispatch)
-> IO (IORef RecvQDict) -> 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
<*> RecvQDict -> IO (IORef RecvQDict)
forall a. a -> IO (IORef a)
newIORef RecvQDict
emptyRecvQDict
  where
    conf :: Config
conf =
        Config
CT.defaultConfig
            { CT.tokenLifetime = scTicketLifetime
            , CT.threadName = "QUIC token manager"
            }

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

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

newtype ConnectionDict = ConnectionDict (Map CID Connection)

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

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

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

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

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

-- Original destination CID -> RecvQ
newtype 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 -> Socket
accMySocket :: Socket
    , Accept -> PeerInfo
accPeerInfo :: PeerInfo
    , 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
    }

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

runDispatcher
    :: Dispatch
    -> ServerConfig
    -> TVar ServerState
    -> (Accept -> IO ())
    -> Socket
    -> IO ThreadId
runDispatcher :: Dispatch
-> ServerConfig
-> TVar ServerState
-> (Accept -> IO ())
-> Socket
-> IO ThreadId
runDispatcher Dispatch
d ServerConfig
conf TVar ServerState
stvar Accept -> IO ()
forkConn Socket
mysock = IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Dispatch
-> ServerConfig
-> TVar ServerState
-> (Accept -> IO ())
-> Socket
-> IO ()
dispatcher Dispatch
d ServerConfig
conf TVar ServerState
stvar Accept -> IO ()
forkConn Socket
mysock

data ServerState = Running | Stopped deriving (ServerState -> ServerState -> Bool
(ServerState -> ServerState -> Bool)
-> (ServerState -> ServerState -> Bool) -> Eq ServerState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServerState -> ServerState -> Bool
== :: ServerState -> ServerState -> Bool
$c/= :: ServerState -> ServerState -> Bool
/= :: ServerState -> ServerState -> Bool
Eq, Int -> ServerState -> ShowS
[ServerState] -> ShowS
ServerState -> FilePath
(Int -> ServerState -> ShowS)
-> (ServerState -> FilePath)
-> ([ServerState] -> ShowS)
-> Show ServerState
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerState -> ShowS
showsPrec :: Int -> ServerState -> ShowS
$cshow :: ServerState -> FilePath
show :: ServerState -> FilePath
$cshowList :: [ServerState] -> ShowS
showList :: [ServerState] -> ShowS
Show)

checkLoop :: TVar ServerState -> STM () -> IO Bool
checkLoop :: TVar ServerState -> STM () -> IO Bool
checkLoop TVar ServerState
stvar STM ()
waitsock = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
    ServerState
st <- TVar ServerState -> STM ServerState
forall a. TVar a -> STM a
readTVar TVar ServerState
stvar
    if ServerState
st ServerState -> ServerState -> Bool
forall a. Eq a => a -> a -> Bool
== ServerState
Stopped
        then
            Bool -> STM Bool
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        else do
            STM ()
waitsock -- blocking is retry
            Bool -> STM Bool
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

dispatcher
    :: Dispatch
    -> ServerConfig
    -> TVar ServerState
    -> (Accept -> IO ())
    -> Socket
    -> IO ()
dispatcher :: Dispatch
-> ServerConfig
-> TVar ServerState
-> (Accept -> IO ())
-> Socket
-> IO ()
dispatcher Dispatch
d ServerConfig
conf TVar ServerState
stvar Accept -> IO ()
forkConnection Socket
mysock = do
    FilePath -> IO ()
labelMe FilePath
"QUIC dispatcher"
    STM ()
wait <- Socket -> IO (STM ())
waitReadSocketSTM Socket
mysock
    DebugLogger -> IO () -> IO ()
handleLogUnit DebugLogger
logAction (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
loop STM ()
wait
  where
    loop :: STM () -> IO ()
loop STM ()
wait = do
        Bool
cont <- TVar ServerState -> STM () -> IO Bool
checkLoop TVar ServerState
stvar STM ()
wait
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cont (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            (SockAddr
peersa, Token
bs, [Cmsg]
cmsgs, MsgFlag
_) <- IO (SockAddr, Token, [Cmsg], MsgFlag)
-> IO (SockAddr, Token, [Cmsg], MsgFlag)
forall {b}. IO b -> IO b
safeRecv (IO (SockAddr, Token, [Cmsg], MsgFlag)
 -> IO (SockAddr, Token, [Cmsg], MsgFlag))
-> IO (SockAddr, Token, [Cmsg], MsgFlag)
-> IO (SockAddr, Token, [Cmsg], MsgFlag)
forall a b. (a -> b) -> a -> b
$ Socket
-> Int -> Int -> MsgFlag -> IO (SockAddr, Token, [Cmsg], MsgFlag)
NSB.recvMsg Socket
mysock Int
2048 Int
2048 MsgFlag
0
            TimeMicrosecond
now <- IO TimeMicrosecond
getTimeMicrosecond
            let send' :: Token -> IO ()
send' Token
b = IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> SockAddr -> [Token] -> [Cmsg] -> MsgFlag -> IO Int
NSB.sendMsg Socket
mysock SockAddr
peersa [Token
b] [Cmsg]
cmsgs MsgFlag
0
                -- cf: greaseQuicBit $ getMyParameters conn
                quicBit :: Bool
quicBit = Parameters -> Bool
greaseQuicBit (Parameters -> Bool) -> Parameters -> Bool
forall a b. (a -> b) -> a -> b
$ ServerConfig -> Parameters
scParameters ServerConfig
conf
            [(CryptPacket, EncryptionLevel, Int)]
cpckts <- Token -> Bool -> IO [(CryptPacket, EncryptionLevel, Int)]
decodeCryptPackets Token
bs (Bool -> Bool
not Bool
quicBit)
            let bytes :: Int
bytes = Token -> Int
BS.length Token
bs
                peerInfo :: PeerInfo
peerInfo = SockAddr -> [Cmsg] -> PeerInfo
PeerInfo SockAddr
peersa [Cmsg]
cmsgs
                switch :: (CryptPacket, EncryptionLevel, Int) -> IO ()
switch = Dispatch
-> ServerConfig
-> (Accept -> IO ())
-> DebugLogger
-> Socket
-> PeerInfo
-> (Token -> IO ())
-> Int
-> TimeMicrosecond
-> (CryptPacket, EncryptionLevel, Int)
-> IO ()
dispatch Dispatch
d ServerConfig
conf Accept -> IO ()
forkConnection DebugLogger
logAction Socket
mysock PeerInfo
peerInfo 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
            STM () -> IO ()
loop STM ()
wait

    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 e a. Exception e => IO a -> IO (Either e a)
E.try (IO b -> IO (Either SomeException b))
-> IO b -> IO (Either SomeException b)
forall a b. (a -> b) -> a -> b
$ IO b -> IO b
forall {b}. IO b -> IO b
windowsThreadBlockHack 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 | SomeException -> Bool
forall e. Exception e => e -> Bool
isAsyncException SomeException
se -> SomeException -> IO b
forall e a. Exception e => e -> IO a
E.throwIO (SomeException
se :: E.SomeException)
            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 e a. Exception e => e -> IO a
E.throwIO SomeException
se
                Maybe IOError
_ -> do
                    DebugLogger
logAction DebugLogger -> DebugLogger
forall a b. (a -> b) -> a -> b
$ Builder
"recv again: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> SomeException -> Builder
forall a. Show a => a -> Builder
bhow SomeException
se
                    IO b
rcv

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

-- If client initial is fragmented into multiple packets,
-- there is no way to put the all packets into a single queue.
-- Rather, each fragment packet is put into its own queue.
-- For the first fragment, handshake would successif others are
-- retransmitted.
-- For the other fragments, handshake will fail since its socket
-- cannot be connected.
dispatch
    :: Dispatch
    -> ServerConfig
    -> (Accept -> IO ())
    -> DebugLogger
    -> Socket
    -> PeerInfo
    -> (ByteString -> IO ())
    -> Int
    -> TimeMicrosecond
    -> (CryptPacket, EncryptionLevel, Int)
    -> IO ()
dispatch :: Dispatch
-> ServerConfig
-> (Accept -> IO ())
-> DebugLogger
-> Socket
-> PeerInfo
-> (Token -> IO ())
-> Int
-> TimeMicrosecond
-> (CryptPacket, EncryptionLevel, Int)
-> IO ()
dispatch
    Dispatch{IORef RecvQDict
IORef ConnectionDict
TokenManager
tokenMgr :: Dispatch -> TokenManager
dstTable :: Dispatch -> IORef ConnectionDict
srcTable :: Dispatch -> IORef RecvQDict
tokenMgr :: TokenManager
dstTable :: IORef ConnectionDict
srcTable :: IORef RecvQDict
..}
    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
..}
    Accept -> IO ()
forkConnection
    DebugLogger
logAction
    Socket
mysock
    PeerInfo
peerInfo
    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
<> PeerInfo -> Builder
forall a. Show a => a -> Builder
bhow PeerInfo
peerInfo
        | 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
                Just Connection
conn -> 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
        | 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 -> 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
                        Maybe CryptoToken
_ -> Bool -> IO ()
pushToAcceptFirst Bool
True
                Just Connection
conn -> 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
      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
                        acc :: Accept
acc =
                            Accept
                                { accVersionInfo :: VersionInfo
accVersionInfo = Version -> [Version] -> VersionInfo
VersionInfo Version
peerVer [Version]
myVersions
                                , accMyAuthCIDs :: AuthCIDs
accMyAuthCIDs = AuthCIDs
myAuthCIDs
                                , accPeerAuthCIDs :: AuthCIDs
accPeerAuthCIDs = AuthCIDs
peerAuthCIDs
                                , accMySocket :: Socket
accMySocket = Socket
mysock
                                , accPeerInfo :: PeerInfo
accPeerInfo = PeerInfo
peerInfo
                                , 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
                                }
                    Accept -> IO ()
forkConnection Accept
acc
        -- Initial: DCID=S1, SCID=C1 ->
        --                                     <- Initial: DCID=C1, SCID=S2
        --                               ...
        -- 1-RTT: DCID=S2 ->
        --                                                <- 1-RTT: DCID=C1
        --
        -- initial_source_connection_id       = S2   (newdCID)
        -- original_destination_connection_id = S1   (dCID)
        -- retry_source_connection_id         = Nothing
        pushToAcceptFirst :: Bool -> IO ()
pushToAcceptFirst Bool
addrValid = do
            CID
newdCID <- IO CID
newCID
            let myAuthCIDs :: AuthCIDs
myAuthCIDs =
                    AuthCIDs
defaultAuthCIDs
                        { initSrcCID = Just newdCID
                        , origDstCID = Just dCID
                        }
                peerAuthCIDs :: AuthCIDs
peerAuthCIDs =
                    AuthCIDs
defaultAuthCIDs
                        { initSrcCID = Just sCID
                        }
            AuthCIDs -> AuthCIDs -> CID -> Bool -> IO ()
pushToAcceptQ AuthCIDs
myAuthCIDs AuthCIDs
peerAuthCIDs CID
dCID Bool
addrValid
        -- Initial: DCID=S1, SCID=C1 ->
        --                                       <- Retry: DCID=C1, SCID=S2
        -- Initial: DCID=S2, SCID=C1 ->
        --                                     <- Initial: DCID=C1, SCID=S3
        --                               ...
        -- 1-RTT: DCID=S3 ->
        --                                                <- 1-RTT: DCID=C1
        --
        -- initial_source_connection_id       = S3   (dCID)  S2 in our server
        -- original_destination_connection_id = S1   (o)
        -- retry_source_connection_id         = S2   (dCID)
        pushToAcceptRetried :: CryptoToken -> IO ()
pushToAcceptRetried (CryptoToken Version
_ Word32
_ TimeMicrosecond
_ (Just (CID
_, CID
_, CID
o))) = do
            let myAuthCIDs :: AuthCIDs
myAuthCIDs =
                    AuthCIDs
defaultAuthCIDs
                        { initSrcCID = Just dCID
                        , origDstCID = Just o
                        , retrySrcCID = Just dCID
                        }
                peerAuthCIDs :: AuthCIDs
peerAuthCIDs =
                    AuthCIDs
defaultAuthCIDs
                        { initSrcCID = Just sCID
                        }
            AuthCIDs -> AuthCIDs -> CID -> Bool -> IO ()
pushToAcceptQ AuthCIDs
myAuthCIDs AuthCIDs
peerAuthCIDs CID
o Bool
True
        pushToAcceptRetried CryptoToken
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        isRetryTokenValid :: CryptoToken -> IO Bool
isRetryTokenValid (CryptoToken Version
_tver Word32
life TimeMicrosecond
etim (Just (CID
l, CID
r, CID
_))) = do
            Microseconds
diff <- TimeMicrosecond -> IO Microseconds
getElapsedTimeMicrosecond TimeMicrosecond
etim
            Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
                Microseconds
diff Microseconds -> Microseconds -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Microseconds
Microseconds (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
life Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000)
                    Bool -> Bool -> Bool
&& CID
dCID CID -> CID -> Bool
forall a. Eq a => a -> a -> Bool
== CID
l
                    Bool -> Bool -> Bool
&& CID
sCID CID -> CID -> Bool
forall a. Eq a => a -> a -> Bool
== CID
r
                    -- Initial for ACK contains the retry token but
                    -- the version would be already version 2, sigh.
                    Bool -> Bool -> Bool
&& Version
_tver Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
peerVer
        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
tokenMgr :: Dispatch -> TokenManager
dstTable :: Dispatch -> IORef ConnectionDict
srcTable :: Dispatch -> IORef RecvQDict
tokenMgr :: TokenManager
dstTable :: IORef ConnectionDict
srcTable :: IORef RecvQDict
..}
    ServerConfig
_
    Accept -> IO ()
_
    DebugLogger
_
    Socket
_mysock
    PeerInfo
_peerInfo
    Token -> IO ()
_
    Int
_
    TimeMicrosecond
tim
    (cpkt :: CryptPacket
cpkt@(CryptPacket (RTT0 Version
_ CID
dCID CID
_) Crypt
_), EncryptionLevel
lvl, Int
siz) = do
        Maybe RecvQ
mq <- IORef RecvQDict -> CID -> IO (Maybe RecvQ)
lookupRecvQDict IORef RecvQDict
srcTable CID
dCID
        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 ()
----------------------------------------------------------------
dispatch
    Dispatch{IORef RecvQDict
IORef ConnectionDict
TokenManager
tokenMgr :: Dispatch -> TokenManager
dstTable :: Dispatch -> IORef ConnectionDict
srcTable :: Dispatch -> IORef RecvQDict
tokenMgr :: TokenManager
dstTable :: IORef ConnectionDict
srcTable :: IORef RecvQDict
..}
    ServerConfig
_
    Accept -> IO ()
_
    DebugLogger
logAction
    Socket
mysock
    PeerInfo
peerInfo
    Token -> IO ()
_
    Int
_
    TimeMicrosecond
tim
    (cpkt :: CryptPacket
cpkt@(CryptPacket Header
hdr Crypt
_crypt), EncryptionLevel
lvl, Int
siz) = do
        let dCID :: CID
dCID = Header -> CID
headerMyCID Header
hdr
        Maybe Connection
mconn <- IORef ConnectionDict -> CID -> IO (Maybe Connection)
lookupConnectionDict IORef ConnectionDict
dstTable CID
dCID
        case Maybe Connection
mconn of
            Maybe Connection
Nothing -> 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
<> PeerInfo -> Builder
forall a. Show a => a -> Builder
bhow PeerInfo
peerInfo
            Just Connection
conn -> do
                IO Socket -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Socket -> IO ()) -> IO Socket -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Socket -> IO Socket
setSocket Connection
conn Socket
mysock
                Connection -> PeerInfo -> IO ()
setPeerInfo Connection
conn PeerInfo
peerInfo
                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

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