diff --git a/Nomyx-Web.cabal b/Nomyx-Web.cabal --- a/Nomyx-Web.cabal +++ b/Nomyx-Web.cabal @@ -1,5 +1,5 @@ name: Nomyx-Web -version: 0.5.0 +version: 0.6.0 cabal-version: >=1.6 build-type: Simple license: BSD3 @@ -16,8 +16,8 @@ extra-source-files: README.md library - build-depends: Nomyx-Language == 0.5.0, - Nomyx-Core == 0.5.0, + build-depends: Nomyx-Language == 0.6.0, + Nomyx-Core == 0.6.0, base == 4.6.*, blaze-html == 0.7.*, blaze-markup == 0.6.*, @@ -57,4 +57,4 @@ source-repository head type: git - location: git://github.com/cdupont/Nomyx-Web.git + location: https://github.com/cdupont/Nomyx-Web.git diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,3 @@ -[![Build Status](https://travis-ci.org/cdupont/Nomyx-Web.png?branch=master)](https://travis-ci.org/cdupont/Nomyx-Web) -[![Hackage](https://budueba.com/hackage/Nomyx-Web)](https://hackage.haskell.org/package/Nomyx-Web) Nomyx-Web ======== diff --git a/src/Nomyx/Web/Common.hs b/src/Nomyx/Web/Common.hs --- a/src/Nomyx/Web/Common.hs +++ b/src/Nomyx/Web/Common.hs @@ -8,6 +8,7 @@ import Prelude hiding (div) +import Safe import Text.Blaze.Html5 hiding (map, output, base) import Text.Blaze.Html5.Attributes hiding (dir, id) import qualified Text.Blaze.Html5 as H @@ -18,25 +19,23 @@ import Web.Routes.TH (derivePathInfo) import Web.Routes.Happstack() import Control.Monad.State -import Control.Monad.Error import Control.Concurrent.STM import Happstack.Server as HS import Happstack.Auth (UserId(..), getUserId, AuthProfileURL) import qualified Data.ByteString.Char8 as C import Data.Maybe import Data.Text (unpack, append, Text, pack) +import Data.String import Text.Reform.Happstack() import Text.Reform import Text.Reform.Blaze.String() -import Text.Blaze.Internal import qualified Text.Reform.Generalized as G import Language.Haskell.HsColour.HTML (hscolour) import Language.Haskell.HsColour.Colourise (defaultColourPrefs) import Language.Nomyx -import Language.Nomyx.Engine +import Nomyx.Core.Engine import Nomyx.Core.Session import Nomyx.Core.Profile -import Nomyx.Core.Serialize import Nomyx.Core.Types as T data NomyxError = PlayerNameRequired @@ -62,8 +61,8 @@ data Server = Server [PlayerClient] deriving (Eq, Show) -data PlayerCommand = HomePage - | UAuthProfile AuthProfileURL +data PlayerCommand = NotLogged + | Auth AuthProfileURL | PostAuth | MainPage | ViewGame GameName @@ -71,7 +70,7 @@ | LeaveGame GameName | DelGame GameName | ForkGame GameName - | DoInput EventNumber GameName + | DoInput EventNumber InputNumber GameName | NewRule GameName | NewGame | SubmitNewGame @@ -146,7 +145,7 @@ -> Html appTemplate' title headers body footer link = do H.head $ do - H.title (string title) + H.title (fromString title) H.link ! rel "stylesheet" ! type_ "text/css" ! href "/static/css/nomyx.css" H.meta ! A.httpEquiv "Content-Type" ! content "text/html;charset=utf-8" H.meta ! A.name "keywords" ! A.content "Nomyx, game, rules, Haskell, auto-reference" @@ -167,29 +166,28 @@ appTemplate title headers body = return $ toResponse $ appTemplate' title headers body True Nothing -- | return the player number (user ID) based on the session cookie. -getPlayerNumber :: TVar Session -> RoutedNomyxServer PlayerNumber +getPlayerNumber :: TVar Session -> RoutedNomyxServer (Maybe PlayerNumber) getPlayerNumber ts = do (T.Session _ _ (Profiles acidAuth acidProfile _)) <- liftIO $ readTVarIO ts uid <- getUserId acidAuth acidProfile case uid of - Nothing -> throwError $ userError "not logged in." - (Just (UserId userID)) -> return $ fromInteger userID + Nothing -> return Nothing + (Just (UserId userID)) -> return $ Just $ fromInteger userID --update the session using the command and saves it webCommand :: TVar Session -> StateT Session IO () -> RoutedNomyxServer () -webCommand ts ss = liftIO $ do - updateSession ts ss - s <- atomically $ readTVar ts - save $ _multi s +webCommand ts ss = liftIO $ updateSession ts ss getIsAdmin :: TVar Session -> RoutedNomyxServer Bool getIsAdmin ts = do - pn <- getPlayerNumber ts - mpf <- getProfile' ts pn - case mpf of - Just pf -> return $ _pIsAdmin pf - Nothing -> throwError $ userError "not logged in." - + mpn <- getPlayerNumber ts + case mpn of + Just pn -> do + mpf <- getProfile' ts pn + case mpf of + Just pf -> return $ _pIsAdmin pf + Nothing -> return False + Nothing -> return False fieldRequired :: NomyxError -> String -> Either NomyxError String fieldRequired a [] = Left a @@ -199,7 +197,7 @@ appendAnchor url a = url `append` "#" `append` a displayCode :: String -> Html -displayCode s = preEscapedString $ hscolour defaultColourPrefs False s +displayCode s = preEscapedToHtml $ hscolour defaultColourPrefs False s getGame :: GameInfo -> Game getGame = _game . _loggedGame @@ -207,6 +205,9 @@ numberOfGamesOwned :: [GameInfo] -> PlayerNumber -> Int numberOfGamesOwned gis pn = length $ filter (maybe False (==pn) . _ownedBy) gis +getFirstGame :: Session -> Maybe GameInfo +getFirstGame = headMay . _gameInfos . _multi + instance FormError NomyxError where type ErrorInputType NomyxError = [HS.Input] commonFormError = NomyxCFE @@ -216,6 +217,6 @@ toMarkup GameNameRequired = "Game Name is required" toMarkup UniqueName = "Name already taken" toMarkup UniqueEmail = "Email already taken" - toMarkup (FieldTooLong l) = string $ "Field max length: " ++ show l + toMarkup (FieldTooLong l) = fromString $ "Field max length: " ++ show l toMarkup (NomyxCFE e) = toHtml e diff --git a/src/Nomyx/Web/Game.hs b/src/Nomyx/Web/Game.hs --- a/src/Nomyx/Web/Game.hs +++ b/src/Nomyx/Web/Game.hs @@ -16,16 +16,13 @@ import Data.String import Data.List import Data.Text (Text) -import Data.Typeable import Data.Time import Data.Lens import Text.Printf import System.Locale import Language.Nomyx -import Language.Nomyx.Engine import Text.Blaze.Html5 (Html, div, (!), p, table, thead, td, tr, h2, h3, h4, h5, pre, toValue, br, toHtml, a, img) import Text.Blaze.Html5.Attributes as A (src, title, width, style, id, onclick, disabled, placeholder, class_, href) -import Text.Blaze.Internal (string, text) import Text.Reform.Blaze.String (label, textarea, inputSubmit, inputCheckboxes, inputHidden) import qualified Text.Reform.Blaze.String as RB import Text.Reform.Happstack (environment) @@ -39,16 +36,21 @@ import Nomyx.Core.Types as T import Nomyx.Core.Mail import Nomyx.Core.Utils +import Nomyx.Core.Engine import Nomyx.Core.Session as S import Nomyx.Core.Profile as Profile default (Integer, Double, Data.Text.Text) -viewGameInfo :: GameInfo -> PlayerNumber -> Maybe LastRule -> Bool -> RoutedNomyxServer Html -viewGameInfo gi pn mlr isAdmin = do +viewGameInfo :: GameInfo -> (Maybe PlayerNumber) -> Maybe LastRule -> Bool -> RoutedNomyxServer Html +viewGameInfo gi mpn mlr isAdmin = do let g = getGame gi - let pi = Profile.getPlayerInfo g pn - let isGameAdmin = isAdmin || maybe False (== pn) (_ownedBy gi) - let playAs = maybe Nothing _playAs pi + (pi, isGameAdmin, playAs, pn) <- case mpn of + Just pn -> do + let pi = Profile.getPlayerInfo g pn + let isGameAdmin = isAdmin || maybe False (== pn) (_ownedBy gi) + let playAs = maybe Nothing _playAs pi + return (pi, isGameAdmin, playAs, pn) + Nothing -> return (Nothing, False, Nothing, 0) rf <- viewRuleForm mlr (isJust pi) isAdmin (_gameName g) vios <- viewIOs (fromMaybe pn playAs) g vgd <- viewGameDesc g playAs isGameAdmin @@ -62,16 +64,13 @@ viewGameDesc :: Game -> Maybe PlayerNumber -> Bool -> RoutedNomyxServer Html viewGameDesc g playAs gameAdmin = do vp <- viewPlayers (_players g) (_gameName g) gameAdmin - paf <- lift $ viewForm "user" $ playAsForm Nothing ok $ do p $ do - h3 $ string $ "Viewing game: " ++ _gameName g - when (isJust playAs) $ do - h4 $ string $ "You are playing as player " ++ (show $ fromJust playAs) ++ ". Cancel:" - paf + h3 $ fromString $ "Viewing game: " ++ _gameName g + when (isJust playAs) $ h4 $ fromString $ "You are playing as player " ++ (show $ fromJust playAs) p $ do h4 "Description:" - string (_desc $ _gameDesc g) + fromString (_desc $ _gameDesc g) p $ h4 $ "This game is discussed in the " >> a "Agora" ! (A.href $ toValue (_agora $ _gameDesc g)) >> "." p $ h4 "Players in game:" when gameAdmin "(click on the player's name to \"play as\" this player)" @@ -91,7 +90,7 @@ viewPlayer gn gameAdmin (PlayerInfo pn name _) = do pad <- playAsDiv pn gn ok $ tr $ do - let inf = string (show pn ++ "\t" ++ name) + let inf = fromString (show pn ++ "\t" ++ name) pad td $ if gameAdmin then a inf ! (href $ toValue $ "#openModalPlayAs" ++ show pn) @@ -106,9 +105,9 @@ let cancel = a "Cancel" ! (href $ toValue main) ! A.class_ "modalButton" div ! A.id (toValue $ "openModalPlayAs" ++ show pn) ! A.class_ "modalWindow" $ do div $ do - h2 $ string $ "When you own a game, you can play instead of any players. This allows you to test" ++ - "the result of the corresponding actions." - blazeForm (h2 (string $ "Play as player " ++ show pn ++ "? ") >> paf) submitPlayAs + h2 $ fromString $ "When you are in a private game, you can play instead of any players. This allows you to test " ++ + "the result of their actions." + blazeForm (h2 (fromString $ "Play as player " ++ show pn ++ "? ") >> paf) submitPlayAs br cancel @@ -121,8 +120,8 @@ let vs = _playerName <$> mapMaybe (Profile.getPlayerInfo g) (getVictorious g) case vs of [] -> br - a:[] -> h3 $ string $ "Player " ++ show a ++ " won the game!" - a:bs -> h3 $ string $ "Players " ++ intercalate ", " bs ++ " and " ++ a ++ " won the game!" + a:[] -> h3 $ fromString $ "Player " ++ show a ++ " won the game!" + a:bs -> h3 $ fromString $ "Players " ++ intercalate ", " bs ++ " and " ++ a ++ " won the game!" viewAllRules :: Game -> Html viewAllRules g = do @@ -134,23 +133,23 @@ viewRules :: [RuleInfo] -> String -> Bool -> Game -> Html viewRules nrs title visible g = showHideTitle title visible (null nrs) (h4 $ toHtml (title ++ ":") ) $ table ! class_ "table" $ do thead $ do - td ! class_ "td" $ text "#" - td ! class_ "td" $ text "Name" - td ! class_ "td" $ text "Description" - td ! class_ "td" $ text "Proposed by" - td ! class_ "td" $ text "Code of the rule" - td ! class_ "td" $ text "Assessed by" + td ! class_ "td" $ "#" + td ! class_ "td" $ "Name" + td ! class_ "td" $ "Description" + td ! class_ "td" $ "Proposed by" + td ! class_ "td" $ "Code of the rule" + td ! class_ "td" $ "Assessed by" forM_ nrs (viewRule g) viewRule :: Game -> RuleInfo -> Html viewRule g nr = tr $ do let pl = fromMaybe ("Player " ++ (show $ _rProposedBy nr)) (_playerName <$> (Profile.getPlayerInfo g $ _rProposedBy nr)) - td ! class_ "td" $ string . show $ _rNumber nr - td ! class_ "td" $ string $ _rName nr - td ! class_ "td" $ string $ _rDescription nr - td ! class_ "td" $ string $ if _rProposedBy nr == 0 then "System" else pl + td ! class_ "td" $ fromString . show $ _rNumber nr + td ! class_ "td" $ fromString $ _rName nr + td ! class_ "td" $ fromString $ _rDescription nr + td ! class_ "td" $ fromString $ if _rProposedBy nr == 0 then "System" else pl td ! class_ "codetd" $ viewRuleFunc nr - td ! class_ "td" $ string $ case _rAssessedBy nr of + td ! class_ "td" $ fromString $ case _rAssessedBy nr of Nothing -> "Not assessed" Just 0 -> "System" Just a -> "Rule " ++ show a @@ -177,21 +176,21 @@ viewLogs (_logs g) pn -viewEvents :: [EventHandler] -> Html +viewEvents :: [EventInfo] -> Html viewEvents ehs = table ! class_ "table" $ do thead $ do - td ! class_ "td" $ text "Event Number" - td ! class_ "td" $ text "By Rule" - td ! class_ "td" $ text "Event" + td ! class_ "td" $ "Event Number" + td ! class_ "td" $ "By Rule" + td ! class_ "td" $ "Event" mapM_ viewEvent $ sort ehs -viewEvent :: EventHandler -> Html -viewEvent (EH eventNumber ruleNumber event _ status) = if status == SActive then disp else disp ! style "background:gray;" where +viewEvent :: EventInfo -> Html +viewEvent (EventInfo eventNumber ruleNumber event _ status env) = if status == SActive then disp else disp ! style "background:gray;" where disp = tr $ do - td ! class_ "td" $ string . show $ eventNumber - td ! class_ "td" $ string . show $ ruleNumber - td ! class_ "td" $ string . show $ event + td ! class_ "td" $ fromString . show $ eventNumber + td ! class_ "td" $ fromString . show $ ruleNumber + td ! class_ "td" $ fromString . show $ getEventFields event env viewIOs :: PlayerNumber -> Game -> RoutedNomyxServer Html viewIOs pn g = do @@ -205,7 +204,7 @@ viewIORule pn g r = do vior <- viewIORuleM pn (_rNumber r) g ok $ when (isJust vior) $ div ! A.id "IORule" $ do - div ! A.id "IORuleTitle" $ h4 $ string $ "IO for Rule \"" ++ _rName r ++ "\" (#" ++ (show $ _rNumber r) ++ "):" + div ! A.id "IORuleTitle" $ h4 $ fromString $ "IO for Rule \"" ++ _rName r ++ "\" (#" ++ (show $ _rNumber r) ++ "):" fromJust vior @@ -218,7 +217,7 @@ when (isJust vor) $ fromJust vor else Nothing -viewInputsRule :: PlayerNumber -> RuleNumber -> [EventHandler] -> GameName -> RoutedNomyxServer (Maybe Html) +viewInputsRule :: PlayerNumber -> RuleNumber -> [EventInfo] -> GameName -> RoutedNomyxServer (Maybe Html) viewInputsRule pn rn ehs gn = do let filtered = filter (\e -> _ruleNumber e == rn) ehs mis <- mapM (viewInput pn gn) $ sort filtered @@ -237,35 +236,43 @@ os -> Just $ mapM_ (viewOutput g) os isPn pn (Output _ _ (Just mypn) _ SActive) = mypn == pn -isPn _ (Output _ _ Nothing _ SActive) = True +isPn _ (Output _ _ Nothing _ SActive) = True isPn _ _ = False -viewInput :: PlayerNumber -> GameName -> EventHandler -> RoutedNomyxServer (Maybe Html) -viewInput me gn (EH eventNumber _ (InputEv (Input pn title iForm)) _ SActive) | me == pn = do - link <- showURL (DoInput eventNumber gn) - lf <- lift $ viewForm "user" $ inputForm iForm - return $ Just $ tr $ td $ do - string title - string " " - blazeForm lf link ! A.id "InputForm" +viewInput :: PlayerNumber -> GameName -> EventInfo -> RoutedNomyxServer (Maybe Html) +viewInput me gn (EventInfo en _ ev _ SActive env) = do + ds <- mapMaybeM (viewInput' me gn en) (getEventFields ev env) + return $ if null ds + then Nothing + else Just $ sequence_ ds viewInput _ _ _ = return Nothing +viewInput' :: PlayerNumber -> GameName -> EventNumber -> SomeField -> RoutedNomyxServer (Maybe Html) +viewInput' me gn en ev@(SomeField (Input inputNumber pn title _)) | me == pn = do + lf <- lift $ viewForm "user" $ inputForm ev + link <- showURL (DoInput en (fromJust inputNumber) gn) + return $ Just $ tr $ td $ do + fromString title + fromString " " + blazeForm lf link ! A.id "InputForm" +viewInput' _ _ _ _ = return Nothing + viewOutput :: Game -> Output -> Html -viewOutput g o = pre $ string (evalOutput g o) >> br +viewOutput g o = pre $ fromString (evalOutput g o) >> br viewVars :: [Var] -> Html viewVars vs = table ! class_ "table" $ do thead $ do - td ! class_ "td" $ text "Rule number" - td ! class_ "td" $ text "Name" - td ! class_ "td" $ text "Value" + td ! class_ "td" $ "Rule number" + td ! class_ "td" $ "Name" + td ! class_ "td" $ "Value" mapM_ viewVar vs viewVar :: Var -> Html viewVar (Var vRuleNumber vName vData) = tr $ do - td ! class_ "td" $ string . show $ vRuleNumber - td ! class_ "td" $ string . show $ vName - td ! class_ "td" $ string . show $ vData + td ! class_ "td" $ fromString . show $ vRuleNumber + td ! class_ "td" $ fromString . show $ vName + td ! class_ "td" $ fromString . show $ vData newRuleForm :: Maybe SubmitRule -> Bool -> NomyxForm (SubmitRule, Maybe String, Maybe String) @@ -291,7 +298,7 @@ if inGame then do blazeForm lf link let msg = snd <$> mlr - when (isJust msg) $ pre $ string $ fromJust msg + when (isJust msg) $ pre $ fromString $ fromJust msg else lf ! disabled "" newRule :: GameName -> TVar Session -> RoutedNomyxServer Response @@ -301,7 +308,7 @@ admin <- getIsAdmin ts r <- liftRouteT $ eitherForm environment "user" (newRuleForm Nothing admin) link <- showURL MainPage - pn <- getPlayerNumber ts + pn <- fromJust <$> getPlayerNumber ts case r of Right (sr, Nothing, Nothing) -> do webCommand ts $ submitRule sr pn gn sh @@ -316,7 +323,7 @@ Right (sr, Nothing, Just _) -> webCommand ts $ adminSubmitRule sr pn gn sh Right (_, Just _, Just _) -> error "Impossible new rule form result" (Left _) -> liftIO $ putStrLn "cannot retrieve form data" - seeOther (link `appendAnchor` ruleFormAnchor) $ string "Redirecting..." + seeOther (link `appendAnchor` ruleFormAnchor) $ "Redirecting..." viewLogs :: [Log] -> PlayerNumber -> Html viewLogs log pn = do @@ -325,48 +332,48 @@ viewLog :: Log -> Html viewLog (Log _ t s) = tr $ do - td $ string $ formatTime defaultTimeLocale "%Y/%m/%d_%H:%M" t - td $ p $ string s + td $ fromString $ formatTime defaultTimeLocale "%Y/%m/%d_%H:%M" t + td $ p $ fromString s -newInput :: EventNumber -> GameName -> TVar Session -> RoutedNomyxServer Response -newInput en gn ts = toResponse <$> do - pn <- getPlayerNumber ts +newInput :: EventNumber -> InputNumber -> GameName -> TVar Session -> RoutedNomyxServer Response +newInput en inum gn ts = toResponse <$> do + pn <- fromJust <$> getPlayerNumber ts s <- liftIO $ atomically $ readTVar ts let g = find ((== gn) . getL gameNameLens) (_gameInfos $ _multi s) - let eventHandler = getEventHandler en (_loggedGame $ fromJust g) + let ei = getEventInfo en (_loggedGame $ fromJust g) methodM POST - r <- liftRouteT $ eitherForm environment "user" (getNomyxForm eventHandler) - link <- showURL MainPage - case r of - (Right c) -> webCommand ts $ S.inputResult pn en c gn - (Left _) -> liftIO $ putStrLn "cannot retrieve form data" - seeOther (link `appendAnchor` inputAnchor) $ string "Redirecting..." - + case (getInput ei inum) of + Nothing -> error "Input not found" + Just bs -> do + r <- liftRouteT $ eitherForm environment "user" (inputForm bs) + link <- showURL MainPage + case r of + (Right c) -> webCommand ts $ S.inputResult pn en inum c gn + (Left _) -> liftIO $ putStrLn "cannot retrieve form data" + seeOther (link `appendAnchor` inputAnchor) "Redirecting..." newPlayAs :: GameName -> TVar Session -> RoutedNomyxServer Response newPlayAs gn ts = toResponse <$> do methodM POST p <- liftRouteT $ eitherForm environment "user" $ playAsForm Nothing - pn <- getPlayerNumber ts + pn <- fromJust <$> getPlayerNumber ts case p of Right playAs -> do webCommand ts $ S.playAs (read playAs) pn gn link <- showURL MainPage - seeOther link $ string "Redirecting..." + seeOther link "Redirecting..." (Left errorForm) -> do settingsLink <- showURL $ SubmitPlayAs gn mainPage "Admin settings" "Admin settings" (blazeForm errorForm settingsLink) False True -getNomyxForm :: EventHandler -> NomyxForm UInputData -getNomyxForm (EH _ _ (InputEv (Input _ _ iForm)) _ _) = inputForm iForm -getNomyxForm _ = error "Not an Input Event" -inputForm :: (Typeable a) => InputForm a -> NomyxForm UInputData -inputForm (Radio choices) = URadioData <$> inputRadio' (zip [0..] (snd <$> choices)) (== 0) <++ label " " -inputForm Text = UTextData <$> RB.inputText "" <++ label " " -inputForm TextArea = UTextAreaData <$> textarea 50 5 "" <++ label " " -inputForm Button = pure UButtonData -inputForm (Checkbox choices) = UCheckboxData <$> inputCheckboxes (zip [0..] (snd <$> choices)) (const False) <++ label " " +inputForm :: SomeField -> NomyxForm InputData +inputForm (SomeField (Input _ _ _ (Radio choices))) = RadioData <$> inputRadio' (zip [0..] (snd <$> choices)) (== 0) <++ label " " +inputForm (SomeField (Input _ _ _ Text)) = TextData <$> RB.inputText "" <++ label " " +inputForm (SomeField (Input _ _ _ TextArea)) = TextAreaData <$> textarea 50 5 "" <++ label " " +inputForm (SomeField (Input _ _ _ Button)) = pure ButtonData +inputForm (SomeField (Input _ _ _ (Checkbox choices))) = CheckboxData <$> inputCheckboxes (zip [0..] (snd <$> choices)) (const False) <++ label " " +inputForm _ = error "Not an input form" showHideTitle :: String -> Bool -> Bool -> Html -> Html -> Html showHideTitle id visible empty title rest = do @@ -378,14 +385,14 @@ joinGame :: GameName -> TVar Session -> RoutedNomyxServer Response joinGame gn ts = do - pn <- getPlayerNumber ts + pn <- fromJust <$> getPlayerNumber ts webCommand ts (S.joinGame gn pn) link <- showURL MainPage seeOther link $ toResponse "Redirecting..." leaveGame :: GameName -> TVar Session -> RoutedNomyxServer Response leaveGame gn ts = do - pn <- getPlayerNumber ts + pn <- fromJust <$> getPlayerNumber ts webCommand ts (S.leaveGame gn pn) link <- showURL MainPage seeOther link $ toResponse "Redirecting..." @@ -398,14 +405,14 @@ forkGame :: GameName -> TVar Session -> RoutedNomyxServer Response forkGame gn ts = do - pn <- getPlayerNumber ts + pn <- fromJust <$> getPlayerNumber ts webCommand ts $ S.forkGame gn pn link <- showURL MainPage seeOther link $ toResponse "Redirecting..." viewGamePlayer :: GameName -> TVar Session -> RoutedNomyxServer Response viewGamePlayer gn ts = do - pn <- getPlayerNumber ts + pn <- fromJust <$> getPlayerNumber ts webCommand ts (S.viewGamePlayer gn pn) link <- showURL MainPage seeOther link $ toResponse "Redirecting..." @@ -414,3 +421,4 @@ titleWithHelpIcon myTitle help = table ! width "100%" $ tr $ do td ! style "text-align:left;" $ myTitle td ! style "text-align:right;" $ img ! src "/static/pictures/help.jpg" ! title (toValue help) + diff --git a/src/Nomyx/Web/Help.hs b/src/Nomyx/Web/Help.hs --- a/src/Nomyx/Web/Help.hs +++ b/src/Nomyx/Web/Help.hs @@ -38,6 +38,6 @@ getSaveFile = "With the following link, you can download the save file of the game. This allows you to load it in a local instance of the game.\n" ++ "This way, you will be able to compose and test the effects of your new rules locally, without affecting the online game. \n" ++ "The procedure is: \n" ++ - "$> cabal install Nomyx- \n" ++ + "$> cabal install Nomyx \n" ++ "$> Nomyx -r \n" ++ - "Warning: Nomyx and Nomyx-Language should have the exact same version as the online instance.\n" + "Warning: Nomyx should have the exact same version as the online instance.\n" diff --git a/src/Nomyx/Web/Login.hs b/src/Nomyx/Web/Login.hs --- a/src/Nomyx/Web/Login.hs +++ b/src/Nomyx/Web/Login.hs @@ -8,13 +8,14 @@ import Text.Blaze.Html5 hiding (map, label, br) import Text.Blaze.Html5.Attributes hiding (dir, label) import qualified Text.Blaze.Html5 as H -import Web.Routes.RouteT -import Text.Blaze.Internal import Control.Monad.State import Control.Concurrent.STM +import Control.Applicative import Happstack.Server import Web.Routes.Happstack() +import Web.Routes.RouteT import Data.Text hiding (map, zip, concatMap) +import Data.Maybe import Happstack.Auth (AuthProfileURL(..), AuthURL(..), handleAuthProfile) import Happstack.Auth.Core.Profile import Facebook (Credentials(..)) @@ -26,13 +27,13 @@ default (Integer, Double, Data.Text.Text) -- | function which generates the homepage -homePage :: TVar Session -> RoutedNomyxServer Response -homePage ts = do +notLogged :: TVar Session -> RoutedNomyxServer Response +notLogged ts = do (T.Session _ _ (Profiles acidAuth acidProfile _)) <- liftIO $ readTVarIO ts do mUserId <- getUserId acidAuth acidProfile case mUserId of Nothing -> - do loginURL <- showURL (UAuthProfile $ AuthURL A_Login) + do loginURL <- showURL (Auth $ AuthURL A_Login) mainPage' "Nomyx" "Not logged in" (H.div $ p $ do @@ -41,28 +42,28 @@ True (Just _) -> do link <- showURL MainPage - seeOther link (toResponse $ string "to game page") + seeOther link $ toResponse $ ("to game page"::String) -- | add a new player if not existing postAuthenticate :: TVar Session -> RoutedNomyxServer Response postAuthenticate ts = do - pn <- getPlayerNumber ts + pn <- fromJust <$> getPlayerNumber ts pf <- getProfile' ts pn case pf of Just _ -> do link <- showURL MainPage - seeOther link (toResponse $ string "to main page") + seeOther link $ toResponse ("to main page" :: String) Nothing -> do webCommand ts $ S.newPlayer pn defaultPlayerSettings link <- showURL PlayerSettings - seeOther link (toResponse $ string "to settings page") + seeOther link $ toResponse ("to settings page" :: String) authenticate :: AuthProfileURL -> TVar Session -> RoutedNomyxServer Response authenticate authProfileURL ts = do (T.Session _ _ Profiles{..}) <- liftIO $ atomically $ readTVar ts postPickedURL <- showURL PostAuth - nestURL UAuthProfile $ handleAuthProfile acidAuth acidProfile appTemplate Nothing Nothing postPickedURL authProfileURL + nestURL Auth $ handleAuthProfile acidAuth acidProfile appTemplate Nothing Nothing postPickedURL authProfileURL facebookAuth = Credentials {appName = "Nomyx", diff --git a/src/Nomyx/Web/MainPage.hs b/src/Nomyx/Web/MainPage.hs --- a/src/Nomyx/Web/MainPage.hs +++ b/src/Nomyx/Web/MainPage.hs @@ -13,13 +13,13 @@ import Web.Routes.PathInfo import Web.Routes.Happstack import Web.Routes.RouteT -import Text.Blaze.Internal import Control.Monad import Control.Monad.State import Data.Monoid +import Data.Maybe +import Data.String import Control.Concurrent.STM import Language.Nomyx -import Language.Nomyx.Engine import Happstack.Server as HS import System.FilePath import qualified Nomyx.Web.Help as Help @@ -38,33 +38,41 @@ import Nomyx.Core.Profile as Profile import Nomyx.Core.Utils import Nomyx.Core.Types as T +import Nomyx.Core.Engine default (Integer, Double, Data.Text.Text) -viewMulti :: PlayerNumber -> FilePath -> Session -> RoutedNomyxServer Html -viewMulti pn saveDir s = do - pfd <- getProfile s pn - let isAdmin = _pIsAdmin $ fromJustNote "viewMulti" pfd - gns <- viewGamesTab (_gameInfos $ _multi s) isAdmin saveDir pn - mgi <- liftRouteT $ lift $ getPlayersGame pn s +viewMulti :: (Maybe PlayerNumber) -> FilePath -> Session -> RoutedNomyxServer Html +viewMulti mpn saveDir s = do + (isAdmin, mgi, lr) <- case mpn of + Just pn -> do + pfd <- getProfile s pn + let isAdmin = _pIsAdmin $ fromJustNote "viewMulti" pfd + mgi <- liftRouteT $ lift $ getPlayersGame pn s + let lr = _pLastRule $ fromJustNote "viewMulti" pfd + return (isAdmin, mgi, lr) + Nothing -> return (False, getFirstGame s, Nothing) + gns <- viewGamesTab (_gameInfos $ _multi s) isAdmin saveDir mpn vg <- case mgi of - Just gi -> viewGameInfo gi pn (_pLastRule $ fromJustNote "viewMulti" pfd) isAdmin - Nothing -> ok $ h3 "Not viewing any game" + Just gi -> viewGameInfo gi mpn lr isAdmin + Nothing -> ok $ h3 "Not viewing any game" ok $ do div ! A.id "gameList" $ gns div ! A.id "game" $ vg -viewGamesTab :: [GameInfo] -> Bool -> FilePath -> PlayerNumber -> RoutedNomyxServer Html -viewGamesTab gis isAdmin saveDir pn = do - let canCreateGame = isAdmin || numberOfGamesOwned gis pn < 1 +viewGamesTab :: [GameInfo] -> Bool -> FilePath -> (Maybe PlayerNumber) -> RoutedNomyxServer Html +viewGamesTab gis isAdmin saveDir mpn = do + let canCreateGame = maybe False (\pn -> isAdmin || numberOfGamesOwned gis pn < 1) mpn let publicPrivate = partition ((== True) . _isPublic) gis - let vgi = viewGameName isAdmin canCreateGame pn + let vgi = viewGameName isAdmin canCreateGame mpn + let defLink a = if (isJust mpn) then showURL a else showURL (Auth $ AuthURL A_Login) public <- mapM vgi (fst publicPrivate) private <- mapM vgi (snd publicPrivate) - newGameLink <- showURL NewGame - settingsLink <- showURL W.PlayerSettings - advLink <- showURL Advanced - logoutURL <- showURL (UAuthProfile $ AuthURL A_Logout) + newGameLink <- defLink NewGame + settingsLink <- defLink W.PlayerSettings + advLink <- defLink Advanced + logoutURL <- defLink (Auth $ AuthURL A_Logout) + loginURL <- showURL (Auth $ AuthURL A_Login) fmods <- liftIO $ getUploadedModules saveDir ok $ do h3 "Main menu" >> br @@ -91,25 +99,27 @@ H.a "Player settings" ! (href $ toValue settingsLink) >> br H.a "Advanced" ! (href $ toValue advLink) >> br H.a "Logout" ! (href $ toValue logoutURL) >> br + H.a "Login" ! (href $ toValue loginURL) >> br -viewGameName :: Bool -> Bool -> PlayerNumber -> GameInfo -> RoutedNomyxServer Html -viewGameName isAdmin canCreateGame pn gi = do +viewGameName :: Bool -> Bool -> (Maybe PlayerNumber) -> GameInfo -> RoutedNomyxServer Html +viewGameName isAdmin canCreateGame mpn gi = do let g = getGame gi - let isGameAdmin = isAdmin || maybe False (==pn) (_ownedBy gi) + let isGameAdmin = isAdmin || maybe False (==mpn) (Just $ _ownedBy gi) let gn = _gameName g let canFork = canCreateGame let canDel = isGameAdmin let canView = isGameAdmin || _isPublic gi + let link a = if (isJust mpn) then showURL a else showURL (Auth $ AuthURL A_Login) main <- showURL W.MainPage - join <- showURL (W.JoinGame gn) - leave <- showURL (W.LeaveGame gn) - view <- showURL (W.ViewGame gn) - del <- showURL (W.DelGame gn) - fork <- showURL (W.ForkGame gn) + join <- link (W.JoinGame gn) + leave <- link (W.LeaveGame gn) + view <- link (W.ViewGame gn) + del <- link (W.DelGame gn) + fork <- link (W.ForkGame gn) ok $ if canView then tr $ do let cancel = H.a "Cancel" ! (href $ toValue main) ! A.class_ "modalButton" - td ! A.id "gameName" $ string (gn ++ " ") + td ! A.id "gameName" $ fromString (gn ++ " ") td $ H.a "View" ! (href $ toValue view) ! (A.title $ toValue Help.view) td $ H.a "Join" ! (href $ toValue $ "#openModalJoin" ++ gn) ! (A.title $ toValue Help.join) td $ H.a "Leave" ! (href $ toValue $ "#openModalLeave" ++ gn) @@ -117,7 +127,7 @@ when canFork $ td $ H.a "Fork" ! (href $ toValue $ "#openModalFork" ++ gn) div ! A.id (toValue $ "openModalJoin" ++ gn) ! A.class_ "modalWindow" $ do div $ do - h2 $ string $ "Joining the game. Please register in the Agora (see the link) and introduce yourself to the other players! \n" ++ + h2 $ fromString $ "Joining the game. Please register in the Agora (see the link) and introduce yourself to the other players! \n" ++ "If you do not wich to play, you can just view the game." cancel H.a "Join" ! (href $ toValue join) ! A.class_ "modalButton" ! (A.title $ toValue Help.join) @@ -128,32 +138,33 @@ H.a "Leave" ! (href $ toValue leave) ! A.class_ "modalButton" div ! A.id (toValue $ "openModalFork" ++ gn) ! A.class_ "modalWindow" $ do div $ do - h2 $ string $ "Fork game \"" ++ gn ++ "\"? This will create a new game based on the previous one. You will be able to test \n" ++ - "your new rules independently of the original game. The new game is private: you will be alone. Please delete it when finished." + h2 $ fromString $ "Fork game \"" ++ gn ++ "\"? This will create a new game based on the previous one. You will be able to test \n" ++ + "your new rules independently of the original game. The new game is completely private: you will be alone. Please delete it when finished." cancel H.a "Fork" ! (href $ toValue fork) ! A.class_ "modalButton" else "" nomyxPage :: TVar Session -> RoutedNomyxServer Response nomyxPage ts = do - pn <- getPlayerNumber ts + mpn <- getPlayerNumber ts s <- liftIO $ atomically $ readTVar ts let saveDir = _saveDir $ _mSettings $ _multi s - name <- liftIO $ Profile.getPlayerName pn s - pn <- getPlayerNumber ts - m <- viewMulti pn saveDir s + name <- case mpn of + Just pn -> liftIO $ Profile.getPlayerName pn s + Nothing -> return "Guest" + m <- viewMulti mpn saveDir s mainPage' "Welcome to Nomyx!" - (string $ "Welcome to Nomyx, " ++ name ++ "! ") + (fromString $ "Welcome to Nomyx, " ++ name ++ "! ") (H.div ! A.id "multi" $ m) False nomyxSite :: TVar Session -> Site PlayerCommand (ServerPartT IO Response) -nomyxSite tm = setDefault HomePage $ mkSitePI (runRouteT $ catchRouteError . flip routedNomyxCommands tm) +nomyxSite tm = setDefault MainPage $ mkSitePI (runRouteT $ catchRouteError . flip routedNomyxCommands tm) routedNomyxCommands :: PlayerCommand -> (TVar Session) -> RoutedNomyxServer Response -routedNomyxCommands (UAuthProfile auth) = authenticate auth +routedNomyxCommands NotLogged = notLogged +routedNomyxCommands (Auth auth) = authenticate auth routedNomyxCommands PostAuth = postAuthenticate -routedNomyxCommands HomePage = homePage routedNomyxCommands MainPage = nomyxPage routedNomyxCommands (W.JoinGame game) = joinGame game routedNomyxCommands (W.LeaveGame game) = leaveGame game @@ -163,7 +174,7 @@ routedNomyxCommands (NewRule game) = newRule game routedNomyxCommands NewGame = newGamePage routedNomyxCommands SubmitNewGame = newGamePost -routedNomyxCommands (DoInput en game) = newInput en game +routedNomyxCommands (DoInput en inn game) = newInput en inn game routedNomyxCommands Upload = newUpload routedNomyxCommands W.PlayerSettings = playerSettings routedNomyxCommands SubmitPlayerSettings = newPlayerSettings @@ -198,8 +209,8 @@ backToLogin :: RoutedNomyxServer Response backToLogin = toResponse <$> do - link <- showURL HomePage - seeOther link $ string "Redirecting..." + link <- showURL NotLogged + seeOther link ("Redirecting..." :: String) getDocDir :: IO FilePath getDocDir = do diff --git a/src/Nomyx/Web/NewGame.hs b/src/Nomyx/Web/NewGame.hs --- a/src/Nomyx/Web/NewGame.hs +++ b/src/Nomyx/Web/NewGame.hs @@ -6,7 +6,6 @@ import Prelude hiding (div) import Text.Reform import Text.Blaze.Html5.Attributes hiding (label) -import Text.Blaze.Internal(string) import Text.Reform.Blaze.String as RB hiding (form) import Text.Reform.Happstack import qualified Text.Reform.Blaze.Common as RBC @@ -16,7 +15,8 @@ import Happstack.Server import Web.Routes.RouteT import Data.Text(Text) -import Language.Nomyx.Engine +import Data.Maybe +import Nomyx.Core.Engine import Nomyx.Web.Common import Nomyx.Core.Session import Nomyx.Core.Types @@ -55,9 +55,9 @@ r <- liftRouteT $ eitherForm environment "user" (newGameForm admin) link <- showURL MainPage newGameLink <- showURL SubmitNewGame - pn <- getPlayerNumber ts + pn <- fromJust <$> getPlayerNumber ts case r of Left errorForm -> mainPage "New game" "New game" (blazeForm errorForm newGameLink) False True Right (NewGameForm name desc isPublic) -> do webCommand ts $ newGame name desc pn isPublic - seeOther link $ string "Redirecting..." + seeOther link "Redirecting..." diff --git a/src/Nomyx/Web/Settings.hs b/src/Nomyx/Web/Settings.hs --- a/src/Nomyx/Web/Settings.hs +++ b/src/Nomyx/Web/Settings.hs @@ -10,7 +10,6 @@ import Text.Reform.Happstack import Text.Reform.Blaze.String as RB hiding (form) import Text.Blaze.Html5.Attributes as A hiding (dir, label) -import Text.Blaze.Internal hiding (Text) import qualified Text.Blaze.Html5 as H import Happstack.Server import Web.Routes.RouteT @@ -20,6 +19,8 @@ import Safe import Data.Text(Text) import Data.Version (showVersion) +import Data.Maybe +import Data.String import System.FilePath import Paths_Nomyx_Web as PNW import Language.Nomyx @@ -47,10 +48,6 @@ <*> pure True <*> pure True -readPlayAs :: NomyxForm Bool -> NomyxForm String -> NomyxForm (Maybe PlayerNumber) -readPlayAs = liftA2 f where - f b s = if b then Just $ read s else Nothing - uniqueName :: [String] -> String -> Either NomyxError String uniqueName names name = if name `elem` names then Left UniqueName else Right name @@ -72,7 +69,7 @@ playerSettings :: TVar Session -> RoutedNomyxServer Response playerSettings ts = toResponse <$> do - pn <- getPlayerNumber ts + pn <- fromJust <$> getPlayerNumber ts pfd <- getProfile' ts pn names <- liftIO $ forbiddenNames ts pn emails <- liftIO $ forbiddenEmails ts pn @@ -81,7 +78,7 @@ newPlayerSettings :: TVar Session -> RoutedNomyxServer Response newPlayerSettings ts = toResponse <$> do methodM POST - pn <- getPlayerNumber ts + pn <- fromJust <$> getPlayerNumber ts names <- liftIO $ forbiddenNames ts pn emails <- liftIO $ forbiddenEmails ts pn p <- liftRouteT $ eitherForm environment "user" $ playerSettingsForm Nothing names emails @@ -89,7 +86,7 @@ Right ps -> do webCommand ts $ S.playerSettings ps pn link <- showURL MainPage - seeOther link $ string "Redirecting..." + seeOther link $ fromString "Redirecting..." (Left errorForm) -> do settingsLink <- showURL SubmitPlayerSettings mainPage "Player settings" "Player settings" (blazeForm errorForm settingsLink) False True @@ -112,7 +109,7 @@ advanced :: TVar Session -> RoutedNomyxServer Response advanced ts = toResponse <$> do session <- liftIO $ atomically $ readTVar ts - pn <- getPlayerNumber ts + pn <- fromJust <$> getPlayerNumber ts pfd <- getProfile session pn pfds <- liftIO $ getAllProfiles session session <- liftIO $ atomically $ readTVar ts @@ -136,16 +133,16 @@ let uploadExample = pathSeparator : testDir "SimpleModule.hs" ok $ do p $ do - string "Version:" - pre $ string $ "Nomyx " ++ showVersion PNW.version ++ "\n" + fromString "Version:" + pre $ fromString $ "Nomyx " ++ showVersion PNW.version ++ "\n" hr p $ do - pre $ string Help.getSaveFile + pre $ fromString Help.getSaveFile H.a "get save file" ! (href $ toValue getSaveFile) H.br hr p $ do - pre $ string Help.upload + pre $ fromString Help.upload H.a "example upload file" ! (href $ toValue uploadExample) H.br >> H.br "Upload new rules file:" >> H.br @@ -153,7 +150,7 @@ case mlu of UploadFailure (_, error) -> do h5 "Error in submitted file: " - pre $ string error + pre $ fromString error UploadSuccess -> h5 "File uploaded successfully!" NoUpload -> p "" hr @@ -166,7 +163,7 @@ p $ do h5 "Send mails:" blazeForm set submitSettings - h5 $ string $ if _sendMails settings then "mails will be sent " else "mails will NOT be sent " + h5 $ fromString $ if _sendMails settings then "mails will be sent " else "mails will NOT be sent " hr p $ do h5 "Players:" @@ -187,22 +184,19 @@ viewProfile :: ProfileData -> Html viewProfile (ProfileData pn (Types.PlayerSettings playerName mail _ mailNewRule _ _) viewingGame lastRule lastUpload isAdmin) = tr $ do - td ! A.class_ "td" $ string $ show pn - td ! A.class_ "td" $ string playerName - td ! A.class_ "td" $ string mail - td ! A.class_ "td" $ string $ show mailNewRule - td ! A.class_ "td" $ string $ show viewingGame - td ! A.class_ "td" $ string $ show lastRule - td ! A.class_ "td" $ string $ show lastUpload - td ! A.class_ "td" $ string $ show isAdmin + td ! A.class_ "td" $ fromString $ show pn + td ! A.class_ "td" $ fromString playerName + td ! A.class_ "td" $ fromString mail + td ! A.class_ "td" $ fromString $ show mailNewRule + td ! A.class_ "td" $ fromString $ show viewingGame + td ! A.class_ "td" $ fromString $ show lastRule + td ! A.class_ "td" $ fromString $ show lastUpload + td ! A.class_ "td" $ fromString $ show isAdmin adminPassForm :: NomyxForm String adminPassForm = RB.inputText "" -playAsForm :: [PlayerNumber] -> NomyxForm (Maybe PlayerNumber) -playAsForm _ = readPlayAs (label "Play as: " ++> RB.inputCheckbox False) (RB.inputText "") - settingsForm :: Bool -> NomyxForm Bool settingsForm sendMails = label "Send mails: " ++> RB.inputCheckbox sendMails @@ -214,7 +208,7 @@ Right ps -> do webCommand ts $ globalSettings ps link <- showURL Advanced - seeOther link $ string "Redirecting..." + seeOther link "Redirecting..." (Left errorForm) -> do settingsLink <- showURL SubmitSettings mainPage "Admin settings" "Admin settings" (blazeForm errorForm settingsLink) False True @@ -226,26 +220,26 @@ newUpload :: TVar Session -> RoutedNomyxServer Response newUpload ts = toResponse <$> do methodM POST - pn <- getPlayerNumber ts + pn <- fromJust <$> getPlayerNumber ts r <- liftRouteT $ eitherForm environment "user" uploadForm link <- showURL Advanced (Types.Session sh _ _) <- liftIO $ readTVarIO ts case r of (Right (temp,name,_)) -> webCommand ts $ void $ S.inputUpload pn temp name sh (Left _) -> liftIO $ putStrLn "cannot retrieve form data" - seeOther link $ string "Redirecting..." + seeOther link "Redirecting..." newAdminPass :: TVar Session -> RoutedNomyxServer Response newAdminPass ts = toResponse <$> do methodM POST p <- liftRouteT $ eitherForm environment "user" adminPassForm - pn <- getPlayerNumber ts + pn <- fromJust <$> getPlayerNumber ts case p of Right ps -> do webCommand ts $ adminPass ps pn link <- showURL Advanced - seeOther link $ string "Redirecting..." + seeOther link "Redirecting..." (Left errorForm) -> do settingsLink <- showURL SubmitAdminPass mainPage "Admin settings" "Admin settings" (blazeForm errorForm settingsLink) False True @@ -254,4 +248,4 @@ saveFilePage ts = toResponse <$> do session <- liftIO $ atomically $ readTVar ts liftIO $ makeTar (_saveDir $ _mSettings $ _multi session) - seeOther (pathSeparator : tarFile) $ string "Redirecting..." + seeOther (pathSeparator : tarFile) "Redirecting..."