quic 0.1.15 → 0.1.16

raw patch · 17 files changed

+95/−113 lines, 17 filesdep +serialisedep ~crypto-tokendep ~tlsdep ~tls-session-managerPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: serialise

Dependency ranges changed: crypto-token, tls, tls-session-manager, unix-time

API changes (from Hackage documentation)

Files

• Network/QUIC/Config.hs +3/−0
• Network/QUIC/Connection/Migration.hs +15/−6
• Network/QUIC/Connection/Role.hs +1/−0
• Network/QUIC/Connection/Types.hs +0/−1
• Network/QUIC/Handshake.hs +2/−2
• Network/QUIC/Packet/Token.hs +28/−64
• Network/QUIC/Receiver.hs +3/−1
• Network/QUIC/Server/Reader.hs +12/−9
• Network/QUIC/Server/Run.hs +6/−5
• Network/QUIC/TLS.hs +3/−8
• Network/QUIC/Types/CID.hs +4/−1
• Network/QUIC/Types/Error.hs +1/−3
• Network/QUIC/Types/Packet.hs +7/−5
• Network/QUIC/Types/Resumption.hs +1/−1
• quic.cabal +5/−4
• test/Config.hs +2/−1
• test/TransportError.hs +2/−2

@@ -133,6 +133,8 @@     , scSessionManager :: SessionManager     -- ^ A session manager of TLS 1.3.     , scDebugLog :: Maybe FilePath+    , scTicketLifetime :: Int+    -- ^ A lifetime (in seconds) for TLS session ticket and QUIC token.     }  -- | The default value for server configuration.@@ -155,4 +157,5 @@         , scRequireRetry = False         , scSessionManager = noSessionManager         , scDebugLog = Nothing+        , scTicketLifetime = 7200         }

@@ -30,9 +30,11 @@ import qualified Data.Map.Strict as Map import UnliftIO.STM +import Network.QUIC.Connection.Misc import Network.QUIC.Connection.Queue import Network.QUIC.Connection.Types import Network.QUIC.Imports+import Network.QUIC.Parameters import Network.QUIC.Qlog import Network.QUIC.Types @@ -81,12 +83,19 @@ ----------------------------------------------------------------  -- | Receiving NewConnectionID-addPeerCID :: Connection -> CIDInfo -> IO ()-addPeerCID Connection{..} cidInfo = atomically $ do-    db <- readTVar peerCIDDB-    case Map.lookup (cidInfoCID cidInfo) (revInfos db) of-        Nothing -> modifyTVar' peerCIDDB $ add cidInfo-        Just _ -> return ()+addPeerCID :: Connection -> CIDInfo -> IO Bool+addPeerCID conn@Connection{..} cidInfo = do+    lim <- activeConnectionIdLimit <$> getPeerParameters conn+    atomically $ do+        db <- readTVar peerCIDDB+        let n = Map.size $ revInfos db+        if n >= lim+            then return False+            else do+                case Map.lookup (cidInfoCID cidInfo) (revInfos db) of+                    Nothing -> modifyTVar' peerCIDDB $ add cidInfo+                    Just _ -> return ()+                return True  shouldUpdatePeerCID :: Connection -> IO Bool shouldUpdatePeerCID Connection{..} =

@@ -92,6 +92,7 @@                     , resumptionSession = Just (si, sd)                     }             }+    return Nothing  setNewToken :: Connection -> Token -> IO () setNewToken conn@Connection{..} token = do

