diff --git a/Network/TLS/Imports.hs b/Network/TLS/Imports.hs --- a/Network/TLS/Imports.hs +++ b/Network/TLS/Imports.hs @@ -1,12 +1,12 @@ module Network.TLS.Imports ( - module Control.Applicative - , module Control.Monad - , module Data.Int - , module Data.List - , module Data.Maybe - , module Data.Monoid - , module Data.Word - ) where + module Control.Applicative, + module Control.Monad, + module Data.Int, + module Data.List, + module Data.Maybe, + module Data.Monoid, + module Data.Word, +) where import Control.Applicative import Control.Monad diff --git a/Network/TLS/SessionManager.hs b/Network/TLS/SessionManager.hs --- a/Network/TLS/SessionManager.hs +++ b/Network/TLS/SessionManager.hs @@ -1,31 +1,27 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} - --- | In-memory TLS session manager. +-- | In-memory TLS 1.2/1.3 session manager. -- -- * 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: each session data is used at most once to prevent replay attacks against 0RTT early data of TLS 1.3. module Network.TLS.SessionManager ( - Config(..) - , defaultConfig - , newSessionManager - ) where + newSessionManager, + Config, + defaultConfig, + ticketLifetime, + pruningDelay, + dbMaxSize, +) where import Basement.Block (Block) -import Data.ByteArray (convert) import Control.Exception (assert) import Control.Reaper +import Data.ByteArray (convert) import Data.ByteString (ByteString) import Data.IORef import Data.OrdPSQ (OrdPSQ) import qualified Data.OrdPSQ as Q import Network.TLS -#if !MIN_VERSION_tls(1,5,0) -import Network.TLS.Compression -#endif import qualified System.Clock as C import Network.TLS.Imports @@ -33,22 +29,23 @@ ---------------------------------------------------------------- -- | Configuration for session managers. -data Config = Config { - -- | Ticket lifetime in seconds. - ticketLifetime :: !Int - -- | Pruning delay in seconds. This is set to 'reaperDelay'. - , pruningDelay :: !Int - -- | The limit size of session data entries. - , dbMaxSize :: !Int +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. } --- | Lifetime: 1 day , delay: 10 minutes, max size: 1000 entries. +-- | ticketLifetime: 2 hours (7200 seconds), pruningDelay: 10 minutes (600 seconds), dbMaxSize: 1000 entries. defaultConfig :: Config -defaultConfig = Config { - ticketLifetime = 86400 - , pruningDelay = 6000 - , dbMaxSize = 1000 - } +defaultConfig = + Config + { ticketLifetime = 7200 + , pruningDelay = 600 + , dbMaxSize = 1000 + } ---------------------------------------------------------------- @@ -56,62 +53,35 @@ toKey = convert toValue :: SessionData -> SessionDataCopy -#if MIN_VERSION_tls(1,5,0) -#if MIN_VERSION_tls(1,5,3) toValue (SessionData v cid comp msni sec mg mti malpn siz flg) = SessionDataCopy v cid comp msni sec' mg mti malpn' siz flg -#else -toValue (SessionData v cid comp msni sec mg mti malpn siz) = - SessionDataCopy v cid comp msni sec' mg mti malpn' siz -#endif where - !sec' = convert sec - !malpn' = convert <$> malpn -#else -toValue (SessionData v cid comp msni sec) = - SessionDataCopy v cid comp msni sec' - where - !sec' = convert sec -#endif + sec' = convert sec + malpn' = convert <$> malpn fromValue :: SessionDataCopy -> SessionData -#if MIN_VERSION_tls(1,5,0) -#if MIN_VERSION_tls(1,5,3) fromValue (SessionDataCopy v cid comp msni sec' mg mti malpn' siz flg) = SessionData v cid comp msni sec mg mti malpn siz flg -#else -fromValue (SessionDataCopy v cid comp msni sec' mg mti malpn' siz) = - SessionData v cid comp msni sec mg mti malpn siz -#endif where - !sec = convert sec' - !malpn = convert <$> malpn' -#else -fromValue (SessionDataCopy v cid comp msni sec') = - SessionData v cid comp msni sec - where - !sec = convert sec' -#endif + sec = convert sec' + malpn = convert <$> malpn' ---------------------------------------------------------------- type SessionIDCopy = Block Word8 -data SessionDataCopy = SessionDataCopy - {- ssVersion -} !Version - {- ssCipher -} !CipherID - {- ssCompression -} !CompressionID - {- ssClientSNI -} !(Maybe HostName) - {- ssSecret -} (Block Word8) -#if MIN_VERSION_tls(1,5,0) - {- ssGroup -} !(Maybe Group) - {- ssTicketInfo -} !(Maybe TLS13TicketInfo) - {- ssALPN -} !(Maybe (Block Word8)) - {- ssMaxEarlyDataSize -} Int -#endif -#if MIN_VERSION_tls(1,5,3) - {- ssFlags -} [SessionFlag] -#endif - deriving (Show,Eq) +data SessionDataCopy + = SessionDataCopy + {- ssVersion -} Version + {- ssCipher -} CipherID + {- ssCompression -} CompressionID + {- ssClientSNI -} (Maybe HostName) + {- ssSecret -} (Block Word8) + {- ssGroup -} (Maybe Group) + {- ssTicketInfo -} (Maybe TLS13TicketInfo) + {- ssALPN -} (Maybe (Block Word8)) + {- ssMaxEarlyDataSize -} Int + {- ssFlags -} [SessionFlag] + deriving (Show, Eq) type Sec = Int64 type Value = (SessionDataCopy, IORef Availability) @@ -129,39 +99,40 @@ 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 - } - return SessionManager { - sessionResume = resume reaper MultipleUse -#if MIN_VERSION_tls(1,5,0) - , sessionResumeOnlyOnce = resume reaper SingleUse -#endif - , sessionEstablish = establish reaper lifetime - , sessionInvalidate = invalidate reaper - - } + reaper <- + mkReaper + defaultReaperSettings + { reaperEmpty = Q.empty + , reaperCons = cons maxsiz + , reaperAction = clean + , reaperNull = Q.null + , reaperDelay = pruningDelay conf * 1000000 + } + return + SessionManager + { 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 +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 + let pruned = snd $ Q.atMostView currentTime olddb return $ merge pruned where - ins db (k,p,v) = Q.insert k p v db + 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 @@ -170,41 +141,50 @@ ---------------------------------------------------------------- -establish :: Reaper DB Item -> Sec - -> SessionID -> SessionData -> IO () +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) + 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 + k' = toKey k + sd' = toValue sd -resume :: Reaper DB Item -> Use - -> SessionID -> IO (Maybe SessionData) +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) + 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 + check Fresh = (Used, True) + check Used = (Used, False) + k' = toKey k -invalidate :: Reaper DB Item - -> SessionID -> IO () +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) + Nothing -> return () + Just (p, v) -> reaperAdd reaper (k', p, v, Del) where - !k' = toKey k + k' = toKey k diff --git a/Network/TLS/SessionTicket.hs b/Network/TLS/SessionTicket.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/SessionTicket.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | A manager for TLS 1.2/1.3 session ticket. +-- +-- Tracking client hello is not implemented yet. +-- So, if this is used for TLS 1.3 0-RTT, +-- replay attack is possible. +-- If your application data in 0-RTT changes the status of server side, +-- use 'Network.TLS.SessionManager' instead. +-- +-- A dedicated thread is running repeatedly to replece +-- secret keys. So, energy saving is not achieved. +module Network.TLS.SessionTicket ( + newSessionTicketManager, + Config, + defaultConfig, + ticketLifetime, + secretKeyInterval, +) where + +import Codec.Serialise +import qualified Crypto.Token as CT +import qualified Data.ByteString.Lazy as L +import Network.TLS +import Network.TLS.Internal + +-- | Configuration for session tickets. +data Config = Config + { ticketLifetime :: Int + -- ^ Ticket lifetime in seconds. + , secretKeyInterval :: Int + } + +-- | ticketLifetime: 2 hours (7200 seconds), secretKeyInterval: 30 minutes (1800 seconds) +defaultConfig :: Config +defaultConfig = + Config + { ticketLifetime = 7200 -- 2 hours + , secretKeyInterval = 1800 -- 30 minites + } + +-- | Creating a session ticket manager. +newSessionTicketManager :: Config -> IO SessionManager +newSessionTicketManager Config{..} = + sessionTicketManager <$> CT.spawnTokenManager conf + where + conf = + CT.defaultConfig + { CT.interval = secretKeyInterval + , CT.tokenLifetime = ticketLifetime + } + +sessionTicketManager :: CT.TokenManager -> SessionManager +sessionTicketManager ctmgr = + SessionManager + { sessionResume = resume ctmgr + , sessionResumeOnlyOnce = resume ctmgr + , sessionEstablish = establish ctmgr + , sessionInvalidate = \_ -> return () + , sessionUseTicket = True + } + +establish :: CT.TokenManager -> SessionID -> SessionData -> IO (Maybe Ticket) +establish ctmgr _ sd = Just <$> CT.encryptToken ctmgr b + where + b = L.toStrict $ serialise sd + +resume :: CT.TokenManager -> Ticket -> IO (Maybe SessionData) +resume ctmgr ticket + | isTicket ticket = do + msdb <- CT.decryptToken ctmgr ticket + case msdb of + Nothing -> return Nothing + Just sdb -> case deserialiseOrFail $ L.fromStrict sdb of + Left _ -> return Nothing + Right sd -> return $ Just sd + | otherwise = return Nothing diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/tls-session-manager.cabal b/tls-session-manager.cabal --- a/tls-session-manager.cabal +++ b/tls-session-manager.cabal @@ -1,31 +1,35 @@ -name: tls-session-manager -version: 0.0.4 -synopsis: In-memory TLS session manager -description: TLS session manager with limitation, automatic pruning, energy saving and replay resistance -license: BSD3 -license-file: LICENSE -author: Kazu Yamamoto -maintainer: kazu@iij.ad.jp --- copyright: -category: Web -build-type: Simple -extra-source-files: ChangeLog.md -cabal-version: >= 1.10 +cabal-version: >=1.10 +name: tls-session-manager +version: 0.0.5 +license: BSD3 +license-file: LICENSE +maintainer: kazu@iij.ad.jp +author: Kazu Yamamoto +synopsis: In-memory TLS session DB and session ticket +description: + TLS session manager with limitation, automatic pruning, energy saving and replay resistance and session ticket manager +category: Web +build-type: Simple +extra-source-files: ChangeLog.md + library - exposed-modules: Network.TLS.SessionManager - other-modules: Network.TLS.Imports - -- other-extensions: - build-depends: base >= 4.7 && < 5 - , auto-update - , basement - , bytestring - , clock - , memory - , psqueues >= 0.2.3 - , tls - -- hs-source-dirs: - default-language: Haskell2010 - ghc-options: -Wall - if impl(ghc >= 8) - default-extensions: Strict StrictData + exposed-modules: Network.TLS.SessionManager + Network.TLS.SessionTicket + other-modules: Network.TLS.Imports + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.7 && <5, + auto-update >= 0.1 && < 0.2, + basement >= 0.0.16 && < 0.1, + bytestring >= 0.10 && < 0.12, + clock >= 0.8 && < 0.9, + crypto-token >= 0.1.1 && < 0.2, + memory >= 0.18.0 && < 0.19, + psqueues >= 0.2 && < 0.3, + serialise >= 0.2 && < 0.3, + tls >= 2.0 && < 2.1 + + if impl(ghc >=8) + default-extensions: Strict StrictData