61 lines
1.6 KiB
Haskell
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
|
|
)
|