@@ -0,0 +1,132 @@
1+{-# LANGUAGE BangPatterns #-}
2+
3+-- | In-memory TLS session manager.
4+--
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.)
9+
10+module Network.TLS.SessionManager (
11+ Config(..)
12+ , defaultConfig
13+ , newSessionManager
14+ ) where
15+
16+import Control.Exception (assert)
17+import Control.Reaper
18+import Data.IORef
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
25+
26+----------------------------------------------------------------
27+
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.
35+ , dbMaxSize :: !Int
36+ }
37+
38+-- | Lifetime: 1 day , delay: 10 minutes, limit: 10,000 entries.
39+defaultConfig :: Config
40+defaultConfig = Config {
41+ ticketLifetime = 86400
42+ , pruningDelay = 6000
43+ , dbMaxSize = 10000
44+ }
45+
46+----------------------------------------------------------------
47+
48+type Sec = Int64
49+type Value = (SessionData, IORef Availability)
50+type DB = OrdPSQ SessionID Sec Value
51+type Item = (SessionID, Sec, Value, Operation)
52+
53+data Operation = Add | Del
54+data Use = SingleUse | MultipleUse
55+data Availability = Fresh | Used
56+
57+----------------------------------------------------------------
58+
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
70+ }
71+ return SessionManager {
72+ sessionResume = resume reaper MultipleUse
73+ , sessionEstablish = establish reaper lifetime
74+ , sessionInvalidate = invalidate reaper
75+ }
76+
77+cons :: Int -> Item -> DB -> DB
78+cons lim (k,t,v,Add) db
79+ | lim <= 0 = Q.empty
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
85+
86+clean :: DB -> IO (DB -> DB)
87+clean olddb = do
88+ currentTime <- C.sec <$> C.getTime C.Monotonic
89+ let !pruned = snd $ Q.atMostView currentTime olddb
90+ return $ merge pruned
91+ where
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
96+ where
97+ entries = Q.toList newdb
98+
99+----------------------------------------------------------------
100+
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
106+ let !v = (sd,ref)
107+ reaperAdd reaper (k,p,v,Add)
108+
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
116+ case use of
117+ SingleUse -> 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
122+ where
123+ check Fresh = (Used,True)
124+ check Used = (Used,False)
125+
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)