antagonist 0.1.0.24 → 0.1.0.25
raw patch · 5 files changed
+57/−29 lines, 5 filesdep +yesod-auth
Dependencies added: yesod-auth
Files
- antagonist.cabal +3/−3
- ironforge-yesod.hs +1/−0
- play.cass +7/−4
- play.htm +6/−2
- server/Web/Antagonist/Server.hs +40/−20
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.24+version: 0.1.0.25 -- A short (one-line) description of the package. synopsis: A web interface to Antisplice dungeons.@@ -50,7 +50,7 @@ library exposed-modules: Web.Antagonist.Server, Web.Antagonist.Server.Data- build-depends: base >=4.6 && <4.8, yesod >=1.2 && <1.3, antisplice >=0.17 && <0.18, text >=1.1 && <1.2, chatty >=0.6 && <0.7, chatty-utils >=0.7 && <0.8, shakespeare >=2.0 && <2.1, mtl >=2.1 && <2.2, time >=1.4 && <1.5, old-locale >=1.0 && <1.1+ build-depends: base >=4.6 && <4.8, yesod >=1.2 && <1.3, antisplice >=0.17 && <0.18, text >=1.1 && <1.2, chatty >=0.6 && <0.7, chatty-utils >=0.7 && <0.8, shakespeare >=2.0 && <2.1, mtl >=2.1 && <2.2, time >=1.4 && <1.5, old-locale >=1.0 && <1.1, yesod-auth >=1.3 && <1.4 default-language: Haskell2010 hs-source-dirs: shared, server, . @@ -65,7 +65,7 @@ -- other-extensions: -- Other library packages from which modules are imported.- build-depends: base >=4.6 && <4.8, yesod >=1.2 && <1.3, antisplice >=0.17 && <0.18, text >=1.1 && <1.2, chatty >=0.6 && <0.7, chatty-utils >=0.7 && <0.8, shakespeare >=2.0 && <2.1, mtl >=2.1 && <2.2, ironforge >=0.1 && <0.2, time >=1.4 && <1.5, old-locale >=1.0 && <1.1+ build-depends: base >=4.6 && <4.8, yesod >=1.2 && <1.3, antisplice >=0.17 && <0.18, text >=1.1 && <1.2, chatty >=0.6 && <0.7, chatty-utils >=0.7 && <0.8, shakespeare >=2.0 && <2.1, mtl >=2.1 && <2.2, ironforge >=0.1 && <0.2, time >=1.4 && <1.5, old-locale >=1.0 && <1.1, yesod-auth >=1.3 && <1.4 -- Directories containing source files. hs-source-dirs: shared, server, .
ironforge-yesod.hs view
@@ -15,6 +15,7 @@ |] instance Yesod Master+instance YesodAntagonist Master instance RenderMessage Master FormMessage where renderMessage _ _ = defaultFormMessage
play.cass view
@@ -21,11 +21,14 @@ position: fixed; bottom: 0px; left: 0px;- font-family: monospace+ font-family: monospace; #prom- color: white- vertical-align: center- left: 0px+ color: white;+ vertical-align: center;+ left: 0px;+ text-decoration: none;+a#prom:hover+ text-decoration: underline; #inp background-color: white .time, .ftime
play.htm view
@@ -1,5 +1,9 @@ <span #cons> <span #pw>- <span #prom>- Loading...+ $maybe customizeR <- mcustomizeR+ <a href=@{customizeR} #prom>+ Loading...+ $nothing+ <span #prom>+ Loading... <input type=text #inp>
server/Web/Antagonist/Server.hs view
@@ -2,7 +2,8 @@ -- | A subsite serving a single-user dungeon. module Web.Antagonist.Server (- module Web.Antagonist.Server.Data+ module Web.Antagonist.Server.Data,+ YesodAntagonist (getNick, antagonistLayout, getAuthR, getCustomizeR) ) where import Data.Chatty.AVL@@ -24,7 +25,7 @@ import Data.IORef import Data.Monoid import Data.List-import Data.Text (pack,unpack)+import Data.Text (pack,unpack,Text) import Data.Time.Format import System.Locale import Text.Shakespeare.Text@@ -32,11 +33,25 @@ import Text.Cassius import Text.Julius import Yesod+import Yesod.Auth -extractSession :: Yesod master => HandlerT SingleUserSub (HandlerT master IO) (Int,SessionState,String)+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)@@ -53,9 +68,9 @@ | otherwise = a se = indexOf . head . sortBy (\(_,_,_,a) (_,_,_,b) -> a `compare` b) . avlPreorder in op &&& op- (ss,r) <- liftIO $ runRecorderT $ startSession ctor+ (ss,r) <- liftIO $ runRecorderT $ startSession ctor nick return (ss,replay r)- ((_,ss1),r) <- liftIO $ runRecorderT $ runSession ctor ss runScheduledTasks+ ((_,ss1),r) <- liftIO $ runRecorderT $ runSession ctor nick ss runScheduledTasks putSession ssid ss1 none return (ssid,ss1,ns <> replay r) @@ -68,6 +83,7 @@ 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 (n-1) sx@@ -81,37 +97,40 @@ let t = formatTime defaultTimeLocale "<span class=\"ftime\"><%R></span> " u return (t++s++"<br/>") -getPrompt :: MonadIO m => SessionState -> m String+getPrompt :: SessionState -> AntaHandler String getPrompt ss = do u <- liftIO $ mutctime- ((ps,_),_) <- liftIO $ runRecorderT $ runSession (return ()) ss $ expand <=< expand $+ nick <- lift getNick+ ((ps,_),_) <- liftIO $ runRecorderT $ runSession (return ()) nick ss $ expand <=< expand $ formatTime defaultTimeLocale "%R $prompt" u return ps -getPlayR :: Yesod master => HandlerT SingleUserSub (HandlerT master IO) Html+getPlayR :: AntaHandler Html getPlayR = do (ssid,ss,ns) <- extractSession toMaster <- getRouteToParent putSession ssid ss ns- lift $ defaultLayout $ do+ 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 :: Yesod master => HandlerT SingleUserSub (HandlerT master IO) Value+postNewsR :: AntaHandler 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 :: AntaHandler Value postPutR = do SingleUserSub _ _ ctor <- getYesod (ssid,ss,ns) <- extractSession line <- lift $ runInputPost $ id <$> ireq textField "line"- ((_,x),r) <- liftIO $ runRecorderT $ runSession ctor ss $ act $ unpack 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@@ -120,10 +139,10 @@ ps <- getPrompt x lift $ return $ object [ "news" .= pack nss, "prompt" .= pack ps ] -instance (Yesod master,RenderMessage master FormMessage) => YesodSubDispatch SingleUserSub (HandlerT master IO) where+instance YesodAntagonist master => YesodSubDispatch SingleUserSub (HandlerT master IO) where yesodSubDispatch = $(mkYesodSubDispatch resourcesSingleUserSub) -putSession :: Yesod master => Int -> SessionState -> String -> HandlerT SingleUserSub (HandlerT master IO) ()+putSession :: Int -> SessionState -> String -> AntaHandler () putSession ssid ss nn = do SingleUserSub ctrref avlref ctor <- getYesod stamp <- liftIO mgetstamp@@ -137,9 +156,9 @@ putDungeonState ds{timeTriggersOf=foldr avlRemove (timeTriggersOf ds) $ map fst ts} forM_ ts (runHandler . snd) -runSession :: (MonadIO m,ChClock m,ChRandom m,ChPrinter m) => Constructor () -> SessionState -> ChattyDungeonM a -> m (a,SessionState)-runSession ctor ss m = do- x <- withSession ss m+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@@ -160,7 +179,7 @@ ReError (Uncon s) -> s _ -> "" case e of- QuitError -> liftM (undefined,) $ startSession ctor+ 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))@@ -176,9 +195,10 @@ flip runDungeonT s m where unjust (Just j) = j -startSession :: (MonadIO m,ChClock m,ChRandom m,ChPrinter m) => Constructor () -> m SessionState-startSession init = do+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