46 lines
987 B
Haskell
46 lines
987 B
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module App (
|
|
T
|
|
, Context(..)
|
|
, debug
|
|
, exec
|
|
, get
|
|
, session
|
|
, update
|
|
) where
|
|
|
|
import Control.Concurrent (MVar, modifyMVar, readMVar)
|
|
import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
|
|
import Data.Map ((!))
|
|
import qualified Server (T(..))
|
|
import qualified Session (ID, T(..))
|
|
|
|
data Context = Context {
|
|
mServer :: MVar Server.T
|
|
, sessionID :: Session.ID
|
|
}
|
|
|
|
type T a = ReaderT Context IO a
|
|
|
|
get :: (Server.T -> a) -> T a
|
|
get projector =
|
|
lift . fmap projector . readMVar =<< asks mServer
|
|
|
|
session :: T Session.T
|
|
session = do
|
|
Context {sessionID} <- ask
|
|
get $ (! sessionID) . Server.sessions
|
|
|
|
debug :: String -> T ()
|
|
debug message =
|
|
show <$> asks sessionID
|
|
>>= lift . putStrLn . (++ ' ':message)
|
|
|
|
exec :: (Server.T -> IO (Server.T, a)) -> T a
|
|
exec f = do
|
|
Context {mServer} <- ask
|
|
lift $ modifyMVar mServer f
|
|
|
|
update :: (Server.T -> Server.T) -> T ()
|
|
update f = exec $ (\x -> return (x, ())) . f
|