diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,10 @@ +## 0.1.0 + +- Supporting QUICv2 and version negotiation. +- Supporting CPUs other than Intel. +- Supporting Windows. +- Using the network-udp package + ## 0.0.1 - Making Haskell servers friendly with Chrome diff --git a/Network/QUIC.hs b/Network/QUIC.hs --- a/Network/QUIC.hs +++ b/Network/QUIC.hs @@ -1,6 +1,8 @@ {-# LANGUAGE PatternSynonyms #-} -- | This main module provides APIs for QUIC. +-- +-- The -threaded option must be specified to GHC to use this library. module Network.QUIC ( -- * Connection Connection diff --git a/Network/QUIC/Client.hs b/Network/QUIC/Client.hs --- a/Network/QUIC/Client.hs +++ b/Network/QUIC/Client.hs @@ -14,6 +14,7 @@ , ccResumption , ccCiphers , ccGroups + , ccVersions -- , ccCredentials , ccValidate , ccAutoMigration diff --git a/Network/QUIC/Client/Reader.hs b/Network/QUIC/Client/Reader.hs --- a/Network/QUIC/Client/Reader.hs +++ b/Network/QUIC/Client/Reader.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -8,11 +9,10 @@ , controlConnection ) where -import Control.Concurrent -import qualified Data.ByteString as BS import Data.List (intersect) -import Network.Socket (Socket, getPeerName, close) -import qualified Network.Socket.ByteString as NSB +import Network.Socket (getSocketName) +import Network.UDP +import UnliftIO.Concurrent import qualified UnliftIO.Exception as E import Network.QUIC.Connection @@ -24,47 +24,55 @@ import Network.QUIC.Parameters import Network.QUIC.Qlog import Network.QUIC.Recovery -import Network.QUIC.Socket import Network.QUIC.Types +#if defined(mingw32_HOST_OS) +import Network.QUIC.Windows +#endif -- | readerClient dies when the socket is closed. -readerClient :: [Version] -> Socket -> Connection -> IO () -readerClient myVers s0 conn = handleLogUnit logAction $ do - getServerAddr conn >>= loop +readerClient :: UDPSocket -> Connection -> IO () +readerClient cs0@(UDPSocket s0 _ _) conn = handleLogUnit logAction $ do + wait + loop where - loop msa0 = do + wait = do + bound <- E.handleAny (\_ -> return False) $ do + _ <- getSocketName s0 + return True + unless bound $ do + yield + wait + loop = do ito <- readMinIdleTimeout conn - mbs <- timeout ito $ do - case msa0 of - Nothing -> NSB.recv s0 maximumUdpPayloadSize - Just sa0 -> do - (bs, sa) <- NSB.recvFrom s0 maximumUdpPayloadSize - return $ if sa == sa0 then bs else "" + mbs <- timeout ito $ +#if defined(mingw32_HOST_OS) + windowsThreadBlockHack $ +#endif + recv cs0 case mbs of - Nothing -> close s0 - Just "" -> loop msa0 + Nothing -> close cs0 Just bs -> do now <- getTimeMicrosecond - let bytes = BS.length bs - addRxBytes conn bytes pkts <- decodePackets bs - mapM_ (putQ now bytes) pkts - loop msa0 + mapM_ (putQ now) pkts + loop logAction msg = connDebugLog conn ("debug: readerClient: " <> msg) - putQ _ _ (PacketIB BrokenPacket) = return () - putQ t _ (PacketIV pkt@(VersionNegotiationPacket dCID sCID peerVers)) = do + putQ _ (PacketIB BrokenPacket) = return () + putQ t (PacketIV pkt@(VersionNegotiationPacket dCID sCID peerVers)) = do qlogReceived conn pkt t - mver <- case myVers of - [] -> return Nothing - [_] -> return Nothing - _:myVers' -> case myVers' `intersect` peerVers of - [] -> return Nothing - ver:_ -> do - ok <- checkCIDs conn dCID (Left sCID) - return $ if ok then Just ver else Nothing - E.throwTo (mainThreadId conn) $ VerNego mver - putQ t z (PacketIC pkt lvl) = writeRecvQ (connRecvQ conn) $ mkReceivedPacket pkt t z lvl - putQ t _ (PacketIR pkt@(RetryPacket ver dCID sCID token ex)) = do + myVerInfo <- getVersionInfo conn + let myVer = chosenVersion myVerInfo + myVers0 = otherVersions myVerInfo + -- ignoring VN if the original version is included. + when (myVer `notElem` peerVers && Negotiation `notElem` peerVers) $ do + ok <- checkCIDs conn dCID (Left sCID) + let myVers = filter (not . isGreasingVersion) myVers0 + nextVerInfo = case myVers `intersect` peerVers of + vers@(ver:_) | ok -> VersionInfo ver vers + _ -> brokenVersionInfo + E.throwTo (mainThreadId conn) $ VerNego nextVerInfo + putQ t (PacketIC pkt lvl siz) = writeRecvQ (connRecvQ conn) $ mkReceivedPacket pkt t siz lvl + putQ t (PacketIR pkt@(RetryPacket ver dCID sCID token ex)) = do qlogReceived conn pkt t ok <- checkCIDs conn dCID ex when ok $ do @@ -135,13 +143,10 @@ rebind :: Connection -> Microseconds -> IO () rebind conn microseconds = do - s0:_ <- getSockets conn - msa0 <- getServerAddr conn - s1 <- case msa0 of - Nothing -> getPeerName s0 >>= udpNATRebindingConnectedSocket - Just sa0 -> udpNATRebindingSocket sa0 - _ <- addSocket conn s1 - v <- getVersion conn - let reader = readerClient [v] s1 conn -- versions are dummy + cs0 <- getSocket conn + cs <- natRebinding cs0 + cs0' <- setSocket conn cs + let reader = readerClient cs conn forkIO reader >>= addReader conn - fire conn microseconds $ close s0 + -- Using cs0' just in case. + fire conn microseconds $ close cs0' diff --git a/Network/QUIC/Client/Run.hs b/Network/QUIC/Client/Run.hs --- a/Network/QUIC/Client/Run.hs +++ b/Network/QUIC/Client/Run.hs @@ -8,6 +8,8 @@ ) where import qualified Network.Socket as NS +import Network.UDP (UDPSocket(..)) +import qualified Network.UDP as UDP import UnliftIO.Async import UnliftIO.Concurrent import qualified UnliftIO.Exception as E @@ -26,7 +28,6 @@ import Network.QUIC.Receiver import Network.QUIC.Recovery import Network.QUIC.Sender -import Network.QUIC.Socket import Network.QUIC.Types ---------------------------------------------------------------- @@ -39,21 +40,33 @@ -- Use the 'migrate' API for the connected socket. run :: ClientConfig -> (Connection -> IO a) -> IO a -- Don't use handleLogUnit here because of a return value. -run conf client = case ccVersions conf of - [] -> E.throwIO NoVersionIsSpecified - ver1:_ -> do - ex <- E.try $ runClient conf client ver1 - case ex of - Right v -> return v - Left (NextVersion Nothing) -> E.throwIO VersionNegotiationFailed - Left (NextVersion (Just ver2)) -> runClient conf client ver2 +run conf client = NS.withSocketsDo $ do + let resInfo = ccResumption conf + verInfo = case resumptionSession resInfo of + Nothing | resumptionToken resInfo == emptyToken -> + let vers = ccVersions conf + ver = head vers + in VersionInfo ver vers + _ -> let ver = resumptionVersion resInfo in VersionInfo ver [ver] + ex <- E.try $ runClient conf client False verInfo + case ex of + Right v -> return v + Left (NextVersion nextVerInfo) + | verInfo == brokenVersionInfo -> E.throwIO VersionNegotiationFailed + | otherwise -> runClient conf client True nextVerInfo -runClient :: ClientConfig -> (Connection -> IO a) -> Version -> IO a -runClient conf client0 ver = do - E.bracket open clse $ \(ConnRes conn send recv myAuthCIDs reader) -> do +runClient :: ClientConfig -> (Connection -> IO a) -> Bool -> VersionInfo -> IO a +runClient conf client0 isICVN verInfo = do + E.bracket open clse $ \(ConnRes conn myAuthCIDs reader) -> do forkIO reader >>= addReader conn forkIO timeouter >>= addTimeouter conn - handshaker <- handshakeClient conf conn myAuthCIDs + let conf' = conf { + ccParameters = (ccParameters conf) { + versionInformation = Just verInfo + } + } + setIncompatibleVN conn isICVN -- must be before handshaker + handshaker <- handshakeClient conf' conn myAuthCIDs let client = do if ccUse0RTT conf then wait0RTTReady conn @@ -63,8 +76,8 @@ client0 conn ldcc = connLDCC conn supporters = foldr1 concurrently_ [handshaker - ,sender conn send - ,receiver conn recv + ,sender conn + ,receiver conn ,resender ldcc ,ldccTimer ldcc ] @@ -75,30 +88,22 @@ Right r -> return r E.trySyncOrAsync runThreads >>= closure conn ldcc where - open = createClientConnection conf ver + open = createClientConnection conf verInfo clse connRes = do let conn = connResConnection connRes setDead conn freeResources conn killReaders conn - socks <- getSockets conn - mapM_ NS.close socks join $ replaceKillTimeouter conn -createClientConnection :: ClientConfig -> Version -> IO ConnRes -createClientConnection conf@ClientConfig{..} ver = do - (s0,sa0) <- if ccAutoMigration then - udpClientSocket ccServerName ccPortName - else - udpClientConnectedSocket ccServerName ccPortName +createClientConnection :: ClientConfig -> VersionInfo -> IO ConnRes +createClientConnection conf@ClientConfig{..} verInfo = do + us@(UDPSocket _ sa _) <- UDP.clientSocket ccServerName ccPortName (not ccAutoMigration) q <- newRecvQ - sref <- newIORef [s0] - let send buf siz = do - s:_ <- readIORef sref - if ccAutoMigration then - void $ NS.sendBufTo s buf siz sa0 - else - void $ NS.sendBuf s buf siz + sref <- newIORef us + let send = \buf siz -> do + cs <- readIORef sref + UDP.sendBuf cs buf siz recv = recvClient q myCID <- newCID peerCID <- newCID @@ -109,18 +114,18 @@ debugLog $ "Original CID: " <> bhow peerCID let myAuthCIDs = defaultAuthCIDs { initSrcCID = Just myCID } peerAuthCIDs = defaultAuthCIDs { initSrcCID = Just peerCID, origDstCID = Just peerCID } - conn <- clientConnection conf ver myAuthCIDs peerAuthCIDs debugLog qLog ccHooks sref q + conn <- clientConnection conf verInfo myAuthCIDs peerAuthCIDs debugLog qLog ccHooks sref q send recv addResource conn qclean + let ver = chosenVersion verInfo initializeCoder conn InitialLevel $ initialSecrets ver peerCID setupCryptoStreams conn -- fixme: cleanup let pktSiz0 = fromMaybe 0 ccPacketSize - pktSiz = (defaultPacketSize sa0 `max` pktSiz0) `min` maximumPacketSize sa0 + pktSiz = (defaultPacketSize sa `max` pktSiz0) `min` maximumPacketSize sa setMaxPacketSize conn pktSiz setInitialCongestionWindow (connLDCC conn) pktSiz setAddressValidated conn - when ccAutoMigration $ setServerAddr conn sa0 - let reader = readerClient ccVersions s0 conn -- dies when s0 is closed. - return $ ConnRes conn send recv myAuthCIDs reader + let reader = readerClient us conn -- dies when s0 is closed. + return $ ConnRes conn myAuthCIDs reader -- | Creating a new socket and execute a path validation -- with a new connection ID. Typically, this is used diff --git a/Network/QUIC/Closer.hs b/Network/QUIC/Closer.hs --- a/Network/QUIC/Closer.hs +++ b/Network/QUIC/Closer.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.QUIC.Closer (closure) where import Foreign.Marshal.Alloc -import qualified Network.Socket as NS +import qualified Network.UDP as UDP import UnliftIO.Concurrent import qualified UnliftIO.Exception as E import Foreign.Ptr @@ -31,54 +32,51 @@ | Just (Abort err desc) <- E.fromException se = do closure' conn ldcc $ ConnectionCloseApp err desc E.throwIO $ ApplicationProtocolErrorIsSent err desc - | Just (VerNego ver) <- E.fromException se = do - E.throwIO $ NextVersion ver + | Just (VerNego vers) <- E.fromException se = do + E.throwIO $ NextVersion vers | otherwise = E.throwIO se closure' :: Connection -> LDCC -> Frame -> IO () closure' conn ldcc frame = do killReaders conn killTimeouter <- replaceKillTimeouter conn - socks@(s:_) <- clearSockets conn let bufsiz = maximumUdpPayloadSize - sendBuf <- mallocBytes (bufsiz * 3) - siz <- encodeCC conn frame sendBuf bufsiz - let recvBuf = sendBuf `plusPtr` (bufsiz * 2) - recv = NS.recvBuf s recvBuf bufsiz + sendBuf <- mallocBytes bufsiz + recvBuf <- mallocBytes bufsiz + siz <- encodeCC conn (SizedBuffer sendBuf bufsiz) frame + us <- getSocket conn + let clos = UDP.close us + send = UDP.sendBuf us sendBuf siz + recv = UDP.recvBuf us recvBuf bufsiz hook = onCloseCompleted $ connHooks conn - send <- if isClient conn then do - msa <- getServerAddr conn - return $ case msa of - Nothing -> NS.sendBuf s sendBuf siz - Just sa -> NS.sendBufTo s sendBuf siz sa - else - return $ NS.sendBuf s sendBuf siz pto <- getPTO ldcc - void $ forkFinally (closer pto send recv hook) $ \_ -> do + void $ forkFinally (closer conn pto send recv hook) $ \_ -> do free sendBuf - mapM_ NS.close socks + free recvBuf + clos killTimeouter -encodeCC :: Connection -> Frame -> Buffer -> BufferSize -> IO Int -encodeCC conn frame sendBuf0 bufsiz0 = do +encodeCC :: Connection -> SizedBuffer -> Frame -> IO Int +encodeCC conn res0@(SizedBuffer sendBuf0 bufsiz0) frame = do lvl0 <- getEncryptionLevel conn let lvl | lvl0 == RTT0Level = InitialLevel | otherwise = lvl0 if lvl == HandshakeLevel then do - siz0 <- encCC sendBuf0 bufsiz0 InitialLevel + siz0 <- encCC res0 InitialLevel let sendBuf1 = sendBuf0 `plusPtr` siz0 bufsiz1 = bufsiz0 - siz0 - siz1 <- encCC sendBuf1 bufsiz1 HandshakeLevel + res1 = SizedBuffer sendBuf1 bufsiz1 + siz1 <- encCC res1 HandshakeLevel return (siz0 + siz1) else - encCC sendBuf0 bufsiz0 lvl + encCC res0 lvl where - encCC sendBuf bufsiz lvl = do + encCC res lvl = do header <- mkHeader conn lvl mypn <- nextPacketNumber conn let plain = Plain (Flags 0) mypn [frame] 0 ppkt = PlainPacket header plain - siz <- fst <$> encodePlainPacket conn sendBuf bufsiz ppkt Nothing + siz <- fst <$> encodePlainPacket conn res ppkt Nothing if siz >= 0 then do now <- getTimeMicrosecond qlogSent conn ppkt now @@ -86,14 +84,18 @@ else return 0 -closer :: Microseconds -> IO Int -> IO Int -> IO () -> IO () -closer (Microseconds pto) send recv hook = loop (3 :: Int) +closer :: Connection -> Microseconds -> IO () -> IO Int -> IO () -> IO () +closer _conn (Microseconds pto) send recv hook +#if defined(mingw32_HOST_OS) + | isServer _conn = send +#endif + | otherwise = loop (3 :: Int) where loop 0 = return () loop n = do - _ <- send + send getTimeMicrosecond >>= skip (Microseconds pto) - mx <- timeout (Microseconds (pto .>>. 1)) recv + mx <- timeout (Microseconds (pto !>>. 1)) recv case mx of Nothing -> hook Just 0 -> return () diff --git a/Network/QUIC/Common.hs b/Network/QUIC/Common.hs --- a/Network/QUIC/Common.hs +++ b/Network/QUIC/Common.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE StrictData #-} + module Network.QUIC.Common where import qualified Network.Socket as NS @@ -8,10 +10,10 @@ ---------------------------------------------------------------- -data ConnRes = ConnRes Connection SendBuf Receive AuthCIDs (IO ()) +data ConnRes = ConnRes Connection AuthCIDs ~(IO ()) connResConnection :: ConnRes -> Connection -connResConnection (ConnRes conn _ _ _ _) = conn +connResConnection (ConnRes conn _ _) = conn defaultPacketSize :: NS.SockAddr -> Int defaultPacketSize NS.SockAddrInet6{} = defaultQUICPacketSizeForIPv6 diff --git a/Network/QUIC/Config.hs b/Network/QUIC/Config.hs --- a/Network/QUIC/Config.hs +++ b/Network/QUIC/Config.hs @@ -40,7 +40,7 @@ -- | Client configuration. data ClientConfig = ClientConfig { - ccVersions :: [Version] -- ^ Versions in the preferred order. + ccVersions :: [Version] -- ^ Compatible versions in the preferred order. , ccCiphers :: [Cipher] -- ^ Cipher candidates defined in TLS 1.3. , ccGroups :: [Group] -- ^ Key exchange group candidates defined in TLS 1.3. , ccParameters :: Parameters @@ -63,8 +63,7 @@ -- | The default value for client configuration. defaultClientConfig :: ClientConfig defaultClientConfig = ClientConfig { - ccVersions = [Version1,Draft29] - -- intentionally excluding cipher_TLS13_CHACHA20POLY1305_SHA256 due to cryptonite limitation + ccVersions = [Version2,Version1] , ccCiphers = supportedCiphers defaultSupported , ccGroups = supportedGroups defaultSupported , ccParameters = defaultParameters @@ -88,7 +87,7 @@ -- | Server configuration. data ServerConfig = ServerConfig { - scVersions :: [Version] -- ^ Versions in the preferred order. + scVersions :: [Version] -- ^ Fully-Deployed Versions in the preferred order. , scCiphers :: [Cipher] -- ^ Cipher candidates defined in TLS 1.3. , scGroups :: [Group] -- ^ Key exchange group candidates defined in TLS 1.3. , scParameters :: Parameters @@ -108,8 +107,7 @@ -- | The default value for server configuration. defaultServerConfig :: ServerConfig defaultServerConfig = ServerConfig { - scVersions = [Version1,Draft29] - -- intentionally excluding cipher_TLS13_CHACHA20POLY1305_SHA256 due to cryptonite limitation + scVersions = [Version2,Version1] , scCiphers = supportedCiphers defaultSupported , scGroups = supportedGroups defaultSupported , scParameters = defaultParameters @@ -119,7 +117,7 @@ , scHooks = defaultHooks , scUse0RTT = False -- server original - , scAddresses = [("127.0.0.1",4433)] + , scAddresses = [("0.0.0.0",4433),("::",4433)] , scALPN = Nothing , scRequireRetry = False , scSessionManager = noSessionManager diff --git a/Network/QUIC/Connection/Crypto.hs b/Network/QUIC/Connection/Crypto.hs --- a/Network/QUIC/Connection/Crypto.hs +++ b/Network/QUIC/Connection/Crypto.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} module Network.QUIC.Connection.Crypto ( setEncryptionLevel @@ -23,16 +24,23 @@ , setCurrentKeyPhase ) where -import Control.Concurrent.STM import Network.TLS.QUIC +import UnliftIO.STM +import Network.QUIC.Connection.Misc import Network.QUIC.Connection.Types import Network.QUIC.Connector import Network.QUIC.Crypto -import Network.QUIC.CryptoFusion import Network.QUIC.Imports import Network.QUIC.Types +useFusion :: Bool +#ifdef USE_FUSION +useFusion = True +#else +useFusion = False +#endif + ---------------------------------------------------------------- setEncryptionLevel :: Connection -> EncryptionLevel -> IO () @@ -55,7 +63,7 @@ waitEncryptionLevel :: Connection -> EncryptionLevel -> IO () waitEncryptionLevel Connection{..} lvl = atomically $ do l <- readTVar $ encryptionLevel connState - check (l >= lvl) + checkSTM (l >= lvl) ---------------------------------------------------------------- @@ -92,82 +100,155 @@ initializeCoder :: Connection -> EncryptionLevel -> TrafficSecrets a -> IO () initializeCoder conn lvl sec = do + ver <- if lvl == RTT0Level then + return $ getOriginalVersion conn + else + getVersion conn cipher <- getCipher conn lvl - (coder, protector, _) <- genCoder (isClient conn) cipher sec + (coder, protector) <- + if useFusion then + genFusionCoder (isClient conn) ver cipher sec + else + genNiteCoder (isClient conn) ver cipher sec writeArray (coders conn) lvl coder writeArray (protectors conn) lvl protector initializeCoder1RTT :: Connection -> TrafficSecrets ApplicationSecret -> IO () initializeCoder1RTT conn sec = do + ver <- getVersion conn cipher <- getCipher conn RTT1Level - (coder, protector, supp) <- genCoder (isClient conn) cipher sec - let coder1 = Coder1RTT coder sec supp + (coder, protector) <- + if useFusion then + genFusionCoder (isClient conn) ver cipher sec + else + genNiteCoder (isClient conn) ver cipher sec + let coder1 = Coder1RTT coder sec writeArray (coders1RTT conn) False coder1 writeArray (protectors conn) RTT1Level protector updateCoder1RTT conn True updateCoder1RTT :: Connection -> Bool -> IO () updateCoder1RTT conn nextPhase = do + ver <- getVersion conn cipher <- getCipher conn RTT1Level - Coder1RTT _ secN supp <- readArray (coders1RTT conn) (not nextPhase) - let secN1 = updateSecret cipher secN - coderN1 <- genCoder1RTT (isClient conn) cipher secN1 supp - let nextCoder = Coder1RTT coderN1 secN1 supp + Coder1RTT coder secN <- readArray (coders1RTT conn) (not nextPhase) + let secN1 = updateSecret ver cipher secN + coderN1 <- if useFusion then + genFusionCoder1RTT (isClient conn) ver cipher secN1 coder + else + genNiteCoder1RTT (isClient conn) ver cipher secN1 coder + let nextCoder = Coder1RTT coderN1 secN1 writeArray (coders1RTT conn) nextPhase nextCoder -updateSecret :: Cipher -> TrafficSecrets ApplicationSecret -> TrafficSecrets ApplicationSecret -updateSecret cipher (ClientTrafficSecret cN, ServerTrafficSecret sN) = secN1 +updateSecret :: Version -> Cipher -> TrafficSecrets ApplicationSecret -> TrafficSecrets ApplicationSecret +updateSecret ver cipher (ClientTrafficSecret cN, ServerTrafficSecret sN) = secN1 where - Secret cN1 = nextSecret cipher $ Secret cN - Secret sN1 = nextSecret cipher $ Secret sN + Secret cN1 = nextSecret ver cipher $ Secret cN + Secret sN1 = nextSecret ver cipher $ Secret sN secN1 = (ClientTrafficSecret cN1, ServerTrafficSecret sN1) -genCoder :: Bool -> Cipher -> TrafficSecrets a -> IO (Coder, Protector, Supplement) -genCoder cli cipher (ClientTrafficSecret c, ServerTrafficSecret s) = do +genFusionCoder :: Bool -> Version -> Cipher -> TrafficSecrets a -> IO (Coder, Protector) +genFusionCoder cli ver cipher (ClientTrafficSecret c, ServerTrafficSecret s) = do fctxt <- fusionNewContext fctxr <- fusionNewContext fusionSetup cipher fctxt txPayloadKey txPayloadIV fusionSetup cipher fctxr rxPayloadKey rxPayloadIV supp <- fusionSetupSupplement cipher txHeaderKey - let enc = fusionEncrypt fctxt supp - dec = fusionDecrypt fctxr - coder = Coder enc dec - let set = fusionSetSample supp - get = fusionGetMask supp - let protector = Protector set get unp - return (coder, protector, supp) + let coder = Coder { + encrypt = fusionEncrypt fctxt supp + , decrypt = fusionDecrypt fctxr + , supplement = Just supp + } + let protector = Protector { + setSample = fusionSetSample supp + , getMask = fusionGetMask supp + , unprotect = unp + } + return (coder, protector) where txSecret | cli = Secret c | otherwise = Secret s rxSecret | cli = Secret s | otherwise = Secret c - txPayloadKey = aeadKey cipher txSecret - txPayloadIV = initialVector cipher txSecret - txHeaderKey = headerProtectionKey cipher txSecret - rxPayloadKey = aeadKey cipher rxSecret - rxPayloadIV = initialVector cipher rxSecret - rxHeaderKey = headerProtectionKey cipher rxSecret + txPayloadKey = aeadKey ver cipher txSecret + txPayloadIV = initialVector ver cipher txSecret + txHeaderKey = headerProtectionKey ver cipher txSecret + rxPayloadKey = aeadKey ver cipher rxSecret + rxPayloadIV = initialVector ver cipher rxSecret + rxHeaderKey = headerProtectionKey ver cipher rxSecret unp = protectionMask cipher rxHeaderKey -genCoder1RTT :: Bool -> Cipher -> TrafficSecrets a -> Supplement -> IO Coder -genCoder1RTT cli cipher (ClientTrafficSecret c, ServerTrafficSecret s) supp = do +genNiteCoder :: Bool -> Version -> Cipher -> TrafficSecrets a -> IO (Coder, Protector) +genNiteCoder cli ver cipher (ClientTrafficSecret c, ServerTrafficSecret s) = do + let enc = makeNiteEncrypt cipher txPayloadKey txPayloadIV + dec = makeNiteDecrypt cipher rxPayloadKey rxPayloadIV + (set,get) <- makeNiteProtector cipher txHeaderKey + let coder = Coder { + encrypt = enc + , decrypt = dec + , supplement = Nothing + } + let protector = Protector { + setSample = set + , getMask = get + , unprotect = unp + } + return (coder, protector) + where + txSecret | cli = Secret c + | otherwise = Secret s + rxSecret | cli = Secret s + | otherwise = Secret c + txPayloadKey = aeadKey ver cipher txSecret + txPayloadIV = initialVector ver cipher txSecret + txHeaderKey = headerProtectionKey ver cipher txSecret + rxPayloadKey = aeadKey ver cipher rxSecret + rxPayloadIV = initialVector ver cipher rxSecret + rxHeaderKey = headerProtectionKey ver cipher rxSecret + unp = protectionMask cipher rxHeaderKey + +genFusionCoder1RTT :: Bool -> Version -> Cipher -> TrafficSecrets a -> Coder -> IO Coder +genFusionCoder1RTT cli ver cipher (ClientTrafficSecret c, ServerTrafficSecret s) oldcoder = do fctxt <- fusionNewContext fctxr <- fusionNewContext fusionSetup cipher fctxt txPayloadKey txPayloadIV fusionSetup cipher fctxr rxPayloadKey rxPayloadIV - let enc = fusionEncrypt fctxt supp - dec = fusionDecrypt fctxr - coder = Coder enc dec + let supp = fromJust $ supplement oldcoder + let coder = Coder { + encrypt = fusionEncrypt fctxt supp + , decrypt = fusionDecrypt fctxr + , supplement = Just supp + } return coder where txSecret | cli = Secret c | otherwise = Secret s rxSecret | cli = Secret s | otherwise = Secret c - txPayloadKey = aeadKey cipher txSecret - txPayloadIV = initialVector cipher txSecret - rxPayloadKey = aeadKey cipher rxSecret - rxPayloadIV = initialVector cipher rxSecret + txPayloadKey = aeadKey ver cipher txSecret + txPayloadIV = initialVector ver cipher txSecret + rxPayloadKey = aeadKey ver cipher rxSecret + rxPayloadIV = initialVector ver cipher rxSecret + +genNiteCoder1RTT :: Bool -> Version -> Cipher -> TrafficSecrets a -> Coder -> IO Coder +genNiteCoder1RTT cli ver cipher (ClientTrafficSecret c, ServerTrafficSecret s) _oldcoder = do + let enc = makeNiteEncrypt cipher txPayloadKey txPayloadIV + dec = makeNiteDecrypt cipher rxPayloadKey rxPayloadIV + let coder = Coder { + encrypt = enc + , decrypt = dec + , supplement = Nothing + } + return coder + where + txSecret | cli = Secret c + | otherwise = Secret s + rxSecret | cli = Secret s + | otherwise = Secret c + txPayloadKey = aeadKey ver cipher txSecret + txPayloadIV = initialVector ver cipher txSecret + rxPayloadKey = aeadKey ver cipher rxSecret + rxPayloadIV = initialVector ver cipher rxSecret getCoder :: Connection -> EncryptionLevel -> Bool -> IO Coder getCoder conn RTT1Level k = coder1RTT <$> readArray (coders1RTT conn) k diff --git a/Network/QUIC/Connection/Migration.hs b/Network/QUIC/Connection/Migration.hs --- a/Network/QUIC/Connection/Migration.hs +++ b/Network/QUIC/Connection/Migration.hs @@ -26,9 +26,9 @@ , validatePath ) where -import Control.Concurrent.STM import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map +import UnliftIO.STM import Network.QUIC.Connection.Queue import Network.QUIC.Connection.Types @@ -114,7 +114,7 @@ let ref = peerCIDDB db <- readTVar ref mncid <- pickPeerCID conn - check $ isJust mncid + checkSTM $ isJust mncid let u = usedCIDInfo db setPeerCID conn (fromJust mncid) True return u @@ -293,7 +293,7 @@ waitResponse :: Connection -> IO () waitResponse Connection{..} = atomically $ do state <- readTVar migrationState - check (state == RecvResponse) + checkSTM (state == RecvResponse) writeTVar migrationState NonMigration checkResponse :: Connection -> PathData -> IO () diff --git a/Network/QUIC/Connection/Misc.hs b/Network/QUIC/Connection/Misc.hs --- a/Network/QUIC/Connection/Misc.hs +++ b/Network/QUIC/Connection/Misc.hs @@ -2,13 +2,17 @@ {-# LANGUAGE TupleSections #-} module Network.QUIC.Connection.Misc ( - setVersion + setVersionInfo + , getVersionInfo + , setVersion , getVersion - , getSockets - , addSocket - , clearSockets + , getOriginalVersion + , getSocket + , setSocket + , clearSocket , getPeerAuthCIDs , setPeerAuthCIDs + , getClientDstCID , getMyParameters , getPeerParameters , setPeerParameters @@ -28,7 +32,7 @@ , abortConnection ) where -import Network.Socket +import Network.UDP import System.Mem.Weak import UnliftIO.Concurrent import qualified UnliftIO.Exception as E @@ -43,32 +47,55 @@ ---------------------------------------------------------------- +setVersionInfo :: Connection -> VersionInfo -> IO () +setVersionInfo Connection{..} ver = writeIORef quicVersionInfo ver + +getVersionInfo :: Connection -> IO VersionInfo +getVersionInfo Connection{..} = readIORef quicVersionInfo + setVersion :: Connection -> Version -> IO () -setVersion Connection{..} ver = writeIORef quicVersion ver +setVersion Connection{..} ver = atomicModifyIORef'' quicVersionInfo $ \vi -> + vi { chosenVersion = ver } getVersion :: Connection -> IO Version -getVersion Connection{..} = readIORef quicVersion +getVersion conn = chosenVersion <$> getVersionInfo conn +getOriginalVersion :: Connection -> Version +getOriginalVersion = chosenVersion . origVersionInfo + ---------------------------------------------------------------- -getSockets :: Connection -> IO [Socket] -getSockets Connection{..} = readIORef sockets +getSocket :: Connection -> IO UDPSocket +getSocket Connection{..} = readIORef udpSocket -addSocket :: Connection -> Socket -> IO Socket -addSocket Connection{..} s1 = atomicModifyIORef' sockets $ - \ss@(s0:_) -> (s1:ss,s0) +setSocket :: Connection -> UDPSocket -> IO UDPSocket +setSocket Connection{..} sock = atomicModifyIORef' udpSocket $ + \sock0 -> (sock, sock0) -clearSockets :: Connection -> IO [Socket] -clearSockets Connection{..} = atomicModifyIORef sockets ([],) +clearSocket :: Connection -> IO UDPSocket +clearSocket Connection{..} = atomicModifyIORef' udpSocket (undefined,) ---------------------------------------------------------------- +getMyAuthCIDs :: Connection -> IO AuthCIDs +getMyAuthCIDs Connection{..} = readIORef connMyAuthCIDs + getPeerAuthCIDs :: Connection -> IO AuthCIDs -getPeerAuthCIDs Connection{..} = readIORef handshakeCIDs +getPeerAuthCIDs Connection{..} = readIORef connPeerAuthCIDs setPeerAuthCIDs :: Connection -> (AuthCIDs -> AuthCIDs) -> IO () -setPeerAuthCIDs Connection{..} f = atomicModifyIORef'' handshakeCIDs f +setPeerAuthCIDs Connection{..} f = atomicModifyIORef'' connPeerAuthCIDs f +getClientDstCID :: Connection -> IO CID +getClientDstCID conn = do + cids <- if isClient conn then + getPeerAuthCIDs conn + else + getMyAuthCIDs conn + return $ case retrySrcCID cids of + Nothing -> fromJust $ origDstCID cids + Just dcid -> dcid + ---------------------------------------------------------------- getMyParameters :: Connection -> Parameters @@ -86,11 +113,11 @@ delayedAck :: Connection -> IO () delayedAck conn@Connection{..} = do - (oldcnt,send) <- atomicModifyIORef' delayedAckCount check + (oldcnt,send_) <- atomicModifyIORef' delayedAckCount check when (oldcnt == 0) $ do new <- cfire conn (Microseconds 20000) sendAck join $ atomicModifyIORef' delayedAckCancel (new,) - when send $ do + when send_ $ do let new = return () join $ atomicModifyIORef' delayedAckCancel (new,) sendAck diff --git a/Network/QUIC/Connection/Queue.hs b/Network/QUIC/Connection/Queue.hs --- a/Network/QUIC/Connection/Queue.hs +++ b/Network/QUIC/Connection/Queue.hs @@ -1,6 +1,6 @@ module Network.QUIC.Connection.Queue where -import Control.Concurrent.STM +import UnliftIO.STM import Network.QUIC.Connection.Types import Network.QUIC.Stream diff --git a/Network/QUIC/Connection/Role.hs b/Network/QUIC/Connection/Role.hs --- a/Network/QUIC/Connection/Role.hs +++ b/Network/QUIC/Connection/Role.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module Network.QUIC.Connection.Role ( setToken @@ -6,6 +7,8 @@ , getResumptionInfo , setRetried , getRetried + , setIncompatibleVN + , getIncompatibleVN , setResumptionSession , setNewToken , setRegister @@ -17,15 +20,13 @@ , getBaseThreadId , setCertificateChain , getCertificateChain - , setServerAddr - , getServerAddr ) where -import Control.Concurrent import qualified Crypto.Token as CT import Data.X509 (CertificateChain) -import Network.Socket (SockAddr) +import UnliftIO.Concurrent +import Network.QUIC.Connection.Misc import Network.QUIC.Connection.Types import Network.QUIC.Connector import Network.QUIC.Imports @@ -64,15 +65,39 @@ ---------------------------------------------------------------- +setIncompatibleVN :: Connection -> Bool -> IO () +setIncompatibleVN conn@Connection{..} icvn + | isClient conn = atomicModifyIORef'' roleInfo $ \ci -> ci { + incompatibleVN = icvn + } + | otherwise = return () + +getIncompatibleVN :: Connection -> IO Bool +getIncompatibleVN conn@Connection{..} + | isClient conn = incompatibleVN <$> readIORef roleInfo + | otherwise = return False + +---------------------------------------------------------------- + setResumptionSession :: Connection -> SessionEstablish -setResumptionSession Connection{..} si sd = atomicModifyIORef'' roleInfo $ \ci -> ci { - resumptionInfo = (resumptionInfo ci) { resumptionSession = Just (si,sd) } - } +setResumptionSession conn@Connection{..} si sd = do + ver <- getVersion conn + atomicModifyIORef'' roleInfo $ \ci -> ci { + resumptionInfo = (resumptionInfo ci) { + resumptionVersion = ver + , resumptionSession = Just (si,sd) + } + } setNewToken :: Connection -> Token -> IO () -setNewToken Connection{..} token = atomicModifyIORef'' roleInfo $ \ci -> ci { - resumptionInfo = (resumptionInfo ci) { resumptionToken = token } - } +setNewToken conn@Connection{..} token = do + ver <- getVersion conn + atomicModifyIORef'' roleInfo $ \ci -> ci { + resumptionInfo = (resumptionInfo ci) { + resumptionVersion = ver + , resumptionToken = token + } + } ---------------------------------------------------------------- @@ -114,12 +139,3 @@ getCertificateChain :: Connection -> IO (Maybe CertificateChain) getCertificateChain Connection{..} = certChain <$> readIORef roleInfo - ----------------------------------------------------------------- - -setServerAddr :: Connection -> SockAddr -> IO () -setServerAddr Connection{..} sa = atomicModifyIORef'' roleInfo $ - \si -> si { serverAddr = Just sa } - -getServerAddr :: Connection -> IO (Maybe SockAddr) -getServerAddr Connection{..} = serverAddr <$> readIORef roleInfo diff --git a/Network/QUIC/Connection/State.hs b/Network/QUIC/Connection/State.hs --- a/Network/QUIC/Connection/State.hs +++ b/Network/QUIC/Connection/State.hs @@ -28,7 +28,7 @@ , checkAntiAmplificationFree ) where -import Control.Concurrent.STM +import UnliftIO.STM import Network.QUIC.Connection.Types import Network.QUIC.Connector @@ -66,20 +66,20 @@ wait0RTTReady :: Connection -> IO () wait0RTTReady Connection{..} = atomically $ do cs <- readTVar $ connectionState connState - check (cs >= ReadyFor0RTT) + checkSTM (cs >= ReadyFor0RTT) -- | Waiting until 1-RTT data can be sent. wait1RTTReady :: Connection -> IO () wait1RTTReady Connection{..} = atomically $ do cs <- readTVar $ connectionState connState - check (cs >= ReadyFor1RTT) + checkSTM (cs >= ReadyFor1RTT) -- | For clients, waiting until HANDSHAKE_DONE is received. -- For servers, waiting until a TLS stack reports that the handshake is complete. waitEstablished :: Connection -> IO () waitEstablished Connection{..} = atomically $ do cs <- readTVar $ connectionState connState - check (cs >= Established) + checkSTM (cs >= Established) ---------------------------------------------------------------- @@ -154,7 +154,7 @@ ok <- checkAntiAmplificationFree conn siz unless ok $ do beforeAntiAmp connLDCC - atomically (checkAntiAmplificationFreeSTM conn siz >>= check) + atomically (checkAntiAmplificationFreeSTM conn siz >>= checkSTM) -- setLossDetectionTimer is called eventually. checkAntiAmplificationFreeSTM :: Connection -> Int -> STM Bool diff --git a/Network/QUIC/Connection/Stream.hs b/Network/QUIC/Connection/Stream.hs --- a/Network/QUIC/Connection/Stream.hs +++ b/Network/QUIC/Connection/Stream.hs @@ -11,7 +11,7 @@ , setPeerMaxStreams ) where -import Control.Concurrent.STM +import UnliftIO.STM import Network.QUIC.Connection.Types import Network.QUIC.Imports @@ -31,7 +31,7 @@ get :: TVar Concurrency -> IO Int get tvar = atomically $ do conc@Concurrency{..} <- readTVar tvar - check (currentStream < maxStreams * 4 + streamType) + checkSTM (currentStream < maxStreams * 4 + streamType) let currentStream' = currentStream + 4 writeTVar tvar conc { currentStream = currentStream' } return currentStream diff --git a/Network/QUIC/Connection/Timeout.hs b/Network/QUIC/Connection/Timeout.hs --- a/Network/QUIC/Connection/Timeout.hs +++ b/Network/QUIC/Connection/Timeout.hs @@ -8,12 +8,12 @@ , delay ) where -import Control.Concurrent -import Control.Concurrent.STM import Data.Typeable -import GHC.Event +import Network.QUIC.Event import System.IO.Unsafe (unsafePerformIO) +import UnliftIO.Concurrent import qualified UnliftIO.Exception as E +import UnliftIO.STM import Network.QUIC.Connection.Types import Network.QUIC.Connector diff --git a/Network/QUIC/Connection/Types.hs b/Network/QUIC/Connection/Types.hs --- a/Network/QUIC/Connection/Types.hs +++ b/Network/QUIC/Connection/Types.hs @@ -1,26 +1,28 @@ +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} module Network.QUIC.Connection.Types where -import Control.Concurrent -import Control.Concurrent.STM import qualified Crypto.Token as CT import Data.Array.IO +import Data.ByteString.Internal import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.X509 (CertificateChain) -import Foreign.Ptr -import Network.Socket (Socket, SockAddr) +import Foreign.Marshal.Alloc +import Foreign.Ptr (nullPtr) import Network.TLS.QUIC +import Network.UDP (UDPSocket) +import UnliftIO.Concurrent +import UnliftIO.STM import Network.QUIC.Config import Network.QUIC.Connector import Network.QUIC.Crypto -import Network.QUIC.CryptoFusion import Network.QUIC.Imports import Network.QUIC.Logger import Network.QUIC.Parameters @@ -38,7 +40,7 @@ data RoleInfo = ClientInfo { clientInitialToken :: Token -- new or retry token , resumptionInfo :: ResumptionInfo - , serverAddr :: Maybe SockAddr + , incompatibleVN :: Bool } | ServerInfo { tokenManager :: ~CT.TokenManager , registerCID :: CID -> Connection -> IO () @@ -51,8 +53,8 @@ defaultClientRoleInfo :: RoleInfo defaultClientRoleInfo = ClientInfo { clientInitialToken = emptyToken - , resumptionInfo = defaultResumptionInfo - , serverAddr = Nothing + , resumptionInfo = defaultResumptionInfo + , incompatibleVN = False } defaultServerRoleInfo :: RoleInfo @@ -93,40 +95,42 @@ | RecvResponse deriving (Eq, Show) +---------------------------------------------------------------- + data Coder = Coder { - encrypt :: Buffer -> Int -> Buffer -> Int -> PacketNumber -> Buffer -> IO Int - , decrypt :: Buffer -> Int -> Buffer -> Int -> PacketNumber -> Buffer -> IO Int + encrypt :: Buffer -> PlainText -> AssDat -> PacketNumber -> IO Int + , decrypt :: Buffer -> CipherText -> AssDat -> PacketNumber -> IO Int + , supplement :: Maybe Supplement } initialCoder :: Coder initialCoder = Coder { - encrypt = \_ _ _ _ _ _ -> return (-1) - , decrypt = \_ _ _ _ _ _ -> return (-1) + encrypt = \_ _ _ _ -> return (-1) + , decrypt = \_ _ _ _ -> return (-1) + , supplement = Nothing } data Coder1RTT = Coder1RTT { coder1RTT :: Coder , secretN :: TrafficSecrets ApplicationSecret - , supplement :: ~Supplement } initialCoder1RTT :: Coder1RTT initialCoder1RTT = Coder1RTT { coder1RTT = initialCoder , secretN = (ClientTrafficSecret "", ServerTrafficSecret "") - , supplement = undefined } data Protector = Protector { - setSample :: Ptr Word8 -> IO () - , getMask :: IO (Ptr Word8) + setSample :: Buffer -> IO () + , getMask :: IO Buffer , unprotect :: Sample -> Mask } initialProtector :: Protector initialProtector = Protector { - setSample = \_ -> return () - , getMask = return nullPtr + setSample = \_ -> return () + , getMask = return nullPtr , unprotect = \_ -> Mask "" } @@ -162,6 +166,11 @@ ---------------------------------------------------------------- +type Send = Buffer -> Int -> IO () +type Recv = IO ReceivedPacket + +---------------------------------------------------------------- + -- | A quic connection to carry multiple streams. data Connection = Connection { connState :: ConnState @@ -169,15 +178,18 @@ , connDebugLog :: DebugLogger -- ^ A logger for debugging. , connQLog :: QLogger , connHooks :: Hooks + , connSend :: ~Send -- ~ for testing + , connRecv :: ~Recv -- ~ for testing -- Manage , connRecvQ :: RecvQ - , sockets :: IORef [Socket] + , udpSocket :: ~(IORef UDPSocket) , readers :: IORef (IO ()) , tmouter :: IORef (IO ()) , mainThreadId :: ThreadId -- Info , roleInfo :: IORef RoleInfo - , quicVersion :: IORef Version + , quicVersionInfo :: IORef VersionInfo + , origVersionInfo :: VersionInfo -- chosenVersion is client's ver in Initial -- Mine , myParameters :: Parameters , myCIDDB :: IORef CIDDB @@ -213,9 +225,13 @@ , protectors :: IOArray EncryptionLevel Protector , currentKeyPhase :: IORef (Bool, PacketNumber) , negotiated :: IORef Negotiated - , handshakeCIDs :: IORef AuthCIDs + , connMyAuthCIDs :: IORef AuthCIDs + , connPeerAuthCIDs :: IORef AuthCIDs -- Resources , connResources :: IORef (IO ()) + , encodeBuf :: Buffer + , encryptRes :: SizedBuffer + , decryptBuf :: Buffer -- Recovery , connLDCC :: LDCC } @@ -245,22 +261,29 @@ newConnection :: Role -> Parameters - -> Version -> AuthCIDs -> AuthCIDs + -> VersionInfo -> AuthCIDs -> AuthCIDs -> DebugLogger -> QLogger -> Hooks - -> IORef [Socket] + -> IORef UDPSocket -> RecvQ + -> Send + -> Recv -> IO Connection -newConnection rl myparams ver myAuthCIDs peerAuthCIDs debugLog qLog hooks sref recvQ = do +newConnection rl myparams verInfo myAuthCIDs peerAuthCIDs debugLog qLog hooks sref recvQ ~send ~recv = do outQ <- newTQueueIO let put x = atomically $ writeTQueue outQ $ OutRetrans x connstate <- newConnState rl - Connection connstate debugLog qLog hooks recvQ sref + let bufsiz = maximumUdpPayloadSize + encBuf <- mallocBytes bufsiz + ecrptBuf <- mallocBytes bufsiz + dcrptBuf <- mallocBytes bufsiz + Connection connstate debugLog qLog hooks send recv recvQ sref <$> newIORef (return ()) <*> newIORef (return ()) <*> myThreadId -- Info <*> newIORef initialRoleInfo - <*> newIORef ver + <*> newIORef verInfo + <*> return verInfo -- Mine <*> return myparams <*> newIORef (newCIDDB myCID) @@ -296,9 +319,13 @@ <*> newArray (InitialLevel,RTT1Level) initialProtector <*> newIORef (False,0) <*> newIORef initialNegotiated + <*> newIORef myAuthCIDs <*> newIORef peerAuthCIDs -- Resources - <*> newIORef (return ()) + <*> newIORef (free encBuf >> free ecrptBuf >> free dcrptBuf) + <*> return encBuf -- used sender or closere + <*> return (SizedBuffer ecrptBuf bufsiz) -- used sender + <*> return dcrptBuf -- used receiver -- Recovery <*> newLDCC connstate qLog put where @@ -306,8 +333,8 @@ initialRoleInfo | isclient = defaultClientRoleInfo | otherwise = defaultServerRoleInfo - Just myCID = initSrcCID myAuthCIDs - Just peerCID = initSrcCID peerAuthCIDs + myCID = fromJust $ initSrcCID myAuthCIDs + peerCID = fromJust $ initSrcCID peerAuthCIDs peer | isclient = Server | otherwise = Client peerConcurrency = newConcurrency peer Bidirectional (initialMaxStreamsBidi myparams) @@ -318,22 +345,22 @@ ---------------------------------------------------------------- clientConnection :: ClientConfig - -> Version -> AuthCIDs -> AuthCIDs + -> VersionInfo -> AuthCIDs -> AuthCIDs -> DebugLogger -> QLogger -> Hooks - -> IORef [Socket] - -> RecvQ + -> IORef UDPSocket + -> RecvQ -> Send -> Recv -> IO Connection -clientConnection ClientConfig{..} ver myAuthCIDs peerAuthCIDs = - newConnection Client ccParameters ver myAuthCIDs peerAuthCIDs +clientConnection ClientConfig{..} verInfo myAuthCIDs peerAuthCIDs = + newConnection Client ccParameters verInfo myAuthCIDs peerAuthCIDs serverConnection :: ServerConfig - -> Version -> AuthCIDs -> AuthCIDs + -> VersionInfo -> AuthCIDs -> AuthCIDs -> DebugLogger -> QLogger -> Hooks - -> IORef [Socket] - -> RecvQ + -> IORef UDPSocket + -> RecvQ -> Send -> Recv -> IO Connection -serverConnection ServerConfig{..} ver myAuthCIDs peerAuthCIDs = - newConnection Server scParameters ver myAuthCIDs peerAuthCIDs +serverConnection ServerConfig{..} verInfo myAuthCIDs peerAuthCIDs = + newConnection Server scParameters verInfo myAuthCIDs peerAuthCIDs ---------------------------------------------------------------- diff --git a/Network/QUIC/Connector.hs b/Network/QUIC/Connector.hs --- a/Network/QUIC/Connector.hs +++ b/Network/QUIC/Connector.hs @@ -1,8 +1,8 @@ module Network.QUIC.Connector where -import Control.Concurrent.STM import Data.IORef import Network.QUIC.Types +import UnliftIO.STM class Connector a where getRole :: a -> Role diff --git a/Network/QUIC/Crypto.hs b/Network/QUIC/Crypto.hs --- a/Network/QUIC/Crypto.hs +++ b/Network/QUIC/Crypto.hs @@ -2,378 +2,18 @@ {-# LANGUAGE OverloadedStrings #-} module Network.QUIC.Crypto ( - -- * Payload encryption - defaultCipher - , initialSecrets - , clientInitialSecret - , serverInitialSecret - , aeadKey - , initialVector - , nextSecret - , headerProtectionKey - , makeNonce - , encryptPayload - , encryptPayload' - , decryptPayload - , decryptPayload' - -- * Header Protection - , protectionMask - , tagLength - , sampleLength - , bsXOR --- , unprotectHeader - -- * Types - , PlainText - , CipherText - , Key(..) - , IV(..) - , CID - , Secret(..) - , AddDat(..) - , Sample(..) - , Mask(..) - , Nonce(..) - , Cipher - , InitialSecret - , TrafficSecrets - , ClientTrafficSecret(..) - , ServerTrafficSecret(..) - -- * Misc - , calculateIntegrityTag + module Network.QUIC.Crypto.Fusion + , module Network.QUIC.Crypto.Nite + , module Network.QUIC.Crypto.Types + , module Network.QUIC.Crypto.Keys + , module Network.QUIC.Crypto.Utils ) where -import Crypto.Cipher.AES -import qualified Crypto.Cipher.ChaCha as ChaCha -import qualified Crypto.Cipher.ChaChaPoly1305 as ChaChaPoly -import Crypto.Cipher.Types hiding (Cipher, IV) -import Crypto.Error (throwCryptoError, maybeCryptoError) -import qualified Crypto.MAC.Poly1305 as Poly1305 -import qualified Data.ByteArray as Byte (convert, xor) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Short as Short -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (Ptr, plusPtr) -import Foreign.Storable (peek, poke) import Network.TLS hiding (Version) -import Network.TLS.Extra.Cipher import Network.TLS.QUIC -import qualified UnliftIO.Exception as E -import Network.QUIC.Imports -import Network.QUIC.Types - ----------------------------------------------------------------- - -defaultCipher :: Cipher -defaultCipher = cipher_TLS13_AES128GCM_SHA256 - ----------------------------------------------------------------- - -type PlainText = ByteString -type CipherText = ByteString -type Salt = ByteString - -newtype Key = Key ByteString deriving (Eq) -newtype IV = IV ByteString deriving (Eq) -newtype Secret = Secret ByteString deriving (Eq) -newtype AddDat = AddDat ByteString deriving (Eq) -newtype Sample = Sample ByteString deriving (Eq) -newtype Mask = Mask ByteString deriving (Eq) -newtype Label = Label ByteString deriving (Eq) -newtype Nonce = Nonce ByteString deriving (Eq) - -instance Show Key where - show (Key x) = "Key=" ++ C8.unpack (enc16 x) -instance Show IV where - show (IV x) = "IV=" ++ C8.unpack (enc16 x) -instance Show Secret where - show (Secret x) = "Secret=" ++ C8.unpack (enc16 x) -instance Show AddDat where - show (AddDat x) = "AddDat=" ++ C8.unpack (enc16 x) -instance Show Sample where - show (Sample x) = "Sample=" ++ C8.unpack (enc16 x) -instance Show Mask where - show (Mask x) = "Mask=" ++ C8.unpack (enc16 x) -instance Show Label where - show (Label x) = "Label=" ++ C8.unpack (enc16 x) -instance Show Nonce where - show (Nonce x) = "Nonce=" ++ C8.unpack (enc16 x) - ----------------------------------------------------------------- - -initialSalt :: Version -> Salt -initialSalt Draft29 = "\xaf\xbf\xec\x28\x99\x93\xd2\x4c\x9e\x97\x86\xf1\x9c\x61\x11\xe0\x43\x90\xa8\x99" -initialSalt Version1 = "\x38\x76\x2c\xf7\xf5\x59\x34\xb3\x4d\x17\x9a\xe6\xa4\xc8\x0c\xad\xcc\xbb\x7f\x0a" -initialSalt (Version v) = E.impureThrow $ VersionIsUnknown v - -data InitialSecret - -initialSecrets :: Version -> CID -> TrafficSecrets InitialSecret -initialSecrets v c = (clientInitialSecret v c, serverInitialSecret v c) - -clientInitialSecret :: Version -> CID -> ClientTrafficSecret InitialSecret -clientInitialSecret v c = ClientTrafficSecret $ initialSecret (Label "client in") v c - -serverInitialSecret :: Version -> CID -> ServerTrafficSecret InitialSecret -serverInitialSecret v c = ServerTrafficSecret $ initialSecret (Label "server in") v c - -initialSecret :: Label -> Version -> CID -> ByteString -initialSecret _ GreasingVersion _ = "greasing !!!!" -initialSecret _ GreasingVersion2 _ = "greasing !!!!" -initialSecret (Label label) ver cid = secret - where - cipher = defaultCipher - hash = cipherHash cipher - iniSecret = hkdfExtract hash (initialSalt ver) $ fromCID cid - hashSize = hashDigestSize hash - secret = hkdfExpandLabel hash iniSecret label "" hashSize - -aeadKey :: Cipher -> Secret -> Key -aeadKey = genKey (Label "quic key") - -headerProtectionKey :: Cipher -> Secret -> Key -headerProtectionKey = genKey (Label "quic hp") - -genKey :: Label -> Cipher -> Secret -> Key -genKey (Label label) cipher (Secret secret) = Key key - where - hash = cipherHash cipher - bulk = cipherBulk cipher - keySize = bulkKeySize bulk - key = hkdfExpandLabel hash secret label "" keySize - -initialVector :: Cipher -> Secret -> IV -initialVector cipher (Secret secret) = IV iv - where - hash = cipherHash cipher - bulk = cipherBulk cipher - ivSize = max 8 (bulkIVSize bulk + bulkExplicitIV bulk) - iv = hkdfExpandLabel hash secret "quic iv" "" ivSize - -nextSecret :: Cipher -> Secret -> Secret -nextSecret cipher (Secret secN) = Secret secN1 - where - label = "quic ku" - hash = cipherHash cipher - hashSize = hashDigestSize hash - secN1 = hkdfExpandLabel hash secN label "" hashSize - ----------------------------------------------------------------- - --- It would be nice to take [PlainText] and update AEAD context with --- [PlainText]. But since each PlainText is not aligned to cipher block, --- it's impossible. -cipherEncrypt :: Cipher -> Key -> Nonce -> PlainText -> AddDat -> [CipherText] -cipherEncrypt cipher - | cipher == cipher_TLS13_AES128GCM_SHA256 = aes128gcmEncrypt - | cipher == cipher_TLS13_AES128CCM_SHA256 = error "cipher_TLS13_AES128CCM_SHA256" - | cipher == cipher_TLS13_AES256GCM_SHA384 = aes256gcmEncrypt - | cipher == cipher_TLS13_CHACHA20POLY1305_SHA256 = chacha20poly1305Encrypt - | otherwise = error "cipherEncrypt" - -cipherDecrypt :: Cipher -> Key -> Nonce -> CipherText -> AddDat -> Maybe PlainText -cipherDecrypt cipher - | cipher == cipher_TLS13_AES128GCM_SHA256 = aes128gcmDecrypt - | cipher == cipher_TLS13_AES128CCM_SHA256 = error "cipher_TLS13_AES128CCM_SHA256" - | cipher == cipher_TLS13_AES256GCM_SHA384 = aes256gcmDecrypt - | cipher == cipher_TLS13_CHACHA20POLY1305_SHA256 = chacha20poly1305Decrypt - | otherwise = error "cipherDecrypt" - --- IMPORTANT: Using 'let' so that parameters can be memorized. -aes128gcmEncrypt :: Key -> (Nonce -> PlainText -> AddDat -> [CipherText]) -aes128gcmEncrypt (Key key) = - let aes = throwCryptoError (cipherInit key) :: AES128 - in \(Nonce nonce) plaintext (AddDat ad) -> - let aead = throwCryptoError $ aeadInit AEAD_GCM aes nonce - (AuthTag tag0, ciphertext) = aeadSimpleEncrypt aead ad plaintext 16 - tag = Byte.convert tag0 - in [ciphertext,tag] - -aes128gcmDecrypt :: Key -> (Nonce -> CipherText -> AddDat -> Maybe PlainText) -aes128gcmDecrypt (Key key) = - let aes = throwCryptoError (cipherInit key) :: AES128 - in \(Nonce nonce) ciphertag (AddDat ad) -> - let aead = throwCryptoError $ aeadInit AEAD_GCM aes nonce - (ciphertext, tag) = BS.splitAt (BS.length ciphertag - 16) ciphertag - authtag = AuthTag $ Byte.convert tag - in aeadSimpleDecrypt aead ad ciphertext authtag - -aes256gcmEncrypt :: Key -> (Nonce -> PlainText -> AddDat -> [CipherText]) -aes256gcmEncrypt (Key key) = - let aes = throwCryptoError (cipherInit key) :: AES256 - in \(Nonce nonce) plaintext (AddDat ad) -> - let aead = throwCryptoError $ aeadInit AEAD_GCM aes nonce - (AuthTag tag0, ciphertext) = aeadSimpleEncrypt aead ad plaintext 16 - tag = Byte.convert tag0 - in [ciphertext, tag] - -aes256gcmDecrypt :: Key -> (Nonce -> CipherText -> AddDat -> Maybe PlainText) -aes256gcmDecrypt (Key key) = - let aes = throwCryptoError (cipherInit key) :: AES256 - in \(Nonce nonce) ciphertag (AddDat ad) -> - let aead = throwCryptoError $ aeadInit AEAD_GCM aes nonce - (ciphertext, tag) = BS.splitAt (BS.length ciphertag - 16) ciphertag - authtag = AuthTag $ Byte.convert tag - in aeadSimpleDecrypt aead ad ciphertext authtag - -chacha20poly1305Encrypt :: Key -> Nonce -> PlainText -> AddDat -> [CipherText] -chacha20poly1305Encrypt (Key key) (Nonce nonce) plaintext (AddDat ad) = - [ciphertext,Byte.convert tag] - where - st1 = throwCryptoError (ChaChaPoly.nonce12 nonce >>= ChaChaPoly.initialize key) - st2 = ChaChaPoly.finalizeAAD (ChaChaPoly.appendAAD ad st1) - (ciphertext, st3) = ChaChaPoly.encrypt plaintext st2 - Poly1305.Auth tag = ChaChaPoly.finalize st3 - -chacha20poly1305Decrypt :: Key -> Nonce -> CipherText -> AddDat -> Maybe PlainText -chacha20poly1305Decrypt (Key key) (Nonce nonce) ciphertag (AddDat ad) = do - st <- maybeCryptoError (ChaChaPoly.nonce12 nonce >>= ChaChaPoly.initialize key) - let st2 = ChaChaPoly.finalizeAAD (ChaChaPoly.appendAAD ad st) - (ciphertext, tag) = BS.splitAt (BS.length ciphertag - 16) ciphertag - (plaintext, st3) = ChaChaPoly.decrypt ciphertext st2 - Poly1305.Auth tag' = ChaChaPoly.finalize st3 - if tag == Byte.convert tag' then Just plaintext else Nothing - ----------------------------------------------------------------- - -makeNonce :: IV -> ByteString -> Nonce -makeNonce (IV iv) pn = Nonce nonce - where - nonce = bsXORpad iv pn - ----------------------------------------------------------------- - -encryptPayload :: Cipher -> Key -> IV - -> (PlainText -> ByteString -> PacketNumber -> [CipherText]) -encryptPayload cipher key iv = - let enc = cipherEncrypt cipher key - mk = makeNonce iv - in \plaintext header pn -> let bytePN = bytestring64 $ fromIntegral pn - nonce = mk bytePN - in enc nonce plaintext (AddDat header) - -encryptPayload' :: Cipher -> Key -> Nonce -> PlainText -> AddDat -> [CipherText] -encryptPayload' cipher key nonce plaintext header = - cipherEncrypt cipher key nonce plaintext header - ----------------------------------------------------------------- - -decryptPayload :: Cipher -> Key -> IV - -> (CipherText -> ByteString -> PacketNumber -> Maybe PlainText) -decryptPayload cipher key iv = - let dec = cipherDecrypt cipher key - mk = makeNonce iv - in \ciphertext header pn -> let bytePN = bytestring64 (fromIntegral pn) - nonce = mk bytePN - in dec nonce ciphertext (AddDat header) - -decryptPayload' :: Cipher -> Key -> Nonce -> CipherText -> AddDat -> Maybe PlainText -decryptPayload' cipher key nonce ciphertext header = - cipherDecrypt cipher key nonce ciphertext header - ----------------------------------------------------------------- - -protectionMask :: Cipher -> Key -> (Sample -> Mask) -protectionMask cipher key = - let f = cipherHeaderProtection cipher key - in \sample -> f sample - -cipherHeaderProtection :: Cipher -> Key -> (Sample -> Mask) -cipherHeaderProtection cipher key - | cipher == cipher_TLS13_AES128GCM_SHA256 = aes128ecbEncrypt key - | cipher == cipher_TLS13_AES128CCM_SHA256 = error "cipher_TLS13_AES128CCM_SHA256" - | cipher == cipher_TLS13_AES256GCM_SHA384 = aes256ecbEncrypt key - | cipher == cipher_TLS13_CHACHA20POLY1305_SHA256 = chachaEncrypt key - | otherwise = error "cipherHeaderProtection" - -aes128ecbEncrypt :: Key -> (Sample -> Mask) -aes128ecbEncrypt (Key key) = - let encrypt = ecbEncrypt (throwCryptoError (cipherInit key) :: AES128) - in \(Sample sample) -> let mask = encrypt sample - in Mask mask - -aes256ecbEncrypt :: Key -> (Sample -> Mask) -aes256ecbEncrypt (Key key) = - let encrypt = ecbEncrypt (throwCryptoError (cipherInit key) :: AES256) - in \(Sample sample) -> let mask = encrypt sample - in Mask mask - -chachaEncrypt :: Key -> Sample -> Mask -chachaEncrypt (Key key) (Sample sample0) = Mask mask - where - -- fixme: cryptonite hard-codes the counter, sigh - (_counter,nonce) = BS.splitAt 4 sample0 - st = ChaCha.initialize 20 key nonce - (mask,_) = ChaCha.combine st "\x0\x0\x0\x0\x0" - -tagLength :: Cipher -> Int -tagLength cipher - | cipher == cipher_TLS13_AES128GCM_SHA256 = 16 - | cipher == cipher_TLS13_AES128CCM_SHA256 = 16 - | cipher == cipher_TLS13_AES256GCM_SHA384 = 16 - | cipher == cipher_TLS13_CHACHA20POLY1305_SHA256 = 16 -- fixme - | otherwise = error "tagLength" - -sampleLength :: Cipher -> Int -sampleLength cipher - | cipher == cipher_TLS13_AES128GCM_SHA256 = 16 - | cipher == cipher_TLS13_AES128CCM_SHA256 = 16 - | cipher == cipher_TLS13_AES256GCM_SHA384 = 16 - | cipher == cipher_TLS13_CHACHA20POLY1305_SHA256 = 16 -- fixme - | otherwise = error "sampleLength" - -bsXOR :: ByteString -> ByteString -> ByteString -bsXOR = Byte.xor - --- XORing IV and a packet numbr with left padded. --- src0 --- IV +IIIIIIIIIIIIIIIIII--------+ --- diff src1 --- PN +000000000000000000+-------+ --- dst --- Nonce +IIIIIIIIIIIIIIIIII--------+ -bsXORpad :: ByteString -> ByteString -> ByteString -bsXORpad (PS fp0 off0 len0) (PS fp1 off1 len1) - | len0 < len1 = error "bsXORpad" - | otherwise = BS.unsafeCreate len0 $ \dst -> - withForeignPtr fp0 $ \p0 -> - withForeignPtr fp1 $ \p1 -> do - let src0 = p0 `plusPtr` off0 - let src1 = p1 `plusPtr` off1 - let diff = len0 - len1 - BS.memcpy dst src0 diff - loop (dst `plusPtr` diff) (src0 `plusPtr` diff) src1 len1 - where - loop :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Int -> IO () - loop _ _ _ 0 = return () - loop dst src0 src1 len = do - w1 <- peek src0 - w2 <- peek src1 - poke dst (w1 `xor` w2) - loop (dst `plusPtr` 1) (src0 `plusPtr` 1) (src1 `plusPtr` 1) (len - 1) - -{- -bsXORpad' :: ByteString -> ByteString -> ByteString -bsXORpad' iv pn = BS.pack $ zipWith xor ivl pnl - where - ivl = BS.unpack iv - diff = BS.length iv - BS.length pn - pnl = replicate diff 0 ++ BS.unpack pn --} - ----------------------------------------------------------------- - -calculateIntegrityTag :: Version -> CID -> ByteString -> ByteString -calculateIntegrityTag ver oCID pseudo0 = - BS.concat $ aes128gcmEncrypt key nonce "" (AddDat pseudo) - where - (ocid, ocidlen) = unpackCID oCID - pseudo = BS.concat [BS.singleton ocidlen - ,Short.fromShort ocid - ,pseudo0] - key | ver == Version1 = Key "\xbe\x0c\x69\x0b\x9f\x66\x57\x5a\x1d\x76\x6b\x54\xe3\x68\xc8\x4e" - | otherwise = Key "\xcc\xce\x18\x7e\xd0\x9a\x09\xd0\x57\x28\x15\x5a\x6c\xb9\x6b\xe1" - nonce | ver == Version1 = Nonce "\x46\x15\x99\xd3\x5d\x63\x2b\xf2\x23\x98\x25\xbb" - | otherwise = Nonce "\xe5\x49\x30\xf9\x7f\x21\x36\xf0\x53\x0a\x8c\x1c" +import Network.QUIC.Crypto.Fusion +import Network.QUIC.Crypto.Keys +import Network.QUIC.Crypto.Nite +import Network.QUIC.Crypto.Types +import Network.QUIC.Crypto.Utils diff --git a/Network/QUIC/Crypto/Fusion.hs b/Network/QUIC/Crypto/Fusion.hs new file mode 100644 --- /dev/null +++ b/Network/QUIC/Crypto/Fusion.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP #-} + +module Network.QUIC.Crypto.Fusion ( + FusionContext + , fusionNewContext + , fusionSetup + , fusionEncrypt + , fusionDecrypt + , Supplement + , fusionSetupSupplement + , fusionSetSample + , fusionGetMask + ) where + +#ifdef USE_FUSION +import qualified Data.ByteString as BS +import Foreign.C.Types +import Foreign.ForeignPtr +import Foreign.Ptr +import Network.TLS.Extra.Cipher + +import Network.QUIC.Crypto.Types +import Network.QUIC.Imports +import Network.QUIC.Types + +---------------------------------------------------------------- + +data FusionContextOpaque +newtype FusionContext = FC (ForeignPtr FusionContextOpaque) + +fusionNewContext :: IO FusionContext +fusionNewContext = FC <$> (c_aead_context_new >>= newForeignPtr p_aead_context_free) + +---------------------------------------------------------------- + +fusionSetup :: Cipher -> FusionContext -> Key -> IV -> IO () +fusionSetup cipher + | cipher == cipher_TLS13_AES128GCM_SHA256 = fusionSetupAES128 + | cipher == cipher_TLS13_AES256GCM_SHA384 = fusionSetupAES256 + | otherwise = error "fusionSetup" + +fusionSetupAES128 :: FusionContext -> Key -> IV -> IO () +fusionSetupAES128 (FC fctx) (Key key) (IV iv) = withForeignPtr fctx $ \pctx -> + withByteString key $ \keyp -> + withByteString iv $ \ivp -> void $ c_aes128gcm_setup pctx 0 keyp ivp + +fusionSetupAES256 :: FusionContext -> Key -> IV -> IO () +fusionSetupAES256 (FC fctx) (Key key) (IV iv) = withForeignPtr fctx $ \pctx -> + withByteString key $ \keyp -> + withByteString iv $ \ivp -> void $ c_aes256gcm_setup pctx 0 keyp ivp + +---------------------------------------------------------------- + +fusionEncrypt :: FusionContext -> Supplement + -> Buffer -> PlainText -> AssDat -> PacketNumber -> IO Int +fusionEncrypt (FC fctx) (SP fsupp) obuf plaintext (AssDat header) pn = + withForeignPtr fctx $ \pctx -> withForeignPtr fsupp $ \psupp -> do + withByteString plaintext $ \ibuf -> + withByteString header $ \abuf -> do + c_aead_do_encrypt pctx obuf ibuf ilen' pn' abuf alen psupp + return (ilen + 16) -- fixme + where + pn' = fromIntegral pn + ilen = BS.length plaintext + ilen' = fromIntegral ilen + alen = fromIntegral $ BS.length header + +fusionDecrypt :: FusionContext + -> Buffer -> CipherText -> AssDat -> PacketNumber -> IO Int +fusionDecrypt (FC fctx) obuf ciphertext (AssDat header) pn = + withForeignPtr fctx $ \pctx -> + withByteString ciphertext $ \ibuf -> + withByteString header $ \abuf -> + fromIntegral <$> c_aead_do_decrypt pctx obuf ibuf ilen pn' abuf alen + where + pn' = fromIntegral pn + ilen = fromIntegral $ BS.length ciphertext + alen = fromIntegral $ BS.length header + +---------------------------------------------------------------- + +data SupplementOpaque +newtype Supplement = SP (ForeignPtr SupplementOpaque) + +fusionSetupSupplement :: Cipher -> Key -> IO Supplement +fusionSetupSupplement cipher (Key hpkey) = withByteString hpkey $ \hpkeyp -> + SP <$> (c_supplement_new hpkeyp keylen >>= newForeignPtr p_supplement_free) + where + keylen + | cipher == cipher_TLS13_AES128GCM_SHA256 = 16 + | otherwise = 32 + +fusionSetSample :: Supplement -> Buffer -> IO () +fusionSetSample (SP fsupp) p = withForeignPtr fsupp $ \psupp -> + c_supplement_set_sample psupp p + +fusionGetMask :: Supplement -> IO Buffer +fusionGetMask (SP fsupp) = withForeignPtr fsupp c_supplement_get_mask + +---------------------------------------------------------------- + +foreign import ccall unsafe "aead_context_new" + c_aead_context_new :: IO (Ptr FusionContextOpaque) + +foreign import ccall unsafe "&aead_context_free" + p_aead_context_free :: FunPtr (Ptr FusionContextOpaque -> IO ()) + +foreign import ccall unsafe "aes128gcm_setup" + c_aes128gcm_setup :: Ptr FusionContextOpaque + -> CInt -- dummy + -> Ptr Word8 -- key + -> Ptr Word8 -- iv + -> IO CInt + +foreign import ccall unsafe "aes256gcm_setup" + c_aes256gcm_setup :: Ptr FusionContextOpaque + -> CInt -- dummy + -> Ptr Word8 -- key + -> Ptr Word8 -- iv + -> IO CInt +{- +foreign import ccall unsafe "aesgcm_dispose_crypto" + c_aesgcm_dispose_crypto :: FusionContext -> IO () +-} + +foreign import ccall unsafe "aead_do_encrypt" + c_aead_do_encrypt :: Ptr FusionContextOpaque + -> Ptr Word8 -- output + -> Ptr Word8 -- input + -> CSize -- input length + -> CULong -- sequence + -> Ptr Word8 -- AAD + -> CSize -- AAD length + -> Ptr SupplementOpaque + -> IO () + +foreign import ccall unsafe "aead_do_decrypt" + c_aead_do_decrypt :: Ptr FusionContextOpaque + -> Ptr Word8 -- output + -> Ptr Word8 -- input + -> CSize -- input length + -> CULong -- sequence + -> Ptr Word8 -- AAD + -> CSize -- AAD length + -> IO CSize + +foreign import ccall unsafe "supplement_new" + c_supplement_new :: Ptr Word8 -> CInt -> IO (Ptr SupplementOpaque) + +foreign import ccall unsafe "&supplement_free" + p_supplement_free :: FunPtr (Ptr SupplementOpaque -> IO ()) + +foreign import ccall unsafe "supplement_set_sample" + c_supplement_set_sample :: Ptr SupplementOpaque -> Ptr Word8 -> IO () + +foreign import ccall unsafe "supplement_get_mask" + c_supplement_get_mask :: Ptr SupplementOpaque -> IO (Ptr Word8) +#else +import Network.QUIC.Crypto.Types +import Network.QUIC.Imports +import Network.QUIC.Types + +data FusionContext + +fusionNewContext :: IO FusionContext +fusionNewContext = undefined + +fusionSetup :: Cipher -> FusionContext -> Key -> IV -> IO () +fusionSetup = undefined + +fusionEncrypt :: FusionContext -> Supplement + -> Buffer -> PlainText -> AssDat -> PacketNumber -> IO Int +fusionEncrypt = undefined + +fusionDecrypt :: FusionContext + -> Buffer -> CipherText -> AssDat -> PacketNumber -> IO Int +fusionDecrypt = undefined + +data Supplement + +fusionSetupSupplement :: Cipher -> Key -> IO Supplement +fusionSetupSupplement = undefined + +fusionSetSample :: Supplement -> Buffer -> IO () +fusionSetSample = undefined + +fusionGetMask :: Supplement -> IO Buffer +fusionGetMask = undefined +#endif diff --git a/Network/QUIC/Crypto/Keys.hs b/Network/QUIC/Crypto/Keys.hs new file mode 100644 --- /dev/null +++ b/Network/QUIC/Crypto/Keys.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.QUIC.Crypto.Keys ( + defaultCipher + , initialSecrets + , clientInitialSecret + , serverInitialSecret + , aeadKey + , initialVector + , nextSecret + , headerProtectionKey + ) where + +import Network.TLS hiding (Version) +import Network.TLS.Extra.Cipher +import Network.TLS.QUIC +import qualified UnliftIO.Exception as E + +import Network.QUIC.Crypto.Types +import Network.QUIC.Imports +import Network.QUIC.Types + +---------------------------------------------------------------- + +defaultCipher :: Cipher +defaultCipher = cipher_TLS13_AES128GCM_SHA256 + +---------------------------------------------------------------- + +initialSalt :: Version -> Salt +initialSalt Draft29 = "\xaf\xbf\xec\x28\x99\x93\xd2\x4c\x9e\x97\x86\xf1\x9c\x61\x11\xe0\x43\x90\xa8\x99" +initialSalt Version1 = "\x38\x76\x2c\xf7\xf5\x59\x34\xb3\x4d\x17\x9a\xe6\xa4\xc8\x0c\xad\xcc\xbb\x7f\x0a" +initialSalt Version2 = "\x0d\xed\xe3\xde\xf7\x00\xa6\xdb\x81\x93\x81\xbe\x6e\x26\x9d\xcb\xf9\xbd\x2e\xd9" +initialSalt (Version v) = E.impureThrow $ VersionIsUnknown v + +initialSecrets :: Version -> CID -> TrafficSecrets InitialSecret +initialSecrets v c = (clientInitialSecret v c, serverInitialSecret v c) + +clientInitialSecret :: Version -> CID -> ClientTrafficSecret InitialSecret +clientInitialSecret v c = ClientTrafficSecret $ initialSecret v c $ Label "client in" + +serverInitialSecret :: Version -> CID -> ServerTrafficSecret InitialSecret +serverInitialSecret v c = ServerTrafficSecret $ initialSecret v c $ Label "server in" + +initialSecret :: Version -> CID -> Label -> ByteString +initialSecret Draft29 = initialSecret' $ initialSalt Draft29 +initialSecret Version1 = initialSecret' $ initialSalt Version1 +initialSecret Version2 = initialSecret' $ initialSalt Version2 +initialSecret _ = \_ _ -> "not supported" + +initialSecret' :: ByteString -> CID -> Label -> ByteString +initialSecret' salt cid (Label label) = secret + where + cipher = defaultCipher + hash = cipherHash cipher + iniSecret = hkdfExtract hash salt $ fromCID cid + hashSize = hashDigestSize hash + secret = hkdfExpandLabel hash iniSecret label "" hashSize + +aeadKey :: Version -> Cipher -> Secret -> Key +aeadKey Draft29 = genKey $ Label "quic key" +aeadKey Version1 = genKey $ Label "quic key" +aeadKey Version2 = genKey $ Label "quicv2 key" +aeadKey _ = genKey $ Label "not supported" + +headerProtectionKey :: Version -> Cipher -> Secret -> Key +headerProtectionKey Draft29 = genKey $ Label "quic hp" +headerProtectionKey Version1 = genKey $ Label "quic hp" +headerProtectionKey Version2 = genKey $ Label "quicv2 hp" +headerProtectionKey _ = genKey $ Label "not supported" + +genKey :: Label -> Cipher -> Secret -> Key +genKey (Label label) cipher (Secret secret) = Key key + where + hash = cipherHash cipher + bulk = cipherBulk cipher + keySize = bulkKeySize bulk + key = hkdfExpandLabel hash secret label "" keySize + +initialVector :: Version -> Cipher -> Secret -> IV +initialVector ver cipher (Secret secret) = IV iv + where + label = ivLabel ver + hash = cipherHash cipher + bulk = cipherBulk cipher + ivSize = max 8 (bulkIVSize bulk + bulkExplicitIV bulk) + iv = hkdfExpandLabel hash secret label "" ivSize + +ivLabel :: Version -> ByteString +ivLabel Draft29 = "quic iv" +ivLabel Version1 = "quic iv" +ivLabel Version2 = "quicv2 iv" +ivLabel _ = "not supported" + +nextSecret :: Version -> Cipher -> Secret -> Secret +nextSecret ver cipher (Secret secN) = Secret secN1 + where + label = kuLabel ver + hash = cipherHash cipher + hashSize = hashDigestSize hash + secN1 = hkdfExpandLabel hash secN label "" hashSize + +kuLabel :: Version -> ByteString +kuLabel Draft29 = "quic ku" +kuLabel Version1 = "quic ku" +kuLabel Version2 = "quicv2 ku" +kuLabel _ = "not supported" diff --git a/Network/QUIC/Crypto/Nite.hs b/Network/QUIC/Crypto/Nite.hs new file mode 100644 --- /dev/null +++ b/Network/QUIC/Crypto/Nite.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.QUIC.Crypto.Nite ( + niteEncrypt + , niteEncrypt' + , niteDecrypt + , niteDecrypt' + , protectionMask + , aes128gcmEncrypt + , makeNonce + , makeNiteEncrypt + , makeNiteDecrypt + , makeNiteProtector + ) where + +import Crypto.Cipher.AES +import Crypto.Cipher.Types hiding (Cipher, IV) +import Crypto.Error (maybeCryptoError) +import qualified Data.ByteArray as Byte (convert) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BS +import Foreign.ForeignPtr (withForeignPtr, newForeignPtr_) +import Foreign.Marshal.Alloc (mallocBytes) +import Foreign.Ptr (Ptr, plusPtr, nullPtr) +import Foreign.Storable (peek, poke) +import Network.TLS hiding (Version) +import Network.TLS.Extra.Cipher + +import Network.QUIC.Crypto.Types +import Network.QUIC.Imports +import Network.QUIC.Types + +---------------------------------------------------------------- + +-- It would be nice to take [PlainText] and update AEAD context with +-- [PlainText]. But since each PlainText is not aligned to cipher block, +-- it's impossible. +cipherEncrypt :: Cipher -> Key -> Nonce -> PlainText -> AssDat -> Maybe (CipherText,CipherText) +cipherEncrypt cipher + | cipher == cipher_TLS13_AES128GCM_SHA256 = aes128gcmEncrypt + | cipher == cipher_TLS13_AES128CCM_SHA256 = error "cipher_TLS13_AES128CCM_SHA256" + | cipher == cipher_TLS13_AES256GCM_SHA384 = aes256gcmEncrypt + | otherwise = error "cipherEncrypt" + +cipherDecrypt :: Cipher -> Key -> Nonce -> CipherText -> AssDat -> Maybe PlainText +cipherDecrypt cipher + | cipher == cipher_TLS13_AES128GCM_SHA256 = aes128gcmDecrypt + | cipher == cipher_TLS13_AES128CCM_SHA256 = error "cipher_TLS13_AES128CCM_SHA256" + | cipher == cipher_TLS13_AES256GCM_SHA384 = aes256gcmDecrypt + | otherwise = error "cipherDecrypt" + +-- IMPORTANT: Using 'let' so that parameters can be memorized. +aes128gcmEncrypt :: Key -> (Nonce -> PlainText -> AssDat -> Maybe (CipherText,CipherText)) +aes128gcmEncrypt (Key key) = case maybeCryptoError $ cipherInit key of + Nothing -> \_ _ _ -> Nothing + Just (aes :: AES128) -> \(Nonce nonce) plaintext (AssDat ad) -> + case maybeCryptoError $ aeadInit AEAD_GCM aes nonce of + Nothing -> Nothing + Just aead -> + let (AuthTag tag0, ciphertext) = aeadSimpleEncrypt aead ad plaintext 16 + tag = Byte.convert tag0 + in Just (ciphertext,tag) + +aes128gcmDecrypt :: Key -> (Nonce -> CipherText -> AssDat -> Maybe PlainText) +aes128gcmDecrypt (Key key) = case maybeCryptoError $ cipherInit key of + Nothing -> \_ _ _ -> Nothing + Just (aes :: AES128) -> \(Nonce nonce) ciphertag (AssDat ad) -> + case maybeCryptoError $ aeadInit AEAD_GCM aes nonce of + Nothing -> Nothing + Just aead -> + let (ciphertext, tag) = BS.splitAt (BS.length ciphertag - 16) ciphertag + authtag = AuthTag $ Byte.convert tag + in aeadSimpleDecrypt aead ad ciphertext authtag + +aes256gcmEncrypt :: Key -> (Nonce -> PlainText -> AssDat -> Maybe (CipherText,CipherText)) +aes256gcmEncrypt (Key key) = case maybeCryptoError $ cipherInit key of + Nothing -> \_ _ _ -> Nothing + Just (aes :: AES256) -> \(Nonce nonce) plaintext (AssDat ad) -> + case maybeCryptoError $ aeadInit AEAD_GCM aes nonce of + Nothing -> Nothing + Just aead -> + let (AuthTag tag0, ciphertext) = aeadSimpleEncrypt aead ad plaintext 16 + tag = Byte.convert tag0 + in Just (ciphertext,tag) + +aes256gcmDecrypt :: Key -> (Nonce -> CipherText -> AssDat -> Maybe PlainText) +aes256gcmDecrypt (Key key) = case maybeCryptoError $ cipherInit key of + Nothing -> \_ _ _ -> Nothing + Just (aes :: AES256) -> \(Nonce nonce) ciphertag (AssDat ad) -> + case maybeCryptoError $ aeadInit AEAD_GCM aes nonce of + Nothing -> Nothing + Just aead -> + let (ciphertext, tag) = BS.splitAt (BS.length ciphertag - 16) ciphertag + authtag = AuthTag $ Byte.convert tag + in aeadSimpleDecrypt aead ad ciphertext authtag + +---------------------------------------------------------------- + +makeNonce :: IV -> ByteString -> Nonce +makeNonce (IV iv) pn = Nonce nonce + where + nonce = bsXORpad iv pn + +-- XORing IV and a packet numbr with left padded. +-- src0 +-- IV +IIIIIIIIIIIIIIIIII--------+ +-- diff src1 +-- PN +000000000000000000+-------+ +-- dst +-- Nonce +IIIIIIIIIIIIIIIIII--------+ +bsXORpad :: ByteString -> ByteString -> ByteString +bsXORpad (PS fp0 off0 len0) (PS fp1 off1 len1) + | len0 < len1 = error "bsXORpad" + | otherwise = BS.unsafeCreate len0 $ \dst -> + withForeignPtr fp0 $ \p0 -> + withForeignPtr fp1 $ \p1 -> do + let src0 = p0 `plusPtr` off0 + let src1 = p1 `plusPtr` off1 + let diff = len0 - len1 + BS.memcpy dst src0 diff + loop (dst `plusPtr` diff) (src0 `plusPtr` diff) src1 len1 + where + loop :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Int -> IO () + loop _ _ _ 0 = return () + loop dst src0 src1 len = do + w1 <- peek src0 + w2 <- peek src1 + poke dst (w1 `xor` w2) + loop (dst `plusPtr` 1) (src0 `plusPtr` 1) (src1 `plusPtr` 1) (len - 1) + +{- +bsXORpad' :: ByteString -> ByteString -> ByteString +bsXORpad' iv pn = BS.pack $ zipWith xor ivl pnl + where + ivl = BS.unpack iv + diff = BS.length iv - BS.length pn + pnl = replicate diff 0 ++ BS.unpack pn +-} + +---------------------------------------------------------------- + +type NiteEncrypt = Buffer -> PlainText -> AssDat -> PacketNumber -> IO Int + +makeNiteEncrypt :: Cipher -> Key -> IV -> NiteEncrypt +makeNiteEncrypt cipher key iv = niteEncryptWrapper (niteEncrypt cipher key iv) + +niteEncryptWrapper :: (PlainText -> AssDat -> PacketNumber -> Maybe (CipherText,CipherText)) -> NiteEncrypt +niteEncryptWrapper enc dst plaintext ad pn = case enc plaintext ad pn of + Nothing -> return (-1) + Just (hdr,bdy) -> do + len <- copyBS dst hdr + let dst' = dst `plusPtr` len + len' <- copyBS dst' bdy + return (len + len') + +niteEncrypt :: Cipher -> Key -> IV + -> PlainText -> AssDat -> PacketNumber -> Maybe (CipherText,CipherText) +niteEncrypt cipher key iv = + let enc = cipherEncrypt cipher key + mk = makeNonce iv + in \plaintext header pn -> let bytePN = bytestring64 $ fromIntegral pn + nonce = mk bytePN + in enc nonce plaintext header + +niteEncrypt' :: Cipher -> Key -> Nonce -> PlainText -> AssDat -> Maybe (CipherText,CipherText) +niteEncrypt' cipher key nonce plaintext header = + cipherEncrypt cipher key nonce plaintext header + +---------------------------------------------------------------- + +type NiteDecrypt = Buffer -> CipherText -> AssDat -> PacketNumber -> IO Int + +makeNiteDecrypt :: Cipher -> Key -> IV -> NiteDecrypt +makeNiteDecrypt cipher key iv = niteDecryptWrapper (niteDecrypt cipher key iv) + +niteDecryptWrapper :: (CipherText -> AssDat -> PacketNumber -> Maybe PlainText) -> NiteDecrypt +niteDecryptWrapper dec dst ciphertext ad pn = case dec ciphertext ad pn of + Nothing -> return (-1) + Just bs -> copyBS dst bs + +niteDecrypt :: Cipher -> Key -> IV + -> CipherText -> AssDat -> PacketNumber -> Maybe PlainText +niteDecrypt cipher key iv = + let dec = cipherDecrypt cipher key + mk = makeNonce iv + in \ciphertext header pn -> let bytePN = bytestring64 (fromIntegral pn) + nonce = mk bytePN + in dec nonce ciphertext header + +niteDecrypt' :: Cipher -> Key -> Nonce -> CipherText -> AssDat -> Maybe PlainText +niteDecrypt' cipher key nonce ciphertext header = + cipherDecrypt cipher key nonce ciphertext header + +---------------------------------------------------------------- + +protectionMask :: Cipher -> Key -> (Sample -> Mask) +protectionMask cipher key = + let f = cipherHeaderProtection cipher key + in \sample -> f sample + +cipherHeaderProtection :: Cipher -> Key -> (Sample -> Mask) +cipherHeaderProtection cipher key + | cipher == cipher_TLS13_AES128GCM_SHA256 = aes128ecbEncrypt key + | cipher == cipher_TLS13_AES128CCM_SHA256 = error "cipher_TLS13_AES128CCM_SHA256" + | cipher == cipher_TLS13_AES256GCM_SHA384 = aes256ecbEncrypt key + | otherwise = error "cipherHeaderProtection" + +aes128ecbEncrypt :: Key -> (Sample -> Mask) +aes128ecbEncrypt (Key key) = case maybeCryptoError $ cipherInit key of + Nothing -> \_ -> Mask "0123456789012345" + Just (aes :: AES128) -> + let encrypt = ecbEncrypt aes + in \(Sample sample) -> let mask = encrypt sample + in Mask mask + +aes256ecbEncrypt :: Key -> (Sample -> Mask) +aes256ecbEncrypt (Key key) = case maybeCryptoError $ cipherInit key of + Nothing -> \_ -> Mask "0123456789012345" + Just (aes :: AES256) -> + let encrypt = ecbEncrypt aes + in \(Sample sample) -> let mask = encrypt sample + in Mask mask + +---------------------------------------------------------------- + +makeNiteProtector :: Cipher -> Key -> IO (Buffer -> IO (), IO Buffer) +makeNiteProtector cipher key = do + ref <- newIORef nullPtr + dstbuf <- mallocBytes 32 -- fixme: free + return (niteSetSample ref, niteGetMask ref samplelen mkMask dstbuf) + where + samplelen = 16 -- sampleLength cipher -- fixme + mkMask = protectionMask cipher key + +niteSetSample :: IORef Buffer -> Buffer -> IO () +niteSetSample = writeIORef + +niteGetMask :: IORef Buffer -> Int -> (Sample -> Mask) -> Buffer -> IO Buffer +niteGetMask ref samplelen mkMask dstbuf = do + srcbuf <- readIORef ref + sample <- do + fptr <- newForeignPtr_ srcbuf + return $ PS fptr 0 samplelen + let Mask mask = mkMask $ Sample sample + _len <- copyBS dstbuf mask + return dstbuf diff --git a/Network/QUIC/Crypto/Types.hs b/Network/QUIC/Crypto/Types.hs new file mode 100644 --- /dev/null +++ b/Network/QUIC/Crypto/Types.hs @@ -0,0 +1,61 @@ +module Network.QUIC.Crypto.Types ( + -- * Types + PlainText + , CipherText + , Key(..) + , IV(..) + , CID + , Secret(..) + , AssDat(..) + , Sample(..) + , Mask(..) + , Nonce(..) + , Salt + , Label(..) + , Cipher + , InitialSecret + , TrafficSecrets + , ClientTrafficSecret(..) + , ServerTrafficSecret(..) + ) where + +import qualified Data.ByteString.Char8 as C8 +import Network.TLS hiding (Version) +import Network.TLS.QUIC + +import Network.QUIC.Imports +import Network.QUIC.Types + +---------------------------------------------------------------- + +type PlainText = ByteString +type CipherText = ByteString +type Salt = ByteString + +newtype Key = Key ByteString deriving (Eq) +newtype IV = IV ByteString deriving (Eq) +newtype Secret = Secret ByteString deriving (Eq) +newtype AssDat = AssDat ByteString deriving (Eq) +newtype Sample = Sample ByteString deriving (Eq) +newtype Mask = Mask ByteString deriving (Eq) +newtype Label = Label ByteString deriving (Eq) +newtype Nonce = Nonce ByteString deriving (Eq) + +instance Show Key where + show (Key x) = "Key=" ++ C8.unpack (enc16 x) +instance Show IV where + show (IV x) = "IV=" ++ C8.unpack (enc16 x) +instance Show Secret where + show (Secret x) = "Secret=" ++ C8.unpack (enc16 x) +instance Show AssDat where + show (AssDat x) = "AssDat=" ++ C8.unpack (enc16 x) +instance Show Sample where + show (Sample x) = "Sample=" ++ C8.unpack (enc16 x) +instance Show Mask where + show (Mask x) = "Mask=" ++ C8.unpack (enc16 x) +instance Show Label where + show (Label x) = "Label=" ++ C8.unpack (enc16 x) +instance Show Nonce where + show (Nonce x) = "Nonce=" ++ C8.unpack (enc16 x) + +data InitialSecret diff --git a/Network/QUIC/Crypto/Utils.hs b/Network/QUIC/Crypto/Utils.hs new file mode 100644 --- /dev/null +++ b/Network/QUIC/Crypto/Utils.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.QUIC.Crypto.Utils ( + tagLength + , sampleLength + , bsXOR + , calculateIntegrityTag + ) where + +import qualified Data.ByteArray as Byte (xor) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Short as Short +import Network.TLS hiding (Version) +import Network.TLS.Extra.Cipher + +import Network.QUIC.Crypto.Nite +import Network.QUIC.Crypto.Types +import Network.QUIC.Imports +import Network.QUIC.Types + +---------------------------------------------------------------- + +bsXOR :: ByteString -> ByteString -> ByteString +bsXOR = Byte.xor + +---------------------------------------------------------------- + +tagLength :: Cipher -> Int +tagLength cipher + | cipher == cipher_TLS13_AES128GCM_SHA256 = 16 + | cipher == cipher_TLS13_AES128CCM_SHA256 = 16 + | cipher == cipher_TLS13_AES256GCM_SHA384 = 16 + | otherwise = error "tagLength" + +sampleLength :: Cipher -> Int +sampleLength cipher + | cipher == cipher_TLS13_AES128GCM_SHA256 = 16 + | cipher == cipher_TLS13_AES128CCM_SHA256 = 16 + | cipher == cipher_TLS13_AES256GCM_SHA384 = 16 + | otherwise = error "sampleLength" + +---------------------------------------------------------------- + +calculateIntegrityTag :: Version -> CID -> ByteString -> ByteString +calculateIntegrityTag ver oCID pseudo0 = + case aes128gcmEncrypt (key ver) (nonce ver) "" (AssDat pseudo) of + Nothing -> "" + Just (hdr,bdy) -> hdr `BS.append` bdy + where + (ocid, ocidlen) = unpackCID oCID + pseudo = BS.concat [BS.singleton ocidlen + ,Short.fromShort ocid + ,pseudo0] + key Draft29 = Key "\xcc\xce\x18\x7e\xd0\x9a\x09\xd0\x57\x28\x15\x5a\x6c\xb9\x6b\xe1" + key Version1 = Key "\xbe\x0c\x69\x0b\x9f\x66\x57\x5a\x1d\x76\x6b\x54\xe3\x68\xc8\x4e" + key Version2 = Key "\x8f\xb4\xb0\x1b\x56\xac\x48\xe2\x60\xfb\xcb\xce\xad\x7c\xcc\x92" + key _ = Key "not supported" + nonce Draft29 = Nonce "\xe5\x49\x30\xf9\x7f\x21\x36\xf0\x53\x0a\x8c\x1c" + nonce Version1 = Nonce "\x46\x15\x99\xd3\x5d\x63\x2b\xf2\x23\x98\x25\xbb" + nonce Version2 = Nonce "\xd8\x69\x69\xbc\x2d\x7c\x6d\x99\x90\xef\xb0\x4a" + nonce _ = Nonce "not supported" diff --git a/Network/QUIC/CryptoFusion.hs b/Network/QUIC/CryptoFusion.hs deleted file mode 100644 --- a/Network/QUIC/CryptoFusion.hs +++ /dev/null @@ -1,146 +0,0 @@ -module Network.QUIC.CryptoFusion ( - FusionContext - , fusionNewContext - , fusionSetup - , fusionEncrypt - , fusionDecrypt - , Supplement - , fusionSetupSupplement - , fusionSetSample - , fusionGetMask - ) where - -import Foreign.C.Types -import Foreign.Ptr -import Foreign.ForeignPtr -import Network.TLS.Extra.Cipher - -import Network.QUIC.Crypto -import Network.QUIC.Imports -import Network.QUIC.Types - ----------------------------------------------------------------- - -data FusionContextOpaque -newtype FusionContext = FC (ForeignPtr FusionContextOpaque) - -fusionNewContext :: IO FusionContext -fusionNewContext = FC <$> (c_aead_context_new >>= newForeignPtr p_aead_context_free) - ----------------------------------------------------------------- - -fusionSetup :: Cipher -> FusionContext -> Key -> IV -> IO () -fusionSetup cipher - | cipher == cipher_TLS13_AES128GCM_SHA256 = fusionSetupAES128 - | cipher == cipher_TLS13_AES256GCM_SHA384 = fusionSetupAES256 - | otherwise = error "fusionSetup" - -fusionSetupAES128 :: FusionContext -> Key -> IV -> IO () -fusionSetupAES128 (FC fctx) (Key key) (IV iv) = withForeignPtr fctx $ \pctx -> - withByteString key $ \keyp -> - withByteString iv $ \ivp -> void $ c_aes128gcm_setup pctx 0 keyp ivp - -fusionSetupAES256 :: FusionContext -> Key -> IV -> IO () -fusionSetupAES256 (FC fctx) (Key key) (IV iv) = withForeignPtr fctx $ \pctx -> - withByteString key $ \keyp -> - withByteString iv $ \ivp -> void $ c_aes256gcm_setup pctx 0 keyp ivp - ----------------------------------------------------------------- - -fusionEncrypt :: FusionContext -> Supplement -> Buffer -> Int -> Buffer -> Int -> PacketNumber -> Buffer -> IO Int -fusionEncrypt (FC fctx) (SP fsupp) ibuf ilen abuf alen pn obuf = - withForeignPtr fctx $ \pctx -> withForeignPtr fsupp $ \psupp -> do - c_aead_do_encrypt pctx obuf ibuf ilen' pn' abuf alen' psupp - return (ilen + 16) -- fixme - where - pn' = fromIntegral pn - ilen' = fromIntegral ilen - alen' = fromIntegral alen - -fusionDecrypt :: FusionContext -> Buffer -> Int -> Buffer -> Int -> PacketNumber -> Buffer -> IO Int -fusionDecrypt (FC fctx) ibuf ilen abuf alen pn buf = - withForeignPtr fctx $ \pctx -> - fromIntegral <$> c_aead_do_decrypt pctx buf ibuf ilen' pn' abuf alen' - where - pn' = fromIntegral pn - ilen' = fromIntegral ilen - alen' = fromIntegral alen - ----------------------------------------------------------------- - -data SupplementOpaque -newtype Supplement = SP (ForeignPtr SupplementOpaque) - -fusionSetupSupplement :: Cipher -> Key -> IO Supplement -fusionSetupSupplement cipher (Key hpkey) = withByteString hpkey $ \hpkeyp -> - SP <$> (c_supplement_new hpkeyp keylen >>= newForeignPtr p_supplement_free) - where - keylen - | cipher == cipher_TLS13_AES128GCM_SHA256 = 16 - | otherwise = 32 - -fusionSetSample :: Supplement -> Ptr Word8 -> IO () -fusionSetSample (SP fsupp) p = withForeignPtr fsupp $ \psupp -> - c_supplement_set_sample psupp p - -fusionGetMask :: Supplement -> IO (Ptr Word8) -fusionGetMask (SP fsupp) = withForeignPtr fsupp c_supplement_get_mask - ----------------------------------------------------------------- - -foreign import ccall unsafe "aead_context_new" - c_aead_context_new :: IO (Ptr FusionContextOpaque) - -foreign import ccall unsafe "&aead_context_free" - p_aead_context_free :: FunPtr (Ptr FusionContextOpaque -> IO ()) - -foreign import ccall unsafe "aes128gcm_setup" - c_aes128gcm_setup :: Ptr FusionContextOpaque - -> CInt -- dummy - -> Ptr Word8 -- key - -> Ptr Word8 -- iv - -> IO CInt - -foreign import ccall unsafe "aes256gcm_setup" - c_aes256gcm_setup :: Ptr FusionContextOpaque - -> CInt -- dummy - -> Ptr Word8 -- key - -> Ptr Word8 -- iv - -> IO CInt -{- -foreign import ccall unsafe "aesgcm_dispose_crypto" - c_aesgcm_dispose_crypto :: FusionContext -> IO () --} - -foreign import ccall unsafe "aead_do_encrypt" - c_aead_do_encrypt :: Ptr FusionContextOpaque - -> Ptr Word8 -- output - -> Ptr Word8 -- input - -> CSize -- input length - -> CULong -- sequence - -> Ptr Word8 -- AAD - -> CSize -- AAD length - -> Ptr SupplementOpaque - -> IO () - -foreign import ccall unsafe "aead_do_decrypt" - c_aead_do_decrypt :: Ptr FusionContextOpaque - -> Ptr Word8 -- output - -> Ptr Word8 -- input - -> CSize -- input length - -> CULong -- sequence - -> Ptr Word8 -- AAD - -> CSize -- AAD length - -> IO CSize - -foreign import ccall unsafe "supplement_new" - c_supplement_new :: Ptr Word8 -> CInt -> IO (Ptr SupplementOpaque) - -foreign import ccall unsafe "&supplement_free" - p_supplement_free :: FunPtr (Ptr SupplementOpaque -> IO ()) - -foreign import ccall unsafe "supplement_set_sample" - c_supplement_set_sample :: Ptr SupplementOpaque -> Ptr Word8 -> IO () - -foreign import ccall unsafe "supplement_get_mask" - c_supplement_get_mask :: Ptr SupplementOpaque -> IO (Ptr Word8) diff --git a/Network/QUIC/Event.hs b/Network/QUIC/Event.hs new file mode 100644 --- /dev/null +++ b/Network/QUIC/Event.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE CPP #-} +module Network.QUIC.Event ( + getSystemTimerManager + , registerTimeout + , unregisterTimeout + , updateTimeout + , TimerManager + , TimeoutCallback + , TimeoutKey + ) where +#if defined(mingw32_HOST_OS) +import GHC.Event.Windows + +type TimerManager = Manager + +getSystemTimerManager :: IO TimerManager +getSystemTimerManager = getSystemManager +#else +import GHC.Event +#endif diff --git a/Network/QUIC/Handshake.hs b/Network/QUIC/Handshake.hs --- a/Network/QUIC/Handshake.hs +++ b/Network/QUIC/Handshake.hs @@ -3,6 +3,7 @@ module Network.QUIC.Handshake where +import Data.List (intersect) import qualified Network.TLS as TLS import Network.TLS.QUIC import qualified UnliftIO.Exception as E @@ -10,6 +11,7 @@ import Network.QUIC.Config import Network.QUIC.Connection import Network.QUIC.Connector +import Network.QUIC.Crypto import Network.QUIC.Imports import Network.QUIC.Info import Network.QUIC.Logger @@ -125,6 +127,13 @@ putOutput conn $ OutHandshake [] -- for h3spec testing sendFrames conn RTT1Level [NewConnectionID cidInfo 0] done _ctx = do + -- Validating Chosen Version + mPeerVerInfo <- versionInformation <$> getPeerParameters conn + case mPeerVerInfo of + Nothing -> return () + Just peerVerInfo -> do + hdrVer <- getVersion conn + when (hdrVer /= chosenVersion peerVerInfo) sendCCVNError info <- getConnectionInfo conn connDebugLog conn $ bhow info use0RTT = ccUse0RTT conf @@ -133,14 +142,18 @@ handshakeServer :: ServerConfig -> Connection -> AuthCIDs -> IO (IO ()) handshakeServer conf conn myAuthCIDs = - handshakeServer' conf conn myAuthCIDs <$> getVersion conn <*> newHndStateRef + handshakeServer' conf conn <$> getVersion conn + <*> newHndStateRef + <*> newIORef params + where + params = setCIDsToParameters myAuthCIDs $ scParameters conf -handshakeServer' :: ServerConfig -> Connection -> AuthCIDs -> Version -> IORef HndState -> IO () -handshakeServer' conf conn myAuthCIDs ver hsr = handshaker +handshakeServer' :: ServerConfig -> Connection -> Version -> IORef HndState -> IORef Parameters -> IO () +handshakeServer' conf conn ver hsRef paramRef = handshaker where - handshaker = serverHandshaker qc conf ver myAuthCIDs `E.catch` sendCCTLSError - qc = QUICCallbacks { quicSend = sendTLS conn hsr - , quicRecv = recvTLS conn hsr + handshaker = serverHandshaker qc conf ver getParams `E.catch` sendCCTLSError + qc = QUICCallbacks { quicSend = sendTLS conn hsRef + , quicRecv = recvTLS conn hsRef , quicInstallKeys = installKeysServer , quicNotifyExtensions = setPeerParams conn , quicDone = done @@ -155,7 +168,7 @@ setCipher conn RTT1Level cphr initializeCoder conn HandshakeLevel tss setEncryptionLevel conn HandshakeLevel - rxLevelChanged hsr + rxLevelChanged hsRef installKeysServer ctx (InstallApplicationKeys appSecInf@(ApplicationSecretInfo tss)) = do storeNegotiated conn ctx appSecInf initializeCoder1RTT conn tss @@ -180,30 +193,30 @@ -- info <- getConnectionInfo conn connDebugLog conn $ bhow info + getParams = do + params <- readIORef paramRef + verInfo <- getVersionInfo conn + return params { versionInformation = Just verInfo } ---------------------------------------------------------------- setPeerParams :: Connection -> TLS.Context -> [ExtensionRaw] -> IO () -setPeerParams conn _ctx ps0 = do - ver <- getVersion conn - let mps | ver == Version1 = getTP extensionID_QuicTransportParameters ps0 - | otherwise = getTP 0xffa5 ps0 - setPP mps +setPeerParams conn _ctx peerExts = do + tpId <- extensionIDForTtransportParameter <$> getVersion conn + case getTP tpId peerExts of + Nothing -> sendCCTLSAlert TLS.MissingExtension "QUIC transport parameters are mssing" + Just (ExtensionRaw _ bs) -> setPP bs where - getTP _ [] = Nothing - getTP n (ExtensionRaw extid bs : ps) - | extid == n = Just bs - | otherwise = getTP n ps - setPP Nothing = return () - setPP (Just bs) = do - let mparams = decodeParameters bs - case mparams of - Nothing -> sendCCParamError - Just params -> do - checkAuthCIDs params - checkInvalid params - setParams params - qlogParamsSet conn (params,"remote") + getTP n = find (\(ExtensionRaw extid _) -> extid == n) + setPP bs = case decodeParameters bs of + Nothing -> sendCCParamError + Just params -> do + checkAuthCIDs params + checkInvalid params + setParams params + qlogParamsSet conn (params,"remote") + when (isServer conn) $ + serverVersionNegotiation $ versionInformation params checkAuthCIDs params = do peerAuthCIDs <- getPeerAuthCIDs conn @@ -224,6 +237,24 @@ when (isJust $ preferredAddress params) sendCCParamError when (isJust $ retrySourceConnectionId params) sendCCParamError when (isJust $ statelessResetToken params) sendCCParamError + let vi = case versionInformation params of + Nothing -> VersionInfo Version1 [Version1] + Just vi0 -> vi0 + when (vi == brokenVersionInfo) sendCCParamError + when (Negotiation `elem` otherVersions vi) sendCCParamError + -- Always False for servers + isICVN <- getIncompatibleVN conn + when isICVN $ do + -- Validating Other Version fields. + verInfo <- getVersionInfo conn + let myVer = chosenVersion verInfo + myVers = filter (not . isGreasingVersion) $ otherVersions verInfo + peerVers = otherVersions vi + case myVers `intersect` peerVers of + ver:_ | ver == myVer -> return () + _ -> sendCCVNError + + setParams params = do setPeerParameters conn params mapM_ (setPeerStatelessResetToken conn) $ statelessResetToken params @@ -233,6 +264,21 @@ setMyMaxStreams conn $ initialMaxStreamsBidi params setMyUniMaxStreams conn $ initialMaxStreamsUni params + serverVersionNegotiation Nothing = return () + serverVersionNegotiation (Just peerVerInfo) = do + myVerInfo <- getVersionInfo conn + let clientVer = chosenVersion myVerInfo + myVers = filter (not . isGreasingVersion) $ otherVersions myVerInfo + peerVers = otherVersions peerVerInfo + -- Server's preference should be preferred. + case myVers `intersect` peerVers of + vers@(serverVer:_) + | clientVer /= serverVer -> do + setVersionInfo conn $ VersionInfo serverVer vers + dcid <- getClientDstCID conn + initializeCoder conn InitialLevel $ initialSecrets serverVer dcid + _ -> return () + storeNegotiated :: Connection -> TLS.Context -> ApplicationSecretInfo -> IO () storeNegotiated conn ctx appSecInf = do appPro <- TLS.getNegotiatedProtocol ctx @@ -245,13 +291,20 @@ sendCCParamError :: IO () sendCCParamError = E.throwIO WrongTransportParameter +sendCCVNError :: IO () +sendCCVNError = E.throwIO WrongVersionInformation + sendCCTLSError :: TLS.TLSException -> IO () -sendCCTLSError (TLS.HandshakeFailed (TLS.Error_Misc "WrongTransportParameter")) = closeConnection TransportParameterError "Transport parametter error" +sendCCTLSError (TLS.HandshakeFailed (TLS.Error_Misc "WrongTransportParameter")) = closeConnection TransportParameterError "Transport parameter error" +sendCCTLSError (TLS.HandshakeFailed (TLS.Error_Misc "WrongVersionInformation")) = closeConnection VersionNegotiationError "Version negotiation error" sendCCTLSError e = closeConnection err msg where tlserr = getErrorCause e err = cryptoError $ errorToAlertDescription tlserr msg = shortpack $ errorToAlertMessage tlserr + +sendCCTLSAlert :: TLS.AlertDescription -> ReasonPhrase -> IO () +sendCCTLSAlert a msg = closeConnection (cryptoError a) msg getErrorCause :: TLS.TLSException -> TLS.TLSError getErrorCause (TLS.HandshakeFailed e) = e diff --git a/Network/QUIC/IO.hs b/Network/QUIC/IO.hs --- a/Network/QUIC/IO.hs +++ b/Network/QUIC/IO.hs @@ -2,9 +2,9 @@ module Network.QUIC.IO where -import Control.Concurrent.STM import qualified Data.ByteString as BS import qualified UnliftIO.Exception as E +import UnliftIO.STM import Network.QUIC.Connection import Network.QUIC.Connector @@ -106,7 +106,7 @@ connWindow = flowWindow connFlow minFlow = min strmWindow connWindow n = min len minFlow - when wait $ check (n > 0) + when wait $ checkSTM (n > 0) if n > 0 then return $ Right n else do @@ -128,6 +128,7 @@ when sclosed $ E.throwIO StreamIsClosed setTxStreamClosed s putSendStreamQ (streamConnection s) $ TxStreamData s [] 0 True + waitFinTx s -- | Closing a stream without an error. -- This sends FIN if necessary. @@ -140,6 +141,7 @@ setTxStreamClosed s setRxStreamClosed s putSendStreamQ conn $ TxStreamData s [] 0 True + waitFinTx s delStream conn s when ((isClient conn && isServerInitiatedBidirectional sid) || (isServer conn && isClientInitiatedBidirectional sid)) $ do @@ -164,7 +166,7 @@ window <- getRxStreamWindow s let sid = streamId s initialWindow = initialRxMaxStreamData conn sid - when (window <= (initialWindow .>>. 1)) $ do + when (window <= (initialWindow !>>. 1)) $ do newMax <- addRxMaxStreamData s initialWindow sendFrames conn RTT1Level [MaxStreamData sid newMax] fire conn (Microseconds 50000) $ do @@ -172,7 +174,7 @@ sendFrames conn RTT1Level [MaxStreamData sid newMax'] cwindow <- getRxDataWindow conn let cinitialWindow = initialMaxData $ getMyParameters conn - when (cwindow <= (cinitialWindow .>>. 1)) $ do + when (cwindow <= (cinitialWindow !>>. 1)) $ do newMax <- addRxMaxData conn cinitialWindow sendFrames conn RTT1Level [MaxData newMax] fire conn (Microseconds 50000) $ do diff --git a/Network/QUIC/Imports.hs b/Network/QUIC/Imports.hs --- a/Network/QUIC/Imports.hs +++ b/Network/QUIC/Imports.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Network.QUIC.Imports ( Bytes , ByteString(..) @@ -18,8 +20,11 @@ , module Numeric , module Network.ByteOrder , module Network.QUIC.Utils - , (.<<.), (.>>.) +#if !MIN_VERSION_base(4,17,0) + , (!<<.), (!>>.) +#endif , atomicModifyIORef'' + , copyBS ) where import Control.Applicative @@ -28,7 +33,7 @@ import Data.Array.IO import Data.Bits import Data.ByteString.Builder (Builder) -import Data.ByteString.Internal (ByteString(..)) +import Data.ByteString.Internal (ByteString(..), memcpy) import Data.ByteString.Short.Internal (ShortByteString(..)) import Data.Foldable import Data.IORef @@ -37,6 +42,8 @@ import Data.Monoid import Data.Ord import Data.Word +import Foreign.ForeignPtr +import Foreign.Ptr import Network.ByteOrder import Network.QUIC.Utils import Numeric @@ -45,13 +52,21 @@ -- `ByteString` should be used for FFI related stuff. type Bytes = ShortByteString -infixl 8 .<<. -(.<<.) :: Bits a => a -> Int -> a -(.<<.) = unsafeShiftL +#if !MIN_VERSION_base(4,17,0) +infixl 8 !<<. +(!<<.) :: Bits a => a -> Int -> a +(!<<.) = unsafeShiftL -infixl 8 .>>. -(.>>.) :: Bits a => a -> Int -> a -(.>>.) = unsafeShiftR +infixl 8 !>>. +(!>>.) :: Bits a => a -> Int -> a +(!>>.) = unsafeShiftR +#endif atomicModifyIORef'' :: IORef a -> (a -> a) -> IO () atomicModifyIORef'' ref f = atomicModifyIORef' ref $ \x -> (f x, ()) + +copyBS :: Buffer -> ByteString -> IO Int +copyBS dst (PS fptr off len) = withForeignPtr fptr $ \src0 -> do + let src = src0 `plusPtr` off + memcpy dst src len + return len diff --git a/Network/QUIC/Info.hs b/Network/QUIC/Info.hs --- a/Network/QUIC/Info.hs +++ b/Network/QUIC/Info.hs @@ -6,9 +6,9 @@ import qualified Data.ByteString.Char8 as C8 import qualified Network.Socket as NS import Network.TLS hiding (Version, HandshakeFailed) +import Network.UDP (UDPSocket(..)) import Network.QUIC.Connection -import Network.QUIC.Connector import Network.QUIC.Imports import Network.QUIC.Types @@ -30,15 +30,8 @@ -- | Getting information about a connection. getConnectionInfo :: Connection -> IO ConnectionInfo getConnectionInfo conn = do - s:_ <- getSockets conn - mysa <- NS.getSocketName s - peersa <- if isClient conn then do - msa <- getServerAddr conn - case msa of - Nothing -> NS.getPeerName s - Just sa -> return sa - else - NS.getPeerName s + UDPSocket{..} <- getSocket conn + mysa <- NS.getSocketName udpSocket mycid <- getMyCID conn peercid <- getPeerCID conn c <- getCipher conn RTT1Level @@ -53,7 +46,7 @@ , handshakeMode = mode , retry = r , localSockAddr = mysa - , remoteSockAddr = peersa + , remoteSockAddr = peerSockAddr , localCID = mycid , remoteCID = peercid } diff --git a/Network/QUIC/Internal.hs b/Network/QUIC/Internal.hs --- a/Network/QUIC/Internal.hs +++ b/Network/QUIC/Internal.hs @@ -3,7 +3,6 @@ , module Network.QUIC.Connection , module Network.QUIC.Connector , module Network.QUIC.Crypto - , module Network.QUIC.CryptoFusion , module Network.QUIC.Logger , module Network.QUIC.Packet , module Network.QUIC.Parameters @@ -14,6 +13,7 @@ , module Network.QUIC.Utils , module Network.QUIC.Recovery , module Network.QUIC.Client.Reader + , module Network.QUIC.Windows ) where import Network.QUIC.Client.Reader (controlConnection,ConnectionControl(..)) @@ -21,7 +21,6 @@ import Network.QUIC.Connection import Network.QUIC.Connector import Network.QUIC.Crypto -import Network.QUIC.CryptoFusion import Network.QUIC.Logger import Network.QUIC.Packet import Network.QUIC.Parameters @@ -31,3 +30,4 @@ import Network.QUIC.TLS import Network.QUIC.Types import Network.QUIC.Utils +import Network.QUIC.Windows diff --git a/Network/QUIC/Packet.hs b/Network/QUIC/Packet.hs --- a/Network/QUIC/Packet.hs +++ b/Network/QUIC/Packet.hs @@ -11,7 +11,8 @@ , decodeStatelessResetToken -- * Frame , encodeFrames - , decodeFrames + , decodeFramesBuffer + , decodeFramesBS , countZero -- testing -- * Header , isLong diff --git a/Network/QUIC/Packet/Decode.hs b/Network/QUIC/Packet/Decode.hs --- a/Network/QUIC/Packet/Decode.hs +++ b/Network/QUIC/Packet/Decode.hs @@ -17,12 +17,13 @@ ---------------------------------------------------------------- -decodeCryptPackets :: ByteString -> IO [(CryptPacket,EncryptionLevel)] +-- Server uses this. +decodeCryptPackets :: ByteString -> IO [(CryptPacket,EncryptionLevel,Int)] decodeCryptPackets bs0 = unwrap <$> decodePackets bs0 where - unwrap (PacketIC c l:xs) = (c,l) : unwrap xs - unwrap (_:xs) = unwrap xs - unwrap [] = [] + unwrap (PacketIC c l s:xs) = (c,l,s) : unwrap xs + unwrap (_:xs) = unwrap xs + unwrap [] = [] -- Client uses this. decodePackets :: ByteString -> IO [PacketI] @@ -33,7 +34,6 @@ (pkt, rest) <- decodePacket bs loop rest (build . (pkt :)) --- Server uses this. decodePacket :: ByteString -> IO (PacketI, ByteString) decodePacket bs = E.handle handler $ withReadBuffer bs $ \rbuf -> do save rbuf @@ -47,29 +47,33 @@ decode rbuf _proFlags True = do header <- Short . makeCID <$> extractShortByteString rbuf myCIDLength cpkt <- CryptPacket header <$> makeShortCrypt bs rbuf - return $ PacketIC cpkt RTT1Level + siz <- savingSize rbuf + return $ PacketIC cpkt RTT1Level siz decode rbuf proFlags False = do (ver, dCID, sCID) <- decodeLongHeader rbuf case ver of Negotiation -> do decodeVersionNegotiationPacket rbuf dCID sCID - _ -> case decodeLongHeaderPacketType proFlags of + _ -> case decodeLongHeaderPacketType ver proFlags of RetryPacketType -> do decodeRetryPacket rbuf proFlags ver dCID sCID RTT0PacketType -> do let header = RTT0 ver dCID sCID cpkt <- CryptPacket header <$> makeLongCrypt bs rbuf - return $ PacketIC cpkt RTT0Level + siz <- savingSize rbuf + return $ PacketIC cpkt RTT0Level siz InitialPacketType -> do tokenLen <- fromIntegral <$> decodeInt' rbuf token <- extractByteString rbuf tokenLen let header = Initial ver dCID sCID token cpkt <- CryptPacket header <$> makeLongCrypt bs rbuf - return $ PacketIC cpkt InitialLevel + siz <- savingSize rbuf + return $ PacketIC cpkt InitialLevel siz HandshakePacketType -> do let header = Handshake ver dCID sCID crypt <- CryptPacket header <$> makeLongCrypt bs rbuf - return $ PacketIC crypt HandshakeLevel + siz <- savingSize rbuf + return $ PacketIC crypt HandshakeLevel siz handler BufferOverrun = return (PacketIB BrokenPacket,"") makeShortCrypt :: ByteString -> ReadBuffer -> IO Crypt @@ -77,7 +81,7 @@ len <- remainingSize rbuf here <- savingSize rbuf ff rbuf len - return $ Crypt here bs 0 + return $ Crypt here bs 0 Nothing makeLongCrypt :: ByteString -> ReadBuffer -> IO Crypt makeLongCrypt bs rbuf = do @@ -85,7 +89,7 @@ here <- savingSize rbuf ff rbuf len let pkt = BS.take (here + len) bs - return $ Crypt here pkt 0 + return $ Crypt here pkt 0 Nothing ---------------------------------------------------------------- diff --git a/Network/QUIC/Packet/Decrypt.hs b/Network/QUIC/Packet/Decrypt.hs --- a/Network/QUIC/Packet/Decrypt.hs +++ b/Network/QUIC/Packet/Decrypt.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ExistentialQuantification #-} module Network.QUIC.Packet.Decrypt ( decryptCrypt @@ -20,8 +21,8 @@ ---------------------------------------------------------------- -decryptCrypt :: Connection -> Buffer -> BufferSize -> Crypt -> EncryptionLevel -> IO (Maybe Plain) -decryptCrypt conn decBuf _bufsiz Crypt{..} lvl = do -- fixme: bufsiz is not used +decryptCrypt :: Connection -> Crypt -> EncryptionLevel -> IO (Maybe Plain) +decryptCrypt conn Crypt{..} lvl = do cipher <- getCipher conn lvl protector <- getProtector conn lvl let proFlags = Flags (cryptPacket `BS.index` 0) @@ -39,7 +40,6 @@ bytePN = bsXOR mask2 epn headerLen = cryptPktNumOffset + epnLen (proHeader, ciphertext) = BS.splitAt headerLen cryptPacket - ilen = BS.length ciphertext peerPN <- if lvl == RTT1Level then getPeerPacketNumber conn else return 0 let pn = decodePacketNumber peerPN (toEncodedPacketNumber bytePN) epnLen header <- BS.create headerLen $ \p -> do @@ -49,11 +49,7 @@ let keyPhase | lvl == RTT1Level = flags `testBit` 2 | otherwise = False coder <- getCoder conn lvl keyPhase - siz <- withByteString ciphertext $ \ibuf -> - withByteString header $ \abuf -> do - let ilen' = fromIntegral ilen - alen' = fromIntegral headerLen - decrypt coder ibuf ilen' abuf alen' pn decBuf + siz <- decrypt coder (decryptBuf conn) ciphertext (AssDat header) pn let rrMask | lvl == RTT1Level = 0x18 | otherwise = 0x0c marks | flags .&. rrMask == 0 = defaultPlainMarks @@ -61,15 +57,15 @@ if siz < 0 then return Nothing else do - mframes <- decodeFrames decBuf siz - case mframes of - Nothing -> do - let marks' = setUnknownFrame marks - return $ Just $ Plain rawFlags pn [] marks' - Just frames -> do - let marks' | null frames = setNoFrames marks - | otherwise = marks - return $ Just $ Plain rawFlags pn frames marks' + mframes <- decodeFramesBuffer (decryptBuf conn) siz + case mframes of + Nothing -> do + let marks' = setUnknownFrame marks + return $ Just $ Plain rawFlags pn [] marks' + Just frames -> do + let marks' | null frames = setNoFrames marks + | otherwise = marks + return $ Just $ Plain rawFlags pn frames marks' toEncodedPacketNumber :: ByteString -> EncodedPacketNumber toEncodedPacketNumber bs = foldl' (\b a -> b * 256 + fromIntegral a) 0 $ BS.unpack bs diff --git a/Network/QUIC/Packet/Encode.hs b/Network/QUIC/Packet/Encode.hs --- a/Network/QUIC/Packet/Encode.hs +++ b/Network/QUIC/Packet/Encode.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + module Network.QUIC.Packet.Encode ( -- encodePacket encodeVersionNegotiationPacket @@ -6,6 +8,7 @@ ) where import qualified Data.ByteString as BS +import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable (peek) @@ -45,7 +48,7 @@ encodeRetryPacket :: RetryPacket -> IO ByteString encodeRetryPacket (RetryPacket ver dCID sCID token (Left odCID)) = withWriteBuffer maximumQUICHeaderSize $ \wbuf -> do save wbuf - Flags flags <- retryPacketType + Flags flags <- retryPacketType ver write8 wbuf flags encodeLongHeader wbuf ver dCID sCID copyByteString wbuf token @@ -54,20 +57,30 @@ let tag = calculateIntegrityTag ver odCID pseudo0 copyByteString wbuf tag -- no header protection -encodeRetryPacket _ = error "encodeRetryPacket" +-- only for testing +encodeRetryPacket (RetryPacket ver dCID sCID token (Right (_,tag))) = withWriteBuffer maximumQUICHeaderSize $ \wbuf -> do + save wbuf + Flags flags <- retryPacketType ver + write8 wbuf flags + encodeLongHeader wbuf ver dCID sCID + copyByteString wbuf token + copyByteString wbuf tag + -- no header protection ---------------------------------------------------------------- -encodePlainPacket :: Connection -> Buffer -> BufferSize -> PlainPacket -> Maybe Int -> IO (Int,Int) -encodePlainPacket conn buf bufsiz ppkt@(PlainPacket _ plain) mlen = do +-- WriteBuffer: protect(header) + encrypt(plain_frames) +-- encodeBuf: plain_frames + +encodePlainPacket :: Connection -> SizedBuffer -> PlainPacket -> Maybe Int -> IO (Int,Int) +encodePlainPacket conn (SizedBuffer buf bufsiz) ppkt@(PlainPacket _ plain) mlen = do let mlen' | isNoPaddings (plainMarks plain) = Nothing | otherwise = mlen wbuf <- newWriteBuffer buf bufsiz - let encodeBuf = buf `plusPtr` bufsiz -- see sender - encodePlainPacket' conn wbuf encodeBuf ppkt mlen' + encodePlainPacket' conn wbuf ppkt mlen' -encodePlainPacket' :: Connection -> WriteBuffer -> Buffer -> PlainPacket -> Maybe Int -> IO (Int,Int) -encodePlainPacket' conn wbuf encodeBuf (PlainPacket (Initial ver dCID sCID token) (Plain flags pn frames _)) mlen = do +encodePlainPacket' :: Connection -> WriteBuffer -> PlainPacket -> Maybe Int -> IO (Int,Int) +encodePlainPacket' conn wbuf (PlainPacket (Initial ver dCID sCID token) (Plain flags pn frames _)) mlen = do headerBeg <- currentOffset wbuf -- flag ... sCID (epn, epnLen) <- encodeLongHeaderPP conn wbuf InitialPacketType ver dCID sCID flags pn @@ -75,23 +88,23 @@ encodeInt' wbuf $ fromIntegral $ BS.length token copyByteString wbuf token -- length .. payload - protectPayloadHeader conn wbuf encodeBuf frames pn epn epnLen headerBeg mlen InitialLevel False + protectPayloadHeader conn wbuf frames pn epn epnLen headerBeg mlen InitialLevel False -encodePlainPacket' conn wbuf encodeBuf (PlainPacket (RTT0 ver dCID sCID) (Plain flags pn frames _)) mlen = do +encodePlainPacket' conn wbuf (PlainPacket (RTT0 ver dCID sCID) (Plain flags pn frames _)) mlen = do headerBeg <- currentOffset wbuf -- flag ... sCID (epn, epnLen) <- encodeLongHeaderPP conn wbuf RTT0PacketType ver dCID sCID flags pn -- length .. payload - protectPayloadHeader conn wbuf encodeBuf frames pn epn epnLen headerBeg mlen RTT0Level False + protectPayloadHeader conn wbuf frames pn epn epnLen headerBeg mlen RTT0Level False -encodePlainPacket' conn wbuf encodeBuf (PlainPacket (Handshake ver dCID sCID) (Plain flags pn frames _)) mlen = do +encodePlainPacket' conn wbuf (PlainPacket (Handshake ver dCID sCID) (Plain flags pn frames _)) mlen = do headerBeg <- currentOffset wbuf -- flag ... sCID (epn, epnLen) <- encodeLongHeaderPP conn wbuf HandshakePacketType ver dCID sCID flags pn -- length .. payload - protectPayloadHeader conn wbuf encodeBuf frames pn epn epnLen headerBeg mlen HandshakeLevel False + protectPayloadHeader conn wbuf frames pn epn epnLen headerBeg mlen HandshakeLevel False -encodePlainPacket' conn wbuf encodeBuf (PlainPacket (Short dCID) (Plain flags pn frames marks)) mlen = do +encodePlainPacket' conn wbuf (PlainPacket (Short dCID) (Plain flags pn frames marks)) mlen = do headerBeg <- currentOffset wbuf -- flag let (epn, epnLen) | is4bytesPN marks = (fromIntegral pn, 4) @@ -104,7 +117,7 @@ -- dCID let (dcid, _) = unpackCID dCID copyShortByteString wbuf dcid - protectPayloadHeader conn wbuf encodeBuf frames pn epn epnLen headerBeg mlen RTT1Level keyPhase + protectPayloadHeader conn wbuf frames pn epn epnLen headerBeg mlen RTT1Level keyPhase ---------------------------------------------------------------- @@ -131,21 +144,20 @@ let el@(_, pnLen) = encodePacketNumber 0 {- dummy -} pn pp = encodePktNumLength pnLen quicBit <- greaseQuicBit <$> getPeerParameters conn - Flags flags' <- encodeLongHeaderFlags pkttyp flags pp quicBit + Flags flags' <- encodeLongHeaderFlags ver pkttyp flags pp quicBit write8 wbuf flags' encodeLongHeader wbuf ver dCID sCID return el ---------------------------------------------------------------- -protectPayloadHeader :: Connection -> WriteBuffer -> Buffer -> [Frame] -> PacketNumber -> EncodedPacketNumber -> Int -> Buffer -> Maybe Int -> EncryptionLevel -> Bool -> IO (Int,Int) -protectPayloadHeader conn wbuf encodeBuf frames pn epn epnLen headerBeg mlen lvl keyPhase = do +protectPayloadHeader :: Connection -> WriteBuffer -> [Frame] -> PacketNumber -> EncodedPacketNumber -> Int -> Buffer -> Maybe Int -> EncryptionLevel -> Bool -> IO (Int,Int) +protectPayloadHeader conn wbuf frames pn epn epnLen headerBeg mlen lvl keyPhase = do -- Real size is maximumUdpPayloadSize. But smaller is better. - let encodeBufLen = 1500 - 20 - 8 - payloadWithoutPaddingSiz <- encodeFramesWithPadding encodeBuf encodeBufLen frames + let encBuf = encodeBuf conn + encBufLen = 1500 - 20 - 8 + payloadWithoutPaddingSiz <- encodeFramesWithPadding encBuf encBufLen frames cipher <- getCipher conn lvl - coder <- getCoder conn lvl keyPhase - protector <- getProtector conn lvl -- before length or packer number lengthOrPNBeg <- currentOffset wbuf (packetLen, headerLen, plainLen, tagLen, padLen) @@ -155,19 +167,22 @@ writeEpn epnLen -- payload cryptoBeg <- currentOffset wbuf + plaintext <- mkBS encBuf plainLen + header <- mkBS headerBeg headerLen + -- let sampleBeg = pnBeg `plusPtr` 4 + coder <- getCoder conn lvl keyPhase + protector <- getProtector conn lvl setSample protector sampleBeg - len <- encrypt coder encodeBuf plainLen headerBeg headerLen pn cryptoBeg - if len < 0 then + len <- encrypt coder cryptoBeg plaintext (AssDat header) pn + maskBeg <- getMask protector + -- + if len < 0 || maskBeg == nullPtr then return (-1, -1) - else do - -- protecting header - maskBeg <- getMask protector - if maskBeg == nullPtr then - return (-1, -1) - else do - protectHeader headerBeg pnBeg epnLen maskBeg - return (packetLen, padLen) + else do + -- protecting header + protectHeader headerBeg pnBeg epnLen maskBeg + return (packetLen, padLen) where calcLen cipher lengthOrPNBeg payloadWithoutPaddingSiz = do let headerLen = (lengthOrPNBeg `minusPtr` headerBeg) @@ -209,3 +224,10 @@ maskn1 <- mask (n + 1) let pp0 = p0 `xor` maskn1 poke8 pp0 pnBeg n + +---------------------------------------------------------------- + +mkBS :: Buffer -> Int -> IO ByteString +mkBS ptr siz = do + fptr <- newForeignPtr_ ptr + return $ PS fptr 0 siz diff --git a/Network/QUIC/Packet/Frame.hs b/Network/QUIC/Packet/Frame.hs --- a/Network/QUIC/Packet/Frame.hs +++ b/Network/QUIC/Packet/Frame.hs @@ -3,7 +3,8 @@ module Network.QUIC.Packet.Frame ( encodeFrames , encodeFramesWithPadding - , decodeFrames + , decodeFramesBS + , decodeFramesBuffer , countZero -- testing ) where @@ -136,18 +137,22 @@ ---------------------------------------------------------------- -decodeFrames :: Buffer -> BufferSize -> IO (Maybe [Frame]) -decodeFrames buf bufsiz = do - rbuf <- newReadBuffer buf bufsiz - loop id rbuf +decodeFramesBS :: ByteString -> IO (Maybe [Frame]) +decodeFramesBS bs = withReadBuffer bs decodeFrames + +decodeFramesBuffer :: Buffer -> BufferSize -> IO (Maybe [Frame]) +decodeFramesBuffer buf bufsiz = newReadBuffer buf bufsiz >>= decodeFrames + +decodeFrames :: ReadBuffer -> IO (Maybe [Frame]) +decodeFrames rbuf = loop id where - loop frames rbuf = do + loop frames = do ok <- (>= 1) <$> remainingSize rbuf if ok then do frame <- decodeFrame rbuf case frame of UnknownFrame _ -> return Nothing - _ -> loop (frames . (frame:)) rbuf + _ -> loop (frames . (frame:)) else return $ Just $ frames [] diff --git a/Network/QUIC/Packet/Header.hs b/Network/QUIC/Packet/Header.hs --- a/Network/QUIC/Packet/Header.hs +++ b/Network/QUIC/Packet/Header.hs @@ -66,25 +66,33 @@ .|. (if keyPhase then 0b00000100 else 0b00000000) {-# INLINE encodeLongHeaderFlags #-} -encodeLongHeaderFlags :: LongHeaderPacketType -> Flags Raw -> Flags Raw -> Bool -> IO (Flags Raw) -encodeLongHeaderFlags typ (Flags fg) (Flags pp) quicBit = +encodeLongHeaderFlags :: Version -> LongHeaderPacketType -> Flags Raw -> Flags Raw -> Bool -> IO (Flags Raw) +encodeLongHeaderFlags ver typ (Flags fg) (Flags pp) quicBit = Flags <$> randomizeQuicBit flags quicBit where - Flags tp = longHeaderPacketType typ + Flags tp = longHeaderPacketType ver typ flags = tp .|. (fg .&. 0b00001100) .|. (pp .&. 0b00000011) {-# INLINE longHeaderPacketType #-} -longHeaderPacketType :: LongHeaderPacketType -> Flags Raw -longHeaderPacketType InitialPacketType = Flags 0b11000000 -longHeaderPacketType RTT0PacketType = Flags 0b11010000 -longHeaderPacketType HandshakePacketType = Flags 0b11100000 -longHeaderPacketType RetryPacketType = Flags 0b11110000 +longHeaderPacketType :: Version -> LongHeaderPacketType -> Flags Raw +longHeaderPacketType Version2 InitialPacketType = Flags 0b11010000 +longHeaderPacketType Version2 RTT0PacketType = Flags 0b11100000 +longHeaderPacketType Version2 HandshakePacketType = Flags 0b11110000 +longHeaderPacketType Version2 RetryPacketType = Flags 0b11000000 +longHeaderPacketType _ InitialPacketType = Flags 0b11000000 +longHeaderPacketType _ RTT0PacketType = Flags 0b11010000 +longHeaderPacketType _ HandshakePacketType = Flags 0b11100000 +longHeaderPacketType _ RetryPacketType = Flags 0b11110000 -retryPacketType :: IO (Flags Raw) -retryPacketType = do +retryPacketType :: Version -> IO (Flags Raw) +retryPacketType Version2 = do r <- getRandomOneByte + let flags = 0b11000000 .|. (r .&. 0b00001111) + return $ Flags flags +retryPacketType _ = do + r <- getRandomOneByte let flags = 0b11110000 .|. (r .&. 0b00001111) return $ Flags flags @@ -95,8 +103,13 @@ return $ Flags flags {-# INLINE decodeLongHeaderPacketType #-} -decodeLongHeaderPacketType :: Flags Protected -> LongHeaderPacketType -decodeLongHeaderPacketType (Flags flags) = case flags .&. 0b00110000 of +decodeLongHeaderPacketType :: Version -> Flags Protected -> LongHeaderPacketType +decodeLongHeaderPacketType Version2 (Flags flags) = case flags .&. 0b00110000 of + 0b00010000 -> InitialPacketType + 0b00100000 -> RTT0PacketType + 0b00110000 -> HandshakePacketType + _ -> RetryPacketType +decodeLongHeaderPacketType _ (Flags flags) = case flags .&. 0b00110000 of 0b00000000 -> InitialPacketType 0b00010000 -> RTT0PacketType 0b00100000 -> HandshakePacketType diff --git a/Network/QUIC/Packet/Number.hs b/Network/QUIC/Packet/Number.hs --- a/Network/QUIC/Packet/Number.hs +++ b/Network/QUIC/Packet/Number.hs @@ -45,11 +45,11 @@ && candidatePN >= pnWin = candidatePN - pnWin | otherwise = candidatePN where - mx = 1 .<<. 62 + mx = 1 !<<. 62 pnNbits = bytes * 8 expectedPN = largestPN + 1 - pnWin = 1 .<<. pnNbits - pnHwin = pnWin .>>. 1 + pnWin = 1 !<<. pnNbits + pnHwin = pnWin !>>. 1 pnMask = pnWin - 1 candidatePN = (expectedPN .&. complement pnMask) .|. fromIntegral truncatedPN diff --git a/Network/QUIC/Parameters.hs b/Network/QUIC/Parameters.hs --- a/Network/QUIC/Parameters.hs +++ b/Network/QUIC/Parameters.hs @@ -27,7 +27,7 @@ decodeParameters :: ByteString -> Maybe Parameters decodeParameters bs = fromParameterList <$> decodeParameterList bs -newtype Key = Key Word16 deriving (Eq, Show) +newtype Key = Key Word32 deriving (Eq, Show) type Value = ByteString type ParameterList = [(Key,Value)] @@ -66,11 +66,14 @@ pattern InitialSourceConnectionId = Key 0x0f pattern RetrySourceConnectionId :: Key pattern RetrySourceConnectionId = Key 0x10 +pattern VersionInformation :: Key +pattern VersionInformation = Key 0x11 pattern Grease :: Key pattern Grease = Key 0xff pattern GreaseQuicBit :: Key pattern GreaseQuicBit = Key 0x2ab2 + -- | QUIC transport parameters. data Parameters = Parameters { originalDestinationConnectionId :: Maybe CID @@ -92,6 +95,7 @@ , retrySourceConnectionId :: Maybe CID , grease :: Maybe ByteString , greaseQuicBit :: Bool + , versionInformation :: Maybe VersionInfo } deriving (Eq,Show) -- | The default value for QUIC transport parameters. @@ -116,6 +120,7 @@ , retrySourceConnectionId = Nothing , grease = Nothing , greaseQuicBit = False + , versionInformation = Nothing } decInt :: ByteString -> Int @@ -130,6 +135,27 @@ encMilliseconds :: Milliseconds -> ByteString encMilliseconds (Milliseconds n) = encodeInt $ fromIntegral n +fromVersionInfo :: Maybe VersionInfo -> Value +fromVersionInfo Nothing = "" -- never reach +fromVersionInfo (Just VersionInfo{..}) = unsafeDupablePerformIO $ + withWriteBuffer len $ \wbuf -> do + let putVersion (Version ver) = write32 wbuf ver + putVersion chosenVersion + mapM_ putVersion otherVersions + where + len = 4 * (length otherVersions + 1) + +toVersionInfo :: Value -> Maybe VersionInfo +toVersionInfo bs + | len < 3 || remainder /= 0 = Just brokenVersionInfo + | otherwise = Just $ unsafeDupablePerformIO $ + withReadBuffer bs $ \rbuf -> do + let getVersion = Version <$> read32 rbuf + VersionInfo <$> getVersion <*> replicateM (cnt - 1) getVersion + where + len = BS.length bs + (cnt,remainder) = len `divMod` 4 + fromParameterList :: ParameterList -> Parameters fromParameterList kvs = foldl' update params kvs where @@ -172,6 +198,8 @@ = x { grease = Just v } update x (GreaseQuicBit,_) = x { greaseQuicBit = True } + update x (VersionInformation,v) + = x { versionInformation = toVersionInfo v } update x _ = x diff :: Eq a => Parameters -> (Parameters -> a) -> Key -> (a -> Value) -> Maybe (Key,Value) @@ -206,6 +234,7 @@ RetrySourceConnectionId (fromCID . fromJust) , diff p greaseQuicBit GreaseQuicBit (const "") , diff p grease Grease fromJust + , diff p versionInformation VersionInformation fromVersionInfo ] encSRT :: Maybe StatelessResetToken -> ByteString diff --git a/Network/QUIC/Receiver.hs b/Network/QUIC/Receiver.hs --- a/Network/QUIC/Receiver.hs +++ b/Network/QUIC/Receiver.hs @@ -6,13 +6,14 @@ ) where import qualified Data.ByteString as BS -import Foreign.Marshal.Alloc import Network.TLS (AlertDescription(..)) +import UnliftIO.Concurrent (forkIO) import qualified UnliftIO.Exception as E import Network.QUIC.Config import Network.QUIC.Connection import Network.QUIC.Connector +import Network.QUIC.Crypto import Network.QUIC.Exception import Network.QUIC.Imports import Network.QUIC.Logger @@ -20,32 +21,30 @@ import Network.QUIC.Parameters import Network.QUIC.Qlog import Network.QUIC.Recovery +import Network.QUIC.Server.Reader (runNewServerReader) import Network.QUIC.Stream import Network.QUIC.Types -receiver :: Connection -> Receive -> IO () -receiver conn recv = handleLogT logAction $ - E.bracket (mallocBytes maximumUdpPayloadSize) - free - body +receiver :: Connection -> IO () +receiver conn = handleLogT logAction body where - body buf = do - loopHandshake buf - loopEstablished buf + body = do + loopHandshake + loopEstablished recvTimeout = do -- The spec says that CC is not sent when timeout. -- But we intentionally sends CC when timeout. ito <- readMinIdleTimeout conn - mx <- timeout ito recv -- fixme: taking minimum with peer's one + mx <- timeout ito $ connRecv conn -- fixme: taking minimum with peer's one case mx of Nothing -> E.throwIO ConnectionIsTimeout Just x -> return x - loopHandshake buf = do + loopHandshake = do rpkt <- recvTimeout - processReceivedPacketHandshake conn buf rpkt + processReceivedPacketHandshake conn rpkt established <- isConnectionEstablished conn - unless established $ loopHandshake buf - loopEstablished buf = forever $ do + unless established loopHandshake + loopEstablished = forever $ do rpkt <- recvTimeout let CryptPacket hdr _ = rpCryptPacket rpkt cid = headerMyCID hdr @@ -60,7 +59,7 @@ register <- getRegister conn register (cidInfoCID cidInfo) conn sendFrames conn RTT1Level [NewConnectionID cidInfo 0] - processReceivedPacket conn buf rpkt + processReceivedPacket conn rpkt shouldUpdatePeer <- if shouldUpdate then shouldUpdatePeerCID conn else return False when shouldUpdatePeer $ choosePeerCIDForPrivacy conn @@ -69,8 +68,8 @@ connDebugLog conn $ bhow cid <> " is unknown" logAction msg = connDebugLog conn ("debug: receiver: " <> msg) -processReceivedPacketHandshake :: Connection -> Buffer -> ReceivedPacket -> IO () -processReceivedPacketHandshake conn buf rpkt = do +processReceivedPacketHandshake :: Connection -> ReceivedPacket -> IO () +processReceivedPacketHandshake conn rpkt = do let CryptPacket hdr _ = rpCryptPacket rpkt lvl = rpEncryptionLevel rpkt mx <- timeout (Microseconds 10000) $ waitEncryptionLevel conn lvl @@ -89,7 +88,17 @@ resetPeerCID conn newPeerCID setPeerAuthCIDs conn $ \auth -> auth { initSrcCID = Just newPeerCID } - processReceivedPacket conn buf rpkt + case hdr of + Initial peerVer _ _ _ -> do + myVer <- getVersion conn + let myOrigiVer = getOriginalVersion conn + firstTime = myVer == myOrigiVer + when (firstTime && myVer /= peerVer) $ do + setVersion conn peerVer + dcid <- getClientDstCID conn + initializeCoder conn InitialLevel $ initialSecrets peerVer dcid + _ -> return () + processReceivedPacket conn rpkt | otherwise -> do mycid <- getMyCID conn when (lvl == HandshakeLevel @@ -98,21 +107,21 @@ when (lvl == HandshakeLevel) $ do let ldcc = connLDCC conn discarded <- getAndSetPacketNumberSpaceDiscarded ldcc InitialLevel - unless discarded $ do + unless discarded $ fire conn (Microseconds 100000) $ do dropSecrets conn InitialLevel clearCryptoStream conn InitialLevel onPacketNumberSpaceDiscarded ldcc InitialLevel - processReceivedPacket conn buf rpkt + processReceivedPacket conn rpkt -processReceivedPacket :: Connection -> Buffer -> ReceivedPacket -> IO () -processReceivedPacket conn buf rpkt = do +processReceivedPacket :: Connection -> ReceivedPacket -> IO () +processReceivedPacket conn rpkt = do let CryptPacket hdr crypt = rpCryptPacket rpkt lvl = rpEncryptionLevel rpkt tim = rpTimeRecevied rpkt - bufsiz = maximumUdpPayloadSize - mplain <- decryptCrypt conn buf bufsiz crypt lvl + mplain <- decryptCrypt conn crypt lvl case mplain of Just plain@Plain{..} -> do + addRxBytes conn $ rpReceivedBytes rpkt when (isIllegalReservedBits plainMarks || isNoFrames plainMarks) $ closeConnection ProtocolViolation "Non 0 RR bits or no frames" when (isUnknownFrame plainMarks) $ @@ -120,31 +129,28 @@ -- For Ping, record PPN first, then send an ACK. onPacketReceived (connLDCC conn) lvl plainPacketNumber when (lvl == RTT1Level) $ setPeerPacketNumber conn plainPacketNumber - unless (isCryptLogged crypt) $ - qlogReceived conn (PlainPacket hdr plain) tim + qlogReceived conn (PlainPacket hdr plain) tim let ackEli = any ackEliciting plainFrames - shouldDrop = rpReceivedBytes rpkt < defaultQUICPacketSize - && lvl == InitialLevel && ackEli - if shouldDrop then do - connDebugLog conn ("debug: drop packet whose size is " <> bhow (rpReceivedBytes rpkt)) - qlogDropped conn hdr - else do - (ckp,cpn) <- getCurrentKeyPhase conn - let Flags flags = plainFlags - nkp = flags `testBit` 2 - when (nkp /= ckp && plainPacketNumber > cpn) $ do - setCurrentKeyPhase conn nkp plainPacketNumber - updateCoder1RTT conn ckp -- ckp is now next - mapM_ (processFrame conn lvl) plainFrames - when ackEli $ do - case lvl of - RTT0Level -> return () - RTT1Level -> delayedAck conn - _ -> do - sup <- getSpeedingUp (connLDCC conn) - when sup $ do - qlogDebug conn $ Debug "ping for speedup" - sendFrames conn lvl [Ping] + case cryptMigraionInfo crypt of + Nothing -> return () + Just miginfo -> + void . forkIO $ runNewServerReader conn miginfo + (ckp,cpn) <- getCurrentKeyPhase conn + let Flags flags = plainFlags + nkp = flags `testBit` 2 + when (nkp /= ckp && plainPacketNumber > cpn) $ do + setCurrentKeyPhase conn nkp plainPacketNumber + updateCoder1RTT conn ckp -- ckp is now next + mapM_ (processFrame conn lvl) plainFrames + when ackEli $ do + case lvl of + RTT0Level -> return () + RTT1Level -> delayedAck conn + _ -> do + sup <- getSpeedingUp (connLDCC conn) + when sup $ do + qlogDebug conn $ Debug "ping for speedup" + sendFrames conn lvl [Ping] Nothing -> do statelessReset <- isStatelessReset conn hdr crypt if statelessReset then do diff --git a/Network/QUIC/Recovery/Constants.hs b/Network/QUIC/Recovery/Constants.hs --- a/Network/QUIC/Recovery/Constants.hs +++ b/Network/QUIC/Recovery/Constants.hs @@ -17,7 +17,7 @@ -- considers a packet lost. Specified as an RTT multiplier. kTimeThreshold :: Microseconds -> Microseconds -kTimeThreshold x = x + (x .>>. 3) -- 9/8 +kTimeThreshold x = x + (x !>>. 3) -- 9/8 -- | Timer granularity. kGranularity :: Microseconds @@ -27,17 +27,17 @@ -- | Default limit on the initial bytes in flight. kInitialWindow :: Int -> Int --kInitialWindow pktSiz = min 14720 (10 * pktSiz) -kInitialWindow pktSiz = pktSiz .<<. 2 -- .<<. 1 is not good enough +kInitialWindow pktSiz = pktSiz !<<. 2 -- !<<. 1 is not good enough -- | Minimum congestion window in bytes. kMinimumWindow :: LDCC -> IO Int kMinimumWindow ldcc = do siz <- getMaxPacketSize ldcc - return (siz .<<. 2) -- .<<. 1 is not good enough + return (siz !<<. 2) -- !<<. 1 is not good enough -- | Reduction in congestion window when a new loss event is detected. kLossReductionFactor :: Int -> Int -kLossReductionFactor = (.>>. 1) -- 0.5 +kLossReductionFactor = (!>>. 1) -- 0.5 -- | Period of time for persistent congestion to be established, -- specified as a PTO multiplier. diff --git a/Network/QUIC/Recovery/Interface.hs b/Network/QUIC/Recovery/Interface.hs --- a/Network/QUIC/Recovery/Interface.hs +++ b/Network/QUIC/Recovery/Interface.hs @@ -8,9 +8,9 @@ , resender ) where -import Control.Concurrent.STM import qualified Data.Sequence as Seq import System.Log.FastLogger (LogStr) +import UnliftIO.STM import Network.QUIC.Imports import Network.QUIC.Qlog @@ -24,12 +24,12 @@ checkWindowOpenSTM :: LDCC -> Int -> STM () checkWindowOpenSTM LDCC{..} siz = do CC{..} <- readTVar recoveryCC - check (siz <= congestionWindow - bytesInFlight) + checkSTM (siz <= congestionWindow - bytesInFlight) takePingSTM :: LDCC -> STM EncryptionLevel takePingSTM LDCC{..} = do mx <- readTVar ptoPing - check $ isJust mx + checkSTM $ isJust mx writeTVar ptoPing Nothing return $ fromJust mx @@ -49,7 +49,7 @@ resender ldcc@LDCC{..} = forever $ do atomically $ do lostPackets <- readTVar lostCandidates - check (lostPackets /= emptySentPackets) + checkSTM (lostPackets /= emptySentPackets) delay $ Microseconds 10000 -- fixme packets <- atomically $ do SentPackets pkts <- readTVar lostCandidates diff --git a/Network/QUIC/Recovery/LossRecovery.hs b/Network/QUIC/Recovery/LossRecovery.hs --- a/Network/QUIC/Recovery/LossRecovery.hs +++ b/Network/QUIC/Recovery/LossRecovery.hs @@ -8,9 +8,9 @@ , onPacketNumberSpaceDiscarded ) where -import Control.Concurrent.STM import Data.Sequence (Seq, (|>), ViewR(..)) import qualified Data.Sequence as Seq +import UnliftIO.STM import Network.QUIC.Connector import Network.QUIC.Imports diff --git a/Network/QUIC/Recovery/Metrics.hs b/Network/QUIC/Recovery/Metrics.hs --- a/Network/QUIC/Recovery/Metrics.hs +++ b/Network/QUIC/Recovery/Metrics.hs @@ -9,8 +9,8 @@ , setInitialCongestionWindow ) where -import Control.Concurrent.STM import Data.Sequence (Seq) +import UnliftIO.STM import Network.QUIC.Imports import Network.QUIC.Qlog @@ -63,11 +63,11 @@ | otherwise = latestRTT0 -- rttvar_sample = abs(smoothed_rtt - adjusted_rtt) -- rttvar = 3/4 * rttvar + 1/4 * rttvar_sample - rttvar' = rttvar - (rttvar .>>. 2) - + (abs (smoothedRTT - adjustedRTT) .>>. 2) + rttvar' = rttvar - (rttvar !>>. 2) + + (abs (smoothedRTT - adjustedRTT) !>>. 2) -- smoothed_rtt = 7/8 * smoothed_rtt + 1/8 * adjusted_rtt - smoothedRTT' = smoothedRTT - (smoothedRTT .>>. 3) - + (adjustedRTT .>>. 3) + smoothedRTT' = smoothedRTT - (smoothedRTT !>>. 3) + + (adjustedRTT !>>. 3) updateCC :: LDCC -> Seq SentPacket -> Bool -> IO () updateCC ldcc@LDCC{..} lostPackets isRecovery = do diff --git a/Network/QUIC/Recovery/Persistent.hs b/Network/QUIC/Recovery/Persistent.hs --- a/Network/QUIC/Recovery/Persistent.hs +++ b/Network/QUIC/Recovery/Persistent.hs @@ -29,7 +29,7 @@ -- Sec 6.2.1. Computing PTO -- PTO = smoothed_rtt + max(4*rttvar, kGranularity) + max_ack_delay calcPTO :: RTT -> Maybe EncryptionLevel -> Microseconds -calcPTO RTT{..} mlvl = smoothedRTT + max (rttvar .<<. 2) kGranularity + dly +calcPTO RTT{..} mlvl = smoothedRTT + max (rttvar !<<. 2) kGranularity + dly where dly = getMaxAckDelay mlvl maxAckDelay1RTT diff --git a/Network/QUIC/Recovery/Release.hs b/Network/QUIC/Recovery/Release.hs --- a/Network/QUIC/Recovery/Release.hs +++ b/Network/QUIC/Recovery/Release.hs @@ -8,9 +8,9 @@ , onPacketsLost ) where -import Control.Concurrent.STM import Data.Sequence (Seq, (><), ViewL(..), ViewR(..)) import qualified Data.Sequence as Seq +import UnliftIO.STM import Network.QUIC.Imports import Network.QUIC.Recovery.Metrics diff --git a/Network/QUIC/Recovery/Timer.hs b/Network/QUIC/Recovery/Timer.hs --- a/Network/QUIC/Recovery/Timer.hs +++ b/Network/QUIC/Recovery/Timer.hs @@ -10,9 +10,9 @@ , ldccTimer ) where -import Control.Concurrent.STM import qualified Data.Sequence as Seq -import GHC.Event hiding (new) +import Network.QUIC.Event +import UnliftIO.STM import Network.QUIC.Connector import Network.QUIC.Imports @@ -114,7 +114,7 @@ ldccTimer ldcc@LDCC{..} = forever $ do atomically $ do x <- readTVar timerInfoQ - check (x /= Empty) + checkSTM (x /= Empty) delay timerGranularity updateWithNext ldcc diff --git a/Network/QUIC/Recovery/Types.hs b/Network/QUIC/Recovery/Types.hs --- a/Network/QUIC/Recovery/Types.hs +++ b/Network/QUIC/Recovery/Types.hs @@ -35,13 +35,13 @@ , qlogLossTimerExpired ) where -import Control.Concurrent.STM import Data.IORef import Data.List (intersperse) import Data.Sequence (Seq) import qualified Data.Sequence as Seq -import GHC.Event +import Network.QUIC.Event import System.Log.FastLogger +import UnliftIO.STM import Network.QUIC.Connector import Network.QUIC.Imports @@ -127,7 +127,7 @@ initialRTT = RTT { latestRTT = Microseconds 0 , smoothedRTT = kInitialRTT - , rttvar = kInitialRTT .>>. 1 + , rttvar = kInitialRTT !>>. 1 , minRTT = Microseconds 0 , maxAckDelay1RTT = Microseconds 0 , ptoCount = 0 diff --git a/Network/QUIC/Recovery/Utils.hs b/Network/QUIC/Recovery/Utils.hs --- a/Network/QUIC/Recovery/Utils.hs +++ b/Network/QUIC/Recovery/Utils.hs @@ -12,10 +12,10 @@ , delay ) where -import Control.Concurrent -import Control.Concurrent.STM import Data.Sequence (Seq, (<|), ViewL(..)) import qualified Data.Sequence as Seq +import UnliftIO.Concurrent +import UnliftIO.STM import Network.QUIC.Connector import Network.QUIC.Imports diff --git a/Network/QUIC/Sender.hs b/Network/QUIC/Sender.hs --- a/Network/QUIC/Sender.hs +++ b/Network/QUIC/Sender.hs @@ -5,12 +5,11 @@ , mkHeader ) where -import Control.Concurrent -import Control.Concurrent.STM import qualified Data.ByteString as BS -import Foreign.Marshal.Alloc import Foreign.Ptr (plusPtr) +import UnliftIO.Concurrent import qualified UnliftIO.Exception as E +import UnliftIO.STM import Network.QUIC.Config import Network.QUIC.Connection @@ -37,26 +36,26 @@ ---------------------------------------------------------------- -sendPacket :: Connection -> SendBuf -> Buffer -> [SentPacket] -> IO () -sendPacket _ _ _ [] = return () -sendPacket conn send buf0 spkts0 = getMaxPacketSize conn >>= go +sendPacket :: Connection -> [SentPacket] -> IO () +sendPacket _ [] = return () +sendPacket conn spkts0 = getMaxPacketSize conn >>= go where + SizedBuffer buf0 bufsiz0 = encryptRes conn ldcc = connLDCC conn go maxSiz = do mx <- atomically ((Just <$> takePingSTM ldcc) `orElse` (Nothing <$ checkWindowOpenSTM ldcc maxSiz)) case mx of Just lvl | lvl `elem` [InitialLevel,HandshakeLevel] -> do - sendPingPacket conn send buf0 lvl + sendPingPacket conn lvl go maxSiz _ -> do when (isJust mx) $ qlogDebug conn $ Debug "probe new" - let bufsiz = maximumUdpPayloadSize - (sentPackets, leftsiz) <- buildPackets buf0 bufsiz maxSiz spkts0 id - let bytes = bufsiz - leftsiz + (sentPackets, leftsiz) <- buildPackets buf0 bufsiz0 maxSiz spkts0 id + let bytes = bufsiz0 - leftsiz when (isServer conn) $ waitAntiAmplificationFree conn bytes now <- getTimeMicrosecond - send buf0 bytes + connSend conn buf0 bytes addTxBytes conn bytes forM_ sentPackets $ \sentPacket0 -> do let sentPacket = sentPacket0 { spTimeSent = now } @@ -65,7 +64,7 @@ buildPackets _ _ _ [] _ = error "sendPacket: buildPackets" buildPackets buf bufsiz siz [spkt] build0 = do let pkt = spPlainPacket spkt - (bytes,padlen) <- encodePlainPacket conn buf bufsiz pkt $ Just siz + (bytes,padlen) <- encodePlainPacket conn (SizedBuffer buf bufsiz) pkt $ Just siz if bytes < 0 then return (build0 [], bufsiz) else do @@ -73,7 +72,7 @@ return (build0 [sentPacket], bufsiz - bytes) buildPackets buf bufsiz siz (spkt:spkts) build0 = do let pkt = spPlainPacket spkt - (bytes,padlen) <- encodePlainPacket conn buf bufsiz pkt Nothing + (bytes,padlen) <- encodePlainPacket conn (SizedBuffer buf bufsiz) pkt Nothing if bytes < 0 then buildPackets buf bufsiz siz spkts build0 else do @@ -86,8 +85,8 @@ ---------------------------------------------------------------- -sendPingPacket :: Connection -> SendBuf -> Buffer -> EncryptionLevel -> IO () -sendPingPacket conn send buf lvl = do +sendPingPacket :: Connection -> EncryptionLevel -> IO () +sendPingPacket conn lvl = do maxSiz <- getMaxPacketSize conn ok <- if isClient conn then return True else checkAntiAmplificationFree conn maxSiz @@ -108,11 +107,11 @@ else do let spkt = last xs ping = spPlainPacket spkt - bufsiz = maximumUdpPayloadSize - (bytes,padlen) <- encodePlainPacket conn buf bufsiz ping (Just maxSiz) + let sizbuf@(SizedBuffer buf _) = encryptRes conn + (bytes,padlen) <- encodePlainPacket conn sizbuf ping (Just maxSiz) when (bytes >= 0) $ do now <- getTimeMicrosecond - send buf bytes + connSend conn buf bytes addTxBytes conn bytes let sentPacket0 = fixSentPacket spkt bytes padlen sentPacket = sentPacket0 { spTimeSent = now } @@ -206,20 +205,17 @@ | SwOut Output | SwStrm TxStreamData -sender :: Connection -> SendBuf -> IO () -sender conn send = handleLogT logAction $ - E.bracket (mallocBytes (maximumUdpPayloadSize * 2)) - free - body +sender :: Connection -> IO () +sender conn = handleLogT logAction body where - body buf = forever $ do + body = forever $ do x <- atomically ((SwPing <$> takePingSTM (connLDCC conn)) `orElse` (SwOut <$> takeOutputSTM conn) `orElse` (SwStrm <$> takeSendStreamQSTM conn)) case x of - SwPing lvl -> sendPingPacket conn send buf lvl - SwOut out -> sendOutput conn send buf out - SwStrm tx -> sendTxStreamData conn send buf tx + SwPing lvl -> sendPingPacket conn lvl + SwOut out -> sendOutput conn out + SwStrm tx -> sendTxStreamData conn tx logAction msg = connDebugLog conn ("debug: sender: " <> msg) ---------------------------------------------------------------- @@ -229,30 +225,30 @@ | isClient conn = do let ldcc = connLDCC conn discarded <- getAndSetPacketNumberSpaceDiscarded ldcc InitialLevel - unless discarded $ do + unless discarded $ fire conn (Microseconds 100000) $ do dropSecrets conn InitialLevel clearCryptoStream conn InitialLevel onPacketNumberSpaceDiscarded ldcc InitialLevel | otherwise = return () -sendOutput :: Connection -> SendBuf -> Buffer -> Output -> IO () -sendOutput conn send buf (OutControl lvl frames action) = do - construct conn lvl frames >>= sendPacket conn send buf +sendOutput :: Connection -> Output -> IO () +sendOutput conn (OutControl lvl frames action) = do + construct conn lvl frames >>= sendPacket conn when (lvl == HandshakeLevel) $ discardClientInitialPacketNumberSpace conn action -sendOutput conn send buf (OutHandshake lcs0) = do +sendOutput conn (OutHandshake lcs0) = do let convert = onTLSHandshakeCreated $ connHooks conn (lcs,wait) = convert lcs0 -- only for h3spec when wait $ wait0RTTReady conn - sendCryptoFragments conn send buf lcs + sendCryptoFragments conn lcs when (any (\(l,_) -> l == HandshakeLevel) lcs) $ discardClientInitialPacketNumberSpace conn -sendOutput conn send buf (OutRetrans (PlainPacket hdr0 plain0)) = do +sendOutput conn (OutRetrans (PlainPacket hdr0 plain0)) = do frames <- adjustForRetransmit conn $ plainFrames plain0 let lvl = levelFromHeader hdr0 - construct conn lvl frames >>= sendPacket conn send buf + construct conn lvl frames >>= sendPacket conn levelFromHeader :: Header -> EncryptionLevel levelFromHeader hdr @@ -289,29 +285,29 @@ thresholdC :: Int thresholdC = 200 -sendCryptoFragments :: Connection -> SendBuf -> Buffer -> [(EncryptionLevel, CryptoData)] -> IO () -sendCryptoFragments _ _ _ [] = return () -sendCryptoFragments conn send buf lcs = do +sendCryptoFragments :: Connection -> [(EncryptionLevel, CryptoData)] -> IO () +sendCryptoFragments _ [] = return () +sendCryptoFragments conn lcs = do loop limitationC id lcs where loop :: Int -> ([SentPacket] -> [SentPacket]) -> [(EncryptionLevel, CryptoData)] -> IO () loop _ build0 [] = do let spkts0 = build0 [] - unless (null spkts0) $ sendPacket conn send buf spkts0 + unless (null spkts0) $ sendPacket conn spkts0 loop len0 build0 ((lvl, bs) : xs) | BS.length bs > len0 = do let (target, rest) = BS.splitAt len0 bs frame1 <- cryptoFrame conn target lvl spkts1 <- construct conn lvl [frame1] - sendPacket conn send buf $ build0 spkts1 + sendPacket conn $ build0 spkts1 loop limitationC id ((lvl, rest) : xs) loop _ build0 [(lvl, bs)] = do frame1 <- cryptoFrame conn bs lvl spkts1 <- construct conn lvl [frame1] - sendPacket conn send buf $ build0 spkts1 + sendPacket conn $ build0 spkts1 loop len0 build0 ((lvl, bs) : xs) | len0 - BS.length bs < thresholdC = do frame1 <- cryptoFrame conn bs lvl spkts1 <- construct conn lvl [frame1] - sendPacket conn send buf $ build0 spkts1 + sendPacket conn $ build0 spkts1 loop limitationC id xs loop len0 build0 ((lvl, bs) : xs) = do frame1 <- cryptoFrame conn bs lvl @@ -339,24 +335,26 @@ return True _ -> return False -sendTxStreamData :: Connection -> SendBuf -> Buffer -> TxStreamData -> IO () -sendTxStreamData conn send buf (TxStreamData s dats len fin0) = do +sendTxStreamData :: Connection -> TxStreamData -> IO () +sendTxStreamData conn (TxStreamData s dats len fin0) = do fin <- packFin conn s fin0 - if len < limitation then do - sendStreamSmall conn send buf s dats fin len + if len < limitation then + sendStreamSmall conn s dats fin len else - sendStreamLarge conn send buf s dats fin + sendStreamLarge conn s dats fin -sendStreamSmall :: Connection -> SendBuf -> Buffer -> Stream -> [StreamData] -> Bool -> Int -> IO () -sendStreamSmall conn send buf s0 dats0 fin0 len0 = do +sendStreamSmall :: Connection -> Stream -> [StreamData] -> Bool -> Int -> IO () +sendStreamSmall conn s0 dats0 fin0 len0 = do off0 <- getTxStreamOffset s0 len0 let sid0 = streamId s0 frame0 = StreamF sid0 off0 dats0 fin0 - frames <- loop s0 frame0 len0 id + sb = if fin0 then (s0 :) else id + (frames,streams) <- loop s0 frame0 len0 id sb ready <- isConnection1RTTReady conn let lvl | ready = RTT1Level | otherwise = RTT0Level - construct conn lvl frames >>= sendPacket conn send buf + construct conn lvl frames >>= sendPacket conn + mapM_ syncFinTx streams where tryPeek = do mx <- tryPeekSendStreamQ conn @@ -365,11 +363,14 @@ yield tryPeekSendStreamQ conn Just _ -> return mx - loop :: Stream -> Frame -> Int -> ([Frame] -> [Frame]) -> IO [Frame] - loop s frame total build = do + loop :: Stream -> Frame -> Int + -> ([Frame] -> [Frame]) + -> ([Stream] -> [Stream]) + -> IO ([Frame], [Stream]) + loop s frame total build sb = do mx <- tryPeek case mx of - Nothing -> return $ build [frame] + Nothing -> return (build [frame], sb []) Just (TxStreamData s1 dats1 len1 fin1) -> do let total1 = len1 + total if total1 < limitation then do @@ -379,18 +380,24 @@ let sid = streamId s sid1 = streamId s1 if sid == sid1 then do - let StreamF _ off dats _ = frame + let (off,dats) = case frame of + StreamF _ o d _ -> (o,d) + _ -> error "sendStreamSmall" frame1 = StreamF sid off (dats ++ dats1) fin1' - loop s1 frame1 total1 build + sb1 = if fin1 then (sb . (s1 :)) else sb + loop s1 frame1 total1 build sb1 else do let frame1 = StreamF sid1 off1 dats1 fin1' build1 = build . (frame :) - loop s1 frame1 total1 build1 + sb1 = if fin1 then (sb . (s1 :)) else sb + loop s1 frame1 total1 build1 sb1 else - return $ build [frame] + return (build [frame], sb []) -sendStreamLarge :: Connection -> SendBuf -> Buffer -> Stream -> [ByteString] -> Bool -> IO () -sendStreamLarge conn send buf s dats0 fin0 = loop dats0 +sendStreamLarge :: Connection -> Stream -> [ByteString] -> Bool -> IO () +sendStreamLarge conn s dats0 fin0 = do + loop dats0 + when fin0 $ syncFinTx s where sid = streamId s loop [] = return () @@ -403,7 +410,7 @@ ready <- isConnection1RTTReady conn let lvl | ready = RTT1Level | otherwise = RTT0Level - construct conn lvl [frame] >>= sendPacket conn send buf + construct conn lvl [frame] >>= sendPacket conn loop dats2 -- Typical case: [3, 1024, 1024, 1024, 200] diff --git a/Network/QUIC/Server.hs b/Network/QUIC/Server.hs --- a/Network/QUIC/Server.hs +++ b/Network/QUIC/Server.hs @@ -12,6 +12,7 @@ , scUse0RTT , scCiphers , scGroups + , scVersions -- , scParameters , scCredentials , scSessionManager diff --git a/Network/QUIC/Server/Reader.hs b/Network/QUIC/Server/Reader.hs --- a/Network/QUIC/Server/Reader.hs +++ b/Network/QUIC/Server/Reader.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -14,36 +15,40 @@ , RecvQ , recvServer , readerServer + -- * Misc + , runNewServerReader ) 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 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.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 +#if defined(mingw32_HOST_OS) +import Network.QUIC.Windows +#else +import Network.QUIC.Connector +#endif ---------------------------------------------------------------- @@ -113,11 +118,11 @@ ---------------------------------------------------------------- data Accept = Accept { - accVersion :: Version + accVersionInfo :: VersionInfo , accMyAuthCIDs :: AuthCIDs , accPeerAuthCIDs :: AuthCIDs - , accMySockAddr :: SockAddr - , accPeerSockAddr :: SockAddr + , accMySocket :: ListenSocket + , accPeerSockAddr :: ClientSockAddr , accRecvQ :: RecvQ , accPacketSize :: Int , accRegister :: CID -> Connection -> IO () @@ -142,46 +147,38 @@ ---------------------------------------------------------------- -runDispatcher :: Dispatch -> ServerConfig -> (Socket, SockAddr) -> IO ThreadId -runDispatcher d conf ssa@(s,_) = - forkFinally (dispatcher d conf ssa) $ \_ -> close s +runDispatcher :: Dispatch -> ServerConfig -> ListenSocket -> IO ThreadId +runDispatcher d conf mysock = + forkFinally (dispatcher d conf mysock) $ \_ -> UDP.stop mysock -dispatcher :: Dispatch -> ServerConfig -> (Socket, SockAddr) -> IO () -dispatcher d conf (s,mysa) = handleLogUnit logAction $ - E.bracket (mallocBytes maximumUdpPayloadSize) - free - body +dispatcher :: Dispatch -> ServerConfig -> ListenSocket -> IO () +dispatcher d conf mysock = handleLogUnit logAction $ do + forever $ do + (bs, peersa) <- safeRecv $ UDP.recvFrom mysock + now <- getTimeMicrosecond + let send' b = UDP.sendTo mysock b peersa + cpckts <- decodeCryptPackets bs + let bytes = BS.length bs + switch = dispatch d conf logAction mysock peersa send' bytes now + mapM_ switch cpckts where - body buf = do - -- let (opt,_cmsgid) = case mysa of - -- SockAddrInet{} -> (RecvIPv4PktInfo, CmsgIdIPv4PktInfo) - -- SockAddrInet6{} -> (RecvIPv6PktInfo, CmsgIdIPv6PktInfo) - -- _ -> error "dispatcher" - -- setSocketOption s opt 1 - forever $ do - -- (peersa, bs0, _cmsgs, _) <- recv - (bs0, peersa) <- recv - let bytes = BS.length bs0 -- both Initial and 0RTT - now <- getTimeMicrosecond - -- macOS overrides the local address of the socket - -- if in_pktinfo is used. - (pkt, bs0RTT) <- decodePacket bs0 - -- let send bs = void $ NSB.sendMsg s peersa [bs] cmsgs' 0 - let send bs = void $ NSB.sendTo s bs peersa - dispatch d conf logAction pkt mysa peersa send buf bs0RTT bytes now doDebug = isJust $ scDebugLog conf logAction msg | doDebug = stdoutLogger ("dispatch(er): " <> msg) | otherwise = return () - recv = do --- ex <- E.try $ NSB.recvMsg s maximumUdpPayloadSize 64 0 - ex <- E.tryAny $ NSB.recvFrom s maximumUdpPayloadSize + + safeRecv rcv = do + ex <- E.tryAny $ +#if defined(mingw32_HOST_OS) + windowsThreadBlockHack $ +#endif + rcv case ex of Right x -> return x Left se -> case E.fromException se of Just e | E.ioeGetErrorType e == E.InvalidArgument -> E.throwIO se _ -> do logAction $ "recv again: " <> bhow se - recv + rcv ---------------------------------------------------------------- @@ -192,24 +189,32 @@ -- 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 + -> ListenSocket -> ClientSockAddr -> (ByteString -> IO ()) -> Int -> TimeMicrosecond + -> (CryptPacket,EncryptionLevel,Int) + -> IO () dispatch Dispatch{..} ServerConfig{..} logAction - (PacketIC cpkt@(CryptPacket (Initial ver dCID sCID token) _) lvl) - mysa peersa send _ bs0RTT bytes tim + mysock peersa send' bytes tim + (cpkt@(CryptPacket (Initial peerVer dCID sCID token) _),lvl,siz) | bytes < defaultQUICPacketSize = do logAction $ "too small " <> bhow bytes <> ", " <> bhow peersa - | ver `notElem` scVersions= do - let vers | ver == GreasingVersion = GreasingVersion2 : scVersions - | otherwise = GreasingVersion : scVersions - bss <- encodeVersionNegotiationPacket $ VersionNegotiationPacket sCID dCID vers - send bss + | peerVer `notElem` myVersions = do + let offerVersions + | peerVer == GreasingVersion = GreasingVersion2 : myVersions + | otherwise = GreasingVersion : myVersions + bss <- encodeVersionNegotiationPacket $ VersionNegotiationPacket sCID dCID offerVersions + send' bss | token == "" = do - mq <- lookupConnectionDict dstTable dCID - case mq of + mconn <- lookupConnectionDict dstTable dCID + case mconn of Nothing | scRequireRetry -> sendRetry | otherwise -> pushToAcceptFirst False +#if defined(mingw32_HOST_OS) + Just conn -> writeRecvQ (connRecvQ conn) $ mkReceivedPacket cpkt tim siz lvl +#else _ -> return () +#endif | otherwise = do mct <- decryptToken tokenMgr token case mct of @@ -218,27 +223,32 @@ ok <- isRetryTokenValid ct if ok then pushToAcceptRetried ct else sendRetry | otherwise -> do - mq <- lookupConnectionDict dstTable dCID - case mq of - Nothing -> pushToAcceptFirst True + mconn <- lookupConnectionDict dstTable dCID + case mconn of + Nothing -> pushToAcceptFirst True +#if defined(mingw32_HOST_OS) + Just conn -> writeRecvQ (connRecvQ conn) $ mkReceivedPacket cpkt tim siz lvl +#else _ -> return () +#endif _ -> sendRetry where + myVersions = scVersions pushToAcceptQ myAuthCIDs peerAuthCIDs key addrValid = do mq <- lookupRecvQDict srcTable key case mq of - Just q -> writeRecvQ q $ mkReceivedPacket cpkt tim bytes lvl + Just q -> writeRecvQ q $ mkReceivedPacket cpkt tim siz lvl Nothing -> do q <- newRecvQ insertRecvQDict srcTable key q - writeRecvQ q $ mkReceivedPacket cpkt tim bytes lvl + writeRecvQ q $ mkReceivedPacket cpkt tim siz lvl let reg = registerConnectionDict dstTable unreg = unregisterConnectionDict dstTable ent = Accept { - accVersion = ver + accVersionInfo = VersionInfo peerVer myVersions , accMyAuthCIDs = myAuthCIDs , accPeerAuthCIDs = peerAuthCIDs - , accMySockAddr = mysa + , accMySocket = mysock , accPeerSockAddr = peersa , accRecvQ = q , accPacketSize = bytes @@ -249,9 +259,6 @@ } -- fixme: check acceptQ length writeAcceptQ acceptQ ent - when (bs0RTT /= "") $ do - (PacketIC cpktRTT0 lvl', _) <- decodePacket bs0RTT - writeRecvQ q $ mkReceivedPacket cpktRTT0 tim bytes lvl' -- Initial: DCID=S1, SCID=C1 -> -- <- Initial: DCID=C1, SCID=S2 -- ... @@ -293,75 +300,80 @@ } pushToAcceptQ myAuthCIDs peerAuthCIDs o True pushToAcceptRetried _ = return () - isRetryTokenValid (CryptoToken tver etim (Just (l,r,_))) = do + isRetryTokenValid (CryptoToken _tver etim (Just (l,r,_))) = do diff <- getElapsedTimeMicrosecond etim - return $ tver == ver - && diff <= Microseconds 30000000 -- fixme + return $ diff <= Microseconds 30000000 -- fixme && dCID == l && sCID == r +#if !defined(mingw32_HOST_OS) + -- Initial for ACK contains the retry token but + -- the version would be already version 2, sigh. + && _tver == peerVer +#endif isRetryTokenValid _ = return False sendRetry = do newdCID <- newCID - retryToken <- generateRetryToken ver newdCID sCID dCID + retryToken <- generateRetryToken peerVer newdCID sCID dCID mnewtoken <- timeout (Microseconds 100000) $ encryptToken tokenMgr retryToken case mnewtoken of Nothing -> logAction "retry token stacked" Just newtoken -> do - bss <- encodeRetryPacket $ RetryPacket ver sCID newdCID newtoken (Left dCID) - send bss + bss <- encodeRetryPacket $ RetryPacket peerVer sCID newdCID newtoken (Left dCID) + send' bss +---------------------------------------------------------------- dispatch Dispatch{..} _ _ - (PacketIC cpkt@(CryptPacket (RTT0 _ o _) _) lvl) _ _peersa _ _ _ bytes tim = do + _ _peersa _ _ tim + (cpkt@(CryptPacket (RTT0 _ o _) _), lvl, siz) = do mq <- lookupRecvQDict srcTable o case mq of - Just q -> writeRecvQ q $ mkReceivedPacket cpkt tim bytes lvl + Just q -> writeRecvQ q $ mkReceivedPacket cpkt tim siz lvl Nothing -> return () +#if defined(mingw32_HOST_OS) +---------------------------------------------------------------- dispatch Dispatch{..} _ logAction - (PacketIC (CryptPacket hdr@(Short dCID) crypt) lvl) mysa peersa _ buf _ bytes tim = do + _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{..} _ logAction + mysock peersa _ _ tim + ((CryptPacket hdr@(Short dCID) crypt),lvl,siz)= do -- fixme: packets for closed connections also match here. - mx <- lookupConnectionDict dstTable dCID - case mx of + mconn <- lookupConnectionDict dstTable dCID + case mconn of Nothing -> do logAction $ "CID no match: " <> bhow dCID <> ", " <> bhow peersa Just conn -> do - let bufsiz = maximumUdpPayloadSize - mplain <- decryptCrypt conn buf bufsiz crypt RTT1Level - case mplain of - Nothing -> connDebugLog conn "debug: dispatch: cannot decrypt" - Just plain -> do - alive <- getAlive conn - when alive $ do - qlogReceived conn (PlainPacket hdr plain) tim - let cpkt' = CryptPacket hdr $ setCryptLogged crypt - writeMigrationQ conn $ mkReceivedPacket cpkt' tim bytes lvl - migrating <- isPathValidating conn - unless migrating $ do - setMigrationStarted conn - -- fixme: should not block in this loop - mcidinfo <- timeout (Microseconds 100000) $ waitPeerCID conn - let msg = "Migration: " <> bhow peersa <> " (" <> bhow dCID <> ")" - qlogDebug conn $ Debug $ toLogStr msg - connDebugLog conn $ "debug: dispatch: " <> msg - void $ forkIO $ migrator conn mysa peersa dCID mcidinfo - -dispatch _ _ _ _ipkt _ _peersa _ _ _ _ _ = return () + alive <- getAlive conn + when alive $ do + let miginfo = MigrationInfo mysock peersa dCID + crypt' = crypt { cryptMigraionInfo = Just miginfo } + cpkt = CryptPacket hdr crypt' + writeRecvQ (connRecvQ conn) $ mkReceivedPacket cpkt tim siz lvl +---------------------------------------------------------------- +dispatch _ _ _ _ _ _ _ _ _ = return () +#endif ---------------------------------------------------------------- -- | readerServer dies when the socket is closed. -readerServer :: Socket -> Connection -> IO () -readerServer s conn = handleLogUnit logAction loop +readerServer :: UDPSocket -> Connection -> IO () +readerServer us conn = handleLogUnit logAction loop where loop = do ito <- readMinIdleTimeout conn - mbs <- timeout ito $ NSB.recv s maximumUdpPayloadSize + mbs <- timeout ito $ UDP.recv us case mbs of - Nothing -> close s + Nothing -> UDP.close us Just bs -> do now <- getTimeMicrosecond - let bytes = BS.length bs - addRxBytes conn bytes pkts <- decodeCryptPackets bs - mapM_ (\(p,l) -> writeRecvQ (connRecvQ conn) (mkReceivedPacket p now bytes l)) pkts + mapM_ (\(p,l,siz) -> writeRecvQ (connRecvQ conn) (mkReceivedPacket p now siz l)) pkts loop logAction msg = connDebugLog conn ("debug: readerServer: " <> msg) @@ -370,15 +382,24 @@ ---------------------------------------------------------------- -migrator :: Connection -> SockAddr -> SockAddr -> CID -> Maybe CIDInfo -> IO () -migrator conn mysa peersa1 dcid mcidinfo = handleLogUnit logAction $ - E.bracketOnError setup close $ \s1 -> - E.bracket (addSocket conn s1) close $ \_ -> do - void $ forkIO $ readerServer s1 conn - -- fixme: if cannot set - setMyCID conn dcid - validatePath conn mcidinfo - void $ timeout (Microseconds 2000000) $ forever (readMigrationQ conn >>= writeRecvQ (connRecvQ conn)) +runNewServerReader :: Connection -> MigrationInfo -> IO () +runNewServerReader conn (MigrationInfo mysock peersa dCID) = handleLogUnit logAction $ do + migrating <- isPathValidating conn -- fixme: test and set + unless migrating $ do + setMigrationStarted conn + -- fixme: should not block + mcidinfo <- timeout (Microseconds 100000) $ waitPeerCID conn + let msg = "Migration: " <> bhow peersa <> " (" <> bhow dCID <> ")" + qlogDebug conn $ Debug $ toLogStr msg + connDebugLog conn $ "debug: runNewServerReader: " <> msg + E.bracketOnError setup UDP.close $ \s1 -> + E.bracket (setSocket conn s1) UDP.close $ \_ -> do + void $ forkIO $ readerServer s1 conn + -- fixme: if cannot set + setMyCID conn dCID + validatePath conn mcidinfo + -- holding the old socket for a while + delay $ Microseconds 20000 where - setup = udpServerConnectedSocket mysa peersa1 - logAction msg = connDebugLog conn ("debug: migrator: " <> msg) + setup = UDP.accept mysock peersa + logAction msg = connDebugLog conn ("debug: runNewServerReader: " <> msg) diff --git a/Network/QUIC/Server/Run.hs b/Network/QUIC/Server/Run.hs --- a/Network/QUIC/Server/Run.hs +++ b/Network/QUIC/Server/Run.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -8,6 +9,8 @@ ) where import qualified Network.Socket as NS +import Network.UDP (UDPSocket(..), ListenSocket(..)) +import qualified Network.UDP as UDP import System.Log.FastLogger import UnliftIO.Async import UnliftIO.Concurrent @@ -30,7 +33,6 @@ import Network.QUIC.Recovery import Network.QUIC.Sender import Network.QUIC.Server.Reader -import Network.QUIC.Socket import Network.QUIC.Types ---------------------------------------------------------------- @@ -39,7 +41,7 @@ -- The action is executed with a new connection -- in a new lightweight thread. run :: ServerConfig -> (Connection -> IO ()) -> IO () -run conf server = handleLogUnit debugLog $ do +run conf server = NS.withSocketsDo $ handleLogUnit debugLog $ do baseThreadId <- myThreadId E.bracket setup teardown $ \(dispatch,_) -> forever $ do acc <- accept dispatch @@ -51,7 +53,7 @@ setup = do dispatch <- newDispatch -- fixme: the case where sockets cannot be created. - ssas <- mapM udpServerListenSocket $ scAddresses conf + ssas <- mapM UDP.serverSocket $ scAddresses conf tids <- mapM (runDispatcher dispatch conf) ssas ttid <- forkIO timeouter -- fixme return (dispatch, ttid:tids) @@ -63,18 +65,25 @@ -- And the exception should be ignored. runServer :: ServerConfig -> (Connection -> IO ()) -> Dispatch -> ThreadId -> Accept -> IO () runServer conf server0 dispatch baseThreadId acc = - E.bracket open clse $ \(ConnRes conn send recv myAuthCIDs reader) -> + E.bracket open clse $ \(ConnRes conn myAuthCIDs _reader) -> handleLogUnit (debugLog conn) $ do - forkIO reader >>= addReader conn - handshaker <- handshakeServer conf conn myAuthCIDs +#if !defined(mingw32_HOST_OS) + forkIO _reader >>= addReader conn +#endif + let conf' = conf { + scParameters = (scParameters conf) { + versionInformation = Just $ accVersionInfo acc + } + } + handshaker <- handshakeServer conf' conn myAuthCIDs let server = do wait1RTTReady conn afterHandshakeServer conn server0 conn ldcc = connLDCC conn supporters = foldr1 concurrently_ [handshaker - ,sender conn send - ,receiver conn recv + ,sender conn + ,receiver conn ,resender ldcc ,ldccTimer ldcc ] @@ -90,9 +99,10 @@ let conn = connResConnection connRes setDead conn freeResources conn +#if !defined(mingw32_HOST_OS) killReaders conn - socks <- getSockets conn - mapM_ NS.close socks +#endif + getSocket conn >>= UDP.close debugLog conn msg = do connDebugLog conn ("runServer: " <> msg) qlogDebug conn $ Debug $ toLogStr msg @@ -100,28 +110,29 @@ createServerConnection :: ServerConfig -> Dispatch -> Accept -> ThreadId -> IO ConnRes createServerConnection conf@ServerConfig{..} dispatch Accept{..} baseThreadId = do - s0 <- udpServerConnectedSocket accMySockAddr accPeerSockAddr - sref <- newIORef [s0] + us <- UDP.accept accMySocket accPeerSockAddr + let ListenSocket _ mysa _ = accMySocket + sref <- newIORef us let send buf siz = void $ do - s:_ <- readIORef sref - NS.sendBuf s buf siz + UDPSocket{..} <- readIORef sref + NS.sendBuf udpSocket buf siz recv = recvServer accRecvQ - let Just myCID = initSrcCID accMyAuthCIDs - Just ocid = origDstCID accMyAuthCIDs + let myCID = fromJust $ initSrcCID accMyAuthCIDs + ocid = fromJust $ origDstCID accMyAuthCIDs (qLog, qclean) <- dirQLogger scQLog accTime ocid "server" (debugLog, dclean) <- dirDebugLogger scDebugLog ocid debugLog $ "Original CID: " <> bhow ocid - conn <- serverConnection conf accVersion accMyAuthCIDs accPeerAuthCIDs debugLog qLog scHooks sref accRecvQ + conn <- serverConnection conf accVersionInfo accMyAuthCIDs accPeerAuthCIDs debugLog qLog scHooks sref accRecvQ send recv addResource conn qclean addResource conn dclean let cid = fromMaybe ocid $ retrySrcCID accMyAuthCIDs - initializeCoder conn InitialLevel $ initialSecrets accVersion cid + ver = chosenVersion accVersionInfo + initializeCoder conn InitialLevel $ initialSecrets ver cid setupCryptoStreams conn -- fixme: cleanup - let pktSiz = (defaultPacketSize accMySockAddr `max` accPacketSize) `min` maximumPacketSize accMySockAddr + let pktSiz = (defaultPacketSize mysa `max` accPacketSize) `min` maximumPacketSize mysa setMaxPacketSize conn pktSiz setInitialCongestionWindow (connLDCC conn) pktSiz debugLog $ "Packet size: " <> bhow pktSiz <> " (" <> bhow accPacketSize <> ")" - addRxBytes conn accPacketSize when accAddressValidated $ setAddressValidated conn -- let retried = isJust $ retrySrcCID accMyAuthCIDs @@ -140,8 +151,12 @@ myCIDs <- getMyCIDs conn mapM_ accUnregister myCIDs -- - let reader = readerServer s0 conn -- dies when s0 is closed. - return $ ConnRes conn send recv accMyAuthCIDs reader +#if defined(mingw32_HOST_OS) + return $ ConnRes conn accMyAuthCIDs undefined +#else + let reader = readerServer us conn -- dies when us is closed. + return $ ConnRes conn accMyAuthCIDs reader +#endif afterHandshakeServer :: Connection -> IO () afterHandshakeServer conn = handleLogT logAction $ do diff --git a/Network/QUIC/Socket.hs b/Network/QUIC/Socket.hs deleted file mode 100644 --- a/Network/QUIC/Socket.hs +++ /dev/null @@ -1,82 +0,0 @@ -module Network.QUIC.Socket where - -import Control.Concurrent -import qualified UnliftIO.Exception as E -import Data.IP hiding (addr) -import qualified GHC.IO.Exception as E -import Network.Socket -import qualified System.IO.Error as E - -sockAddrFamily :: SockAddr -> Family -sockAddrFamily SockAddrInet{} = AF_INET -sockAddrFamily SockAddrInet6{} = AF_INET6 -sockAddrFamily _ = error "sockAddrFamily" - -anySockAddr :: SockAddr -> SockAddr -anySockAddr (SockAddrInet p _) = SockAddrInet p 0 -anySockAddr (SockAddrInet6 p f _ s) = SockAddrInet6 p f (0,0,0,0) s -anySockAddr _ = error "anySockAddr" - -udpServerListenSocket :: (IP, PortNumber) -> IO (Socket, SockAddr) -udpServerListenSocket ip = E.bracketOnError open close $ \s -> do - setSocketOption s ReuseAddr 1 - withFdSocket s setCloseOnExecIfNeeded - -- setSocketOption s IPv6Only 1 -- fixme - bind s sa - return (s,sa) - where - sa = toSockAddr ip - family = sockAddrFamily sa - open = socket family Datagram defaultProtocol - -udpServerConnectedSocket :: SockAddr -> SockAddr -> IO Socket -udpServerConnectedSocket mysa peersa = E.bracketOnError open close $ \s -> do - setSocketOption s ReuseAddr 1 - withFdSocket s setCloseOnExecIfNeeded - -- bind and connect is not atomic - -- So, bind may results in EADDRINUSE - bind s anysa -- (UDP, *:13443, *:*) - `E.catch` postphone (bind s anysa) - connect s peersa -- (UDP, 127.0.0.1:13443, pa:pp) - return s - where - postphone action e - | E.ioeGetErrorType e == E.ResourceBusy = threadDelay 10000 >> action - | otherwise = E.throwIO e - anysa = anySockAddr mysa - family = sockAddrFamily mysa - open = socket family Datagram defaultProtocol - -udpClientSocket :: HostName -> ServiceName -> IO (Socket,SockAddr) -udpClientSocket host port = do - addr <- head <$> getAddrInfo (Just hints) (Just host) (Just port) - E.bracketOnError (openSocket addr) close $ \s -> do - let sa = addrAddress addr - return (s,sa) - where - hints = defaultHints { addrSocketType = Datagram } - -udpClientConnectedSocket :: HostName -> ServiceName -> IO (Socket,SockAddr) -udpClientConnectedSocket host port = do - addr <- head <$> getAddrInfo (Just hints) (Just host) (Just port) - E.bracketOnError (openSocket addr) close $ \s -> do - let sa = addrAddress addr - connect s sa - return (s,sa) - where - hints = defaultHints { addrSocketType = Datagram } - -udpNATRebindingSocket :: SockAddr -> IO Socket -udpNATRebindingSocket peersa = E.bracketOnError open close $ \s -> - return s - where - family = sockAddrFamily peersa - open = socket family Datagram defaultProtocol - -udpNATRebindingConnectedSocket :: SockAddr -> IO Socket -udpNATRebindingConnectedSocket peersa = E.bracketOnError open close $ \s -> do - connect s peersa - return s - where - family = sockAddrFamily peersa - open = socket family Datagram defaultProtocol diff --git a/Network/QUIC/Stream.hs b/Network/QUIC/Stream.hs --- a/Network/QUIC/Stream.hs +++ b/Network/QUIC/Stream.hs @@ -11,6 +11,8 @@ , RecvStreamQ(..) , RxStreamData(..) , Length + , syncFinTx + , waitFinTx -- * Misc , getTxStreamOffset , isTxStreamClosed diff --git a/Network/QUIC/Stream/Misc.hs b/Network/QUIC/Stream/Misc.hs --- a/Network/QUIC/Stream/Misc.hs +++ b/Network/QUIC/Stream/Misc.hs @@ -19,7 +19,7 @@ , getRxStreamWindow ) where -import Control.Concurrent.STM +import UnliftIO.STM import Network.QUIC.Imports import Network.QUIC.Stream.Types diff --git a/Network/QUIC/Stream/Queue.hs b/Network/QUIC/Stream/Queue.hs --- a/Network/QUIC/Stream/Queue.hs +++ b/Network/QUIC/Stream/Queue.hs @@ -3,7 +3,7 @@ module Network.QUIC.Stream.Queue where import Data.ByteString (ByteString) -import Control.Concurrent.STM +import UnliftIO.STM import Network.QUIC.Stream.Types diff --git a/Network/QUIC/Stream/Types.hs b/Network/QUIC/Stream/Types.hs --- a/Network/QUIC/Stream/Types.hs +++ b/Network/QUIC/Stream/Types.hs @@ -11,10 +11,13 @@ , RecvStreamQ(..) , RxStreamData(..) , Length + , syncFinTx + , waitFinTx ) where -import Control.Concurrent.STM import qualified Data.ByteString as BS +import UnliftIO.Concurrent +import UnliftIO.STM import {-# Source #-} Network.QUIC.Connection.Types import Network.QUIC.Imports @@ -37,6 +40,7 @@ , streamStateRx :: IORef StreamState -- offset, fin , streamRecvQ :: RecvStreamQ -- input bytestring , streamReass :: IORef (Skew RxStreamData) -- input stream fragments to streamQ + , streamSyncFinTx :: MVar () } instance Show Stream where @@ -49,6 +53,13 @@ <*> newIORef emptyStreamState <*> newRecvStreamQ <*> newIORef Skew.empty + <*> newEmptyMVar + +syncFinTx :: Stream -> IO () +syncFinTx s = void $ tryPutMVar (streamSyncFinTx s) () + +waitFinTx :: Stream -> IO () +waitFinTx s = takeMVar $ streamSyncFinTx s ---------------------------------------------------------------- diff --git a/Network/QUIC/TLS.hs b/Network/QUIC/TLS.hs --- a/Network/QUIC/TLS.hs +++ b/Network/QUIC/TLS.hs @@ -9,6 +9,7 @@ import Data.Default.Class import Network.TLS hiding (Version) import Network.TLS.QUIC +import System.X509 import Network.QUIC.Config import Network.QUIC.Parameters @@ -29,11 +30,12 @@ -> SessionEstablish -> Bool -> IO () -clientHandshaker callbacks ClientConfig{..} ver myAuthCIDs establish use0RTT = - tlsQUICClient cparams callbacks +clientHandshaker callbacks ClientConfig{..} ver myAuthCIDs establish use0RTT = do + caStore <- if ccValidate then getSystemCertificateStore else return mempty + tlsQUICClient (cparams caStore) callbacks where - cparams = (defaultParamsClient ccServerName "") { - clientShared = cshared + cparams caStore = (defaultParamsClient ccServerName "") { + clientShared = cshared caStore , clientHooks = hook , clientSupported = supported , clientDebug = debug @@ -41,18 +43,14 @@ , clientEarlyData = if use0RTT then Just "" else Nothing } convTP = onTransportParametersCreated ccHooks + params = convTP $ setCIDsToParameters myAuthCIDs ccParameters convExt = onTLSExtensionCreated ccHooks - qparams = convTP $ setCIDsToParameters myAuthCIDs ccParameters - eQparams = encodeParameters qparams - tpId | ver == Version1 = extensionID_QuicTransportParameters - | otherwise = 0xffa5 - cshared = def { - sharedValidationCache = if ccValidate then - def - else - ValidationCache (\_ _ _ -> return ValidationCachePass) (\_ _ _ -> return ()) - , sharedHelloExtensions = convExt [ExtensionRaw tpId eQparams] - , sharedSessionManager = sessionManager establish + skipValidation = ValidationCache (\_ _ _ -> return ValidationCachePass) (\_ _ _ -> return ()) + cshared caStore = def { + sharedValidationCache = if ccValidate then def else skipValidation + , sharedCAStore = caStore + , sharedHelloExtensions = convExt $ parametersToExtensionRaw ver params + , sharedSessionManager = sessionManager establish } hook = def { onSuggestALPN = ccALPN ver @@ -65,12 +63,18 @@ debugKeyLogger = ccKeyLog } +parametersToExtensionRaw :: Version -> Parameters -> [ExtensionRaw] +parametersToExtensionRaw ver params = [ExtensionRaw tpId eParams] + where + tpId = extensionIDForTtransportParameter ver + eParams = encodeParameters params + serverHandshaker :: QUICCallbacks -> ServerConfig -> Version - -> AuthCIDs + -> IO Parameters -> IO () -serverHandshaker callbacks ServerConfig{..} ver myAuthCIDs = +serverHandshaker callbacks ServerConfig{..} ver getParams = tlsQUICServer sparams callbacks where sparams = def { @@ -82,19 +86,18 @@ } convTP = onTransportParametersCreated scHooks convExt = onTLSExtensionCreated scHooks - qparams = convTP $ setCIDsToParameters myAuthCIDs scParameters - eQparams = encodeParameters qparams - tpId | ver == Version1 = extensionID_QuicTransportParameters - | otherwise = 0xffa5 sshared = def { - sharedCredentials = scCredentials - , sharedHelloExtensions = convExt [ExtensionRaw tpId eQparams] - , sharedSessionManager = scSessionManager - } + sharedCredentials = scCredentials + , sharedSessionManager = scSessionManager + } hook = def { onALPNClientSuggest = case scALPN of Nothing -> Nothing Just io -> Just $ io ver + , onEncryptedExtensionsCreating = \exts0 -> do + params <- getParams + let exts = convExt $ parametersToExtensionRaw ver $ convTP params + return $ exts ++ exts0 } supported = def { supportedVersions = [TLS13] diff --git a/Network/QUIC/Types.hs b/Network/QUIC/Types.hs --- a/Network/QUIC/Types.hs +++ b/Network/QUIC/Types.hs @@ -1,9 +1,8 @@ module Network.QUIC.Types ( Bytes - , SendBuf - , Receive , Close , Direction(..) + , SizedBuffer(..) , module Network.QUIC.Types.Ack , module Network.QUIC.Types.CID , module Network.QUIC.Types.Constants @@ -30,6 +29,5 @@ import Network.QUIC.Types.Resumption import Network.QUIC.Types.Time -type SendBuf = Buffer -> Int -> IO () -type Receive = IO ReceivedPacket type Close = IO () +data SizedBuffer = SizedBuffer Buffer BufferSize diff --git a/Network/QUIC/Types/Constants.hs b/Network/QUIC/Types/Constants.hs --- a/Network/QUIC/Types/Constants.hs +++ b/Network/QUIC/Types/Constants.hs @@ -7,18 +7,17 @@ ---------------------------------------------------------------- --- minimum PMTU = 1024 + 256 = 1280 --- IPv4 payload = 1280 - 20 - 8 = 1252 --- IPv6 payload = 1280 - 40 - 8 = 1232 - defaultQUICPacketSize :: Int defaultQUICPacketSize = 1200 +-- Google paper: UDP payload size = 1350 +-- http://www.audentia-gestion.fr/Recherche-Research-Google/46403.pdf + defaultQUICPacketSizeForIPv4 :: Int -defaultQUICPacketSizeForIPv4 = 1252 +defaultQUICPacketSizeForIPv4 = 1350 defaultQUICPacketSizeForIPv6 :: Int -defaultQUICPacketSizeForIPv6 = 1232 +defaultQUICPacketSizeForIPv6 = 1330 ---------------------------------------------------------------- diff --git a/Network/QUIC/Types/Error.hs b/Network/QUIC/Types/Error.hs --- a/Network/QUIC/Types/Error.hs +++ b/Network/QUIC/Types/Error.hs @@ -4,9 +4,10 @@ import qualified Network.TLS as TLS import Network.TLS.QUIC +import Text.Printf -- | Transport errors of QUIC. -newtype TransportError = TransportError Int deriving (Eq, Show) +newtype TransportError = TransportError Int deriving (Eq) pattern NoError :: TransportError pattern NoError = TransportError 0x0 @@ -58,6 +59,34 @@ pattern NoViablePath :: TransportError pattern NoViablePath = TransportError 0x10 + +pattern VersionNegotiationError :: TransportError +pattern VersionNegotiationError = TransportError 0x11 + +instance Show TransportError where + show (TransportError 0x0) = "NoError" + show (TransportError 0x1) = "InternalError" + show (TransportError 0x2) = "ConnectionRefused" + show (TransportError 0x3) = "FlowControlError" + show (TransportError 0x4) = "StreamLimitError" + show (TransportError 0x5) = "StreamStateError" + show (TransportError 0x6) = "FinalSizeError" + show (TransportError 0x7) = "FrameEncodingError" + show (TransportError 0x8) = "TransportParameterError" + show (TransportError 0x9) = "ConnectionIdLimitError" + show (TransportError 0xa) = "ProtocolViolation" + show (TransportError 0xb) = "InvalidToken" + show (TransportError 0xc) = "ApplicationError" + show (TransportError 0xd) = "CryptoBufferExceeded" + show (TransportError 0xe) = "KeyUpdateError" + show (TransportError 0xf) = "AeadLimitReached" + show (TransportError 0x10) = "NoViablePath" + show (TransportError 0x11) = "VersionNegotiationError" + show (TransportError x) + | 0x100 <= x && x <= 0x01ff = case toAlertDescription $ fromIntegral (x - 0x100) of + Just e -> "TLS " ++ show e + Nothing -> "TLS Alert " ++ show x + | otherwise = "TransportError " ++ printf "%x" x -- | Converting a TLS alert to a corresponding transport error. cryptoError :: TLS.AlertDescription -> TransportError diff --git a/Network/QUIC/Types/Exception.hs b/Network/QUIC/Types/Exception.hs --- a/Network/QUIC/Types/Exception.hs +++ b/Network/QUIC/Types/Exception.hs @@ -30,17 +30,18 @@ data InternalControl = MustNotReached | ExitConnection | WrongTransportParameter + | WrongVersionInformation | BreakForever deriving (Eq, Show) instance E.Exception InternalControl -newtype NextVersion = NextVersion (Maybe Version) deriving (Show) +newtype NextVersion = NextVersion VersionInfo deriving (Show) instance E.Exception NextVersion data Abort = Abort ApplicationProtocolError ReasonPhrase - | VerNego (Maybe Version) + | VerNego VersionInfo deriving (Show) instance E.Exception Abort where diff --git a/Network/QUIC/Types/Integer.hs b/Network/QUIC/Types/Integer.hs --- a/Network/QUIC/Types/Integer.hs +++ b/Network/QUIC/Types/Integer.hs @@ -55,31 +55,31 @@ where tag = 0b01000000 n = 2 - i' = i .<<. 48 + i' = i !<<. 48 encodeInt'4 :: WriteBuffer -> Int64 -> IO () encodeInt'4 wbuf i = go' tag n i' wbuf where tag = 0b10000000 n = 4 - i' = i .<<. 32 + i' = i !<<. 32 tagLen :: Int64 -> (Word8, Int, Int64) -tagLen i | i <= 63 = (0b00000000, 1, i .<<. 56) - | i <= 16383 = (0b01000000, 2, i .<<. 48) - | i <= 1073741823 = (0b10000000, 4, i .<<. 32) +tagLen i | i <= 63 = (0b00000000, 1, i !<<. 56) + | i <= 16383 = (0b01000000, 2, i !<<. 48) + | i <= 1073741823 = (0b10000000, 4, i !<<. 32) | otherwise = (0b11000000, 8, i) {-# INLINE tagLen #-} msb8 :: Int64 -> Word8 -msb8 i = fromIntegral (i .>>. 56) +msb8 i = fromIntegral (i !>>. 56) {-# INLINE msb8 #-} go :: Word8 -> Int -> Int64 -> Ptr Word8 -> IO () go tag n0 i0 p0 = do poke p0 (tag .|. msb8 i0) let n' = n0 - 1 - i' = i0 .<<. 8 + i' = i0 !<<. 8 p' = p0 `plusPtr` 1 loop n' i' p' where @@ -87,7 +87,7 @@ loop n i p = do poke p $ msb8 i let n' = n - 1 - i' = i .<<. 8 + i' = i !<<. 8 p' = p `plusPtr` 1 loop n' i' p' {-# INLINE go #-} @@ -96,14 +96,14 @@ go' tag n0 i0 wbuf = do write8 wbuf (tag .|. msb8 i0) let n' = n0 - 1 - i' = i0 .<<. 8 + i' = i0 !<<. 8 loop n' i' where loop 0 _ = return () loop n i = do write8 wbuf $ msb8 i let n' = n - 1 - i' = i .<<. 8 + i' = i !<<. 8 loop n' i' {-# INLINE go' #-} @@ -125,7 +125,7 @@ decodeInt' :: ReadBuffer -> IO Int64 decodeInt' rbuf = do b0 <- read8 rbuf - let flag = b0 .>>. 6 + let flag = b0 !>>. 6 b1 = fromIntegral (b0 .&. 0b00111111) case flag of 0 -> return b1 diff --git a/Network/QUIC/Types/Packet.hs b/Network/QUIC/Types/Packet.hs --- a/Network/QUIC/Types/Packet.hs +++ b/Network/QUIC/Types/Packet.hs @@ -4,6 +4,9 @@ module Network.QUIC.Types.Packet where import Data.Ix +import Network.UDP +import Network.TLS.QUIC (extensionID_QuicTransportParameters, ExtensionID) +import Text.Printf import Network.QUIC.Imports import Network.QUIC.Types.Ack @@ -14,12 +17,14 @@ ---------------------------------------------------------------- -- | QUIC version. -newtype Version = Version Word32 deriving (Eq, Ord, Show) +newtype Version = Version Word32 deriving (Eq, Ord) pattern Negotiation :: Version pattern Negotiation = Version 0 pattern Version1 :: Version pattern Version1 = Version 1 +pattern Version2 :: Version +pattern Version2 = Version 0x6b3343cf pattern Draft29 :: Version pattern Draft29 = Version 0xff00001d pattern GreasingVersion :: Version @@ -27,11 +32,40 @@ pattern GreasingVersion2 :: Version pattern GreasingVersion2 = Version 0x1a2a3a4a +instance Show Version where + show (Version 0) = "Negotiation" + show (Version 1) = "Version1" + show (Version 0x6b3343cf) = "Version2" + show (Version 0xff00001d) = "Draft29" + show ver@(Version v) + | isGreasingVersion ver = "Greasing 0x" ++ printf "%08x" v + | otherwise = "Version 0x" ++ printf "%08x" v + +isGreasingVersion :: Version -> Bool +isGreasingVersion (Version v) = v .&. 0x0a0a0a0a == 0x0a0a0a0a + ---------------------------------------------------------------- +data VersionInfo = VersionInfo { + chosenVersion :: Version + , otherVersions :: [Version] + } deriving (Eq, Show) + +brokenVersionInfo :: VersionInfo +brokenVersionInfo = VersionInfo Negotiation [] + +---------------------------------------------------------------- + +extensionIDForTtransportParameter :: Version -> ExtensionID +extensionIDForTtransportParameter Version1 = extensionID_QuicTransportParameters +extensionIDForTtransportParameter Version2 = extensionID_QuicTransportParameters +extensionIDForTtransportParameter _ = 0xffa5 + +---------------------------------------------------------------- + data PacketI = PacketIV VersionNegotiationPacket | PacketIR RetryPacket - | PacketIC CryptPacket EncryptionLevel + | PacketIC CryptPacket EncryptionLevel Int | PacketIB BrokenPacket deriving (Eq, Show) @@ -110,20 +144,17 @@ is4bytesPN :: Int -> Bool is4bytesPN = (`testBit` 9) +data MigrationInfo = MigrationInfo ListenSocket ClientSockAddr CID deriving (Eq, Show) + data Crypt = Crypt { cryptPktNumOffset :: Int , cryptPacket :: ByteString , cryptMarks :: Int + , cryptMigraionInfo :: Maybe MigrationInfo } deriving (Eq, Show) -isCryptLogged :: Crypt -> Bool -isCryptLogged crypt = cryptMarks crypt `testBit` 0 - isCryptDelayed :: Crypt -> Bool isCryptDelayed crypt = cryptMarks crypt `testBit` 1 - -setCryptLogged :: Crypt -> Crypt -setCryptLogged crypt = crypt { cryptMarks = cryptMarks crypt `setBit` 0 } setCryptDelayed :: Crypt -> Crypt setCryptDelayed crypt = crypt { cryptMarks = cryptMarks crypt `setBit` 1 } diff --git a/Network/QUIC/Types/Queue.hs b/Network/QUIC/Types/Queue.hs --- a/Network/QUIC/Types/Queue.hs +++ b/Network/QUIC/Types/Queue.hs @@ -1,6 +1,6 @@ module Network.QUIC.Types.Queue where -import Control.Concurrent.STM +import UnliftIO.STM import Network.QUIC.Types.Packet diff --git a/Network/QUIC/Types/Resumption.hs b/Network/QUIC/Types/Resumption.hs --- a/Network/QUIC/Types/Resumption.hs +++ b/Network/QUIC/Types/Resumption.hs @@ -2,24 +2,27 @@ module Network.QUIC.Types.Resumption where -import Network.TLS +import Network.TLS hiding (Version) import Network.TLS.QUIC import Network.QUIC.Imports import Network.QUIC.Types.Frame +import Network.QUIC.Types.Packet type SessionEstablish = SessionID -> SessionData -> IO () -- | Information about resumption data ResumptionInfo = ResumptionInfo { - resumptionSession :: Maybe (SessionID, SessionData) + resumptionVersion :: Version + , resumptionSession :: Maybe (SessionID, SessionData) , resumptionToken :: Token , resumptionRetry :: Bool } deriving (Eq, Show) defaultResumptionInfo :: ResumptionInfo defaultResumptionInfo = ResumptionInfo { - resumptionSession = Nothing + resumptionVersion = Version1 + , resumptionSession = Nothing , resumptionToken = emptyToken , resumptionRetry = False } @@ -41,4 +44,3 @@ get0RTTCipher ri = case resumptionSession ri of Nothing -> Nothing Just (_, sd) -> Just $ sessionCipher sd - diff --git a/Network/QUIC/Windows.hs b/Network/QUIC/Windows.hs new file mode 100644 --- /dev/null +++ b/Network/QUIC/Windows.hs @@ -0,0 +1,17 @@ +module Network.QUIC.Windows ( + windowsThreadBlockHack + ) where + +import Control.Concurrent +import qualified Control.Exception as CE +import Control.Monad + +windowsThreadBlockHack :: IO a -> IO a +windowsThreadBlockHack act = do + var <- newEmptyMVar :: IO (MVar (Either CE.SomeException a)) + -- Catch and rethrow even async exceptions, so don't bother with UnliftIO + void . forkIO $ CE.try act >>= putMVar var + res <- takeMVar var + case res of + Left e -> print e >> CE.throwIO e + Right r -> return r diff --git a/cbits/fusion.c b/cbits/fusion.c --- a/cbits/fusion.c +++ b/cbits/fusion.c @@ -38,7 +38,9 @@ * IN THE SOFTWARE. */ #include - +#ifdef _WINDOWS +#include +#endif #include #include #include @@ -1076,7 +1078,7 @@ /* ---------------------------------------------------------------- */ -ptls_aead_supplementary_encryption_t *supplement_new(uint8_t *key, uint siz) { +ptls_aead_supplementary_encryption_t *supplement_new(uint8_t *key, unsigned int siz) { ptls_aead_supplementary_encryption_t *supp = malloc(sizeof(ptls_aead_supplementary_encryption_t)); if (siz == PTLS_AES256_KEY_SIZE) { supp->ctx = ptls_cipher_new(&ptls_fusion_aes256ctr, 1, key); diff --git a/cbits/picotls.c b/cbits/picotls.c --- a/cbits/picotls.c +++ b/cbits/picotls.c @@ -25,7 +25,7 @@ #include #include #ifdef _WINDOWS -#include "wincompat.h" +#include "winsock.h" #else #include #include @@ -5300,9 +5300,13 @@ static uint64_t get_time(ptls_get_time_t *self) { +#if 0 struct timeval tv; gettimeofday(&tv, NULL); return (uint64_t)tv.tv_sec * 1000 + tv.tv_usec / 1000; +#else + return 0; +#endif } ptls_get_time_t ptls_get_time = {get_time}; diff --git a/cbits/picotls.h b/cbits/picotls.h --- a/cbits/picotls.h +++ b/cbits/picotls.h @@ -27,7 +27,7 @@ #endif #ifdef _WINDOWS -#include "wincompat.h" +#include "winsock.h" #endif #include diff --git a/quic.cabal b/quic.cabal --- a/quic.cabal +++ b/quic.cabal @@ -1,5 +1,5 @@ name: quic -version: 0.0.1 +version: 0.1.0 synopsis: QUIC description: Library for QUIC: A UDP-Based Multiplexed and Secure Transport license: BSD3 @@ -20,7 +20,7 @@ Source-Repository head Type: git - Location: git://github.com/kazu-yamamoto/quic + Location: https://github.com/kazu-yamamoto/quic Flag devel Description: Development commands @@ -53,7 +53,12 @@ Network.QUIC.Connection.Types Network.QUIC.Connector Network.QUIC.Crypto - Network.QUIC.CryptoFusion + Network.QUIC.Crypto.Fusion + Network.QUIC.Crypto.Keys + Network.QUIC.Crypto.Nite + Network.QUIC.Crypto.Types + Network.QUIC.Crypto.Utils + Network.QUIC.Event Network.QUIC.Exception Network.QUIC.Handshake Network.QUIC.IO @@ -88,7 +93,6 @@ Network.QUIC.Sender Network.QUIC.Server.Reader Network.QUIC.Server.Run - Network.QUIC.Socket Network.QUIC.Stream Network.QUIC.Stream.Frag Network.QUIC.Stream.Misc @@ -111,6 +115,7 @@ Network.QUIC.Types.Resumption Network.QUIC.Types.Time Network.QUIC.Utils + Network.QUIC.Windows -- other-extensions: build-depends: base >= 4.9 && < 5 , array @@ -125,20 +130,25 @@ , iproute >= 1.7.8 , memory , network >= 3.1.2 + , network-udp , network-byte-order >= 0.1.5 , psqueues , random >= 1.2 , stm - , tls + , tls >= 1.5.6 , unix-time , unliftio >= 0.2.18 , unliftio-core , x509 + , x509-system -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall -Wcompat default-extensions: Strict StrictData - if arch(x86_64) || arch(aarch64) + if os(windows) + cc-options: -D_WINDOWS + if arch(x86_64) + cpp-options: -DUSE_FUSION cc-options: -mavx2 -maes -mpclmul c-sources: cbits/fusion.c cbits/picotls.c @@ -146,7 +156,9 @@ Type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test - ghc-options: -Wall -threaded + ghc-options: -Wall -threaded -rtsopts + if os(windows) + ghc-options: -with-rtsopts=--io-manager=native main-is: Spec.hs other-modules: Config ErrorSpec @@ -167,6 +179,7 @@ , cryptonite , hspec , network >= 3.1.2 + , network-udp , quic , tls , unix-time @@ -199,6 +212,8 @@ Common ServerX ghc-options: -Wall -threaded -rtsopts + if os(windows) + ghc-options: -with-rtsopts=--io-manager=native build-depends: base >= 4.9 && < 5 , base16-bytestring , bytestring @@ -223,6 +238,8 @@ ClientX Common ghc-options: -Wall -threaded -rtsopts + if os(windows) + ghc-options: -with-rtsopts=--io-manager=native build-depends: base >= 4.9 && < 5 , base16-bytestring , bytestring diff --git a/test/Config.hs b/test/Config.hs --- a/test/Config.hs +++ b/test/Config.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Config ( @@ -12,7 +13,6 @@ , newSessionManager ) where -import Control.Concurrent import Control.Monad import Data.ByteString (ByteString) import Data.IORef @@ -20,6 +20,7 @@ import Network.Socket import Network.Socket.ByteString import Network.TLS (Credentials(..), credentialLoadX509, SessionManager(..), SessionData, SessionID) +import UnliftIO.Concurrent import qualified UnliftIO.Exception as E import Network.QUIC.Client @@ -31,12 +32,14 @@ let credentials = Credentials [cred] return testServerConfig { scCredentials = credentials - , scALPN = Just chooseALPN + , scALPN = Just chooseALPN } testServerConfig :: ServerConfig testServerConfig = defaultServerConfig { - scAddresses = [("127.0.0.1",8003)] + -- Don't use "0.0.0.0" and "::" for Windows (UDP dispatching bug) + -- Don't use "127.0.0.1" for macOS (recvmsg bug) + scAddresses = [("::1",50003)] } makeTestServerConfigR :: IO ServerConfig @@ -45,25 +48,30 @@ let credentials = Credentials [cred] return testServerConfigR { scCredentials = credentials - , scALPN = Just chooseALPN + , scALPN = Just chooseALPN } testServerConfigR :: ServerConfig testServerConfigR = defaultServerConfig { - scAddresses = [("127.0.0.1",8003)] + -- Don't use "0.0.0.0" and "::" for Windows (UDP dispatching bug) + -- Don't use "127.0.0.1" for macOS (recvmsg bug) + scAddresses = [("::1",50003)] } testClientConfig :: ClientConfig testClientConfig = defaultClientConfig { - ccPortName = "8003" - , ccValidate = False + ccServerName = "::1" + , ccPortName = "50003" + , ccValidate = False + , ccDebugLog = True } testClientConfigR :: ClientConfig testClientConfigR = defaultClientConfig { - ccPortName = "8002" - , ccValidate = False - , ccDebugLog = True + ccServerName = "::1" + , ccPortName = "50002" + , ccValidate = False + , ccDebugLog = True } setServerQlog :: ServerConfig -> ServerConfig @@ -78,9 +86,9 @@ withPipe :: Scenario -> IO () -> IO () withPipe scenario body = do - addrC <- resolve "8002" + addrC <- resolve "50002" let saC = addrAddress addrC - addrS <- resolve "8003" + addrS <- resolve "50003" let saS = addrAddress addrS irefC <- newIORef 0 irefS <- newIORef 0 @@ -98,13 +106,21 @@ dropPacket0 <- shouldDrop scenario True n0 unless dropPacket0 $ void $ send sockS bs forever $ do - bs1 <- recv sockC 2048 + bs1 <- +#if defined(mingw32_HOST_OS) + windowsThreadBlockHack $ +#endif + recv sockC 2048 n <- atomicModifyIORef' irefC $ \x -> (x + 1, x) dropPacket <- shouldDrop scenario True n unless dropPacket $ void $ send sockS bs1 -- from server tid1 <- forkIO $ forever $ do - bs <- recv sockS 2048 + bs <- +#if defined(mingw32_HOST_OS) + windowsThreadBlockHack $ +#endif + recv sockS 2048 n <- atomicModifyIORef' irefS $ \x -> (x + 1, x) dropPacket <- shouldDrop scenario False n unless dropPacket $ void $ send sockC bs @@ -112,9 +128,12 @@ killThread tid0 killThread tid1 where - hints = defaultHints { addrSocketType = Datagram } + hints = defaultHints { addrSocketType = Datagram + , addrFlags = [AI_NUMERICHOST] + , addrFamily = AF_INET6 + } resolve port = - head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just port) + head <$> getAddrInfo (Just hints) (Just "::1") (Just port) shouldDrop (Randomly n) _ _ = do w <- getRandomOneByte return ((w `mod` fromIntegral n) == 0) diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs --- a/test/ErrorSpec.hs +++ b/test/ErrorSpec.hs @@ -2,12 +2,12 @@ module ErrorSpec where -import Control.Concurrent import Control.Monad (forever, void) import Data.ByteString () import Network.QUIC import Network.QUIC.Server import Test.Hspec +import UnliftIO.Concurrent import Config import TransportError diff --git a/test/HandshakeSpec.hs b/test/HandshakeSpec.hs --- a/test/HandshakeSpec.hs +++ b/test/HandshakeSpec.hs @@ -2,13 +2,13 @@ module HandshakeSpec where -import Control.Concurrent import Control.Monad import qualified Data.ByteString as BS import Network.TLS (HandshakeMode13(..), Group(..)) import qualified Network.TLS as TLS import Test.Hspec import UnliftIO.Async +import UnliftIO.Concurrent import qualified UnliftIO.Exception as E import Network.QUIC @@ -62,7 +62,7 @@ | TransportErrorIsReceived te@(TransportError _) _ <- e = te == cryptoError TLS.HandshakeFailure | otherwise = False testHandshake3 cc1 cc2 sc handshakeFailure - it "can handshake with large EE from a client" $ do + it "can handshake with large HE from a client" $ do let cc0 = testClientConfig params = (ccParameters cc0) { grease = Just (BS.pack (replicate 2400 0)) @@ -82,7 +82,9 @@ onE h b = E.onException b h testHandshake :: ClientConfig -> ServerConfig -> HandshakeMode13 -> IO () -testHandshake cc sc mode = concurrently_ server client +testHandshake cc sc mode = do + concurrently_ server client + threadDelay 10000 where client = do threadDelay 10000 @@ -103,11 +105,14 @@ void $ recvStream s 1024 testHandshake2 :: ClientConfig -> ServerConfig -> (HandshakeMode13, HandshakeMode13) -> Bool -> IO () -testHandshake2 cc1 sc (mode1, mode2) use0RTT = concurrently_ server client +testHandshake2 cc1 sc (mode1, mode2) use0RTT = do + concurrently_ server client + threadDelay 10000 where runClient cc mode action = C.run cc $ \conn -> do void $ action conn handshakeMode <$> getConnectionInfo conn `shouldReturn` mode + threadDelay 10000 getResumptionInfo conn client = do threadDelay 10000 @@ -123,10 +128,13 @@ s <- acceptStream conn bs <- recvStream s 1024 sendStream s "bye" + closeStream s when (bs == "second") $ stop conn testHandshake3 :: ClientConfig -> ClientConfig -> ServerConfig -> (QUICException -> Bool) -> IO () -testHandshake3 cc1 cc2 sc selector = concurrently_ server client +testHandshake3 cc1 cc2 sc selector = do + concurrently_ server client + threadDelay 10000 where client = do threadDelay 10000 @@ -136,4 +144,5 @@ s <- acceptStream conn recvStream s 1024 `shouldReturn` "second" sendStream s "bye" + closeStream s stop conn diff --git a/test/IOSpec.hs b/test/IOSpec.hs --- a/test/IOSpec.hs +++ b/test/IOSpec.hs @@ -2,11 +2,11 @@ module IOSpec where -import Control.Concurrent import Control.Monad import qualified Data.ByteString as BS import Test.Hspec import UnliftIO.Async +import UnliftIO.Concurrent import qualified Network.QUIC.Client as C import Network.QUIC @@ -74,6 +74,7 @@ testSendRecv cc sc times = do mvar <- newEmptyMVar void $ concurrently (client mvar) (server mvar) + threadDelay 10000 where client mvar = do threadDelay 10000 diff --git a/test/PacketSpec.hs b/test/PacketSpec.hs --- a/test/PacketSpec.hs +++ b/test/PacketSpec.hs @@ -6,8 +6,8 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS import Data.IORef -import Foreign.Marshal.Alloc -import qualified Network.Socket as NS +import Data.Tuple (swap) +import Network.UDP import Test.Hspec import Network.QUIC.Internal @@ -19,37 +19,67 @@ serverConf <- runIO makeTestServerConfig describe "test vector" $ do it "describes example of Client Initial version 1" $ do - let noLog _ = return () - let serverCID = makeCID $ dec16s "8394c8f03e515708" - clientCID = makeCID "" - serverAuthCIDs = defaultAuthCIDs { initSrcCID = Just serverCID - , origDstCID = Just serverCID - } - clientAuthCIDs = defaultAuthCIDs { initSrcCID = Just clientCID } - -- dummy - let clientConf = testClientConfig - ver = Version1 - s <- NS.socket NS.AF_INET NS.Stream NS.defaultProtocol - q <- newRecvQ - sref <- newIORef [s] - clientConn <- clientConnection clientConf ver clientAuthCIDs serverAuthCIDs noLog noLog defaultHooks sref q - initializeCoder clientConn InitialLevel $ initialSecrets ver serverCID - serverConn <- serverConnection serverConf ver serverAuthCIDs clientAuthCIDs noLog noLog defaultHooks sref q - initializeCoder serverConn InitialLevel $ initialSecrets ver serverCID - (PacketIC (CryptPacket header crypt) lvl, _) <- decodePacket clientInitialPacketBinary - let dlen = 2048 - dbuf <- mallocBytes dlen - Just plain <- decryptCrypt serverConn dbuf dlen crypt lvl - let ppkt = PlainPacket header plain - clientInitialPacketBinary' <- BS.createAndTrim 4096 $ \buf -> do - fst <$> encodePlainPacket clientConn buf 2048 ppkt Nothing - (PacketIC (CryptPacket header' crypt') lvl', _) <- decodePacket clientInitialPacketBinary' - Just plain' <- decryptCrypt serverConn dbuf dlen crypt' lvl' - header' `shouldBe` header - plainFrames plain' `shouldBe` plainFrames plain + conns <- makeConnections serverConf Version1 + checkBinary conns 2 clientInitialPacketBinaryV1 + it "describes example of Server Initial version 1" $ do + conns <- swap <$> makeConnections serverConf Version1 + checkBinary conns 1 serverInitialPacketBinaryV1 + it "describes example of Client Initial version 2" $ do + conns <- makeConnections serverConf Version2 + checkBinary conns 2 clientInitialPacketBinaryV2 + it "describes example of Server Initial version 2" $ do + conns <- swap <$> makeConnections serverConf Version2 + checkBinary conns 1 serverInitialPacketBinaryV2 -clientInitialPacketBinary :: ByteString -clientInitialPacketBinary = dec16 $ BS.concat [ +clientChosenCID :: CID +clientChosenCID = toCID $ dec16 "8394c8f03e515708" + +makeConnections :: ServerConfig -> Version -> IO (Connection, Connection) +makeConnections conf v = do + let noLog _ = return () + let serverCID = clientChosenCID + clientCID = toCID "" + serverAuthCIDs = defaultAuthCIDs { initSrcCID = Just serverCID + , origDstCID = Just serverCID + } + clientAuthCIDs = defaultAuthCIDs { initSrcCID = Just clientCID } + -- dummy + let clientConf = testClientConfig + us <- clientSocket "127.0.0.1" "2000" False + q <- newRecvQ + sref <- newIORef us + let ver = v + verInfo = VersionInfo ver [ver] + ---- + clientConn <- clientConnection clientConf verInfo clientAuthCIDs serverAuthCIDs noLog noLog defaultHooks sref q undefined undefined + initializeCoder clientConn InitialLevel $ initialSecrets ver serverCID + serverConn <- serverConnection conf verInfo serverAuthCIDs clientAuthCIDs noLog noLog defaultHooks sref q undefined undefined + initializeCoder serverConn InitialLevel $ initialSecrets ver serverCID + ---- + return (clientConn, serverConn) + +checkBinary :: (Connection,Connection)-> PacketNumber -> ByteString -> IO () +checkBinary (senderConn,recverConn) pn bin = do + ---- Decoding by the receiver + (PacketIC (CryptPacket header crypt) lvl _, _) <- decodePacket bin + ---- Cecrypting by the receiver + Just plain <- decryptCrypt recverConn crypt lvl + ---- Checking + plainPacketNumber plain `shouldBe` pn + ---- Encoding by the sender + let ppkt = PlainPacket header plain + bin' <- BS.createAndTrim 4096 $ \buf -> + fst <$> encodePlainPacket senderConn (SizedBuffer buf 2048) ppkt Nothing + ---- Decoding by the receiver again + (PacketIC (CryptPacket header' crypt') lvl' _, _) <- decodePacket bin' + ---- Cecrypting by the receiver again + Just plain' <- decryptCrypt recverConn crypt' lvl' + ---- Checking + header' `shouldBe` header + plainFrames plain' `shouldBe` plainFrames plain + +clientInitialPacketBinaryV1 :: ByteString +clientInitialPacketBinaryV1 = dec16 $ BS.concat [ "c000000001088394c8f03e5157080000449e7b9aec34d1b1c98dd7689fb8ec11" , "d242b123dc9bd8bab936b47d92ec356c0bab7df5976d27cd449f63300099f399" , "1c260ec4c60d17b31f8429157bb35a1282a643a8d2262cad67500cadb8e7378c" @@ -88,4 +118,64 @@ , "056df31bd267b6b90a079831aaf579be0a39013137aac6d404f518cfd4684064" , "7e78bfe706ca4cf5e9c5453e9f7cfd2b8b4c8d169a44e55c88d4a9a7f9474241" , "e221af44860018ab0856972e194cd934" + ] + +clientInitialPacketBinaryV2 :: ByteString +clientInitialPacketBinaryV2 = dec16 $ BS.concat [ + "d76b3343cf088394c8f03e5157080000449ea0c95e82ffe67b6abcdb4298b485" + , "dd04de806071bf03dceebfa162e75d6c96058bdbfb127cdfcbf903388e99ad04" + , "9f9a3dd4425ae4d0992cfff18ecf0fdb5a842d09747052f17ac2053d21f57c5d" + , "250f2c4f0e0202b70785b7946e992e58a59ac52dea6774d4f03b55545243cf1a" + , "12834e3f249a78d395e0d18f4d766004f1a2674802a747eaa901c3f10cda5500" + , "cb9122faa9f1df66c392079a1b40f0de1c6054196a11cbea40afb6ef5253cd68" + , "18f6625efce3b6def6ba7e4b37a40f7732e093daa7d52190935b8da58976ff33" + , "12ae50b187c1433c0f028edcc4c2838b6a9bfc226ca4b4530e7a4ccee1bfa2a3" + , "d396ae5a3fb512384b2fdd851f784a65e03f2c4fbe11a53c7777c023462239dd" + , "6f7521a3f6c7d5dd3ec9b3f233773d4b46d23cc375eb198c63301c21801f6520" + , "bcfb7966fc49b393f0061d974a2706df8c4a9449f11d7f3d2dcbb90c6b877045" + , "636e7c0c0fe4eb0f697545460c806910d2c355f1d253bc9d2452aaa549e27a1f" + , "ac7cf4ed77f322e8fa894b6a83810a34b361901751a6f5eb65a0326e07de7c12" + , "16ccce2d0193f958bb3850a833f7ae432b65bc5a53975c155aa4bcb4f7b2c4e5" + , "4df16efaf6ddea94e2c50b4cd1dfe06017e0e9d02900cffe1935e0491d77ffb4" + , "fdf85290fdd893d577b1131a610ef6a5c32b2ee0293617a37cbb08b847741c3b" + , "8017c25ca9052ca1079d8b78aebd47876d330a30f6a8c6d61dd1ab5589329de7" + , "14d19d61370f8149748c72f132f0fc99f34d766c6938597040d8f9e2bb522ff9" + , "9c63a344d6a2ae8aa8e51b7b90a4a806105fcbca31506c446151adfeceb51b91" + , "abfe43960977c87471cf9ad4074d30e10d6a7f03c63bd5d4317f68ff325ba3bd" + , "80bf4dc8b52a0ba031758022eb025cdd770b44d6d6cf0670f4e990b22347a7db" + , "848265e3e5eb72dfe8299ad7481a408322cac55786e52f633b2fb6b614eaed18" + , "d703dd84045a274ae8bfa73379661388d6991fe39b0d93debb41700b41f90a15" + , "c4d526250235ddcd6776fc77bc97e7a417ebcb31600d01e57f32162a8560cacc" + , "7e27a096d37a1a86952ec71bd89a3e9a30a2a26162984d7740f81193e8238e61" + , "f6b5b984d4d3dfa033c1bb7e4f0037febf406d91c0dccf32acf423cfa1e70710" + , "10d3f270121b493ce85054ef58bada42310138fe081adb04e2bd901f2f13458b" + , "3d6758158197107c14ebb193230cd1157380aa79cae1374a7c1e5bbcb80ee23e" + , "06ebfde206bfb0fcbc0edc4ebec309661bdd908d532eb0c6adc38b7ca7331dce" + , "8dfce39ab71e7c32d318d136b6100671a1ae6a6600e3899f31f0eed19e3417d1" + , "34b90c9058f8632c798d4490da4987307cba922d61c39805d072b589bd52fdf1" + , "e86215c2d54e6670e07383a27bbffb5addf47d66aa85a0c6f9f32e59d85a44dd" + , "5d3b22dc2be80919b490437ae4f36a0ae55edf1d0b5cb4e9a3ecabee93dfc6e3" + , "8d209d0fa6536d27a5d6fbb17641cde27525d61093f1b28072d111b2b4ae5f89" + , "d5974ee12e5cf7d5da4d6a31123041f33e61407e76cffcdcfd7e19ba58cf4b53" + , "6f4c4938ae79324dc402894b44faf8afbab35282ab659d13c93f70412e85cb19" + , "9a37ddec600545473cfb5a05e08d0b209973b2172b4d21fb69745a262ccde96b" + , "a18b2faa745b6fe189cf772a9f84cbfc" + ] + +serverInitialPacketBinaryV1 :: ByteString +serverInitialPacketBinaryV1 = dec16 $ BS.concat [ + "cf000000010008f067a5502a4262b5004075c0d95a482cd0991cd25b0aac406a" + , "5816b6394100f37a1c69797554780bb38cc5a99f5ede4cf73c3ec2493a1839b3" + , "dbcba3f6ea46c5b7684df3548e7ddeb9c3bf9c73cc3f3bded74b562bfb19fb84" + , "022f8ef4cdd93795d77d06edbb7aaf2f58891850abbdca3d20398c276456cbc4" + , "2158407dd074ee" + ] + +serverInitialPacketBinaryV2 :: ByteString +serverInitialPacketBinaryV2 = dec16 $ BS.concat [ + "dc6b3343cf0008f067a5502a4262b5004075d92faaf16f05d8a4398c47089698" + , "baeea26b91eb761d9b89237bbf87263017915358230035f7fd3945d88965cf17" + , "f9af6e16886c61bfc703106fbaf3cb4cfa52382dd16a393e42757507698075b2" + , "c984c707f0a0812d8cd5a6881eaf21ceda98f4bd23f6fe1a3e2c43edd9ce7ca8" + , "4bed8521e2e140" ] diff --git a/test/TLSSpec.hs b/test/TLSSpec.hs --- a/test/TLSSpec.hs +++ b/test/TLSSpec.hs @@ -3,7 +3,9 @@ module TLSSpec where +import Data.Bits import qualified Data.ByteString as BS +import Data.Maybe import Test.Hspec import Network.QUIC.Internal @@ -20,49 +22,39 @@ spec :: Spec spec = do - let ver = Version1 - describe "test vector" $ do + describe "test vector for version 1" $ do + let ver = Version1 it "describes the examples of Keys" $ do ---------------------------------------------------------------- -- shared keys let dcID = makeCID (dec16s "8394c8f03e515708") let client_initial_secret@(ClientTrafficSecret cis) = clientInitialSecret ver dcID client_initial_secret `shouldBe` ClientTrafficSecret (dec16 "c00cf151ca5be075ed0ebfb5c80323c42d6b7db67881289af4008f1f6c357aea") - let ckey = aeadKey defaultCipher (Secret cis) + let ckey = aeadKey ver defaultCipher (Secret cis) ckey `shouldBe` Key (dec16 "1f369613dd76d5467730efcbe3b1a22d") - let civ = initialVector defaultCipher (Secret cis) + let civ = initialVector ver defaultCipher (Secret cis) civ `shouldBe` IV (dec16 "fa044b2f42a3fd3b46fb255c") - let chp = headerProtectionKey defaultCipher (Secret cis) + let chp = headerProtectionKey ver defaultCipher (Secret cis) chp `shouldBe` Key (dec16 "9f50449e04a0e810283a1e9933adedd2") let server_initial_secret@(ServerTrafficSecret sis) = serverInitialSecret ver dcID server_initial_secret `shouldBe` ServerTrafficSecret (dec16 "3c199828fd139efd216c155ad844cc81fb82fa8d7446fa7d78be803acdda951b") - let skey = aeadKey defaultCipher (Secret sis) + let skey = aeadKey ver defaultCipher (Secret sis) skey `shouldBe` Key (dec16 "cf3a5331653c364c88f0f379b6067e37") - let siv = initialVector defaultCipher (Secret sis) + let siv = initialVector ver defaultCipher (Secret sis) siv `shouldBe` IV (dec16 "0ac1493ca1905853b0bba03e") - let shp = headerProtectionKey defaultCipher (Secret sis) + let shp = headerProtectionKey ver defaultCipher (Secret sis) shp `shouldBe` Key (dec16 "c206b8d9b9f0f37644430b490eeaa314") it "describes the examples of Client Initial" $ do let dcID = makeCID (dec16s "8394c8f03e515708") ClientTrafficSecret cis = clientInitialSecret ver dcID - ckey = aeadKey defaultCipher (Secret cis) - civ = initialVector defaultCipher (Secret cis) - chp = headerProtectionKey defaultCipher (Secret cis) + ckey = aeadKey ver defaultCipher (Secret cis) + civ = initialVector ver defaultCipher (Secret cis) + chp = headerProtectionKey ver defaultCipher (Secret cis) ---------------------------------------------------------------- -- payload encryption - let clientCRYPTOframe = dec16 $ BS.concat [ - "060040f1010000ed0303ebf8fa56f12939b9584a3896472ec40bb863cfd3e868" - , "04fe3a47f06a2b69484c00000413011302010000c000000010000e00000b6578" - , "616d706c652e636f6dff01000100000a00080006001d00170018001000070005" - , "04616c706e000500050100000000003300260024001d00209370b2c9caa47fba" - , "baf4559fedba753de171fa71f50f1ce15d43e994ec74d748002b000302030400" - , "0d0010000e0403050306030203080408050806002d00020101001c0002400100" - , "3900320408ffffffffffffffff05048000ffff07048000ffff08011001048000" - , "75300901100f088394c8f03e51570806048000ffff" - ] let clientPacketHeader = dec16 "c300000001088394c8f03e5157080000449e00000002" - -- c30000000108 8394c8f03e515708 0000449e 00000002 + -- c3 00000001 08 8394c8f03e515708 00 00 449e 00000002 -- c3 (11000011) -- flags -- 00000001 -- version 1 -- 08 -- dcid len @@ -81,9 +73,10 @@ clientCRYPTOframePadded = clientCRYPTOframe `BS.append` BS.pack (replicate padLen 0) let plaintext = clientCRYPTOframePadded let nonce = makeNonce civ $ dec16 "00000002" - let add = AddDat clientPacketHeader - let ciphertext = BS.concat $ encryptPayload' defaultCipher ckey nonce plaintext add - let Just plaintext' = decryptPayload' defaultCipher ckey nonce ciphertext add + let add = AssDat clientPacketHeader + let (hdr,bdy) = fromJust $ niteEncrypt' defaultCipher ckey nonce plaintext add + ciphertext = hdr `BS.append` bdy + let plaintext' = fromJust $ niteDecrypt' defaultCipher ckey nonce ciphertext add plaintext' `shouldBe` plaintext ---------------------------------------------------------------- @@ -92,3 +85,194 @@ sample `shouldBe` Sample (dec16 "d1b1c98dd7689fb8ec11d242b123dc9b") let Mask mask = protectionMask defaultCipher chp sample BS.take 5 mask `shouldBe` dec16 "437b9aec36" + + it "describes the examples of Server Initial" $ do + let dcID = makeCID (dec16s "8394c8f03e515708") + ServerTrafficSecret sis = serverInitialSecret ver dcID + skey = aeadKey ver defaultCipher (Secret sis) + siv = initialVector ver defaultCipher (Secret sis) + shp = headerProtectionKey ver defaultCipher (Secret sis) + ---------------------------------------------------------------- + -- payload encryption + let serverPacketHeader = dec16 "c1000000010008f067a5502a4262b50040750001" + -- c1 00000001 00 08 f067a5502a4262b5 00 4075 0001 + -- c1 (11000001) -- flags + -- 00000001 -- version 1 + -- 00 -- dcid len + -- 08 -- scid len + -- f067a5502a4262b5 -- scid + -- 00 -- token length + -- 4075 -- length + -- 0001 -- encoded packet number + + let bodyLen = fromIntegral $ decodeInt (dec16 "4075") + let padLen = bodyLen + - 2 -- packet number length + - 16 -- GCM encrypt expansion + - BS.length serverCRYPTOframe + serverCRYPTOframePadded = serverCRYPTOframe `BS.append` BS.pack (replicate padLen 0) + let plaintext = serverCRYPTOframePadded + let nonce = makeNonce siv $ dec16 "0001" + let add = AssDat serverPacketHeader + let (hdr,bdy) = fromJust $ niteEncrypt' defaultCipher skey nonce plaintext add + ciphertext = hdr `BS.append` bdy + let plaintext' = fromJust $ niteDecrypt' defaultCipher skey nonce ciphertext add + plaintext' `shouldBe` plaintext + + ---------------------------------------------------------------- + -- header protection + let sample = Sample (BS.take 16 $ BS.drop 2 ciphertext) + sample `shouldBe` Sample (dec16 "2cd0991cd25b0aac406a5816b6394100") + let Mask mask = protectionMask defaultCipher shp sample + BS.take 5 mask `shouldBe` dec16 "2ec0d8356a" + + it "describes the examples of Retry" $ do + let wire0 = dec16 "ff000000010008f067a5502a4262b5746f6b656e04a265ba2eff4d829058fb3f0f2496ba" + (ipkt,rest) <- decodePacket wire0 + rest `shouldBe` "" + case ipkt of + PacketIR retrypkt -> do + wire1 <- encodeRetryPacket retrypkt + let (f0,r0) = fromJust $ BS.uncons wire0 + (f1,r1) = fromJust $ BS.uncons wire1 + f0 .&. 0xf0 `shouldBe` f1 .&. 0xf0 + r0 `shouldBe` r1 + _ -> error "Retry version 1" + + describe "test vector for version 2" $ do + let ver = Version2 + it "describes the examples of Keys" $ do + ---------------------------------------------------------------- + -- shared keys + let dcID = makeCID (dec16s "8394c8f03e515708") + let client_initial_secret@(ClientTrafficSecret cis) = clientInitialSecret ver dcID + client_initial_secret `shouldBe` ClientTrafficSecret (dec16 "14ec9d6eb9fd7af83bf5a668bc17a7e283766aade7ecd0891f70f9ff7f4bf47b") + let ckey = aeadKey ver defaultCipher (Secret cis) + ckey `shouldBe` Key (dec16 "8b1a0bc121284290a29e0971b5cd045d") + let civ = initialVector ver defaultCipher (Secret cis) + civ `shouldBe` IV (dec16 "91f73e2351d8fa91660e909f") + let chp = headerProtectionKey ver defaultCipher (Secret cis) + chp `shouldBe` Key (dec16 "45b95e15235d6f45a6b19cbcb0294ba9") + let server_initial_secret@(ServerTrafficSecret sis) = serverInitialSecret ver dcID + server_initial_secret `shouldBe` ServerTrafficSecret (dec16 "0263db1782731bf4588e7e4d93b7463907cb8cd8200b5da55a8bd488eafc37c1") + let skey = aeadKey ver defaultCipher (Secret sis) + skey `shouldBe` Key (dec16 "82db637861d55e1d011f19ea71d5d2a7") + let siv = initialVector ver defaultCipher (Secret sis) + siv `shouldBe` IV (dec16 "dd13c276499c0249d3310652") + let shp = headerProtectionKey ver defaultCipher (Secret sis) + shp `shouldBe` Key (dec16 "edf6d05c83121201b436e16877593c3a") + + it "describes the examples of Client Initial" $ do + let dcID = makeCID (dec16s "8394c8f03e515708") + ClientTrafficSecret cis = clientInitialSecret ver dcID + ckey = aeadKey ver defaultCipher (Secret cis) + civ = initialVector ver defaultCipher (Secret cis) + chp = headerProtectionKey ver defaultCipher (Secret cis) + ---------------------------------------------------------------- + -- payload encryption + let clientPacketHeader = dec16 "d36b3343cf088394c8f03e5157080000449e00000002" + -- d3 6b3343cf 08 8394c8f03e515708 00 00 449e 00000002 + -- d3 (11010011) -- flags + -- 6b3343cf -- version 2 + -- 08 -- dcid len + -- 8394c8f03e515708 -- dcid + -- 00 -- scid len + -- 00 -- token length + -- 449e -- length: decodeInt (dec16 "449e") + -- 1182 = 4 + 1162 + 16 (fixme) + -- 00000002 -- encoded packet number + + let bodyLen = fromIntegral $ decodeInt (dec16 "449e") + let padLen = bodyLen + - 4 -- packet number length + - 16 -- GCM encrypt expansion + - BS.length clientCRYPTOframe + clientCRYPTOframePadded = clientCRYPTOframe `BS.append` BS.pack (replicate padLen 0) + let plaintext = clientCRYPTOframePadded + let nonce = makeNonce civ $ dec16 "00000002" + let add = AssDat clientPacketHeader + let (hdr,bdy) = fromJust $ niteEncrypt' defaultCipher ckey nonce plaintext add + ciphertext = hdr `BS.append` bdy + let plaintext' = fromJust $ niteDecrypt' defaultCipher ckey nonce ciphertext add + plaintext' `shouldBe` plaintext + + ---------------------------------------------------------------- + -- header protection + let sample = Sample (BS.take 16 ciphertext) + sample `shouldBe` Sample (dec16 "ffe67b6abcdb4298b485dd04de806071") + let Mask mask = protectionMask defaultCipher chp sample + BS.take 5 mask `shouldBe` dec16 "94a0c95e80" + + it "describes the examples of Server Initial" $ do + let dcID = makeCID (dec16s "8394c8f03e515708") + ServerTrafficSecret sis = serverInitialSecret ver dcID + skey = aeadKey ver defaultCipher (Secret sis) + siv = initialVector ver defaultCipher (Secret sis) + shp = headerProtectionKey ver defaultCipher (Secret sis) + ---------------------------------------------------------------- + -- payload encryption + let serverPacketHeader = dec16 "d16b3343cf0008f067a5502a4262b50040750001" + -- d1 709a50c4 00 08 f067a5502a4262b5 00 4075 0001 + -- d1 (11010001) -- flags + -- 709a50c4 -- version 2 + -- 00 -- dcid len + -- 08 -- scid len + -- f067a5502a4262b5 -- scid + -- 00 -- token length + -- 4075 -- length + -- 0001 -- encoded packet number + + let bodyLen = fromIntegral $ decodeInt (dec16 "4075") + let padLen = bodyLen + - 2 -- packet number length + - 16 -- GCM encrypt expansion + - BS.length serverCRYPTOframe + serverCRYPTOframePadded = serverCRYPTOframe `BS.append` BS.pack (replicate padLen 0) + let plaintext = serverCRYPTOframePadded + let nonce = makeNonce siv $ dec16 "0001" + let add = AssDat serverPacketHeader + let (hdr,bdy) = fromJust $ niteEncrypt' defaultCipher skey nonce plaintext add + ciphertext = hdr `BS.append` bdy + let plaintext' = fromJust $ niteDecrypt' defaultCipher skey nonce ciphertext add + plaintext' `shouldBe` plaintext + + ---------------------------------------------------------------- + -- header protection + let sample = Sample (BS.take 16 $ BS.drop 2 ciphertext) + sample `shouldBe` Sample (dec16 "6f05d8a4398c47089698baeea26b91eb") + let Mask mask = protectionMask defaultCipher shp sample + BS.take 5 mask `shouldBe` dec16 "4dd92e91ea" + + it "describes the examples of Retry" $ do + let wire0 = dec16 "cf6b3343cf0008f067a5502a4262b5746f6b656ec8646ce8bfe33952d955543665dcc7b6" + (ipkt,rest) <- decodePacket wire0 + rest `shouldBe` "" + case ipkt of + PacketIR retrypkt -> do + wire1 <- encodeRetryPacket retrypkt + let (f0,r0) = fromJust $ BS.uncons wire0 + (f1,r1) = fromJust $ BS.uncons wire1 + f0 .&. 0xf0 `shouldBe` f1 .&. 0xf0 + r0 `shouldBe` r1 + _ -> error "Retry version 2" + + +serverCRYPTOframe :: BS.ByteString +serverCRYPTOframe = dec16 $ BS.concat [ + "02000000000600405a020000560303eefce7f7b37ba1d1632e96677825ddf739" + , "88cfc79825df566dc5430b9a045a1200130100002e00330024001d00209d3c94" + , "0d89690b84d08a60993c144eca684d1081287c834d5311bcf32bb9da1a002b00" + , "020304" + ] + +clientCRYPTOframe :: BS.ByteString +clientCRYPTOframe = dec16 $ BS.concat [ + "060040f1010000ed0303ebf8fa56f12939b9584a3896472ec40bb863cfd3e868" + , "04fe3a47f06a2b69484c00000413011302010000c000000010000e00000b6578" + , "616d706c652e636f6dff01000100000a00080006001d00170018001000070005" + , "04616c706e000500050100000000003300260024001d00209370b2c9caa47fba" + , "baf4559fedba753de171fa71f50f1ce15d43e994ec74d748002b000302030400" + , "0d0010000e0403050306030203080408050806002d00020101001c0002400100" + , "3900320408ffffffffffffffff05048000ffff07048000ffff08011001048000" + , "75300901100f088394c8f03e51570806048000ffff" + ] diff --git a/test/TransportError.hs b/test/TransportError.hs --- a/test/TransportError.hs +++ b/test/TransportError.hs @@ -4,13 +4,13 @@ transportErrorSpec ) where -import Control.Concurrent import Control.Monad import Data.ByteString () import qualified Data.ByteString as BS import qualified Network.TLS as TLS -import Network.TLS.QUIC (ExtensionRaw) +import Network.TLS.QUIC (ExtensionRaw(..)) import Test.Hspec +import UnliftIO.Concurrent import UnliftIO.Timeout import Network.QUIC.Client @@ -129,6 +129,11 @@ runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.NoApplicationProtocol] it "MUST send missing_extension TLS alert if the quic_transport_parameters extension does not included [TLS 8.2]" $ \_ -> do let cc = addHook cc0 $ setOnTLSExtensionCreated (const []) + runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.MissingExtension] + it "MUST send missing_extension TLS alert if the quic_transport_parameters extension does not included [TLS 8.2]" $ \_ -> do + let f [ExtensionRaw _ v] = [ExtensionRaw 0xffa5 v] + f _ = error "f" + cc = addHook cc0 $ setOnTLSExtensionCreated f runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.MissingExtension] it "MUST send unexpected_message TLS alert if EndOfEarlyData is received [TLS 8.3]" $ \_ -> do let cc = addHook cc0 $ setOnTLSHandshakeCreated cryptoEndOfEarlyData diff --git a/util/Common.hs b/util/Common.hs --- a/util/Common.hs +++ b/util/Common.hs @@ -46,6 +46,7 @@ makeProtos :: Version -> (ByteString, ByteString) makeProtos Version1 = ("h3","hq-interop") +makeProtos Version2 = ("h3","hq-interop") makeProtos ver = (h3X,hqX) where verbs = C8.pack $ show $ fromVersion ver diff --git a/util/client.hs b/util/client.hs --- a/util/client.hs +++ b/util/client.hs @@ -18,6 +18,7 @@ import System.Exit import System.IO import Text.Printf +import qualified UnliftIO.Timeout as T import ClientX import Common @@ -160,34 +161,35 @@ cmvar <- newEmptyMVar let path | ipslen == 3 = ips !! 2 | otherwise = "/" - addr:port:_ = ips + addr = head ips + port = head $ tail ips ccalpn ver | optPerformance /= 0 = return $ Just ["perf"] | otherwise = let (h3X, hqX) = makeProtos ver protos | optHQ = [hqX,h3X] | otherwise = [h3X,hqX] in return $ Just protos - confver vers + gvers vers | optVerNego = GreasingVersion : vers | otherwise = vers - confparams params + setTPQuantum params | optQuantum = let bs = BS.replicate 1200 0 in params { grease = Just bs } | otherwise = params cc0 = defaultClientConfig cc = cc0 { - ccServerName = addr - , ccPortName = port - , ccALPN = ccalpn - , ccValidate = optValidate - , ccPacketSize = optPacketSize - , ccDebugLog = optDebugLog - , ccVersions = confver $ ccVersions cc0 - , ccParameters = confparams $ ccParameters cc0 - , ccKeyLog = getLogger optKeyLogFile - , ccGroups = getGroups (ccGroups cc0) optGroups - , ccQLog = optQLogDir - , ccHooks = defaultHooks { + ccServerName = addr + , ccPortName = port + , ccALPN = ccalpn + , ccValidate = optValidate + , ccPacketSize = optPacketSize + , ccDebugLog = optDebugLog + , ccVersions = gvers $ ccVersions cc0 + , ccParameters = setTPQuantum $ ccParameters cc0 + , ccKeyLog = getLogger optKeyLogFile + , ccGroups = getGroups (ccGroups cc0) optGroups + , ccQLog = optQLogDir + , ccHooks = defaultHooks { onCloseCompleted = putMVar cmvar () } , ccAutoMigration = optUnconSock @@ -202,7 +204,7 @@ , auxDebug = debug , auxShow = showContent , auxCheckClose = do - mx <- timeout 1000000 $ takeMVar cmvar + mx <- T.timeout 1000000 $ takeMVar cmvar case mx of Nothing -> return False _ -> return True