@@ -0,0 +1,127 @@
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+-- * Replay resistance: each session data is used at most once to prevent replay attacks.
8+-- * Energy saving: no dedicate pruning thread is running when the size of session database is zero.
9+
10+module Network.TLS.SessionManager (
11+ Config(..)
12+ , defaultConfig
13+ , newSessionManager
14+ ) where
15+
16+import Control.Reaper
17+import Data.IORef
18+import Data.List (foldl')
19+import Data.OrdPSQ (OrdPSQ)
20+import qualified Data.OrdPSQ as Q
21+import Data.Time (UTCTime, NominalDiffTime, getCurrentTime, addUTCTime)
22+import Network.TLS (SessionID, SessionData, SessionManager(..))
23+
24+----------------------------------------------------------------
25+
26+-- | Configuration for session managers.
27+data Config = Config {
28+ -- | Ticket lifetime in seconds.
29+ ticketLifetime :: !Int
30+ -- | Pruning delay in seconds. This is set to 'reaperDelay'.
31+ , pruningDelay :: !Int
32+ -- | The limit size of session data entries.
33+ , dbMaxSize :: !Int
34+ }
35+
36+-- | Lifetime: 1 day , delay: 10 minutes, limit: 10,000 entries.
37+defaultConfig :: Config
38+defaultConfig = Config {
39+ ticketLifetime = 86400
40+ , pruningDelay = 6000
41+ , dbMaxSize = 10000
42+ }
43+
44+----------------------------------------------------------------
45+
46+type Value = (SessionData, IORef Availability)
47+type DB = OrdPSQ SessionID UTCTime Value
48+type Item = (SessionID, UTCTime, Value, Operation)
49+
50+data Operation = Add | Del
51+data Availability = Fresh | Used
52+
53+----------------------------------------------------------------
54+
55+-- | Creating a in-memory session manager.
56+newSessionManager :: Config -> IO SessionManager
57+newSessionManager conf = do
58+ let lifetime = fromIntegral $ ticketLifetime conf
59+ maxsiz = dbMaxSize conf
60+ reaper <- mkReaper defaultReaperSettings {
61+ reaperEmpty = Q.empty
62+ , reaperCons = cons maxsiz
63+ , reaperAction = clean
64+ , reaperNull = Q.null
65+ , reaperDelay = pruningDelay conf * 1000000
66+ }
67+ return SessionManager {
68+ sessionResume = resume reaper
69+ , sessionEstablish = establish reaper lifetime
70+ , sessionInvalidate = invalidate reaper
71+ }
72+
73+cons :: Int -> Item -> DB -> DB
74+cons lim (k,t,v,Add) db
75+ | Q.size db == lim = case Q.minView db of
76+ Nothing -> Q.insert k t v Q.empty -- not happens, just in case
77+ Just (_,_,_,db') -> Q.insert k t v db'
78+ | otherwise = Q.insert k t v db
79+cons _ (k,_,_,Del) db = Q.delete k db
80+
81+clean :: DB -> IO (DB -> DB)
82+clean olddb = do
83+ currentTime <- getCurrentTime
84+ let !pruned = snd $ Q.atMostView currentTime olddb
85+ return $ merge pruned
86+ where
87+ ins db (k,p,v) = Q.insert k p v db
88+ -- There is not 'merge' API.
89+ -- We hope that newdb is smaller than pruned.
90+ merge pruned newdb = foldl' ins pruned entries
91+ where
92+ entries = Q.toList newdb
93+
94+----------------------------------------------------------------
95+
96+establish :: Reaper DB Item -> NominalDiffTime
97+ -> SessionID -> SessionData -> IO ()
98+establish reaper lifetime k sd = do
99+ ref <- newIORef Fresh
100+ !p <- addUTCTime lifetime <$> getCurrentTime
101+ let !v = (sd,ref)
102+ reaperAdd reaper (k,p,v,Add)
103+
104+resume :: Reaper DB Item
105+ -> SessionID -> IO (Maybe SessionData)
106+resume reaper k = do
107+ db <- reaperRead reaper
108+ case Q.lookup k db of
109+ Nothing -> return Nothing
110+ Just (p,v@(sd,ref)) -> do
111+ available <- atomicModifyIORef' ref check
112+ reaperAdd reaper (k,p,v,Del)
113+ return $ if available then Just sd else Nothing
114+ where
115+ check Fresh = (Used,True)
116+ check Used = (Used,False)
117+
118+invalidate :: Reaper DB Item
119+ -> SessionID -> IO ()
120+invalidate reaper k = do
121+ -- repaerDelete does not exist
122+ -- So, let's set the entry used and hope that it will be
123+ -- cleaned in the future.
124+ db <- reaperRead reaper
125+ case Q.lookup k db of
126+ Nothing -> return ()
127+ Just (_,(_,ref)) -> atomicModifyIORef' ref $ \_ -> (Used, ())