ClientSessionManager.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 module ClientSessionManager
  12     ( clientSessionManager
  13     , ClientSessions
  14     , newClientSessions
  15     , lookupClientSession
  16     ) where
  17
  18 import           Control.Concurrent
  19 import           Data.Map           (fromAscList, toAscList)
  20 import           Network.TLS
  21
  22 import           Data.Hourglass     (timeAdd)
  23 import           Time.System        (timeCurrent)
  24 import           Time.Types         (Elapsed (..), Seconds (..))
  25
  26 import qualified Data.Map           as Map
  27
  28 import           Fingerprint
  29
  30 type ClientSessions = MVar (Map.Map (HostName, Maybe Fingerprint) (Elapsed, (SessionID, SessionData)))
  31
  32 newClientSessions :: IO ClientSessions
  33 newClientSessions = newMVar Map.empty
  34
  35 clientSessionManager :: Int -> ClientSessions -> Maybe Fingerprint -> SessionManager
  36 clientSessionManager lifetime sess fp = SessionManager
  37     (\_ -> return Nothing)
  38     (\_ -> return Nothing)
  39     insert
  40     delete
  41     True
  42     where
  43     insert sid sd@SessionData{ sessionClientSNI = Just sni } = do
  44         now <- timeCurrent
  45         let expire = now `timeAdd` Seconds (fromIntegral lifetime)
  46         modifyMVar_ sess $ return .
  47             Map.insert (sni, fp) (expire,(sid,sd)) .
  48             fromAscList . filter (\(_,(t,(_,_))) -> t >= now) . toAscList
  49         return Nothing
  50     insert _ _ = return Nothing
  51     delete sid =
  52         modifyMVar_ sess $ return .
  53             fromAscList . filter (\(_,(_,(sid',_))) -> sid /= sid') . toAscList
  54
  55 lookupClientSession :: HostName -> Maybe Fingerprint -> ClientSessions -> IO (Maybe (SessionID, SessionData))
  56 lookupClientSession sni fp sess = (snd <$>) . Map.lookup (sni,fp) <$> readMVar sess