@@ -73,7 +73,6 @@         , certChain = Nothing         } --- fixme: limitation data CIDDB = CIDDB     { usedCIDInfo :: CIDInfo     , cidInfos :: IntMap CIDInfo

@@ -53,7 +53,7 @@ recvTLS conn hsr level =     case level of             CryptInitial           -> go InitialLevel-            CryptMasterSecret      -> failure "QUIC does not receive data < TLS 1.3"+            CryptMainSecret        -> failure "QUIC does not receive data < TLS 1.3"             CryptEarlySecret       -> failure "QUIC does not send early data with TLS library"             CryptHandshakeSecret   -> go HandshakeLevel             CryptApplicationSecret -> go RTT1Level@@ -80,7 +80,7 @@     sendCompleted hsr   where     convertLevel (CryptInitial, bs) = return (InitialLevel, bs)-    convertLevel (CryptMasterSecret, _) = errorTLS "QUIC does not send data < TLS 1.3"+    convertLevel (CryptMainSecret, _) = errorTLS "QUIC does not send data < TLS 1.3"     convertLevel (CryptEarlySecret, _) = errorTLS "QUIC does not receive early data with TLS library"     convertLevel (CryptHandshakeSecret, bs) = return (HandshakeLevel, bs)     convertLevel (CryptApplicationSecret, bs) = return (RTT1Level, bs)

@@ -1,3 +1,6 @@+{-# LANGUAGE DeriveGeneric #-}+{-# OPTIONS_GHC -Wno-orphans #-}+ module Network.QUIC.Packet.Token (     CryptoToken (..),     isRetryToken,@@ -7,11 +10,11 @@     decryptToken, ) where -import qualified UnliftIO.Exception as E+import Codec.Serialise import qualified Crypto.Token as CT+import qualified Data.ByteString.Lazy as BL import Data.UnixTime-import Foreign.C.Types-import Network.ByteOrder+import GHC.Generics  import Network.QUIC.Imports import Network.QUIC.Types@@ -20,86 +23,47 @@  data CryptoToken = CryptoToken     { tokenQUICVersion :: Version+    , tokenLifeTime :: Word32     , tokenCreatedTime :: TimeMicrosecond     , tokenCIDs :: Maybe (CID, CID, CID) -- local, remote, orig local     }+    deriving (Generic) +instance Serialise UnixTime+instance Serialise Version+instance Serialise CID+instance Serialise CryptoToken+ isRetryToken :: CryptoToken -> Bool isRetryToken token = isJust $ tokenCIDs token  ---------------------------------------------------------------- -generateToken :: Version -> IO CryptoToken-generateToken ver = do+generateToken :: Version -> Int -> IO CryptoToken+generateToken ver life = do     t <- getTimeMicrosecond-    return $ CryptoToken ver t Nothing+    return $ CryptoToken ver (fromIntegral life) t Nothing -generateRetryToken :: Version -> CID -> CID -> CID -> IO CryptoToken-generateRetryToken ver l r o = do+generateRetryToken :: Version -> Int -> CID -> CID -> CID -> IO CryptoToken+generateRetryToken ver life l r o = do     t <- getTimeMicrosecond-    return $ CryptoToken ver t $ Just (l, r, o)+    return $ CryptoToken ver (fromIntegral life) t $ Just (l, r, o)  ----------------------------------------------------------------  encryptToken :: CT.TokenManager -> CryptoToken -> IO Token-encryptToken mgr ct = encodeCryptoToken ct >>= CT.encryptToken mgr+encryptToken mgr ct = CT.encryptToken mgr (encodeCryptoToken ct)  decryptToken :: CT.TokenManager -> Token -> IO (Maybe CryptoToken)-decryptToken mgr token = do-    mx <- CT.decryptToken mgr token-    case mx of-      Nothing -> return Nothing-      Just x -> decodeCryptoToken x+decryptToken mgr token =+    (>>= decodeCryptoToken) <$> CT.decryptToken mgr token  ---------------------------------------------------------------- -cryptoTokenSize :: Int-cryptoTokenSize = 76 -- 4 + 8 + 1 + (1 + 20) * 3--encodeCryptoToken :: CryptoToken -> IO Token-encodeCryptoToken (CryptoToken (Version ver) tim mcids) =-    withWriteBuffer cryptoTokenSize $ \wbuf -> do-        write32 wbuf ver-        let CTime s = utSeconds tim-        write64 wbuf $ fromIntegral s-        case mcids of-            Nothing -> write8 wbuf 0-            Just (l, r, o) -> do-                write8 wbuf 1-                bury wbuf l-                bury wbuf r-                bury wbuf o-      where-        bury wbuf x = do-            let (xcid, xlen) = unpackCID x-            write8 wbuf xlen-            copyShortByteString wbuf xcid-            ff wbuf (20 - fromIntegral xlen)--decodeCryptoToken :: Token -> IO (Maybe CryptoToken)-decodeCryptoToken token = do-    ex <- E.try $ decodeCryptoToken' token-    case ex of-      Left (E.SomeException _) -> return Nothing-      Right x -> return $ Just x+encodeCryptoToken :: CryptoToken -> Token+encodeCryptoToken = BL.toStrict . serialise -decodeCryptoToken' :: ByteString -> IO CryptoToken-decodeCryptoToken' token = withReadBuffer token $ \rbuf -> do-    ver <- Version <$> read32 rbuf-    s <- CTime . fromIntegral <$> read64 rbuf-    let tim = UnixTime s 0-    typ <- read8 rbuf-    case typ of-        0 -> return $ CryptoToken ver tim Nothing-        _ -> do-            l <- pick rbuf-            r <- pick rbuf-            o <- pick rbuf-            return $ CryptoToken ver tim $ Just (l, r, o)-  where-    pick rbuf = do-        xlen0 <- fromIntegral <$> read8 rbuf-        let xlen = min xlen0 20-        x <- makeCID <$> extractShortByteString rbuf xlen-        ff rbuf (20 - xlen)-        return x+decodeCryptoToken :: Token -> Maybe CryptoToken+decodeCryptoToken token = case deserialiseOrFail (BL.fromStrict token) of+    Left DeserialiseFailure{} -> Nothing+    Right x -> Just x

@@ -365,7 +365,9 @@ processFrame conn lvl (NewConnectionID cidInfo rpt) = do     when (lvl == InitialLevel || lvl == HandshakeLevel) $         closeConnection ProtocolViolation "NEW_CONNECTION_ID in Initial or Handshake"-    addPeerCID conn cidInfo+    ok <- addPeerCID conn cidInfo+    unless ok $+        closeConnection ConnectionIdLimitError "NEW_CONNECTION_ID limit error"     let (_, cidlen) = unpackCID $ cidInfoCID cidInfo     when (cidlen < 1 || 20 < cidlen || rpt > cidInfoSeq cidInfo) $         closeConnection FrameEncodingError "NEW_CONNECTION_ID parameter error"

@@ -59,11 +59,14 @@   , acceptQ  :: AcceptQ   } -newDispatch :: IO Dispatch-newDispatch = Dispatch <$> CT.spawnTokenManager CT.defaultConfig-                       <*> newIORef emptyConnectionDict-                       <*> newIORef emptyRecvQDict-                       <*> newAcceptQ+newDispatch :: ServerConfig -> IO Dispatch+newDispatch ServerConfig{..} =+    Dispatch <$> CT.spawnTokenManager conf+             <*> newIORef emptyConnectionDict+             <*> newIORef emptyRecvQDict+             <*> newAcceptQ+  where+    conf = CT.defaultConfig { CT.tokenLifetime = scTicketLifetime }  clearDispatch :: Dispatch -> IO () clearDispatch d = CT.killTokenManager $ tokenMgr d@@ -285,7 +288,7 @@     -- initial_source_connection_id       = S3   (dCID)  S2 in our server     -- original_destination_connection_id = S1   (o)     -- retry_source_connection_id         = S2   (dCID)-    pushToAcceptRetried (CryptoToken _ _ (Just (_,_,o))) = do+    pushToAcceptRetried (CryptoToken _ _ _ (Just (_,_,o))) = do         let myAuthCIDs = defaultAuthCIDs {                 initSrcCID  = Just dCID               , origDstCID  = Just o@@ -296,9 +299,9 @@               }         pushToAcceptQ myAuthCIDs peerAuthCIDs o True     pushToAcceptRetried _ = return ()-    isRetryTokenValid (CryptoToken _tver etim (Just (l,r,_))) = do+    isRetryTokenValid (CryptoToken _tver life etim (Just (l,r,_))) = do         diff <- getElapsedTimeMicrosecond etim-        return $ diff <= Microseconds 30000000 -- fixme+        return $ diff <= Microseconds (fromIntegral life * 1000000)               && dCID == l               && sCID == r #if !defined(mingw32_HOST_OS)@@ -309,7 +312,7 @@     isRetryTokenValid _ = return False     sendRetry = do         newdCID <- newCID-        retryToken <- generateRetryToken peerVer newdCID sCID dCID+        retryToken <- generateRetryToken peerVer scTicketLifetime newdCID sCID dCID         mnewtoken <- timeout (Microseconds 100000) "sendRetry" $ encryptToken tokenMgr retryToken         case mnewtoken of           Nothing       -> logAction "retry token stacked"

@@ -53,7 +53,7 @@     debugLog msg | doDebug   = stdoutLogger ("run: " <> msg)                  | otherwise = return ()     setup = do-        dispatch <- newDispatch+        dispatch <- newDispatch conf         -- fixme: the case where sockets cannot be created.         ssas <- mapM UDP.serverSocket $ scAddresses conf         tids <- mapM (runDispatcher dispatch conf) ssas@@ -79,7 +79,7 @@             handshaker <- handshakeServer conf' conn myAuthCIDs             let server = do                     wait1RTTReady conn-                    afterHandshakeServer conn+                    afterHandshakeServer conf conn                     server0 conn                 ldcc = connLDCC conn                 supporters = foldr1 concurrently_ [handshaker@@ -160,14 +160,15 @@     return $ ConnRes conn accMyAuthCIDs reader #endif -afterHandshakeServer :: Connection -> IO ()-afterHandshakeServer conn = handleLogT logAction $ do+afterHandshakeServer :: ServerConfig -> Connection -> IO ()+afterHandshakeServer ServerConfig{..} conn = handleLogT logAction $ do     --     cidInfo <- getNewMyCID conn     register <- getRegister conn     register (cidInfoCID cidInfo) conn     ---    cryptoToken <- generateToken =<< getVersion conn+    ver <- getVersion conn+    cryptoToken <- generateToken ver scTicketLifetime     mgr <- getTokenManager conn     token <- encryptToken mgr cryptoToken     let ncid = NewConnectionID cidInfo 0

@@ -17,13 +17,7 @@ import Network.QUIC.Types  sessionManager :: SessionEstablish -> SessionManager-sessionManager establish =-    SessionManager-        { sessionEstablish = establish-        , sessionResume = \_ -> return Nothing-        , sessionResumeOnlyOnce = \_ -> return Nothing-        , sessionInvalidate = \_ -> return ()-        }+sessionManager establish = noSessionManager{sessionEstablish = establish}  clientHandshaker     :: QUICCallbacks@@ -44,7 +38,7 @@             , clientSupported = supported             , clientDebug = debug             , clientWantSessionResume = resumptionSession ccResumption-            , clientEarlyData = if use0RTT then Just "" else Nothing+            , clientUseEarlyData = use0RTT             }     convTP = onTransportParametersCreated ccHooks     params = convTP $ setCIDsToParameters myAuthCIDs ccParameters@@ -93,6 +87,7 @@             , serverSupported = supported             , serverDebug = debug             , serverEarlyDataSize = if scUse0RTT then quicMaxEarlyDataSize else 0+            , serverTicketLifetime = scTicketLifetime             }     convTP = onTransportParametersCreated scHooks     convExt = onTLSExtensionCreated scHooks

