Nomyx-Web 0.5.0 → 0.6.0
raw patch · 9 files changed
+220/−207 lines, 9 filesdep ~Nomyx-Coredep ~Nomyx-Language
Dependency ranges changed: Nomyx-Core, Nomyx-Language
Files
- Nomyx-Web.cabal +4/−4
- README.md +0/−2
- src/Nomyx/Web/Common.hs +24/−23
- src/Nomyx/Web/Game.hs +97/−89
- src/Nomyx/Web/Help.hs +2/−2
- src/Nomyx/Web/Login.hs +11/−10
- src/Nomyx/Web/MainPage.hs +52/−41
- src/Nomyx/Web/NewGame.hs +4/−4
- src/Nomyx/Web/Settings.hs +26/−32
Nomyx-Web.cabal view
@@ -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
README.md view
@@ -1,5 +1,3 @@-[](https://travis-ci.org/cdupont/Nomyx-Web)-[](https://hackage.haskell.org/package/Nomyx-Web) Nomyx-Web ========
src/Nomyx/Web/Common.hs view
@@ -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
src/Nomyx/Web/Game.hs view
@@ -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)+
src/Nomyx/Web/Help.hs view
@@ -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-<version> \n" +++ "$> cabal install Nomyx \n" ++ "$> Nomyx -r <save file name>\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"
src/Nomyx/Web/Login.hs view
@@ -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",
src/Nomyx/Web/MainPage.hs view
@@ -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
src/Nomyx/Web/NewGame.hs view
@@ -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..."
src/Nomyx/Web/Settings.hs view
@@ -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..."