{-# LANGUAGE QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, OverloadedStrings, RankNTypes, FlexibleContexts #-}
-- | A subsite serving a single-user dungeon.
module Web.Antagonist.Server (
module Web.Antagonist.Server.Data
) where
import Game.Antisplice
import Game.Antisplice.Utils.AVL
import Web.Antagonist.Server.Data
import Text.Chatty.Printer
import Text.Chatty.Extended.Printer
import Text.Chatty.Extended.HTML
import Text.Chatty.Expansion
import Text.Chatty.Expansion.Vars
import Text.Chatty.Interactor
import Text.Chatty.Scanner
import System.Chatty.Misc
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.Error.Class
import Data.IORef
import Data.Monoid
import Data.Text (pack,unpack)
import Data.Time.Format
import System.Locale
import Text.Shakespeare.Text
import Text.Hamlet
import Text.Cassius
import Text.Julius
import Yesod
extractSession :: Yesod master => HandlerT SingleUserSub (HandlerT master IO) (Int,SessionState,String)
extractSession = do
SingleUserSub ctrref avlref ctor <- getYesod
ssid_ <- lookupSession "ssid"
ssid <- case ssid_ of
Nothing -> do
ssid <- liftIO $ atomicModifyIORef ctrref $ (+1) &&& (+1)
setSession "ssid" (pack $ show ssid)
return ssid
Just ssid_ -> return $ read $ unpack ssid_
ss_ <- liftIO $ readIORef avlref
(ss,ns) <- case avlLookup ssid ss_ of
Just (x,ns,st) -> return (x,ns)
Nothing -> do
(ss,r) <- liftIO $ runRecorderT $ startSession ctor
return (ss,replay r)
((_,ss1),r) <- liftIO $ runRecorderT $ runSession ss runScheduledTasks
putSession ssid ss1 none
return (ssid,ss1,ns <> replay r)
substitute :: Eq a => a -> [a] -> [a] -> [a]
substitute e by = concatMap subst'
where subst' a | a == e = by
| otherwise = [a]
prepOutput :: MonadIO m => String -> m String
prepOutput s = do
u <- liftIO $ mutctime
let t = formatTime defaultTimeLocale "[%R] " u
return (concatMap ((++"
").(t++)) $ lines s)
getPrompt :: MonadIO m => SessionState -> m String
getPrompt ss = do
u <- liftIO $ mutctime
((ps,_),_) <- liftIO $ runRecorderT $ runSession ss $ expand $
formatTime defaultTimeLocale "%R $user #{health}H#?{ #{otitle} #{ohealth}H}" u
return ps
getPlayR :: Yesod master => HandlerT SingleUserSub (HandlerT master IO) Html
getPlayR = do
(ssid,ss,ns) <- extractSession
toMaster <- getRouteToParent
putSession ssid ss ns
lift $ defaultLayout $ do
setTitle $ toHtml [lt| Session #{show ssid}|]
toWidget $(hamletFile "play.htm")
toWidget $(cassiusFileReload "play.cass")
toWidget $(juliusFileReload "play.js")
postNewsR :: Yesod master => HandlerT SingleUserSub (HandlerT master IO) Value
postNewsR = do
(_,ss,ns) <- extractSession
nss <- prepOutput ns
ps <- getPrompt ss
lift $ return $ object [ "news" .= pack nss, "prompt" .= pack ps ]
postPutR :: (Yesod master,RenderMessage master FormMessage) => HandlerT SingleUserSub (HandlerT master IO) Value
postPutR = do
(ssid,ss,ns) <- extractSession
line <- lift $ runInputPost $ id <$> ireq textField "line"
((_,x),r) <- liftIO $ runRecorderT $ runSession ss $ act $ unpack line
putSession ssid x none
nss <- prepOutput (ns <> replay r)
ps <- getPrompt x
lift $ return $ object [ "news" .= pack nss, "prompt" .= pack ps ]
instance (Yesod master,RenderMessage master FormMessage) => YesodSubDispatch SingleUserSub (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesSingleUserSub)
putSession :: Yesod master => Int -> SessionState -> String -> HandlerT SingleUserSub (HandlerT master IO) ()
putSession ssid ss nn = do
SingleUserSub ctrref avlref ctor <- getYesod
stamp <- liftIO mgetstamp
void $ liftIO $ atomicModifyIORef avlref $ (avlInsert (ssid,ss,nn,stamp)) &&& (avlInsert (ssid,ss,nn,stamp))
runScheduledTasks :: ChattyDungeonM ()
runScheduledTasks = do
now <- mgetstamp
ds <- getDungeonState
let ts = takeWhile (( SessionState -> ChattyDungeonM a -> m (a,SessionState)
runSession ss m = do
x <- withSession ss m
case x of
Right r -> return r
Left e -> do
mprintLn $ case e of
VerbMustFirstError -> "Please start with a verb."
UnintellegibleError -> "I don't understand that."
CantWalkThereError -> "I can't walk there."
WhichOneError -> "Which one do you mean?"
CantSeeOneError -> "I can't see one here."
DontCarryOneError -> "You don't carry one."
CantEquipThatError -> "I can't equip that."
CantEquipThatThereError -> "I can't wear that there. You might want to try some other place?"
WhereToEquipError -> "Where?"
CantCastThatNowError -> "Sorry, I can't cast that now. Check your health, mana and cooldowns."
_ -> ""
return (undefined,ss)
withSession :: (MonadIO m,MonadClock m,MonadRandom m,MonadPrinter m) => SessionState -> ChattyDungeonM a -> m (Either SplErr (a,SessionState))
withSession ((((s,ts),as),c),es) m =
runNullExpanderT $
liftM rot $ flip runExpanderT es $
runHtmlPrinterT $
liftM rot $ flip runCounterT c $
liftM rot $ flip runAtomStoreT as $
liftM rot $ flip runVocabT ts $
runFailT $
flip runDungeonT s m
startSession :: (MonadIO m,MonadClock m,MonadRandom m,MonadPrinter m) => Constructor -> m SessionState
startSession init = do
Right (_,x) <- withSession ((((none,defVocab),none),0),none) $ do
init
reenterCurrentRoom
roomTriggerOnAnnounceOf =<< getRoomState
roomTriggerOnLookOf =<< getRoomState
return x
rot :: (Either x (a,b),c) -> Either x (a,(b,c))
rot (Right (a,b),c) = Right (a,(b,c))
rot (Left e,_) = Left e
semirot :: (Either x a,b) -> Either x (a,b)
semirot (Right a,b) = Right (a,b)
semirot (Left e,_) = Left e