antagonist 0.1.0.3 → 0.1.0.7
raw patch · 3 files changed
+25/−13 lines, 3 filesdep ~chatty
Dependency ranges changed: chatty
Files
- antagonist.cabal +3/−3
- play.js +2/−2
- server/Web/Antagonist/Server.hs +20/−8
antagonist.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.0.3+version: 0.1.0.7 -- A short (one-line) description of the package. synopsis: A web interface to Antisplice dungeons.@@ -48,7 +48,7 @@ library exposed-modules: Web.Antagonist.Server, Web.Antagonist.Server.Data- build-depends: base >=4.6 && <4.7, yesod >=1.2 && <1.3, antisplice >=0.12.1 && <0.13, text >=0.11 && <0.12, chatty >=0.5 && <0.6, shakespeare-text >=1.0 && <1.1, hamlet >=1.1 && <1.2, mtl >=2.1 && <2.2, shakespeare-css >=1.0 && <1.1, shakespeare-js >=1.2 && <1.3, time >=1.4 && <1.5, old-locale >=1.0 && <1.1+ build-depends: base >=4.6 && <4.7, yesod >=1.2 && <1.3, antisplice >=0.12.1 && <0.13, text >=0.11 && <0.12, chatty >=0.5.3 && <0.6, shakespeare-text >=1.0 && <1.1, hamlet >=1.1 && <1.2, mtl >=2.1 && <2.2, shakespeare-css >=1.0 && <1.1, shakespeare-js >=1.2 && <1.3, time >=1.4 && <1.5, old-locale >=1.0 && <1.1 default-language: Haskell2010 hs-source-dirs: shared, server, . @@ -63,7 +63,7 @@ -- other-extensions: -- Other library packages from which modules are imported.- build-depends: base >=4.6 && <4.7, yesod >=1.2 && <1.3, antisplice >=0.12.1 && <0.13, text >=0.11 && <0.12, chatty >=0.5 && <0.6, shakespeare-text >=1.0 && <1.1, hamlet >=1.1 && <1.2, mtl >=2.1 && <2.2, shakespeare-css >=1.0 && <1.1, shakespeare-js >=1.2 && <1.3, ironforge >=0.1 && <0.2, time >=1.4 && <1.5, old-locale >=1.0 && <1.1+ build-depends: base >=4.6 && <4.7, yesod >=1.2 && <1.3, antisplice >=0.12.1 && <0.13, text >=0.11 && <0.12, chatty >=0.5.3 && <0.6, shakespeare-text >=1.0 && <1.1, hamlet >=1.1 && <1.2, mtl >=2.1 && <2.2, shakespeare-css >=1.0 && <1.1, shakespeare-js >=1.2 && <1.3, ironforge >=0.1 && <0.2, time >=1.4 && <1.5, old-locale >=1.0 && <1.1 -- Directories containing source files. hs-source-dirs: shared, server, .
play.js view
@@ -34,7 +34,7 @@ cons.innerHTML+=res.news; cons.scrollTop = cons.scrollHeight; }- document.getElementById("prom").textContent = res.prompt;+ document.getElementById("prom").innerHTML = res.prompt; fixwidth(); } }@@ -67,6 +67,6 @@ } document.getElementById("inp").onkeypress = keypress; function fixwidth() {- document.getElementById("inp").style.width = (window.innerWidth - document.getElementById("prom").offsetWidth - 12)+"px";+ document.getElementById("inp").style.width = (window.innerWidth - document.getElementById("prom").offsetWidth - 60)+"px"; } fixwidth();
server/Web/Antagonist/Server.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, OverloadedStrings, RankNTypes, FlexibleContexts #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, OverloadedStrings, RankNTypes, FlexibleContexts, TupleSections #-} -- | A subsite serving a single-user dungeon. module Web.Antagonist.Server (@@ -23,6 +23,7 @@ import Control.Monad.Error.Class import Data.IORef import Data.Monoid+import Data.List import Data.Text (pack,unpack) import Data.Time.Format import System.Locale@@ -46,9 +47,15 @@ (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 return (ss,replay r)- ((_,ss1),r) <- liftIO $ runRecorderT $ runSession ss runScheduledTasks+ ((_,ss1),r) <- liftIO $ runRecorderT $ runSession ctor ss runScheduledTasks putSession ssid ss1 none return (ssid,ss1,ns <> replay r) @@ -66,7 +73,7 @@ getPrompt :: MonadIO m => SessionState -> m String getPrompt ss = do u <- liftIO $ mutctime- ((ps,_),_) <- liftIO $ runRecorderT $ runSession ss $ expand $+ ((ps,_),_) <- liftIO $ runRecorderT $ runSession (return ()) ss $ expand $ formatTime defaultTimeLocale "%R $user #{health}H#?{ #{otitle} #{ohealth}H}" u return ps @@ -90,9 +97,10 @@ postPutR :: (Yesod master,RenderMessage master FormMessage) => HandlerT SingleUserSub (HandlerT master IO) Value postPutR = do+ SingleUserSub _ _ ctor <- getYesod (ssid,ss,ns) <- extractSession line <- lift $ runInputPost $ id <$> ireq textField "line"- ((_,x),r) <- liftIO $ runRecorderT $ runSession ss $ act $ unpack line+ ((_,x),r) <- liftIO $ runRecorderT $ runSession ctor ss $ act $ unpack line putSession ssid x none nss <- prepOutput (ns <> replay r) ps <- getPrompt x@@ -105,7 +113,7 @@ 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))+ void $ liftIO $ atomicModifyIORef avlref $ let op = avlInsert (ssid,ss,nn,stamp) in op &&& op runScheduledTasks :: ChattyDungeonM () runScheduledTasks = do@@ -115,8 +123,8 @@ putDungeonState ds{timeTriggersOf=foldr avlRemove (timeTriggersOf ds) $ map fst ts} forM_ ts (runHandler . snd) -runSession :: (MonadIO m,MonadClock m,MonadRandom m,MonadPrinter m) => SessionState -> ChattyDungeonM a -> m (a,SessionState)-runSession ss m = do+runSession :: (MonadIO m,MonadClock m,MonadRandom m,MonadPrinter m) => Constructor -> SessionState -> ChattyDungeonM a -> m (a,SessionState)+runSession ctor ss m = do x <- withSession ss m case x of Right r -> return r@@ -132,8 +140,12 @@ 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." _ -> ""- return (undefined,ss)+ case e of+ QuitError -> liftM (undefined,) $ startSession ctor+ _ -> 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 =