module Web.Antagonist.Server (
module Web.Antagonist.Server.Data,
YesodAntagonist (getNick, antagonistLayout, getAuthR, getCustomizeR)
) where
import Data.Chatty.AVL
import Game.Antisplice
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 Text.Chatty.Channel.Printer
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.List
import Data.Text (pack,unpack,Text)
import Data.Time.Format
import Data.Time.Locale.Compat
import Text.Shakespeare.Text
import Text.Hamlet
import Text.Cassius
import Text.Julius
import Yesod
import Yesod.Auth
class (Yesod master, RenderMessage master FormMessage) => YesodAntagonist master where
getNick :: HandlerT master IO Text
getNick = return "Bernd"
antagonistLayout :: WidgetT master IO () -> HandlerT master IO Html
antagonistLayout = defaultLayout
getAuthR :: HandlerT master IO (Maybe (AuthRoute -> Route master))
getAuthR = return Nothing
getCustomizeR :: HandlerT master IO (Maybe (Route master))
getCustomizeR = return Nothing
type AntaHandler a = forall master. YesodAntagonist master => HandlerT SingleUserSub (HandlerT master IO) a
extractSession :: AntaHandler (Int,SessionState,String)
extractSession = do
SingleUserSub ctrref avlref ctor <- getYesod
ssid_ <- lookupSession "ssid"
nick <- lift getNick
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
liftIO $ atomicModifyIORef avlref $
let op a
| avlSize a >= 100 = avlRemove (se a) a
| otherwise = a
se = indexOf . head . sortBy (\(_,_,_,a) (_,_,_,b) -> a `compare` b) . avlPreorder
in op &&& op
(ss,r) <- liftIO $ runRecorderT $ startSession ctor nick
return (ss,replay r)
((_,ss1),r) <- liftIO $ runRecorderT $ runSession ctor nick 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 "<span class=\"time\">[%R]</span> " u
ms :: Int -> String -> String
ms 0 (' ':sx) = let wc = length $ takeWhile (==' ') sx in " " ++ concat (replicate wc " ") ++ ms 0 (drop wc sx)
ms n ('<':sx) = '<' : ms (n+1) sx
ms n ('>':sx) = '>' : ms (n1) sx
ms n (x:xs) = x : ms n xs
ms n [] = []
return (concatMap ((++"<br/>") . ms 0 . (t++)) $ lines s)
prepFeedback :: MonadIO m => String -> m String
prepFeedback s = do
u <- liftIO mutctime
let t = formatTime defaultTimeLocale "<span class=\"ftime\"><%R></span> " u
return (t++s++"<br/>")
getPrompt :: SessionState -> AntaHandler String
getPrompt ss = do
u <- liftIO $ mutctime
nick <- lift getNick
((ps,_),_) <- liftIO $ runRecorderT $ runSession (return ()) nick ss $ expand <=< expand $
formatTime defaultTimeLocale "%R $prompt" u
return ps
getPlayR :: AntaHandler Html
getPlayR = do
(ssid,ss,ns) <- extractSession
toMaster <- getRouteToParent
putSession ssid ss ns
mcustomizeR <- lift getCustomizeR
lift $ antagonistLayout $ do
setTitle $ toHtml [lt| Session #{show ssid}|]
toWidget $(hamletFile "play.htm")
toWidget $(cassiusFile "play.cass")
toWidget $(juliusFile "play.js")
postNewsR :: AntaHandler Value
postNewsR = do
(_,ss,ns) <- extractSession
nss <- prepOutput ns
ps <- getPrompt ss
lift $ return $ object [ "news" .= pack nss, "prompt" .= pack ps ]
postPutR :: AntaHandler Value
postPutR = do
SingleUserSub _ _ ctor <- getYesod
(ssid,ss,ns) <- extractSession
line <- lift $ runInputPost $ id <$> ireq textField "line"
nick <- lift getNick
((_,x),r) <- liftIO $ runRecorderT $ runSession ctor nick ss $ act $ unpack line
putSession ssid x none
nss1 <- prepOutput ns
nss2 <- prepOutput $ replay r
nssF <- prepFeedback $ unpack line
let nss = nss1 <> nssF <> nss2
ps <- getPrompt x
lift $ return $ object [ "news" .= pack nss, "prompt" .= pack ps ]
instance YesodAntagonist master => YesodSubDispatch SingleUserSub (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesSingleUserSub)
putSession :: Int -> SessionState -> String -> AntaHandler ()
putSession ssid ss nn = do
SingleUserSub ctrref avlref ctor <- getYesod
stamp <- liftIO mgetstamp
void $ liftIO $ atomicModifyIORef avlref $ let op = avlInsert (ssid,ss,nn,stamp) in op &&& op
runScheduledTasks :: ChattyDungeonM ()
runScheduledTasks = do
now <- mgetstamp
ds <- getDungeonState
let ts = takeWhile ((<now).fst) $ avlInorder $ timeTriggersOf ds
putDungeonState ds{timeTriggersOf=foldr avlRemove (timeTriggersOf ds) $ map fst ts}
forM_ ts (runHandler . snd)
runSession :: (MonadIO m,ChClock m,ChRandom m,ChPrinter m) => Constructor () -> Text -> SessionState -> ChattyDungeonM a -> m (a,SessionState)
runSession ctor nick ss m = do
x <- withSession ss (mputv "user" (Literal $ unpack nick) >> m)
case x of
Right r -> return r
Left e -> do
runHtmlPrinterT $ eprintLn (Vivid Red) $ 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."
CantAcquireThatError -> "I can't take that."
WontHitThatError -> "I won't hit that."
ReError (Unint _ s) -> s
ReError (Uncon s) -> s
_ -> ""
case e of
QuitError -> liftM (undefined,) $ startSession ctor nick
_ -> return (undefined,ss)
withSession :: (MonadIO m,ChClock m,ChRandom m,ChPrinter m) => SessionState -> ChattyDungeonM a -> m (Either SplErr (a,SessionState))
withSession ((((s,ts),as),c),es) m =
runJoinerT $
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
where unjust (Just j) = j
startSession :: (MonadIO m,ChClock m,ChRandom m,ChPrinter m) => Constructor () -> Text -> m SessionState
startSession init nick = do
Right (_,x) <- withSession ((((none,defVocab),none),0),none) $ do
mputv "user" $ Literal $ unpack nick
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