@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveGeneric #-}+ module Network.QUIC.Types.CID (     CID (..),     myCIDLength,@@ -15,13 +17,14 @@  import qualified Data.ByteString.Short as Short +import GHC.Generics import Network.QUIC.Imports  myCIDLength :: Int myCIDLength = 8  -- | A type for conneciton ID.-newtype CID = CID Bytes deriving (Eq, Ord)+newtype CID = CID Bytes deriving (Eq, Ord, Generic)  instance Show CID where     show (CID cid) = shortToString (enc16s cid)

@@ -84,9 +84,7 @@     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+      | 0x100 <= x && x <= 0x01ff = "TLS" ++ show (toAlertDescription $ fromIntegral (x - 0x100))       | otherwise = "TransportError " ++ printf "%x" x {- FOURMOLU_ENABLE -} 

@@ -1,10 +1,12 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-}  module Network.QUIC.Types.Packet where  import Data.Ix-import Network.TLS.QUIC (ExtensionID, extensionID_QuicTransportParameters)+import GHC.Generics+import Network.TLS.QUIC (ExtensionID (EID_QuicTransportParameters, ExtensionID)) import Network.UDP import Text.Printf @@ -17,7 +19,7 @@ ----------------------------------------------------------------  -- | QUIC version.-newtype Version = Version Word32 deriving (Eq, Ord)+newtype Version = Version Word32 deriving (Eq, Ord, Generic)  {- FOURMOLU_DISABLE -} pattern Negotiation      :: Version@@ -60,9 +62,9 @@ ----------------------------------------------------------------  extensionIDForTtransportParameter :: Version -> ExtensionID-extensionIDForTtransportParameter Version1 = extensionID_QuicTransportParameters-extensionIDForTtransportParameter Version2 = extensionID_QuicTransportParameters-extensionIDForTtransportParameter _ = 0xffa5+extensionIDForTtransportParameter Version1 = EID_QuicTransportParameters+extensionIDForTtransportParameter Version2 = EID_QuicTransportParameters+extensionIDForTtransportParameter _ = ExtensionID 0xffa5  ---------------------------------------------------------------- 

