mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-04-01 11:46:14 +00:00
f3408d9bb6
* explicit exports * more empty exports * add exports * reorder * use correct ControlProtocol type for xftp router --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
43 lines
1.4 KiB
Haskell
43 lines
1.4 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module Simplex.Messaging.Session
|
|
( SessionVar (..),
|
|
getSessVar,
|
|
removeSessVar,
|
|
tryReadSessVar,
|
|
) where
|
|
|
|
import Control.Concurrent.STM
|
|
import Data.Time (UTCTime)
|
|
import Simplex.Messaging.TMap (TMap)
|
|
import qualified Simplex.Messaging.TMap as TM
|
|
import Simplex.Messaging.Util (($>>=))
|
|
|
|
data SessionVar a = SessionVar
|
|
{ sessionVar :: TMVar a,
|
|
sessionVarId :: Int,
|
|
sessionVarTs :: UTCTime
|
|
}
|
|
|
|
getSessVar :: forall k a. Ord k => TVar Int -> k -> TMap k (SessionVar a) -> UTCTime -> STM (Either (SessionVar a) (SessionVar a))
|
|
getSessVar sessSeq sessKey vs sessionVarTs = maybe (Left <$> newSessionVar) (pure . Right) =<< TM.lookup sessKey vs
|
|
where
|
|
newSessionVar :: STM (SessionVar a)
|
|
newSessionVar = do
|
|
sessionVar <- newEmptyTMVar
|
|
sessionVarId <- stateTVar sessSeq $ \next -> (next, next + 1)
|
|
let v = SessionVar {sessionVar, sessionVarId, sessionVarTs}
|
|
TM.insert sessKey v vs
|
|
pure v
|
|
|
|
removeSessVar :: Ord k => SessionVar a -> k -> TMap k (SessionVar a) -> STM ()
|
|
removeSessVar v sessKey vs =
|
|
TM.lookup sessKey vs >>= \case
|
|
Just v' | sessionVarId v == sessionVarId v' -> TM.delete sessKey vs
|
|
_ -> pure ()
|
|
|
|
tryReadSessVar :: Ord k => k -> TMap k (SessionVar a) -> STM (Maybe a)
|
|
tryReadSessVar sessKey vs = TM.lookup sessKey vs $>>= (tryReadTMVar . sessionVar)
|