@@ -0,0 +1,132 @@
1+{-# LANGUAGE BangPatterns #-}
3+-- | In-memory TLS session manager.
5+-- * Limitation: you can set the maximum size of the session data database.
6+-- * Automatic pruning: old session data over their lifetime are pruned automatically.
7+-- * Energy saving: no dedicate pruning thread is running when the size of session data database is zero.
8+-- * (Replay resistance: each session data is used at most once to prevent replay attacks against 0RTT early data of TLS 1.3.)
10+module Network.TLS.SessionManager (
16+import Control.Exception (assert)
19+import Data.Int (Int64)
20+import Data.List (foldl')
21+import Data.OrdPSQ (OrdPSQ)
22+import qualified Data.OrdPSQ as Q
23+import Network.TLS (SessionID, SessionData, SessionManager(..))
24+import qualified System.Clock as C
26+----------------------------------------------------------------
28+-- | Configuration for session managers.
29+data Config = Config {
30+ -- | Ticket lifetime in seconds.
31+ ticketLifetime :: !Int
32+ -- | Pruning delay in seconds. This is set to 'reaperDelay'.
33+ , pruningDelay :: !Int
34+ -- | The limit size of session data entries.
38+-- | Lifetime: 1 day , delay: 10 minutes, limit: 10,000 entries.
39+defaultConfig :: Config
40+defaultConfig = Config {
41+ ticketLifetime = 86400
42+ , pruningDelay = 6000
46+----------------------------------------------------------------
49+type Value = (SessionData, IORef Availability)
50+type DB = OrdPSQ SessionID Sec Value
51+type Item = (SessionID, Sec, Value, Operation)
53+data Operation = Add | Del
54+data Use = SingleUse | MultipleUse
55+data Availability = Fresh | Used
57+----------------------------------------------------------------
59+-- | Creating an in-memory session manager.
60+newSessionManager :: Config -> IO SessionManager
61+newSessionManager conf = do
62+ let lifetime = fromIntegral $ ticketLifetime conf
63+ maxsiz = dbMaxSize conf
64+ reaper <- mkReaper defaultReaperSettings {
65+ reaperEmpty = Q.empty
66+ , reaperCons = cons maxsiz
67+ , reaperAction = clean
68+ , reaperNull = Q.null
69+ , reaperDelay = pruningDelay conf * 1000000
71+ return SessionManager {
72+ sessionResume = resume reaper MultipleUse
73+ , sessionEstablish = establish reaper lifetime
74+ , sessionInvalidate = invalidate reaper
77+cons :: Int -> Item -> DB -> DB
78+cons lim (k,t,v,Add) db
80+ | Q.size db == lim = case Q.minView db of
81+ Nothing -> assert False $ Q.insert k t v Q.empty
82+ Just (_,_,_,db') -> Q.insert k t v db'
83+ | otherwise = Q.insert k t v db
84+cons _ (k,_,_,Del) db = Q.delete k db
86+clean :: DB -> IO (DB -> DB)
88+ currentTime <- C.sec <$> C.getTime C.Monotonic
89+ let !pruned = snd $ Q.atMostView currentTime olddb
90+ return $ merge pruned
92+ ins db (k,p,v) = Q.insert k p v db
93+ -- There is not 'merge' API.
94+ -- We hope that newdb is smaller than pruned.
95+ merge pruned newdb = foldl' ins pruned entries
97+ entries = Q.toList newdb
99+----------------------------------------------------------------
101+establish :: Reaper DB Item -> Sec
102+ -> SessionID -> SessionData -> IO ()
103+establish reaper lifetime k sd = do
104+ ref <- newIORef Fresh
105+ !p <- ((+ lifetime) . C.sec) <$> C.getTime C.Monotonic
107+ reaperAdd reaper (k,p,v,Add)
109+resume :: Reaper DB Item -> Use
110+ -> SessionID -> IO (Maybe SessionData)
111+resume reaper use k = do
112+ db <- reaperRead reaper
113+ case Q.lookup k db of
114+ Nothing -> return Nothing
115+ Just (p,v@(sd,ref)) -> do
118+ available <- atomicModifyIORef' ref check
119+ reaperAdd reaper (k,p,v,Del)
120+ return $ if available then Just sd else Nothing
121+ MultipleUse -> return $ Just sd
123+ check Fresh = (Used,True)
124+ check Used = (Used,False)
126+invalidate :: Reaper DB Item
127+ -> SessionID -> IO ()
128+invalidate reaper k = do
129+ db <- reaperRead reaper
130+ case Q.lookup k db of
131+ Nothing -> return ()
132+ Just (p,v) -> reaperAdd reaper (k,p,v,Del)