Merge branch 'tls-v2'

Network/QUIC/Config.hs

@@ -133,6 +133,8 @@ data ServerConfig = ServerConfig
     , 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 @@ defaultServerConfig =
         , scRequireRetry = False
         , scSessionManager = noSessionManager
         , scDebugLog = Nothing
+        , scTicketLifetime = 7200
         }

Network/QUIC/Connection/Role.hs

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

Network/QUIC/Handshake.hs

@@ -53,7 +53,7 @@ recvTLS :: Connection -> IORef HndState -> CryptLevel -> IO (Either TLS.TLSError
 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 @@ sendTLS conn hsr x = do
     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)

Network/QUIC/Packet/Token.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module Network.QUIC.Packet.Token (
     CryptoToken (..),
     isRetryToken,
@@ -7,11 +10,11 @@ module Network.QUIC.Packet.Token (
     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 @@ import Network.QUIC.Types
 
 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
-
-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
+encodeCryptoToken :: CryptoToken -> Token
+encodeCryptoToken = BL.toStrict . serialise
+
+decodeCryptoToken :: Token -> Maybe CryptoToken
+decodeCryptoToken token = case deserialiseOrFail (BL.fromStrict token) of
+    Left DeserialiseFailure{} -> Nothing
+    Right x -> Just x

Network/QUIC/Server/Reader.hs

@@ -59,11 +59,14 @@ data Dispatch = Dispatch {
   , 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 @@ dispatch Dispatch{..} ServerConfig{..} logAction
     -- 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 @@ dispatch Dispatch{..} ServerConfig{..} logAction
               }
         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 @@ dispatch Dispatch{..} ServerConfig{..} logAction
     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"

Network/QUIC/Server/Run.hs

@@ -53,7 +53,7 @@ run conf server = NS.withSocketsDo $ handleLogUnit debugLog $ do
     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 @@ runServer conf server0 dispatch baseThreadId acc =
             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 @@ createServerConnection conf@ServerConfig{..} dispatch Accept{..} baseThreadId =
     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

Network/QUIC/TLS.hs

@@ -17,13 +17,7 @@ import Network.QUIC.Parameters
 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 @@ clientHandshaker callbacks ClientConfig{..} ver myAuthCIDs establish use0RTT = d
             , 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 @@ serverHandshaker callbacks ServerConfig{..} ver getParams =
             , serverSupported = supported
             , serverDebug = debug
             , serverEarlyDataSize = if scUse0RTT then quicMaxEarlyDataSize else 0
+            , serverTicketLifetime = scTicketLifetime
             }
     convTP = onTransportParametersCreated scHooks
     convExt = onTLSExtensionCreated scHooks

Network/QUIC/Types/CID.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveGeneric #-}
+
 module Network.QUIC.Types.CID (
     CID (..),
     myCIDLength,
@@ -15,13 +17,14 @@ module Network.QUIC.Types.CID (
 
 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)

Network/QUIC/Types/Error.hs

@@ -84,9 +84,7 @@ instance Show TransportError where
     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 -}
 

Network/QUIC/Types/Packet.hs

@@ -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 @@ import Network.QUIC.Types.Time
 ----------------------------------------------------------------
 
 -- | 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 @@ brokenVersionInfo = VersionInfo Negotiation []
 ----------------------------------------------------------------
 
 extensionIDForTtransportParameter :: Version -> ExtensionID
-extensionIDForTtransportParameter Version1 = extensionID_QuicTransportParameters
-extensionIDForTtransportParameter Version2 = extensionID_QuicTransportParameters
-extensionIDForTtransportParameter _ = 0xffa5
+extensionIDForTtransportParameter Version1 = EID_QuicTransportParameters
+extensionIDForTtransportParameter Version2 = EID_QuicTransportParameters
+extensionIDForTtransportParameter _ = ExtensionID 0xffa5
 
 ----------------------------------------------------------------
 

Network/QUIC/Types/Resumption.hs

@@ -9,7 +9,7 @@ import Network.QUIC.Imports
 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