@@ -9,7 +9,7 @@ import Network.QUIC.Types.Frame import Network.QUIC.Types.Packet -type SessionEstablish = SessionID -> SessionData -> IO ()+type SessionEstablish = SessionID -> SessionData -> IO (Maybe Ticket)  -- | Information about resumption data ResumptionInfo = ResumptionInfo

@@ -1,6 +1,6 @@ cabal-version:      >=1.10 name:               quic-version:            0.1.15+version:            0.1.16 license:            BSD3 license-file:       LICENSE maintainer:         kazu@iij.ad.jp@@ -130,7 +130,7 @@         base16-bytestring >= 1.0 && < 1.1,         bytestring >= 0.10 && < 0.13,         containers >= 0.6 && < 0.7,-        crypto-token >= 0.1 && < 0.2,+        crypto-token >= 0.1.1 && < 0.2,         crypton >= 0.34 && < 0.35,         memory >= 0.18.0 && < 0.19,         crypton-x509 >= 1.7.6 && < 1.8,@@ -146,7 +146,8 @@         network-control >= 0.0.2 && < 0.1,         network-udp >= 0.0.0 && < 0.1,         random >= 1.2.1 && < 1.3,-        tls >= 1.9.0 && < 1.10,+        serialise,+        tls >= 2.0 && < 2.1,         unliftio >= 0.2 && < 0.3,         unliftio-core >= 0.2 && < 0.3 @@ -180,7 +181,7 @@         network-byte-order,         quic,         tls,-        tls-session-manager,+        tls-session-manager >= 0.0.5,         unliftio      if flag(devel)

@@ -176,9 +176,10 @@         , sessionResume = resume         , sessionResumeOnlyOnce = resume         , sessionInvalidate = \_ -> return ()+        , sessionUseTicket = False         }   where-    establish sid sdata = writeIORef ref $ Just (sid, sdata)+    establish sid sdata = writeIORef ref (Just (sid, sdata)) >> return Nothing     resume sid = do         mx <- readIORef ref         case mx of

@@ -8,7 +8,7 @@ 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 (..), ExtensionID (..)) import Test.Hspec import UnliftIO.Concurrent import UnliftIO.Timeout@@ -194,7 +194,7 @@         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]+                let f [ExtensionRaw _ v] = [ExtensionRaw (ExtensionID 0xffa5) v]                     f _ = error "f"                     cc = addHook cc0 $ setOnTLSExtensionCreated f                 runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.MissingExtension]