diff --git a/antagonist.cabal b/antagonist.cabal --- a/antagonist.cabal +++ b/antagonist.cabal @@ -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, . diff --git a/ironforge-yesod.hs b/ironforge-yesod.hs --- a/ironforge-yesod.hs +++ b/ironforge-yesod.hs @@ -15,6 +15,7 @@ |] instance Yesod Master +instance YesodAntagonist Master instance RenderMessage Master FormMessage where renderMessage _ _ = defaultFormMessage diff --git a/play.cass b/play.cass --- a/play.cass +++ b/play.cass @@ -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 diff --git a/play.htm b/play.htm --- a/play.htm +++ b/play.htm @@ -1,5 +1,9 @@ - - Loading... + $maybe customizeR <- mcustomizeR + + Loading... + $nothing + + Loading... diff --git a/server/Web/Antagonist/Server.hs b/server/Web/Antagonist/Server.hs --- a/server/Web/Antagonist/Server.hs +++ b/server/Web/Antagonist/Server.hs @@ -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 "[%R] " 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 "<%R> " u return (t++s++"
") -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