matebeamter/src/Session.hs

61 lines
1.6 KiB
Haskell

{-# LANGUAGE ScopedTypeVariables #-}
module Session where
import Network.Wai.Session
import Control.Monad (liftM)
import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
import qualified StmContainers.Map as SMap
import System.IO.Unsafe (unsafePerformIO)
import Data.Maybe (fromJust)
import Data.ByteString (ByteString)
import Data.Hashable
sessionMap = unsafePerformIO SMap.newIO
sessionStore
:: IO ByteString
-> SMap.Map ByteString (SMap.Map ByteString ByteString)
-> SessionStore IO ByteString ByteString
-- -> IO ((key2 -> IO (Maybe value)), (key2 -> value -> IO ()))
sessionStore genKey inmap =
mapStore genKey inmap
where
mapStore
:: IO ByteString
-> SMap.Map ByteString (SMap.Map ByteString ByteString)
-> SessionStore IO ByteString ByteString
-- -> IO ((key2 -> IO (Maybe value1)), (key2 -> value1 -> IO ()))
mapStore gen map = (\inkey ->
case inkey of
Just k -> do
mcmap <- atomically $ SMap.lookup k map
case mcmap of
Just cmap ->
return $ (sessionMapFromSTMMap cmap, genKey)
Nothing -> (mapStore genKey map) Nothing
Nothing -> do
nkey <- gen
nmap <- atomically $ SMap.new
atomically $ SMap.insert nmap nkey map
cmap <- fromJust <$> (atomically $ SMap.lookup nkey map)
return $ (sessionMapFromSTMMap cmap, gen)
)
sessionMapFromSTMMap
:: SMap.Map ByteString ByteString
-> Session IO ByteString ByteString
sessionMapFromSTMMap inmap =
( \k -> atomically $ SMap.lookup k inmap
, \k v -> atomically $ SMap.insert v k inmap
)