quic 0.0.1 → 0.1.0

raw patch · 81 files changed

+2299/−1418 lines, 81 filesdep +network-udpdep +x509-systemdep ~basedep ~crypto-tokendep ~tls

Dependencies added: network-udp, x509-system

Dependency ranges changed: base, crypto-token, tls

Files

• ChangeLog.md +7/−0
• Network/QUIC.hs +2/−0
• Network/QUIC/Client.hs +1/−0
• Network/QUIC/Client/Reader.hs +48/−43
• Network/QUIC/Client/Run.hs +41/−36
• Network/QUIC/Closer.hs +30/−28
• Network/QUIC/Common.hs +4/−2
• Network/QUIC/Config.hs +5/−7
• Network/QUIC/Connection/Crypto.hs +119/−38
• Network/QUIC/Connection/Migration.hs +3/−3
• Network/QUIC/Connection/Misc.hs +45/−18
• Network/QUIC/Connection/Queue.hs +1/−1
• Network/QUIC/Connection/Role.hs +35/−19
• Network/QUIC/Connection/State.hs +5/−5
• Network/QUIC/Connection/Stream.hs +2/−2
• Network/QUIC/Connection/Timeout.hs +3/−3
• Network/QUIC/Connection/Types.hs +66/−39
• Network/QUIC/Connector.hs +1/−1
• Network/QUIC/Crypto.hs +10/−370
• Network/QUIC/Crypto/Fusion.hs +189/−0
• Network/QUIC/Crypto/Keys.hs +108/−0
• Network/QUIC/Crypto/Nite.hs +247/−0
• Network/QUIC/Crypto/Types.hs +61/−0
• Network/QUIC/Crypto/Utils.hs +61/−0
• Network/QUIC/CryptoFusion.hs +0/−146
• Network/QUIC/Event.hs +20/−0
• Network/QUIC/Handshake.hs +80/−27
• Network/QUIC/IO.hs +6/−4
• Network/QUIC/Imports.hs +23/−8
• Network/QUIC/Info.hs +4/−11
• Network/QUIC/Internal.hs +2/−2
• Network/QUIC/Packet.hs +2/−1
• Network/QUIC/Packet/Decode.hs +16/−12
• Network/QUIC/Packet/Decrypt.hs +13/−17
• Network/QUIC/Packet/Encode.hs +54/−32
• Network/QUIC/Packet/Frame.hs +12/−7
• Network/QUIC/Packet/Header.hs +25/−12
• Network/QUIC/Packet/Number.hs +3/−3
• Network/QUIC/Parameters.hs +30/−1
• Network/QUIC/Receiver.hs +54/−48
• Network/QUIC/Recovery/Constants.hs +4/−4
• Network/QUIC/Recovery/Interface.hs +4/−4
• Network/QUIC/Recovery/LossRecovery.hs +1/−1
• Network/QUIC/Recovery/Metrics.hs +5/−5
• Network/QUIC/Recovery/Persistent.hs +1/−1
• Network/QUIC/Recovery/Release.hs +1/−1
• Network/QUIC/Recovery/Timer.hs +3/−3
• Network/QUIC/Recovery/Types.hs +3/−3
• Network/QUIC/Recovery/Utils.hs +2/−2
• Network/QUIC/Sender.hs +68/−61
• Network/QUIC/Server.hs +1/−0
• Network/QUIC/Server/Reader.hs +130/−109
• Network/QUIC/Server/Run.hs +37/−22
• Network/QUIC/Socket.hs +0/−82
• Network/QUIC/Stream.hs +2/−0
• Network/QUIC/Stream/Misc.hs +1/−1
• Network/QUIC/Stream/Queue.hs +1/−1
• Network/QUIC/Stream/Types.hs +12/−1
• Network/QUIC/TLS.hs +28/−25
• Network/QUIC/Types.hs +2/−4
• Network/QUIC/Types/Constants.hs +5/−6
• Network/QUIC/Types/Error.hs +30/−1
• Network/QUIC/Types/Exception.hs +3/−2
• Network/QUIC/Types/Integer.hs +11/−11
• Network/QUIC/Types/Packet.hs +39/−8
• Network/QUIC/Types/Queue.hs +1/−1
• Network/QUIC/Types/Resumption.hs +6/−4
• Network/QUIC/Windows.hs +17/−0
• cbits/fusion.c +4/−2
• cbits/picotls.c +5/−1
• cbits/picotls.h +1/−1
• quic.cabal +24/−7
• test/Config.hs +35/−16
• test/ErrorSpec.hs +1/−1
• test/HandshakeSpec.hs +14/−5
• test/IOSpec.hs +2/−1
• test/PacketSpec.hs +122/−32
• test/TLSSpec.hs +209/−25
• test/TransportError.hs +7/−2
• util/Common.hs +1/−0
• util/client.hs +18/−16

@@ -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

@@ -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

@@ -14,6 +14,7 @@   , ccResumption   , ccCiphers   , ccGroups+  , ccVersions --  , ccCredentials   , ccValidate   , ccAutoMigration

@@ -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'

@@ -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

@@ -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 ()

@@ -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

@@ -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

@@ -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

@@ -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 ()

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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  ---------------------------------------------------------------- 

@@ -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

@@ -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

@@ -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

@@ -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"

@@ -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

@@ -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

@@ -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"

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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       }

@@ -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

@@ -11,7 +11,8 @@   , decodeStatelessResetToken   -- * Frame   , encodeFrames-  , decodeFrames+  , decodeFramesBuffer+  , decodeFramesBS   , countZero -- testing   -- * Header   , isLong

@@ -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  ---------------------------------------------------------------- 

@@ -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

@@ -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

@@ -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 [] 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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 

@@ -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

@@ -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 

@@ -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

@@ -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

@@ -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]

@@ -12,6 +12,7 @@   , scUse0RTT   , scCiphers   , scGroups+  , scVersions --   , scParameters   , scCredentials   , scSessionManager

@@ -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)

@@ -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

@@ -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

@@ -11,6 +11,8 @@   , RecvStreamQ(..)   , RxStreamData(..)   , Length+  , syncFinTx+  , waitFinTx   -- * Misc   , getTxStreamOffset   , isTxStreamClosed

@@ -19,7 +19,7 @@   , getRxStreamWindow   ) where -import Control.Concurrent.STM+import UnliftIO.STM  import Network.QUIC.Imports import Network.QUIC.Stream.Types

@@ -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 

@@ -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  ---------------------------------------------------------------- 

@@ -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]

@@ -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

@@ -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  ---------------------------------------------------------------- 

@@ -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

@@ -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

@@ -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

@@ -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 }

@@ -1,6 +1,6 @@ module Network.QUIC.Types.Queue where -import Control.Concurrent.STM+import UnliftIO.STM  import Network.QUIC.Types.Packet 

@@ -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-

@@ -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

@@ -38,7 +38,9 @@  * IN THE SOFTWARE.  */ #include <stdint.h>-+#ifdef _WINDOWS+#include <intrin.h>+#endif #include <stdlib.h> #include <string.h> #include <immintrin.h>@@ -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);

@@ -25,7 +25,7 @@ #include <stdlib.h> #include <string.h> #ifdef _WINDOWS-#include "wincompat.h"+#include "winsock.h" #else #include <arpa/inet.h> #include <sys/time.h>@@ -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};

@@ -27,7 +27,7 @@ #endif  #ifdef _WINDOWS-#include "wincompat.h"+#include "winsock.h" #endif  #include <assert.h>

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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"   ]

@@ -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"+  ]

@@ -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

@@ -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

@@ -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