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

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

import Control.Concurrent
import Control.Concurrent.STM
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 Foreign.Marshal.Alloc
import qualified GHC.IO.Exception as E
import Network.ByteOrder
import Network.Socket hiding (accept, Debug)
import qualified Network.Socket.ByteString as NSB
import qualified System.IO.Error as E
import System.Log.FastLogger
import qualified UnliftIO.Exception as E

import Network.QUIC.Config
import Network.QUIC.Connection
import Network.QUIC.Connector
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.Socket
import Network.QUIC.Types

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

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 (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
CT.defaultConfig
                       IO (IORef ConnectionDict -> IORef RecvQDict -> AcceptQ -> Dispatch)
-> IO (IORef ConnectionDict)
-> IO (IORef RecvQDict -> AcceptQ -> Dispatch)
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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return (Maybe Connection -> IO (Maybe Connection))
-> Maybe Connection -> IO (Maybe Connection)
forall a b. (a -> b) -> a -> b
$ CID -> Map CID Connection -> Maybe Connection
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup CID
cid Map CID Connection
tbl

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

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

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

-- Original destination CID -> RecvQ
data RecvQDict = RecvQDict 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 OrdPSQ CID Int RecvQ
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 <- IORef RecvQDict -> IO RecvQDict
forall a. IORef a -> IO a
readIORef IORef RecvQDict
ref
    Maybe RecvQ -> IO (Maybe RecvQ)
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 -> OrdPSQ CID Int RecvQ -> Maybe (Int, RecvQ)
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     -> Maybe RecvQ
forall a. Maybe a
Nothing
      Just (Int
_,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 Int
p OrdPSQ CID Int RecvQ
qt0) = let qt1 :: OrdPSQ CID Int RecvQ
qt1 | OrdPSQ CID Int RecvQ -> Int
forall k p v. OrdPSQ k p v -> Int
PSQ.size OrdPSQ CID Int RecvQ
qt0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
recvQDictSize = OrdPSQ CID Int RecvQ
qt0
                                    | Bool
otherwise = OrdPSQ CID Int RecvQ -> OrdPSQ CID Int RecvQ
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 = CID -> Int -> RecvQ -> OrdPSQ CID Int RecvQ -> OrdPSQ CID Int RecvQ
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 -- fixme: overflow
                            in Int -> OrdPSQ CID Int RecvQ -> RecvQDict
RecvQDict Int
p' OrdPSQ CID Int RecvQ
qt2

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

data Accept = Accept {
    Accept -> Version
accVersion      :: Version
  , Accept -> AuthCIDs
accMyAuthCIDs   :: AuthCIDs
  , Accept -> AuthCIDs
accPeerAuthCIDs :: AuthCIDs
  , Accept -> SockAddr
accMySockAddr   :: SockAddr
  , Accept -> SockAddr
accPeerSockAddr :: SockAddr
  , 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 a. IO (TQueue a)
newTQueueIO

readAcceptQ :: AcceptQ -> IO Accept
readAcceptQ :: AcceptQ -> IO Accept
readAcceptQ (AcceptQ TQueue Accept
q) = STM Accept -> IO Accept
forall a. STM a -> IO 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 a. STM a -> IO 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 -> (Socket, SockAddr) -> IO ThreadId
runDispatcher :: Dispatch -> ServerConfig -> (Socket, SockAddr) -> IO ThreadId
runDispatcher Dispatch
d ServerConfig
conf ssa :: (Socket, SockAddr)
ssa@(Socket
s,SockAddr
_) =
    IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (Dispatch -> ServerConfig -> (Socket, SockAddr) -> IO ()
dispatcher Dispatch
d ServerConfig
conf (Socket, SockAddr)
ssa) ((Either SomeException () -> IO ()) -> IO ThreadId)
-> (Either SomeException () -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \Either SomeException ()
_ -> Socket -> IO ()
close Socket
s

dispatcher :: Dispatch -> ServerConfig -> (Socket, SockAddr) -> IO ()
dispatcher :: Dispatch -> ServerConfig -> (Socket, SockAddr) -> IO ()
dispatcher Dispatch
d ServerConfig
conf (Socket
s,SockAddr
mysa) = DebugLogger -> IO () -> IO ()
handleLogUnit DebugLogger
logAction (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    IO (Ptr Word8)
-> (Ptr Word8 -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket (Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
maximumUdpPayloadSize)
              Ptr Word8 -> IO ()
forall a. Ptr a -> IO ()
free
              Ptr Word8 -> IO ()
forall b. Ptr Word8 -> IO b
body
  where
    body :: Ptr Word8 -> IO b
body Ptr Word8
buf = do
    --    let (opt,_cmsgid) = case mysa of
    --          SockAddrInet{}  -> (RecvIPv4PktInfo, CmsgIdIPv4PktInfo)
    --          SockAddrInet6{} -> (RecvIPv6PktInfo, CmsgIdIPv6PktInfo)
    --          _               -> error "dispatcher"
    --    setSocketOption s opt 1
        IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ do
    --        (peersa, bs0, _cmsgs, _) <- recv
            (ByteString
bs0, SockAddr
peersa) <- IO (ByteString, SockAddr)
recv
            let bytes :: Int
bytes = ByteString -> Int
BS.length ByteString
bs0 -- both Initial and 0RTT
            TimeMicrosecond
now <- IO TimeMicrosecond
getTimeMicrosecond
            -- macOS overrides the local address of the socket
            -- if in_pktinfo is used.
            (PacketI
pkt, ByteString
bs0RTT) <- ByteString -> IO (PacketI, ByteString)
decodePacket ByteString
bs0
    --        let send bs = void $ NSB.sendMsg s peersa [bs] cmsgs' 0
            let send :: ByteString -> IO ()
send ByteString
bs = 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 -> ByteString -> SockAddr -> IO Int
NSB.sendTo Socket
s ByteString
bs SockAddr
peersa
            Dispatch
-> ServerConfig
-> DebugLogger
-> PacketI
-> SockAddr
-> SockAddr
-> (ByteString -> IO ())
-> Ptr Word8
-> ByteString
-> Int
-> TimeMicrosecond
-> IO ()
dispatch Dispatch
d ServerConfig
conf DebugLogger
logAction PacketI
pkt SockAddr
mysa SockAddr
peersa ByteString -> IO ()
send Ptr Word8
buf ByteString
bs0RTT Int
bytes TimeMicrosecond
now
    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 (m :: * -> *) a. Monad m => a -> m a
return ()
    recv :: IO (ByteString, SockAddr)
recv = do
--        ex <- E.try $ NSB.recvMsg s maximumUdpPayloadSize 64 0
        Either SomeException (ByteString, SockAddr)
ex <- IO (ByteString, SockAddr)
-> IO (Either SomeException (ByteString, SockAddr))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
E.tryAny (IO (ByteString, SockAddr)
 -> IO (Either SomeException (ByteString, SockAddr)))
-> IO (ByteString, SockAddr)
-> IO (Either SomeException (ByteString, SockAddr))
forall a b. (a -> b) -> a -> b
$ Socket -> Int -> IO (ByteString, SockAddr)
NSB.recvFrom Socket
s Int
maximumUdpPayloadSize
        case Either SomeException (ByteString, SockAddr)
ex of
           Right (ByteString, SockAddr)
x -> (ByteString, SockAddr) -> IO (ByteString, SockAddr)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString, SockAddr)
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 (ByteString, SockAddr)
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 (ByteString, SockAddr)
recv

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

-- If client initial is fragmented into multiple packets,
-- there is no way to put the all packets into a single queue.
-- Rather, each fragment packet is put into its own queue.
-- For the first fragment, handshake would successif others are
-- retransmitted.
-- For the other fragments, handshake will fail since its socket
-- cannot be connected.
dispatch :: Dispatch -> ServerConfig -> DebugLogger -> PacketI -> SockAddr -> SockAddr -> (ByteString -> IO ()) -> Buffer -> ByteString -> Int -> TimeMicrosecond -> IO ()
dispatch :: Dispatch
-> ServerConfig
-> DebugLogger
-> PacketI
-> SockAddr
-> SockAddr
-> (ByteString -> IO ())
-> Ptr Word8
-> ByteString
-> Int
-> TimeMicrosecond
-> 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 -> [ByteString] -> IO ByteString)
Credentials
SessionManager
Parameters
Hooks
FilePath -> IO ()
scSessionManager :: ServerConfig -> SessionManager
scRequireRetry :: ServerConfig -> Bool
scALPN :: ServerConfig -> Maybe (Version -> [ByteString] -> IO ByteString)
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 -> [ByteString] -> IO ByteString)
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
         (PacketIC cpkt :: CryptPacket
cpkt@(CryptPacket (Initial Version
ver CID
dCID CID
sCID ByteString
token) Crypt
_) EncryptionLevel
lvl)
         SockAddr
mysa SockAddr
peersa ByteString -> IO ()
send Ptr Word8
_ ByteString
bs0RTT Int
bytes TimeMicrosecond
tim
  | 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
<> SockAddr -> Builder
forall a. Show a => a -> Builder
bhow SockAddr
peersa
  | Version
ver Version -> [Version] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Version]
scVersions= do
        let vers :: [Version]
vers | Version
ver Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
GreasingVersion = Version
GreasingVersion2 Version -> [Version] -> [Version]
forall a. a -> [a] -> [a]
: [Version]
scVersions
                 | Bool
otherwise = Version
GreasingVersion Version -> [Version] -> [Version]
forall a. a -> [a] -> [a]
: [Version]
scVersions
        ByteString
bss <- VersionNegotiationPacket -> IO ByteString
encodeVersionNegotiationPacket (VersionNegotiationPacket -> IO ByteString)
-> VersionNegotiationPacket -> IO ByteString
forall a b. (a -> b) -> a -> b
$ CID -> CID -> [Version] -> VersionNegotiationPacket
VersionNegotiationPacket CID
sCID CID
dCID [Version]
vers
        ByteString -> IO ()
send ByteString
bss
  | ByteString
token ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" = do
        Maybe Connection
mq <- IORef ConnectionDict -> CID -> IO (Maybe Connection)
lookupConnectionDict IORef ConnectionDict
dstTable CID
dCID
        case Maybe Connection
mq of
          Maybe Connection
Nothing
            | Bool
scRequireRetry -> IO ()
sendRetry
            | Bool
otherwise      -> Bool -> IO ()
pushToAcceptFirst Bool
False
          Maybe Connection
_                  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = do
        Maybe CryptoToken
mct <- TokenManager -> ByteString -> IO (Maybe CryptoToken)
decryptToken TokenManager
tokenMgr ByteString
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
mq <- IORef ConnectionDict -> CID -> IO (Maybe Connection)
lookupConnectionDict IORef ConnectionDict
dstTable CID
dCID
                  case Maybe Connection
mq of
                    Maybe Connection
Nothing -> Bool -> IO ()
pushToAcceptFirst Bool
True
                    Maybe Connection
_       -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Maybe CryptoToken
_ -> IO ()
sendRetry
  where
    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
bytes 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
bytes 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 :: Version
-> AuthCIDs
-> AuthCIDs
-> SockAddr
-> SockAddr
-> RecvQ
-> Int
-> (CID -> Connection -> IO ())
-> (CID -> IO ())
-> Bool
-> TimeMicrosecond
-> Accept
Accept {
                      accVersion :: Version
accVersion      = Version
ver
                    , accMyAuthCIDs :: AuthCIDs
accMyAuthCIDs   = AuthCIDs
myAuthCIDs
                    , accPeerAuthCIDs :: AuthCIDs
accPeerAuthCIDs = AuthCIDs
peerAuthCIDs
                    , accMySockAddr :: SockAddr
accMySockAddr   = SockAddr
mysa
                    , accPeerSockAddr :: SockAddr
accPeerSockAddr = SockAddr
peersa
                    , accRecvQ :: RecvQ
accRecvQ        = RecvQ
q
                    , accPacketSize :: Int
accPacketSize   = Int
bytes
                    , accRegister :: CID -> Connection -> IO ()
accRegister     = CID -> Connection -> IO ()
reg
                    , accUnregister :: CID -> IO ()
accUnregister   = CID -> IO ()
unreg
                    , accAddressValidated :: Bool
accAddressValidated = Bool
addrValid
                    , accTime :: TimeMicrosecond
accTime         = TimeMicrosecond
tim
                    }
              -- fixme: check acceptQ length
              AcceptQ -> Accept -> IO ()
writeAcceptQ AcceptQ
acceptQ Accept
ent
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
bs0RTT ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                  (PacketIC CryptPacket
cpktRTT0 EncryptionLevel
lvl', ByteString
_) <- ByteString -> IO (PacketI, ByteString)
decodePacket ByteString
bs0RTT
                  RecvQ -> ReceivedPacket -> IO ()
writeRecvQ RecvQ
q (ReceivedPacket -> IO ()) -> ReceivedPacket -> IO ()
forall a b. (a -> b) -> a -> b
$ CryptPacket
-> TimeMicrosecond -> Int -> EncryptionLevel -> ReceivedPacket
mkReceivedPacket CryptPacket
cpktRTT0 TimeMicrosecond
tim Int
bytes EncryptionLevel
lvl'
    -- Initial: DCID=S1, SCID=C1 ->
    --                                     <- Initial: DCID=C1, SCID=S2
    --                               ...
    -- 1-RTT: DCID=S2 ->
    --                                                <- 1-RTT: DCID=C1
    --
    -- initial_source_connection_id       = S2   (newdCID)
    -- original_destination_connection_id = S1   (dCID)
    -- retry_source_connection_id         = Nothing
    pushToAcceptFirst :: Bool -> IO ()
pushToAcceptFirst Bool
addrValid = do
        CID
newdCID <- IO CID
newCID
        let myAuthCIDs :: AuthCIDs
myAuthCIDs = AuthCIDs
defaultAuthCIDs {
                initSrcCID :: Maybe CID
initSrcCID  = CID -> Maybe CID
forall a. a -> Maybe a
Just CID
newdCID
              , origDstCID :: Maybe CID
origDstCID  = CID -> Maybe CID
forall a. a -> Maybe a
Just CID
dCID
              }
            peerAuthCIDs :: AuthCIDs
peerAuthCIDs = AuthCIDs
defaultAuthCIDs {
                initSrcCID :: Maybe CID
initSrcCID = CID -> Maybe CID
forall a. a -> Maybe a
Just CID
sCID
              }
        AuthCIDs -> AuthCIDs -> CID -> Bool -> IO ()
pushToAcceptQ AuthCIDs
myAuthCIDs AuthCIDs
peerAuthCIDs CID
dCID Bool
addrValid
    -- Initial: DCID=S1, SCID=C1 ->
    --                                       <- Retry: DCID=C1, SCID=S2
    -- Initial: DCID=S2, SCID=C1 ->
    --                                     <- Initial: DCID=C1, SCID=S3
    --                               ...
    -- 1-RTT: DCID=S3 ->
    --                                                <- 1-RTT: DCID=C1
    --
    -- initial_source_connection_id       = S3   (dCID)  S2 in our server
    -- original_destination_connection_id = S1   (o)
    -- retry_source_connection_id         = S2   (dCID)
    pushToAcceptRetried :: CryptoToken -> IO ()
pushToAcceptRetried (CryptoToken Version
_ TimeMicrosecond
_ (Just (CID
_,CID
_,CID
o))) = do
        let myAuthCIDs :: AuthCIDs
myAuthCIDs = AuthCIDs
defaultAuthCIDs {
                initSrcCID :: Maybe CID
initSrcCID  = CID -> Maybe CID
forall a. a -> Maybe a
Just CID
dCID
              , origDstCID :: Maybe CID
origDstCID  = CID -> Maybe CID
forall a. a -> Maybe a
Just CID
o
              , retrySrcCID :: Maybe CID
retrySrcCID = CID -> Maybe CID
forall a. a -> Maybe a
Just CID
dCID
              }
            peerAuthCIDs :: AuthCIDs
peerAuthCIDs = AuthCIDs
defaultAuthCIDs {
                initSrcCID :: Maybe CID
initSrcCID = CID -> Maybe CID
forall a. a -> Maybe a
Just CID
sCID
              }
        AuthCIDs -> AuthCIDs -> CID -> Bool -> IO ()
pushToAcceptQ AuthCIDs
myAuthCIDs AuthCIDs
peerAuthCIDs CID
o Bool
True
    pushToAcceptRetried CryptoToken
_ = () -> IO ()
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
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Version
tver Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
ver
              Bool -> Bool -> Bool
&& Microseconds
diff Microseconds -> Microseconds -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Microseconds
Microseconds Int
30000000 -- fixme
              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
    isRetryTokenValid CryptoToken
_ = Bool -> IO Bool
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
ver CID
newdCID CID
sCID CID
dCID
        Maybe ByteString
mnewtoken <- Microseconds -> IO ByteString -> IO (Maybe ByteString)
forall a. Microseconds -> IO a -> IO (Maybe a)
timeout (Int -> Microseconds
Microseconds Int
100000) (IO ByteString -> IO (Maybe ByteString))
-> IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ TokenManager -> CryptoToken -> IO ByteString
encryptToken TokenManager
tokenMgr CryptoToken
retryToken
        case Maybe ByteString
mnewtoken of
          Maybe ByteString
Nothing       -> DebugLogger
logAction Builder
"retry token stacked"
          Just ByteString
newtoken -> do
              ByteString
bss <- RetryPacket -> IO ByteString
encodeRetryPacket (RetryPacket -> IO ByteString) -> RetryPacket -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Version
-> CID
-> CID
-> ByteString
-> Either CID (ByteString, ByteString)
-> RetryPacket
RetryPacket Version
ver CID
sCID CID
newdCID ByteString
newtoken (CID -> Either CID (ByteString, ByteString)
forall a b. a -> Either a b
Left CID
dCID)
              ByteString -> IO ()
send ByteString
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
_
         (PacketIC cpkt :: CryptPacket
cpkt@(CryptPacket (RTT0 Version
_ CID
o CID
_) Crypt
_) EncryptionLevel
lvl) SockAddr
_ SockAddr
_peersa ByteString -> IO ()
_ Ptr Word8
_ ByteString
_ Int
bytes TimeMicrosecond
tim = 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
bytes EncryptionLevel
lvl
      Maybe RecvQ
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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
         (PacketIC (CryptPacket hdr :: Header
hdr@(Short CID
dCID) Crypt
crypt) EncryptionLevel
lvl) SockAddr
mysa SockAddr
peersa ByteString -> IO ()
_ Ptr Word8
buf ByteString
_ Int
bytes TimeMicrosecond
tim  = do
    -- fixme: packets for closed connections also match here.
    Maybe Connection
mx <- IORef ConnectionDict -> CID -> IO (Maybe Connection)
lookupConnectionDict IORef ConnectionDict
dstTable CID
dCID
    case Maybe Connection
mx 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
<> SockAddr -> Builder
forall a. Show a => a -> Builder
bhow SockAddr
peersa
      Just Connection
conn -> do
          let bufsiz :: Int
bufsiz = Int
maximumUdpPayloadSize
          Maybe Plain
mplain <- Connection
-> Ptr Word8 -> Int -> Crypt -> EncryptionLevel -> IO (Maybe Plain)
decryptCrypt Connection
conn Ptr Word8
buf Int
bufsiz Crypt
crypt EncryptionLevel
RTT1Level
          case Maybe Plain
mplain of
            Maybe Plain
Nothing -> Connection -> DebugLogger
connDebugLog Connection
conn Builder
"debug: dispatch: cannot decrypt"
            Just Plain
plain -> 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
                    Connection -> PlainPacket -> TimeMicrosecond -> IO ()
forall q a.
(KeepQlog q, Qlog a) =>
q -> a -> TimeMicrosecond -> IO ()
qlogReceived Connection
conn (Header -> Plain -> PlainPacket
PlainPacket Header
hdr Plain
plain) TimeMicrosecond
tim
                    let cpkt' :: CryptPacket
cpkt' = Header -> Crypt -> CryptPacket
CryptPacket Header
hdr (Crypt -> CryptPacket) -> Crypt -> CryptPacket
forall a b. (a -> b) -> a -> b
$ Crypt -> Crypt
setCryptLogged Crypt
crypt
                    Connection -> ReceivedPacket -> IO ()
writeMigrationQ Connection
conn (ReceivedPacket -> IO ()) -> ReceivedPacket -> IO ()
forall a b. (a -> b) -> a -> b
$ CryptPacket
-> TimeMicrosecond -> Int -> EncryptionLevel -> ReceivedPacket
mkReceivedPacket CryptPacket
cpkt' TimeMicrosecond
tim Int
bytes EncryptionLevel
lvl
                    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
                        -- fixme: should not block in this loop
                        Maybe CIDInfo
mcidinfo <- Microseconds -> IO CIDInfo -> IO (Maybe CIDInfo)
forall a. Microseconds -> IO a -> IO (Maybe a)
timeout (Int -> Microseconds
Microseconds Int
100000) (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
<> SockAddr -> Builder
forall a. Show a => a -> Builder
bhow SockAddr
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: dispatch: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
msg
                        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
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Connection -> SockAddr -> SockAddr -> CID -> Maybe CIDInfo -> IO ()
migrator Connection
conn SockAddr
mysa SockAddr
peersa CID
dCID Maybe CIDInfo
mcidinfo

dispatch Dispatch
_ ServerConfig
_ DebugLogger
_ PacketI
_ipkt SockAddr
_ SockAddr
_peersa ByteString -> IO ()
_ Ptr Word8
_ ByteString
_ Int
_ TimeMicrosecond
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

-- | readerServer dies when the socket is closed.
readerServer :: Socket -> Connection -> IO ()
readerServer :: Socket -> Connection -> IO ()
readerServer Socket
s Connection
conn = DebugLogger -> IO () -> IO ()
handleLogUnit DebugLogger
logAction IO ()
loop
  where
    loop :: IO ()
loop = do
        Microseconds
ito <- Connection -> IO Microseconds
readMinIdleTimeout Connection
conn
        Maybe ByteString
mbs <- Microseconds -> IO ByteString -> IO (Maybe ByteString)
forall a. Microseconds -> IO a -> IO (Maybe a)
timeout Microseconds
ito (IO ByteString -> IO (Maybe ByteString))
-> IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Socket -> Int -> IO ByteString
NSB.recv Socket
s Int
maximumUdpPayloadSize
        case Maybe ByteString
mbs of
          Maybe ByteString
Nothing -> Socket -> IO ()
close Socket
s
          Just ByteString
bs -> do
              TimeMicrosecond
now <- IO TimeMicrosecond
getTimeMicrosecond
              let bytes :: Int
bytes = ByteString -> Int
BS.length ByteString
bs
              Connection -> Int -> IO ()
addRxBytes Connection
conn Int
bytes
              [(CryptPacket, EncryptionLevel)]
pkts <- ByteString -> IO [(CryptPacket, EncryptionLevel)]
decodeCryptPackets ByteString
bs
              ((CryptPacket, EncryptionLevel) -> IO ())
-> [(CryptPacket, EncryptionLevel)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(CryptPacket
p,EncryptionLevel
l) -> RecvQ -> ReceivedPacket -> IO ()
writeRecvQ (Connection -> RecvQ
connRecvQ Connection
conn) (CryptPacket
-> TimeMicrosecond -> Int -> EncryptionLevel -> ReceivedPacket
mkReceivedPacket CryptPacket
p TimeMicrosecond
now Int
bytes EncryptionLevel
l)) [(CryptPacket, EncryptionLevel)]
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

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

migrator :: Connection -> SockAddr -> SockAddr -> CID -> Maybe CIDInfo -> IO ()
migrator :: Connection -> SockAddr -> SockAddr -> CID -> Maybe CIDInfo -> IO ()
migrator Connection
conn SockAddr
mysa SockAddr
peersa1 CID
dcid Maybe CIDInfo
mcidinfo = DebugLogger -> IO () -> IO ()
handleLogUnit DebugLogger
logAction (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracketOnError IO Socket
setup Socket -> IO ()
close ((Socket -> IO ()) -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
s1 ->
        IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket (Connection -> Socket -> IO Socket
addSocket Connection
conn Socket
s1) Socket -> IO ()
close ((Socket -> IO ()) -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
_ -> 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
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Socket -> Connection -> IO ()
readerServer Socket
s1 Connection
conn
            -- fixme: if cannot set
            Connection -> CID -> IO ()
setMyCID Connection
conn CID
dcid
            Connection -> Maybe CIDInfo -> IO ()
validatePath Connection
conn Maybe CIDInfo
mcidinfo
            IO (Maybe Any) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe Any) -> IO ()) -> IO (Maybe Any) -> IO ()
forall a b. (a -> b) -> a -> b
$ Microseconds -> IO Any -> IO (Maybe Any)
forall a. Microseconds -> IO a -> IO (Maybe a)
timeout (Int -> Microseconds
Microseconds Int
2000000) (IO Any -> IO (Maybe Any)) -> IO Any -> IO (Maybe Any)
forall a b. (a -> b) -> a -> b
$ IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Connection -> IO ReceivedPacket
readMigrationQ Connection
conn IO ReceivedPacket -> (ReceivedPacket -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RecvQ -> ReceivedPacket -> IO ()
writeRecvQ (Connection -> RecvQ
connRecvQ Connection
conn))
  where
    setup :: IO Socket
setup = SockAddr -> SockAddr -> IO Socket
udpServerConnectedSocket SockAddr
mysa SockAddr
peersa1
    logAction :: DebugLogger
logAction Builder
msg = Connection -> DebugLogger
connDebugLog Connection
conn (Builder
"debug: migrator: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
msg)