diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,18 @@ # ChangeLog for tls-session-manager +## 0.1.1 + +* Keep a TLS 1.3 session no longer than the lifetime of its ticket. + [#604](https://github.com/haskell-tls/hs-tls/pull/604) +* Do not resume an expired session before it is pruned. + [#604](https://github.com/haskell-tls/hs-tls/pull/604) +* Keep deletions and the size limit across pruning. + [#604](https://github.com/haskell-tls/hs-tls/pull/604) +* Do not drop another session when a key is added again at the limit. + [#604](https://github.com/haskell-tls/hs-tls/pull/604) +* Expose `Network.TLS.SessionManager.Internal` for testing. + [#604](https://github.com/haskell-tls/hs-tls/pull/604) + ## 0.1.0 * Using "ram" instead of "memory" diff --git a/Network/TLS/SessionManager.hs b/Network/TLS/SessionManager.hs --- a/Network/TLS/SessionManager.hs +++ b/Network/TLS/SessionManager.hs @@ -3,7 +3,7 @@ -- * Limitation: you can set the maximum size of the session data database. -- * Automatic pruning: old session data over their lifetime are pruned automatically. -- * Energy saving: no dedicate pruning thread is running when the size of session data database is zero. --- * Replay resistance: each session data is used at most once to prevent replay attacks against 0RTT early data of TLS 1.3. +-- * Replay resistance: for 0-RTT early data of TLS 1.3, each session data is used at most once ('sessionResumeOnlyOnce'). Other resumptions may use it again. module Network.TLS.SessionManager ( newSessionManager, Config, @@ -13,170 +13,4 @@ dbMaxSize, ) where -import Control.Exception (assert) -import Control.Reaper -import Data.ByteArray (convert) -import Data.ByteString (ByteString) -import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as SBS -import Data.IORef -import Data.OrdPSQ (OrdPSQ) -import qualified Data.OrdPSQ as Q -import Network.TLS -import qualified System.Clock as C - -import Network.TLS.Imports - ----------------------------------------------------------------- - --- | Configuration for session managers. -data Config = Config - { ticketLifetime :: Int - -- ^ Ticket lifetime in seconds. - , pruningDelay :: Int - -- ^ Pruning delay in seconds. This is set to 'reaperDelay'. - , dbMaxSize :: Int - -- ^ The limit size of session data entries. - } - --- | ticketLifetime: 2 hours (7200 seconds), pruningDelay: 10 minutes (600 seconds), dbMaxSize: 1000 entries. -defaultConfig :: Config -defaultConfig = - Config - { ticketLifetime = 7200 - , pruningDelay = 600 - , dbMaxSize = 1000 - } - ----------------------------------------------------------------- - -toKey :: ByteString -> SessionIDCopy -toKey = SBS.toShort - -toValue :: SessionData -> SessionDataCopy -toValue sd = - SessionDataCopy $ - sd - { sessionSecret = convert $ sessionSecret sd - , sessionALPN = convert <$> sessionALPN sd - } - -fromValue :: SessionDataCopy -> SessionData -fromValue (SessionDataCopy sd) = - sd - { sessionSecret = convert $ sessionSecret sd - , sessionALPN = convert <$> sessionALPN sd - } - ----------------------------------------------------------------- - -type SessionIDCopy = ShortByteString -newtype SessionDataCopy = SessionDataCopy SessionData - deriving (Show, Eq) - -type Sec = Int64 -type Value = (SessionDataCopy, IORef Availability) -type DB = OrdPSQ SessionIDCopy Sec Value -type Item = (SessionIDCopy, Sec, Value, Operation) - -data Operation = Add | Del -data Use = SingleUse | MultipleUse -data Availability = Fresh | Used - ----------------------------------------------------------------- - --- | Creating an in-memory session manager. -newSessionManager :: Config -> IO SessionManager -newSessionManager conf = do - let lifetime = fromIntegral $ ticketLifetime conf - maxsiz = dbMaxSize conf - reaper <- - mkReaper - defaultReaperSettings - { reaperEmpty = Q.empty - , reaperCons = cons maxsiz - , reaperAction = clean - , reaperNull = Q.null - , reaperDelay = pruningDelay conf * 1000000 - , reaperThreadName = "TLS session manager" - } - return $ - noSessionManager - { sessionResume = resume reaper MultipleUse - , sessionResumeOnlyOnce = resume reaper SingleUse - , sessionEstablish = \x y -> establish reaper lifetime x y >> return Nothing - , sessionInvalidate = invalidate reaper - , sessionUseTicket = False - } - -cons :: Int -> Item -> DB -> DB -cons lim (k, t, v, Add) db - | lim <= 0 = Q.empty - | Q.size db == lim = case Q.minView db of - Nothing -> assert False $ Q.insert k t v Q.empty - Just (_, _, _, db') -> Q.insert k t v db' - | otherwise = Q.insert k t v db -cons _ (k, _, _, Del) db = Q.delete k db - -clean :: DB -> IO (DB -> DB) -clean olddb = do - currentTime <- C.sec <$> C.getTime C.Monotonic - let pruned = snd $ Q.atMostView currentTime olddb - return $ merge pruned - where - ins db (k, p, v) = Q.insert k p v db - -- There is not 'merge' API. - -- We hope that newdb is smaller than pruned. - merge pruned newdb = foldl' ins pruned entries - where - entries = Q.toList newdb - ----------------------------------------------------------------- - -establish - :: Reaper DB Item - -> Sec - -> SessionID - -> SessionData - -> IO () -establish reaper lifetime k sd = do - ref <- newIORef Fresh - p <- (+ lifetime) . C.sec <$> C.getTime C.Monotonic - let v = (sd', ref) - reaperAdd reaper (k', p, v, Add) - where - k' = toKey k - sd' = toValue sd - -resume - :: Reaper DB Item - -> Use - -> SessionID - -> IO (Maybe SessionData) -resume reaper use k = do - db <- reaperRead reaper - case Q.lookup k' db of - Nothing -> return Nothing - Just (p, v@(sd, ref)) -> - case use of - SingleUse -> do - available <- atomicModifyIORef' ref check - reaperAdd reaper (k', p, v, Del) - return $ if available then Just (fromValue sd) else Nothing - MultipleUse -> return $ Just (fromValue sd) - where - check Fresh = (Used, True) - check Used = (Used, False) - k' = toKey k - -invalidate - :: Reaper DB Item - -> SessionID - -> IO () -invalidate reaper k = do - db <- reaperRead reaper - case Q.lookup k' db of - Nothing -> return () - Just (p, v) -> reaperAdd reaper (k', p, v, Del) - where - k' = toKey k +import Network.TLS.SessionManager.Internal diff --git a/Network/TLS/SessionManager/Internal.hs b/Network/TLS/SessionManager/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/SessionManager/Internal.hs @@ -0,0 +1,187 @@ +-- | The implementation of "Network.TLS.SessionManager", exposed for +-- testing. This module may change without notice. +module Network.TLS.SessionManager.Internal where + +import Control.Exception (assert) +import Control.Reaper +import Data.ByteArray (convert) +import Data.ByteString (ByteString) +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as SBS +import Data.IORef +import Data.OrdPSQ (OrdPSQ) +import qualified Data.OrdPSQ as Q +import Network.TLS +import qualified Network.TLS.Internal as I +import qualified System.Clock as C + +import Network.TLS.Imports + +---------------------------------------------------------------- + +-- | Configuration for session managers. +data Config = Config + { ticketLifetime :: Int + -- ^ Ticket lifetime in seconds. It should match 'serverTicketLifetime' + -- on a server. A TLS 1.3 session is kept no longer than the lifetime of + -- its ticket. + , pruningDelay :: Int + -- ^ Pruning delay in seconds. This is set to 'reaperDelay'. + , dbMaxSize :: Int + -- ^ The limit size of session data entries. + } + +-- | ticketLifetime: 2 hours (7200 seconds), pruningDelay: 10 minutes (600 seconds), dbMaxSize: 1000 entries. +defaultConfig :: Config +defaultConfig = + Config + { ticketLifetime = 7200 + , pruningDelay = 600 + , dbMaxSize = 1000 + } + +---------------------------------------------------------------- + +toKey :: ByteString -> SessionIDCopy +toKey = SBS.toShort + +toValue :: SessionData -> SessionDataCopy +toValue sd = + SessionDataCopy $ + sd + { sessionSecret = convert $ sessionSecret sd + , sessionALPN = convert <$> sessionALPN sd + } + +fromValue :: SessionDataCopy -> SessionData +fromValue (SessionDataCopy sd) = + sd + { sessionSecret = convert $ sessionSecret sd + , sessionALPN = convert <$> sessionALPN sd + } + +---------------------------------------------------------------- + +type SessionIDCopy = ShortByteString +newtype SessionDataCopy = SessionDataCopy SessionData + deriving (Show, Eq) + +type Sec = Int64 +type Value = (SessionDataCopy, IORef Availability) +type Sessions = OrdPSQ SessionIDCopy Sec Value + +-- | The sessions, and the keys deleted since the reaper last took them away +-- to prune. While it prunes, the workload left in their place is empty, so +-- a deletion there is kept to be applied to the pruned sessions too. +data DB = DB Sessions [SessionIDCopy] + +data Item = Add SessionIDCopy Sec Value | Del SessionIDCopy + +data Use = SingleUse | MultipleUse +data Availability = Fresh | Used + +---------------------------------------------------------------- + +-- | Creating an in-memory session manager. +newSessionManager :: Config -> IO SessionManager +newSessionManager conf = do + let lifetime = fromIntegral $ ticketLifetime conf + maxsiz = dbMaxSize conf + reaper <- + mkReaper + defaultReaperSettings + { reaperEmpty = DB Q.empty [] + , reaperCons = cons maxsiz + , reaperAction = clean maxsiz + , reaperNull = \(DB q _) -> Q.null q + , reaperDelay = pruningDelay conf * 1000000 + , reaperThreadName = "TLS session manager" + } + return $ + noSessionManager + { sessionResume = resume reaper MultipleUse + , sessionResumeOnlyOnce = resume reaper SingleUse + , sessionEstablish = \x y -> establish reaper lifetime x y >> return Nothing + , sessionInvalidate = invalidate reaper + , sessionUseTicket = False + } + +cons :: Int -> Item -> DB -> DB +cons lim (Add k t v) (DB q ds) + | lim <= 0 = DB Q.empty ds + -- Replacing a session makes no room for it. + | Q.size q == lim && not (Q.member k q) = case Q.minView q of + Nothing -> assert False $ DB (Q.insert k t v Q.empty) ds + Just (_, _, _, q') -> DB (Q.insert k t v q') ds + | otherwise = DB (Q.insert k t v q) ds +-- At most as many keys as there can be sessions are kept. +cons lim (Del k) (DB q ds) = DB (Q.delete k q) (take lim (k : ds)) + +clean :: Int -> DB -> IO (DB -> DB) +clean lim (DB oldq _) = do + currentTime <- C.sec <$> C.getTime C.Monotonic + let pruned = snd $ Q.atMostView currentTime oldq + return $ merge pruned + where + ins q (k, p, v) = Q.insert k p v q + -- There is not 'merge' API. + -- We hope that the new sessions are fewer than the pruned ones. + merge pruned (DB newq ds) = DB (limit $ foldl' ins (foldr Q.delete pruned ds) entries) [] + where + entries = Q.toList newq + -- The size was checked against the new sessions alone. + limit q + | lim <= 0 = Q.empty + | Q.size q > lim = maybe q (\(_, _, _, q') -> limit q') $ Q.minView q + | otherwise = q + +---------------------------------------------------------------- + +establish + :: Reaper DB Item + -> Sec + -> SessionID + -> SessionData + -> IO () +establish reaper lifetime k sd = do + ref <- newIORef Fresh + p <- (+ lifetime') . C.sec <$> C.getTime C.Monotonic + let v = (sd', ref) + reaperAdd reaper (Add k' p v) + where + k' = toKey k + sd' = toValue sd + -- A TLS 1.3 ticket is not kept past the lifetime the server gave it. + lifetime' = case sessionTicketInfo sd of + Just tinfo -> min lifetime (fromIntegral (I.lifetime tinfo)) + Nothing -> lifetime + +resume + :: Reaper DB Item + -> Use + -> SessionID + -> IO (Maybe SessionData) +resume reaper use k = do + DB q _ <- reaperRead reaper + now <- C.sec <$> C.getTime C.Monotonic + case Q.lookup k' q of + -- An expired session stays until the next pruning; it is not used. + Just (p, (sd, ref)) + | p > now -> case use of + SingleUse -> do + available <- atomicModifyIORef' ref check + reaperAdd reaper (Del k') + return $ if available then Just (fromValue sd) else Nothing + MultipleUse -> return $ Just (fromValue sd) + _ -> return Nothing + where + check Fresh = (Used, True) + check Used = (Used, False) + k' = toKey k + +invalidate + :: Reaper DB Item + -> SessionID + -> IO () +-- Not looked up first: while the reaper prunes, the session is not seen. +invalidate reaper k = reaperAdd reaper (Del (toKey k)) diff --git a/Network/TLS/SessionTicket.hs b/Network/TLS/SessionTicket.hs --- a/Network/TLS/SessionTicket.hs +++ b/Network/TLS/SessionTicket.hs @@ -28,8 +28,12 @@ -- | Configuration for session tickets. data Config = Config { ticketLifetime :: Int - -- ^ Ticket lifetime in seconds. + -- ^ Ticket lifetime in seconds. It should match the lifetime the + -- server announces, 'serverTicketLifetime'. As the secret keys are + -- replaced every 'secretKeyInterval', a ticket is accepted for up to + -- one interval less. , secretKeyInterval :: Int + -- ^ The interval to replace the secret key in seconds. } -- | ticketLifetime: 2 hours (7200 seconds), secretKeyInterval: 30 minutes (1800 seconds) @@ -37,7 +41,7 @@ defaultConfig = Config { ticketLifetime = 7200 -- 2 hours - , secretKeyInterval = 1800 -- 30 minites + , secretKeyInterval = 1800 -- 30 minutes } -- | Creating a session ticket manager. diff --git a/test/SessionManagerSpec.hs b/test/SessionManagerSpec.hs new file mode 100644 --- /dev/null +++ b/test/SessionManagerSpec.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SessionManagerSpec where + +import Control.Concurrent (threadDelay) +import Data.IORef +import Data.Maybe (isJust, isNothing) +import qualified Data.OrdPSQ as Q +import Network.TLS +import Network.TLS.Internal (Second, SessionData (..), TLS13TicketInfo (..)) +import Network.TLS.SessionManager +import Network.TLS.SessionManager.Internal ( + Availability (..), + DB (..), + Item (..), + clean, + cons, + toValue, + ) +import Test.Hspec + +spec :: Spec +spec = do + describe "newSessionManager" $ do + it "keeps a TLS 1.3 session no longer than its ticket lifetime" $ do + mgr <- newSessionManager defaultConfig + _ <- sessionEstablish mgr "short" $ sessionData (Just 1) + _ <- sessionEstablish mgr "none" $ sessionData Nothing + threadDelay 2000000 + sessionResume mgr "short" >>= (`shouldSatisfy` isNothing) + sessionResume mgr "none" >>= (`shouldSatisfy` isJust) + it "does not resume an expired session before it is pruned" $ do + mgr <- newSessionManager defaultConfig{ticketLifetime = 1} + _ <- sessionEstablish mgr "expired" $ sessionData Nothing + threadDelay 2000000 + sessionResume mgr "expired" >>= (`shouldSatisfy` isNothing) + it "keeps the other session when a key is added again at the limit" $ do + mgr <- newSessionManager defaultConfig{dbMaxSize = 2} + -- "a" comes first both by expiry and by key, so it would be the + -- one dropped for room + _ <- sessionEstablish mgr "a" $ sessionData (Just 1800) + _ <- sessionEstablish mgr "b" $ sessionData (Just 3600) + _ <- sessionEstablish mgr "b" $ sessionData (Just 3600) + sessionResume mgr "a" >>= (`shouldSatisfy` isJust) + it "does not resume an invalidated session" $ do + mgr <- newSessionManager defaultConfig + _ <- sessionEstablish mgr "a" $ sessionData Nothing + sessionInvalidate mgr "a" + sessionResume mgr "a" >>= (`shouldSatisfy` isNothing) + it "resumes a session only once for 0-RTT" $ do + mgr <- newSessionManager defaultConfig + _ <- sessionEstablish mgr "a" $ sessionData Nothing + sessionResumeOnlyOnce mgr "a" >>= (`shouldSatisfy` isJust) + sessionResumeOnlyOnce mgr "a" >>= (`shouldSatisfy` isNothing) + -- While the reaper prunes, the sessions are taken away and an empty + -- workload is left in their place; the pruned ones are merged back. + describe "pruning" $ do + it "keeps a deletion made while pruning" $ do + v <- value + merge <- clean 2 $ foldr (cons 2) (DB Q.empty []) [Add "a" far v, Add "b" far v] + let DB q _ = merge $ cons 2 (Del "a") (DB Q.empty []) + Q.member "a" q `shouldBe` False + Q.member "b" q `shouldBe` True + it "keeps the size limit when merging" $ do + v <- value + merge <- clean 2 $ foldr (cons 2) (DB Q.empty []) [Add "a" far v, Add "b" far v] + let DB q _ = merge $ cons 2 (Add "c" far v) (DB Q.empty []) + Q.size q `shouldBe` 2 + where + far = maxBound `div` 2 + value = do + ref <- newIORef Fresh + return (toValue (sessionData Nothing), ref) + +-- | Session data with a TLS 1.3 ticket of the given lifetime, if any. +sessionData :: Maybe Second -> SessionData +sessionData life = + SessionData + { sessionVersion = TLS13 + , sessionCipher = 0x1301 + , sessionCompression = 0 + , sessionClientSNI = Nothing + , sessionSecret = "secret" + , sessionGroup = Nothing + , sessionTicketInfo = ticketInfo <$> life + , sessionALPN = Nothing + , sessionMaxEarlyDataSize = 0 + , sessionFlags = [] + } + where + ticketInfo l = + TLS13TicketInfo{lifetime = l, ageAdd = 0, txrxTime = 0, estimatedRTT = Nothing} diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tls-session-manager.cabal b/tls-session-manager.cabal --- a/tls-session-manager.cabal +++ b/tls-session-manager.cabal @@ -1,6 +1,6 @@ -cabal-version: >=1.10 +cabal-version: 2.0 name: tls-session-manager -version: 0.1.0 +version: 0.1.1 license: BSD3 license-file: LICENSE maintainer: kazu@iij.ad.jp @@ -15,6 +15,7 @@ library exposed-modules: Network.TLS.SessionManager + Network.TLS.SessionManager.Internal Network.TLS.SessionTicket other-modules: Network.TLS.Imports default-language: Haskell2010 @@ -28,7 +29,22 @@ psqueues >= 0.2 && < 0.3, ram, serialise >= 0.2 && < 0.3, - tls >= 2.3 && < 2.4 + tls >= 2.3 && < 2.6 if impl(ghc >=8) default-extensions: Strict StrictData + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: SessionManagerSpec + default-language: Haskell2010 + ghc-options: -Wall -threaded + build-tool-depends: hspec-discover:hspec-discover + build-depends: + base >=4.7 && <5, + hspec, + psqueues, + tls, + tls-session-manager