{-# LANGUAGE NamedFieldPuns #-}
module Session (
      App
    , T(..)
    , connection
    , debug
    , get
    , player
    , serve
    , update
  ) where

import Data.Map ((!))
import Control.Concurrent (MVar, newMVar, modifyMVar, putMVar, readMVar, takeMVar)
import Control.Exception (finally)
import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
import Network.WebSockets (Connection, ServerApp, acceptRequest)
import qualified Player (T(..), new)
import qualified Server (SessionId, T(..), join, new)

data T = T {
      server :: MVar Server.T
    , key :: Server.SessionId
  }

type App a = ReaderT T IO a

get :: (Server.T -> a) -> App a
get f =
  asks server
  >>= lift . (f <$>) . readMVar

player :: App Player.T
player = do
  sId <- asks key
  get ((! sId) . Server.bySessionId)

connection :: App Connection
connection = Player.connection <$> player

debug :: String -> App ()
debug message =
  show <$> asks Session.key
  >>= lift . putStrLn . (++ ' ':message)

update :: (Server.SessionId -> Server.T -> Either String Server.T) -> App (Maybe String)
update f = do
  T {server, key} <- ask
  currentValue <- lift $ takeMVar server
  lift $ case f key currentValue of
    Left message -> putMVar server currentValue >> return (Just message)
    Right updated -> putMVar server updated >> return Nothing

serve :: App () -> App () -> IO ServerApp
serve onEnter onExit = do
  server <- newMVar Server.new
  return $ \pending -> do
    key <- acceptRequest pending
                 >>= return . Player.new
                 >>= modifyMVar server . Server.join
    finally
      (runReaderT onEnter $ T {server, key})
      (runReaderT onExit $ T {server, key})