diohsc-0.1.3: ClientSessionManager.hs

-- This file is part of Diohsc
-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

module ClientSessionManager
    ( clientSessionManager
    , ClientSessions
    , newClientSessions
    , lookupClientSession
    ) where

import           Control.Concurrent
import           Data.Map           (fromAscList, toAscList)
import           Network.TLS

import           Data.Hourglass     (timeAdd)
import           Time.System        (timeCurrent)
import           Time.Types         (Elapsed (..), Seconds (..))

import qualified Data.Map           as Map

import           Fingerprint

type ClientSessions = MVar (Map.Map (HostName, Maybe Fingerprint) (Elapsed, (SessionID, SessionData)))

newClientSessions :: IO ClientSessions
newClientSessions = newMVar Map.empty

clientSessionManager :: Int -> ClientSessions -> Maybe Fingerprint -> SessionManager
clientSessionManager lifetime sess fp = SessionManager
    (\_ -> return Nothing)
    (\_ -> return Nothing)
    insert
    delete
    where
    insert sid sd@SessionData{ sessionClientSNI = Just sni } = do
        now <- timeCurrent
        let expire = now `timeAdd` Seconds (fromIntegral lifetime)
        modifyMVar_ sess $ return .
            Map.insert (sni, fp) (expire,(sid,sd)) .
            fromAscList . filter (\(_,(t,(_,_))) -> t >= now) . toAscList
    insert _ _ = return ()
    delete sid =
        modifyMVar_ sess $ return .
            fromAscList . filter (\(_,(_,(sid',_))) -> sid /= sid') . toAscList

lookupClientSession :: HostName -> Maybe Fingerprint -> ClientSessions -> IO (Maybe (SessionID, SessionData))
lookupClientSession sni fp sess = (snd <$>) . Map.lookup (sni,fp) <$> readMVar sess