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.7.2 +version: 0.7.3 cabal-version: >=1.6 build-type: Simple license: BSD3 @@ -16,8 +16,8 @@ extra-source-files: README.md library - build-depends: Nomyx-Language == 0.7.2, - Nomyx-Core == 0.7.2, + build-depends: Nomyx-Language == 0.7.3, + Nomyx-Core == 0.7.3, base >= 4.6 && <5, blaze-html == 0.7.*, blaze-markup == 0.6.*, @@ -26,7 +26,7 @@ data-lens-fd == 2.0.*, fb >= 0.15 && < 2, filepath == 1.3.*, - happstack-authenticate == 0.10.*, + happstack-authenticate == 0.10.15, happstack-server == 7.3.*, hscolour == 1.20.*, mtl == 2.1.*, @@ -50,10 +50,14 @@ Paths_Nomyx_Web other-modules: Nomyx.Web.Common Nomyx.Web.Help - Nomyx.Web.NewGame - Nomyx.Web.Game + Nomyx.Web.Game.Infos + Nomyx.Web.Game.Rules + Nomyx.Web.Game.IOs + Nomyx.Web.Game.NewRule + Nomyx.Web.Game.Details Nomyx.Web.Login Nomyx.Web.Settings + Nomyx.Web.NewGame ghc-options: -W -threaded source-repository head diff --git a/data/static/css/nomyx.css b/data/static/css/nomyx.css --- a/data/static/css/nomyx.css +++ b/data/static/css/nomyx.css @@ -6,19 +6,28 @@ position:absolute; background-color:#F4F4F4; border:1px solid black; - width:250px; + width:180px; padding:10px; top:60px; left:10px; overflow: auto; } -#game { +#titleBar { + padding-top:7px; + padding-bottom:10px; +} + +#titleBar > a:first-child { + font-weight:bold; +} + +.game { position:absolute; background-color:#FFFFFF; height:90%; top:57px; - left:288px; + left:218px; right:10px; padding-right:23px; overflow: auto; @@ -76,13 +85,13 @@ padding:10px; } -#ios, #details, #rules, #newRule, #gameDesc { +.gameBox { + position:absolute; float:left; background-color:#F4F4F4; border:1px solid black; - padding-left:10px; - padding-right:10px; - width:100%; + padding:10px; + width:98%; margin-bottom:5px; } @@ -90,8 +99,16 @@ text-align:right; } -#gameName { - padding-right: 10px; +.button { + text-decoration: none; + background-color: #EEEEEE; + color: #333333; + padding: 2px 6px 2px 6px; + border-top: 1px solid #CCCCCC; + border-right: 1px solid #333333; + border-bottom: 1px solid #333333; + border-left: 1px solid #CCCCCC; + margin:3px; } #header { diff --git a/data/static/nomyx.js b/data/static/nomyx.js --- a/data/static/nomyx.js +++ b/data/static/nomyx.js @@ -13,3 +13,30 @@ show.innerHTML ='[Click to show]'; } } + +//toggle visibility for overlapping divs +//all elements with the class name will be pushed back, +//while only the element with the id name is put on front +function div_visibility(id_box, class_box, id_button, class_button) +{ + //push back every divs + var boxes = document.getElementsByClassName(class_box); + for (i = 0; i < boxes.length; i++) { + boxes[i].style.display = 'none'; + } + + //pull front our div + var myBox = document.getElementById(id_box); + myBox.style.display = 'inline'; + + //unbold the text in the buttons + var buttons = document.getElementsByClassName(class_button); + for (i = 0; i < buttons.length; i++) { + buttons[i].style.fontWeight = 'normal'; + } + + //pull front our div + var myButton = document.getElementById(id_button); + myButton.style.fontWeight = 'bold'; + +} 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 @@ -11,7 +11,6 @@ module Nomyx.Web.Common where - import Prelude hiding (div) import Safe import Text.Blaze.Html5 hiding (map, output, base) @@ -26,11 +25,12 @@ import Control.Monad.State import Control.Concurrent.STM import Happstack.Server as HS -import Happstack.Auth (UserId(..), getUserId, AuthProfileURL) +import Happstack.Auth (UserId(..), getUserId, AuthProfileURL(..), AuthURL(..)) import qualified Data.ByteString.Char8 as C import Data.Maybe import Data.Text (unpack, append, Text, pack) import Data.String +import Text.Printf import Text.Reform.Happstack() import Text.Reform import Text.Reform.Blaze.String() @@ -69,12 +69,10 @@ | Auth AuthProfileURL | PostAuth | MainPage - | ViewGame GameName | JoinGame GameName | LeaveGame GameName | DelGame GameName - | ForkGame GameName - | DoInput EventNumber FieldAddress FormField GameName + | DoInput EventNumber SignalAddress FormField GameName | NewRule GameName | NewGame | SubmitNewGame @@ -95,8 +93,8 @@ type RoutedNomyxServer a = RouteT PlayerCommand (ServerPartT IO) a -instance PathInfo FieldAddressElem -instance PathInfo FieldAddress +instance PathInfo SignalAddressElem +instance PathInfo SignalAddress instance PathInfo FormField instance PathInfo (Int, String) instance PathInfo [(Int, String)] @@ -189,8 +187,8 @@ webCommand :: TVar Session -> StateT Session IO () -> RoutedNomyxServer () webCommand ts ss = liftIO $ updateSession ts ss -getIsAdmin :: TVar Session -> RoutedNomyxServer Bool -getIsAdmin ts = do +isAdmin :: TVar Session -> RoutedNomyxServer Bool +isAdmin ts = do mpn <- getPlayerNumber ts case mpn of Just pn -> do @@ -200,6 +198,20 @@ Nothing -> return False Nothing -> return False +isGameAdmin :: GameInfo -> TVar Session -> RoutedNomyxServer Bool +isGameAdmin gi ts = do + mpn <- getPlayerNumber ts + admin <- isAdmin ts + return $ case mpn of + Just pn -> admin || (_ownedBy gi == Just pn) + Nothing -> False + +getPublicGames :: TVar Session -> RoutedNomyxServer [GameInfo] +getPublicGames ts = do + (T.Session _ m _) <- liftIO $ readTVarIO ts + return $ filter ((== True) . _isPublic) (_gameInfos $ m) + + fieldRequired :: NomyxError -> String -> Either NomyxError String fieldRequired a [] = Left a fieldRequired _ str = Right str @@ -218,6 +230,37 @@ getFirstGame :: Session -> Maybe GameInfo getFirstGame = headMay . (filter _isPublic) ._gameInfos . _multi + +showHideTitle :: String -> Bool -> Bool -> Html -> Html -> Html +showHideTitle id visible empty title rest = do + div ! onclick (fromString $ printf "toggle_visibility('%sBody', '%sShow')" id id) $ table ! width "100%" $ tr $ do + td $ title ! width "80%" + td ! A.style "text-align:right;" $ h5 (if visible then "[Click to hide]" else "[Click to show]") ! A.id (fromString $ printf "%sShow" id) ! width "20%" + div ! A.id (fromString $ printf "%sBody" id) ! A.style (fromString $ "display:" ++ (if visible then "block;" else "none;")) $ + if empty then toHtml $ "No " ++ id else rest + +titleWithHelpIcon :: Html -> String -> Html +titleWithHelpIcon myTitle help = table ! width "100%" $ tr $ do + td ! A.style "text-align:left;" $ myTitle + td ! A.style "text-align:right;" $ img ! src "/static/pictures/help.jpg" ! A.title (toValue help) + +--mapping for the javascript function. +divVisibility :: GameName -> String -> String -> String +divVisibility gn boxName className = + printf "div_visibility('%s', '%s', '%s', '%s')" + (getIdBox gn boxName) + (getClassBox gn className) + (getIdButton gn boxName) + (getClassButton gn className) + +getIdBox, getClassBox, getIdButton, getClassButton :: String -> String -> String +getIdBox gn boxName = gn ++ "IdBox" ++ boxName +getClassBox gn className = gn ++ "ClassBox" ++ className +getIdButton gn boxName = gn ++ "IdButton" ++ boxName +getClassButton gn className = gn ++ "ClassButton" ++ className + +defLink :: PlayerCommand -> Bool -> RoutedNomyxServer Text +defLink a logged = if logged then showURL a else showURL (Auth $ AuthURL A_Login) instance FormError NomyxError where type ErrorInputType NomyxError = [HS.Input] diff --git a/src/Nomyx/Web/Game.hs b/src/Nomyx/Web/Game.hs deleted file mode 100644 --- a/src/Nomyx/Web/Game.hs +++ /dev/null @@ -1,434 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ExtendedDefaultRules #-} -{-# LANGUAGE DoAndIfThenElse #-} - -module Nomyx.Web.Game where - -import Prelude hiding (div) -import qualified Prelude -import Control.Monad -import Control.Monad.State -import Control.Concurrent.STM -import Control.Applicative -import Data.Monoid -import Data.Maybe -import Data.String -import Data.List -import Data.List.Split -import Data.Text (Text) -import Data.Time -import Text.Printf -import System.Locale -import Language.Nomyx -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.Reform.Blaze.String (label, textarea, inputSubmit, inputCheckboxes, inputHidden) -import qualified Text.Reform.Blaze.String as RB -import Text.Reform.Happstack (environment) -import Text.Reform ((<++), (++>), viewForm, eitherForm) -import Text.Reform.Blaze.Common (setAttr) -import Happstack.Server (Response, Method(..), seeOther, toResponse, methodM, ok) -import Web.Routes.RouteT (showURL, liftRouteT) -import Safe -import qualified Nomyx.Web.Help as Help -import Nomyx.Web.Common as NWC -import Nomyx.Core.Types as T -import Nomyx.Core.Mail -import Nomyx.Core.Engine -import Nomyx.Core.Session as S -import Nomyx.Core.Profile as Profile -default (Integer, Double, Data.Text.Text) - -viewGameInfo :: GameInfo -> (Maybe PlayerNumber) -> Maybe LastRule -> Bool -> RoutedNomyxServer Html -viewGameInfo gi mpn mlr isAdmin = do - let g = getGame gi - (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 - ok $ table $ do - tr $ td $ div ! A.id "gameDesc" $ vgd - tr $ td $ div ! A.id "rules" $ viewAllRules g - tr $ td $ div ! A.id "ios" $ vios - tr $ td $ div ! A.id "newRule" $ rf - tr $ td $ div ! A.id "details" $ viewDetails pn g - -viewGameDesc :: Game -> Maybe PlayerNumber -> Bool -> RoutedNomyxServer Html -viewGameDesc g playAs gameAdmin = do - vp <- viewPlayers (_players g) (_gameName g) gameAdmin - ok $ do - p $ do - h3 $ fromString $ "Viewing game: " ++ _gameName g - when (isJust playAs) $ h4 $ fromString $ "You are playing as player " ++ (show $ fromJust playAs) - p $ pre $ 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 a player name to \"play as\" this player)" - vp - p $ viewVictory g - - -viewPlayers :: [PlayerInfo] -> GameName -> Bool -> RoutedNomyxServer Html -viewPlayers pis gn gameAdmin = do - let plChunks = transpose $ chunksOf 15 (sort pis) - vp <- mapM mkRow plChunks - ok $ table $ mconcat vp - where mkRow :: [PlayerInfo] -> RoutedNomyxServer Html - mkRow row = do - r <- mapM (viewPlayer gn gameAdmin) row - ok $ tr $ mconcat r - - -viewPlayer :: GameName -> Bool -> PlayerInfo -> RoutedNomyxServer Html -viewPlayer gn gameAdmin (PlayerInfo pn name _) = do - pad <- playAsDiv pn gn - let inf = fromString name - ok $ do - pad - td $ div ! A.id "playerNumber" $ fromString $ show pn - td $ div ! A.id "playerName" $ if gameAdmin - then a inf ! (href $ toValue $ "#openModalPlayAs" ++ show pn) - else inf - -playAsDiv :: PlayerNumber -> GameName -> RoutedNomyxServer Html -playAsDiv pn gn = do - submitPlayAs <- showURL $ SubmitPlayAs gn - main <- showURL MainPage - paf <- lift $ viewForm "user" $ playAsForm $ Just pn - ok $ do - let cancel = a "Cancel" ! (href $ toValue main) ! A.class_ "modalButton" - div ! A.id (toValue $ "openModalPlayAs" ++ show pn) ! A.class_ "modalWindow" $ do - div $ do - 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 - -playAsForm :: Maybe PlayerNumber -> NomyxForm String -playAsForm pn = inputHidden (show pn) - - -viewVictory :: Game -> Html -viewVictory g = do - let vs = _playerName <$> mapMaybe (Profile.getPlayerInfo g) (getVictorious g) - case vs of - [] -> br - 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 - titleWithHelpIcon (h3 "Rules") Help.rules - viewRules (activeRules g) "Active rules" True g >> br - viewRules (pendingRules g) "Pending rules" True g >> br - viewRules (rejectedRules g) "Suppressed rules" False g >> br - -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" $ "#" - td ! class_ "td" $ "Name" - td ! class_ "td" $ "Description" - td ! class_ "td" $ "Code of the rule" - forM_ nrs (viewRule g) - -viewRule :: Game -> RuleInfo -> Html -viewRule g ri = tr $ do - let pl = fromMaybe ("Player " ++ (show $ _rProposedBy ri)) (_playerName <$> (Profile.getPlayerInfo g $ _rProposedBy ri)) - td ! class_ "td" $ p (fromString . show $ _rNumber ri) ! A.id "ruleNumber" - td ! class_ "td" $ do - div ! A.id "ruleName" $ (fromString $ _rName ri) - br - div ! A.id "proposedBy" $ (fromString $ "by " ++ (if _rProposedBy ri == 0 then "System" else pl)) - td ! class_ "td" $ fromString $ _rDescription ri - td ! class_ "td" $ viewRuleFunc ri - -viewRuleFunc :: RuleInfo -> Html -viewRuleFunc ri = do - let code = lines $ _rRuleCode ri - let codeCutLines = 7 - let ref = "openModalCode" ++ (show $ _rNumber ri) - let assessedBy = case _rAssessedBy ri of - Nothing -> "not assessed" - Just 0 -> "the system" - Just a -> "rule " ++ show a - div ! A.id "showCodeLink" $ a ! (href $ toValue $ "#" ++ ref) $ "show more..." >> br - div ! A.id "codeDiv" $ displayCode $ unlines $ take codeCutLines code - div $ when (length code >= codeCutLines) $ fromString "(...)" - div ! A.id (toValue ref) ! class_ "modalDialog" $ do - div $ do - p "Code of the rule:" - a ! href "#close" ! title "Close" ! class_ "close" $ "X" - div ! A.id "modalCode" $ do - displayCode $ unlines code - br - case _rStatus ri of - Active -> (fromString $ "This rule was activated by " ++ assessedBy ++ ".") ! A.id "assessedBy" - Reject -> (fromString $ "This rule was deleted by " ++ assessedBy ++ ".") ! A.id "assessedBy" - Pending -> return () - -viewDetails :: PlayerNumber -> Game -> Html -viewDetails pn g = showHideTitle "Details" False False (h3 "Details") $ do - p $ titleWithHelpIcon (h4 "Variables:") Help.variables - viewVars (_variables g) - p $ titleWithHelpIcon (h4 "Events:") Help.events - viewEvents g - p $ h4 "Log:" - viewLogs (_logs g) pn - -viewEvents :: Game -> Html -viewEvents g = table ! class_ "table" $ do - thead $ do - td ! class_ "td" $ "Event Number" - td ! class_ "td" $ "By Rule" - td ! class_ "td" $ "Event" - mapM_ (viewEvent g) (sort $ _events g) - -viewEvent :: Game -> EventInfo -> Html -viewEvent g ei@(EventInfo eventNumber ruleNumber _ _ status _) = if status == SActive then disp else disp ! style "background:gray;" where - disp = tr $ do - td ! class_ "td" $ fromString . show $ eventNumber - td ! class_ "td" $ fromString . show $ ruleNumber - td ! class_ "td" $ fromString . show $ getEventFields ei g - -viewIOs :: PlayerNumber -> Game -> RoutedNomyxServer Html -viewIOs pn g = do - vios <- mapM (viewIORule pn g) (sort $ _rules g) - ok $ do - titleWithHelpIcon (h3 "Inputs/Ouputs") Help.inputsOutputs - a "" ! A.id (toValue inputAnchor) - mconcat vios - -viewIORule :: PlayerNumber -> Game -> RuleInfo -> RoutedNomyxServer Html -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 $ fromString $ "Rule #" ++ (show $ _rNumber r) ++ " \"" ++ _rName r ++ "\": " - fromJust vior - - -viewIORuleM :: PlayerNumber -> RuleNumber -> Game -> RoutedNomyxServer (Maybe Html) -viewIORuleM pn rn g = do - vir <- viewInputsRule pn rn (_events g) g - let vor = viewOutputsRule pn rn g - return $ if isJust vir || isJust vor then Just $ do - when (isJust vir) $ fromJust vir - when (isJust vor) $ fromJust vor - else Nothing - -viewInputsRule :: PlayerNumber -> RuleNumber -> [EventInfo] -> Game -> RoutedNomyxServer (Maybe Html) -viewInputsRule pn rn ehs g = do - let filtered = filter (\e -> _ruleNumber e == rn) ehs - mis <- mapM (viewInput pn g) $ sort filtered - let is = catMaybes mis - case is of - [] -> return Nothing - i -> return $ Just $ table $ mconcat i - -viewOutputsRule :: PlayerNumber -> RuleNumber -> Game -> Maybe Html -viewOutputsRule pn rn g = do - let filtered = filter (\o -> _oRuleNumber o == rn && _oStatus o == SActive) (_outputs g) - let myos = filter (isPn pn) (sort filtered) - case myos of - [] -> Nothing - os -> Just $ sequence_ $ mapMaybe (viewOutput g) os - -isPn pn (Output _ _ (Just mypn) _ SActive) = mypn == pn -isPn _ (Output _ _ Nothing _ SActive) = True -isPn _ _ = False - -viewInput :: PlayerNumber -> Game -> EventInfo -> RoutedNomyxServer (Maybe Html) -viewInput me g ei@(EventInfo en _ _ _ SActive _) = do - ds <- mapMaybeM (viewInput' me (_gameName g) en) (getEventFields ei g) - return $ if null ds - then Nothing - else Just $ sequence_ ds -viewInput _ _ _ = return Nothing - -viewInput' :: PlayerNumber -> GameName -> EventNumber -> (FieldAddress, SomeField) -> RoutedNomyxServer (Maybe Html) -viewInput' me gn en (fa, ev@(SomeField (Input pn title _))) | me == pn = do - lf <- lift $ viewForm "user" $ inputForm ev - link <- showURL (DoInput en fa (fromJust $ getFormField ev) gn) - return $ Just $ tr $ td $ do - fromString title - fromString " " - blazeForm lf link ! A.id "InputForm" -viewInput' _ _ _ _ = return Nothing - -viewOutput :: Game -> Output -> Maybe Html -viewOutput g o = if (s /= "") then Just (pre $ fromString s >> br) else Nothing where - s = (evalOutput g o) - -viewVars :: [Var] -> Html -viewVars vs = table ! class_ "table" $ do - thead $ do - 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" $ 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) -newRuleForm (Just sr) isAdmin = newRuleForm' sr isAdmin -newRuleForm Nothing isAdmin = newRuleForm' (SubmitRule "" "" "") isAdmin - -newRuleForm' :: SubmitRule -> Bool -> NomyxForm (SubmitRule, Maybe String, Maybe String) -newRuleForm' (SubmitRule name desc code) isAdmin = - (,,) <$> (SubmitRule <$> label "Name: " ++> RB.inputText name `setAttr` class_ "ruleName" - <*> (label " Short description: " ++> (RB.inputText desc `setAttr` class_ "ruleDescr") <++ RB.br) - <*> label " Code: " ++> textarea 80 15 code `setAttr` class_ "ruleCode" `setAttr` placeholder "Enter here your rule") - <*> inputSubmit "Check" - <*> if isAdmin then inputSubmit "Admin submit" else pure Nothing - - -viewRuleForm :: Maybe LastRule -> Bool -> Bool -> GameName -> RoutedNomyxServer Html -viewRuleForm mlr inGame isAdmin gn = do - link <- showURL (NewRule gn) - lf <- lift $ viewForm "user" (newRuleForm (fst <$> mlr) isAdmin) - ok $ do - a "" ! A.id (toValue ruleFormAnchor) - titleWithHelpIcon (h3 "Propose a new rule:") Help.code - if inGame then do - blazeForm lf link - let msg = snd <$> mlr - when (isJust msg) $ pre $ fromString $ fromJust msg - else lf ! disabled "" - -newRule :: GameName -> TVar Session -> RoutedNomyxServer Response -newRule gn ts = toResponse <$> do - methodM POST - s@(T.Session sh _ _) <- liftIO $ readTVarIO ts - admin <- getIsAdmin ts - r <- liftRouteT $ eitherForm environment "user" (newRuleForm Nothing admin) - link <- showURL MainPage - pn <- fromJust <$> getPlayerNumber ts - case r of - Right (sr, Nothing, Nothing) -> do - webCommand ts $ submitRule sr pn gn sh - liftIO $ do - s' <- readTVarIO ts --TODO clean this - gn <- getPlayersGame pn s - gn' <- getPlayersGame pn s' - let rs = _rules $ _game $ _loggedGame $ fromJustNote "newRule" gn - let rs' = _rules $ _game $ _loggedGame $ fromJustNote "newRule" gn' - when (length rs' > length rs) $ sendMailsNewRule s' sr pn - Right (sr, Just _, Nothing) -> webCommand ts $ checkRule sr pn sh - 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) $ "Redirecting..." - -viewLogs :: [Log] -> PlayerNumber -> Html -viewLogs log pn = do - let ls = filter (\o -> (_lPlayerNumber o == Just pn) || (isNothing $ _lPlayerNumber o)) log - table $ mapM_ viewLog (reverse ls) - -viewLog :: Log -> Html -viewLog (Log _ t s) = tr $ do - td $ fromString $ formatTime defaultTimeLocale "%Y/%m/%d_%H:%M" t - td $ p $ fromString s - --- | a form result has been sent -newInput :: EventNumber -> FieldAddress -> FormField -> GameName -> TVar Session -> RoutedNomyxServer Response -newInput en fa ft gn ts = toResponse <$> do - pn <- fromJust <$> getPlayerNumber ts - link <- showURL MainPage - methodM POST - r <- liftRouteT $ eitherForm environment "user" (inputForm' ft) - case r of - (Right c) -> webCommand ts $ S.inputResult pn en fa ft 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 <- fromJust <$> getPlayerNumber ts - case p of - Right playAs -> do - webCommand ts $ S.playAs (read playAs) pn gn - link <- showURL MainPage - seeOther link "Redirecting..." - (Left errorForm) -> do - settingsLink <- showURL $ SubmitPlayAs gn - mainPage "Admin settings" "Admin settings" (blazeForm errorForm settingsLink) False True - --- TODO: merge SomeField and FormField... -inputForm :: SomeField -> NomyxForm InputData -inputForm (SomeField (Input _ _ (Radio choices))) = RadioData <$> NWC.inputRadio' (zip [0..] (snd <$> choices)) (== 0) <++ label (" " :: String) -inputForm (SomeField (Input _ _ Text)) = TextData <$> RB.inputText "" <++ label (" " :: String) -inputForm (SomeField (Input _ _ TextArea)) = TextAreaData <$> textarea 50 5 "" <++ label (" " :: String) -inputForm (SomeField (Input _ _ Button)) = pure ButtonData -inputForm (SomeField (Input _ _ (Checkbox choices))) = CheckboxData <$> inputCheckboxes (zip [0..] (snd <$> choices)) (const False) <++ label (" " :: String) -inputForm _ = error "Not an input form" - - -inputForm' :: FormField -> NomyxForm InputData -inputForm' (RadioField _ _ choices) = RadioData <$> NWC.inputRadio' choices (== 0) <++ label (" " :: String) -inputForm' (TextField _ _) = TextData <$> RB.inputText "" <++ label (" " :: String) -inputForm' (TextAreaField _ _) = TextAreaData <$> textarea 50 5 "" <++ label (" " :: String) -inputForm' (ButtonField _ _) = pure ButtonData -inputForm' (CheckboxField _ _ choices) = CheckboxData <$> inputCheckboxes choices (const False) <++ label (" " :: String) - -showHideTitle :: String -> Bool -> Bool -> Html -> Html -> Html -showHideTitle id visible empty title rest = do - div ! onclick (fromString $ printf "toggle_visibility('%sBody', '%sShow')" id id) $ table ! width "100%" $ tr $ do - td $ title ! width "80%" - td ! style "text-align:right;" $ h5 (if visible then "[Click to hide]" else "[Click to show]") ! A.id (fromString $ printf "%sShow" id) ! width "20%" - div ! A.id (fromString $ printf "%sBody" id) ! style (fromString $ "display:" ++ (if visible then "block;" else "none;")) $ - if empty then toHtml $ "No " ++ id else rest - -joinGame :: GameName -> TVar Session -> RoutedNomyxServer Response -joinGame gn ts = do - 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 <- fromJust <$> getPlayerNumber ts - webCommand ts (S.leaveGame gn pn) - link <- showURL MainPage - seeOther link $ toResponse "Redirecting..." - -delGame :: GameName -> TVar Session -> RoutedNomyxServer Response -delGame gn ts = do - webCommand ts (S.delGame gn) - link <- showURL MainPage - seeOther link $ toResponse "Redirecting..." - -forkGame :: GameName -> TVar Session -> RoutedNomyxServer Response -forkGame gn ts = do - 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 <- fromJust <$> getPlayerNumber ts - webCommand ts (S.viewGamePlayer gn pn) - link <- showURL MainPage - seeOther link $ toResponse "Redirecting..." - -titleWithHelpIcon :: Html -> String -> Html -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/Game/Details.hs b/src/Nomyx/Web/Game/Details.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Web/Game/Details.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} + +module Nomyx.Web.Game.Details where + +import Data.Maybe +import Data.String +import Data.List +import Data.Text (Text) +import Data.Time +import System.Locale +import Language.Nomyx +import Text.Blaze.Html5 (Html, (!), p, table, thead, td, tr, h4) +import Text.Blaze.Html5.Attributes as A (style, class_) +import qualified Nomyx.Web.Help as Help +import Nomyx.Web.Common as NWC +import Nomyx.Core.Engine +default (Integer, Double, Data.Text.Text) + + +viewDetails :: PlayerNumber -> Game -> Html +viewDetails pn g = do + p $ titleWithHelpIcon (h4 "Variables:") Help.variables + viewVars (_variables g) + p $ titleWithHelpIcon (h4 "Events:") Help.events + viewEvents g + p $ h4 "Log:" + viewLogs (_logs g) pn + +viewEvents :: Game -> Html +viewEvents g = table ! class_ "table" $ do + thead $ do + td ! class_ "td" $ "Event Number" + td ! class_ "td" $ "By Rule" + td ! class_ "td" $ "Event" + mapM_ (viewEvent g) (sort $ _events g) + +viewEvent :: Game -> EventInfo -> Html +viewEvent g ei@(EventInfo eventNumber ruleNumber _ _ status _) = if status == SActive then disp else disp ! style "background:gray;" where + disp = tr $ do + td ! class_ "td" $ fromString . show $ eventNumber + td ! class_ "td" $ fromString . show $ ruleNumber + td ! class_ "td" $ fromString . show $ getRemainingSignals ei g + +viewVars :: [Var] -> Html +viewVars vs = table ! class_ "table" $ do + thead $ do + 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" $ fromString . show $ vRuleNumber + td ! class_ "td" $ fromString . show $ vName + td ! class_ "td" $ fromString . show $ vData + +viewLogs :: [Log] -> PlayerNumber -> Html +viewLogs log pn = do + let ls = filter (\o -> (_lPlayerNumber o == Just pn) || (isNothing $ _lPlayerNumber o)) log + table $ mapM_ viewLog (reverse ls) + +viewLog :: Log -> Html +viewLog (Log _ t s) = tr $ do + td $ fromString $ formatTime defaultTimeLocale "%Y/%m/%d_%H:%M" t + td $ p $ fromString s diff --git a/src/Nomyx/Web/Game/IOs.hs b/src/Nomyx/Web/Game/IOs.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Web/Game/IOs.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE GADTs #-} + +module Nomyx.Web.Game.IOs where + +import Prelude hiding (div) +import Control.Monad +import Control.Monad.State +import Control.Concurrent.STM +import Control.Applicative +import Data.Monoid +import Data.Maybe +import Data.String +import Data.List +import Data.Text (Text) +import Language.Nomyx +import Text.Blaze.Html5 (Html, div, (!), table, td, tr, h3, h4, pre, toValue, br, a) +import Text.Blaze.Html5.Attributes as A (id) +import Text.Reform.Blaze.String (label, textarea, inputCheckboxes) +import qualified Text.Reform.Blaze.String as RB +import Text.Reform.Happstack (environment) +import Text.Reform ((<++), viewForm, eitherForm) +import Happstack.Server (Response, Method(..), seeOther, toResponse, methodM, ok) +import Web.Routes.RouteT (showURL, liftRouteT) +import qualified Nomyx.Web.Help as Help +import Nomyx.Web.Common as NWC +import Nomyx.Core.Types as T +import Nomyx.Core.Mail +import Nomyx.Core.Engine +import Nomyx.Core.Session as S +default (Integer, Double, Data.Text.Text) + + +viewIOs :: PlayerNumber -> Game -> RoutedNomyxServer Html +viewIOs pn g = do + vios <- mapM (viewIORule pn g) (sort $ _rules g) + ok $ do + titleWithHelpIcon (h3 "Inputs/Ouputs") Help.inputsOutputs + a "" ! A.id (toValue inputAnchor) + mconcat vios + +viewIORule :: PlayerNumber -> Game -> RuleInfo -> RoutedNomyxServer Html +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 $ fromString $ "Rule #" ++ (show $ _rNumber r) ++ " \"" ++ _rName r ++ "\": " + fromJust vior + +viewIORuleM :: PlayerNumber -> RuleNumber -> Game -> RoutedNomyxServer (Maybe Html) +viewIORuleM pn rn g = do + vir <- viewInputsRule pn rn (_events g) g + let vor = viewOutputsRule pn rn g + return $ if isJust vir || isJust vor then Just $ do + when (isJust vir) $ fromJust vir + when (isJust vor) $ fromJust vor + else Nothing + +viewInputsRule :: PlayerNumber -> RuleNumber -> [EventInfo] -> Game -> RoutedNomyxServer (Maybe Html) +viewInputsRule pn rn ehs g = do + let filtered = filter (\e -> _ruleNumber e == rn) ehs + mis <- mapM (viewInput pn g) $ sort filtered + let is = catMaybes mis + case is of + [] -> return Nothing + i -> return $ Just $ table $ mconcat i + +viewOutputsRule :: PlayerNumber -> RuleNumber -> Game -> Maybe Html +viewOutputsRule pn rn g = do + let filtered = filter (\o -> _oRuleNumber o == rn && _oStatus o == SActive) (_outputs g) + let myos = filter (isPn pn) (sort filtered) + case myos of + [] -> Nothing + os -> Just $ sequence_ $ mapMaybe (viewOutput g) os + +isPn pn (Output _ _ (Just mypn) _ SActive) = mypn == pn +isPn _ (Output _ _ Nothing _ SActive) = True +isPn _ _ = False + +viewInput :: PlayerNumber -> Game -> EventInfo -> RoutedNomyxServer (Maybe Html) +viewInput me g ei@(EventInfo en _ _ _ SActive _) = do + ds <- mapMaybeM (viewInput' me (_gameName g) en) (getRemainingSignals ei g) + return $ if null ds + then Nothing + else Just $ sequence_ ds +viewInput _ _ _ = return Nothing + +viewInput' :: PlayerNumber -> GameName -> EventNumber -> (SignalAddress, SomeSignal) -> RoutedNomyxServer (Maybe Html) +viewInput' me gn en (fa, ev@(SomeSignal (Input pn title _))) | me == pn = do + lf <- lift $ viewForm "user" $ inputForm ev + link <- showURL (DoInput en fa (fromJust $ getFormField ev) gn) + return $ Just $ tr $ td $ do + fromString title + fromString " " + blazeForm lf link ! A.id "InputForm" +viewInput' _ _ _ _ = return Nothing + +viewOutput :: Game -> Output -> Maybe Html +viewOutput g o = if (s /= "") then Just (pre $ fromString s >> br) else Nothing where + s = (evalOutput g o) + +--- TODO: merge SomeSignal and FormField... +inputForm :: SomeSignal -> NomyxForm InputData +inputForm (SomeSignal (Input _ _ (Radio choices))) = RadioData <$> NWC.inputRadio' (zip [0..] (snd <$> choices)) (== 0) <++ label (" " :: String) +inputForm (SomeSignal (Input _ _ Text)) = TextData <$> RB.inputText "" <++ label (" " :: String) +inputForm (SomeSignal (Input _ _ TextArea)) = TextAreaData <$> textarea 50 5 "" <++ label (" " :: String) +inputForm (SomeSignal (Input _ _ Button)) = pure ButtonData +inputForm (SomeSignal (Input _ _ (Checkbox choices))) = CheckboxData <$> inputCheckboxes (zip [0..] (snd <$> choices)) (const False) <++ label (" " :: String) +inputForm _ = error "Not an input form" + + +inputForm' :: FormField -> NomyxForm InputData +inputForm' (RadioField _ _ choices) = RadioData <$> NWC.inputRadio' choices (== 0) <++ label (" " :: String) +inputForm' (TextField _ _) = TextData <$> RB.inputText "" <++ label (" " :: String) +inputForm' (TextAreaField _ _) = TextAreaData <$> textarea 50 5 "" <++ label (" " :: String) +inputForm' (ButtonField _ _) = pure ButtonData +inputForm' (CheckboxField _ _ choices) = CheckboxData <$> inputCheckboxes choices (const False) <++ label (" " :: String) + +-- | a form result has been sent +newInput :: EventNumber -> SignalAddress -> FormField -> GameName -> TVar Session -> RoutedNomyxServer Response +newInput en fa ft gn ts = toResponse <$> do + pn <- fromJust <$> getPlayerNumber ts + link <- showURL MainPage + methodM POST + r <- liftRouteT $ eitherForm environment "user" (inputForm' ft) + case r of + (Right c) -> webCommand ts $ S.inputResult pn en fa ft c gn + (Left _) -> liftIO $ putStrLn "cannot retrieve form data" + seeOther (link `appendAnchor` inputAnchor) "Redirecting..." diff --git a/src/Nomyx/Web/Game/Infos.hs b/src/Nomyx/Web/Game/Infos.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Web/Game/Infos.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} + +module Nomyx.Web.Game.Infos where + +import Prelude hiding (div) +import Control.Monad +import Control.Monad.State +import Control.Concurrent.STM +import Control.Applicative +import Data.Monoid +import Data.Maybe +import Data.String +import Data.List +import Data.List.Split +import Data.Text (Text) +import Language.Nomyx +import Text.Blaze.Html5 (Html, div, (!), p, table, td, tr, h2, h3, h4, pre, toValue, br, a) +import Text.Blaze.Html5.Attributes as A (id, class_, href, title) +import Text.Reform.Blaze.String (inputHidden) +import Text.Reform (viewForm, eitherForm) +import Text.Reform.Happstack (environment) +import Happstack.Server (Response, Method(..), seeOther, toResponse, methodM, ok) +import Web.Routes.RouteT (showURL, liftRouteT) +import Nomyx.Web.Common as NWC +import Nomyx.Web.Help as Help +import Nomyx.Core.Types as T +import Nomyx.Core.Engine +import Nomyx.Core.Session as S +import Nomyx.Core.Profile as Profile +default (Integer, Double, Data.Text.Text) + +viewGameDesc :: Game -> Maybe PlayerNumber -> Maybe PlayerNumber -> Bool -> RoutedNomyxServer Html +viewGameDesc g mpn playAs gameAdmin = do + let gn = _gameName g + let logged = isJust mpn + vp <- viewPlayers (_players g) gn gameAdmin + modJoin <- modalJoin gn logged + modLeave <- modalLeave gn logged + modDel <- modalDel gn logged + let isInGame = maybe False (\pn -> pn `elem` (_playerNumber <$> _players g)) mpn + ok $ do + p $ do + h3 $ fromString $ _gameName g + when (isJust playAs) $ h4 $ fromString $ "You are playing as player " ++ (show $ fromJust playAs) + p $ pre $ fromString (_desc $ _gameDesc g) + p $ h4 $ "This game is discussed in the " >> a "Forum" ! (A.href $ toValue (_forumURL $ _gameDesc g)) >> "." + p $ h4 "Players in game:" + when gameAdmin "(click on a player name to \"play as\" this player)" + vp + p $ viewVictory g + if isInGame + then a "Leave" ! (href $ toValue $ "#openModalLeave" ++ gn) ! A.class_ "button" + else a "Join" ! (href $ toValue $ "#openModalJoin" ++ gn) ! A.class_ "button" ! (title $ toValue Help.joinGame) + when gameAdmin $ a "Del" ! (href $ toValue $ "#openModalDel" ++ gn) ! A.class_ "button" + modJoin >> modLeave >> modDel + +modalWindow :: Text -> String -> String -> String -> RoutedNomyxServer Html +modalWindow link buttonTitle question modelRef = do + main <- showURL NWC.MainPage + ok $ do + div ! A.id (toValue $ modelRef) ! A.class_ "modalWindow" $ do + div $ do + h2 (fromString question) + a "Cancel" ! (href $ toValue main) ! A.class_ "modalButton" + a (fromString buttonTitle) ! (href $ toValue link) ! A.class_ "modalButton" + +modalLeave :: GameName -> Bool -> RoutedNomyxServer Html +modalLeave gn logged = do + leave <- defLink (NWC.LeaveGame gn) logged + modalWindow leave + "Leave" + "Do you really want to leave? You will loose your assets in the game (for example, your bank account)." + ("openModalLeave" ++ gn) + +modalJoin :: GameName -> Bool -> RoutedNomyxServer Html +modalJoin gn logged = do + join <- defLink (NWC.JoinGame gn) logged + modalWindow join + "Join" + "Joining the game. Please register in the forum (see the link) and introduce yourself to the other players! If you do not whish to play, you can just view the game." + ("openModalJoin" ++ gn) + +modalDel :: GameName -> Bool -> RoutedNomyxServer Html +modalDel gn logged = do + del <- defLink (NWC.DelGame gn) logged + modalWindow del + "Delete" + ("Delete the game " ++ gn ++ " ?") + ("openModalDel" ++ gn) + +viewPlayers :: [PlayerInfo] -> GameName -> Bool -> RoutedNomyxServer Html +viewPlayers pis gn gameAdmin = do + let plChunks = transpose $ chunksOf 15 (sort pis) + vp <- mapM mkRow plChunks + ok $ table $ mconcat vp + where mkRow :: [PlayerInfo] -> RoutedNomyxServer Html + mkRow row = do + r <- mapM (viewPlayer gn gameAdmin) row + ok $ tr $ mconcat r + +viewPlayer :: GameName -> Bool -> PlayerInfo -> RoutedNomyxServer Html +viewPlayer gn gameAdmin (PlayerInfo pn name _) = do + pad <- playAsDiv pn gn + let inf = fromString name + ok $ do + pad + td $ div ! A.id "playerNumber" $ fromString $ show pn + td $ div ! A.id "playerName" $ if gameAdmin + then a inf ! (href $ toValue $ "#openModalPlayAs" ++ show pn) + else inf + +playAsDiv :: PlayerNumber -> GameName -> RoutedNomyxServer Html +playAsDiv pn gn = do + submitPlayAs <- showURL $ SubmitPlayAs gn + main <- showURL MainPage + paf <- lift $ viewForm "user" $ playAsForm $ Just pn + ok $ do + let cancel = a "Cancel" ! (href $ toValue main) ! A.class_ "modalButton" + div ! A.id (toValue $ "openModalPlayAs" ++ show pn) ! A.class_ "modalWindow" $ do + div $ do + 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 + +playAsForm :: Maybe PlayerNumber -> NomyxForm String +playAsForm pn = inputHidden (show pn) + +viewVictory :: Game -> Html +viewVictory g = do + let vs = _playerName <$> mapMaybe (Profile.getPlayerInfo g) (getVictorious g) + case vs of + [] -> br + a:[] -> h3 $ fromString $ "Player " ++ show a ++ " won the game!" + a:bs -> h3 $ fromString $ "Players " ++ intercalate ", " bs ++ " and " ++ a ++ " won the game!" + +newPlayAs :: GameName -> TVar Session -> RoutedNomyxServer Response +newPlayAs gn ts = toResponse <$> do + methodM POST + p <- liftRouteT $ eitherForm environment "user" $ playAsForm Nothing + pn <- fromJust <$> getPlayerNumber ts + case p of + Right playAs -> do + webCommand ts $ S.playAs (read playAs) pn gn + link <- showURL MainPage + seeOther link "Redirecting..." + (Left errorForm) -> do + settingsLink <- showURL $ SubmitPlayAs gn + mainPage "Admin settings" "Admin settings" (blazeForm errorForm settingsLink) False True + diff --git a/src/Nomyx/Web/Game/NewRule.hs b/src/Nomyx/Web/Game/NewRule.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Web/Game/NewRule.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} + +module Nomyx.Web.Game.NewRule where + +import Prelude hiding (div) +import Control.Monad +import Control.Monad.State +import Control.Concurrent.STM +import Control.Applicative +import Data.Maybe +import Data.String +import Data.Text (Text) +import Text.Blaze.Html5 (Html, (!), h3, pre, toValue, a) +import Text.Blaze.Html5.Attributes as A (id, disabled, placeholder, class_) +import Text.Reform.Blaze.String (label, textarea, inputSubmit) +import qualified Text.Reform.Blaze.String as RB +import Text.Reform.Happstack (environment) +import Text.Reform ((<++), (++>), viewForm, eitherForm) +import Text.Reform.Blaze.Common (setAttr) +import Happstack.Server (Response, Method(..), seeOther, toResponse, methodM, ok) +import Web.Routes.RouteT (showURL, liftRouteT) +import qualified Nomyx.Web.Help as Help +import Nomyx.Web.Common as NWC +import Nomyx.Core.Types as T +import Nomyx.Core.Engine +import Nomyx.Core.Session as S +default (Integer, Double, Data.Text.Text) + +newRuleForm :: Maybe SubmitRule -> Bool -> NomyxForm (SubmitRule, Maybe String, Maybe String) +newRuleForm (Just sr) isGameAdmin = newRuleForm' sr isGameAdmin +newRuleForm Nothing isGameAdmin = newRuleForm' (SubmitRule "" "" "") isGameAdmin + +newRuleForm' :: SubmitRule -> Bool -> NomyxForm (SubmitRule, Maybe String, Maybe String) +newRuleForm' (SubmitRule name desc code) isGameAdmin = + (,,) <$> submitRuleForm name desc code + <*> inputSubmit "Check" + <*> if isGameAdmin then inputSubmit "Admin submit" else pure Nothing + +submitRuleForm :: String -> String -> String -> NomyxForm SubmitRule +submitRuleForm name desc code = + SubmitRule <$> label "Name: " ++> RB.inputText name `setAttr` class_ "ruleName" + <*> (label " Short description: " ++> (RB.inputText desc `setAttr` class_ "ruleDescr") <++ RB.br) + <*> label " Code: " ++> textarea 80 15 code `setAttr` class_ "ruleCode" `setAttr` placeholder "Enter here your rule" + +viewRuleForm :: Maybe LastRule -> Bool -> Bool -> GameName -> RoutedNomyxServer Html +viewRuleForm mlr inGame isGameAdmin gn = do + link <- showURL (NewRule gn) + lf <- lift $ viewForm "user" (newRuleForm (fst <$> mlr) isGameAdmin) + ok $ do + a "" ! A.id (toValue ruleFormAnchor) + titleWithHelpIcon (h3 "Propose a new rule:") Help.code + if inGame then do + blazeForm lf link + let msg = snd <$> mlr + when (isJust msg) $ pre $ fromString $ fromJust msg + else lf ! disabled "" + +newRule :: GameName -> TVar Session -> RoutedNomyxServer Response +newRule gn ts = toResponse <$> do + methodM POST + s@(T.Session sh _ _) <- liftIO $ readTVarIO ts + let gi = getGameByName gn s + admin <- isGameAdmin (fromJust gi) ts + r <- liftRouteT $ eitherForm environment "user" (newRuleForm Nothing admin) + link <- showURL MainPage + pn <- fromJust <$> getPlayerNumber ts + case r of + Right (sr, Nothing, Nothing) -> webCommand ts $ submitRule sr pn gn sh + Right (sr, Just _, Nothing) -> webCommand ts $ checkRule sr pn sh + 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) $ "Redirecting..." + diff --git a/src/Nomyx/Web/Game/Rules.hs b/src/Nomyx/Web/Game/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Web/Game/Rules.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} + +module Nomyx.Web.Game.Rules where + +import Prelude hiding (div) +import Control.Monad +import Control.Applicative +import Data.Maybe +import Data.String +import Data.Text (Text) +import Language.Nomyx +import Text.Blaze.Html5 (Html, div, (!), p, table, thead, td, tr, h3, h4, toValue, br, toHtml, a) +import Text.Blaze.Html5.Attributes as A (title, id, class_, href) +import qualified Nomyx.Web.Help as Help +import Nomyx.Web.Common as NWC +import Nomyx.Core.Engine +import Nomyx.Core.Profile as Profile +default (Integer, Double, Data.Text.Text) + +viewAllRules :: Game -> Html +viewAllRules g = do + titleWithHelpIcon (h3 "Rules") Help.rules + viewRules (activeRules g) "Active rules" True g >> br + viewRules (pendingRules g) "Pending rules" True g >> br + viewRules (rejectedRules g) "Suppressed rules" False g >> br + +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" $ "#" + td ! class_ "td" $ "Name" + td ! class_ "td" $ "Description" + td ! class_ "td" $ "Code of the rule" + forM_ nrs (viewRule g) + +viewRule :: Game -> RuleInfo -> Html +viewRule g ri = tr $ do + let pl = fromMaybe ("Player " ++ (show $ _rProposedBy ri)) (_playerName <$> (Profile.getPlayerInfo g $ _rProposedBy ri)) + td ! class_ "td" $ p (fromString . show $ _rNumber ri) ! A.id "ruleNumber" + td ! class_ "td" $ do + div ! A.id "ruleName" $ (fromString $ _rName ri) + br + div ! A.id "proposedBy" $ (fromString $ "by " ++ (if _rProposedBy ri == 0 then "System" else pl)) + td ! class_ "td" $ fromString $ _rDescription ri + td ! class_ "td" $ viewRuleFunc ri + +viewRuleFunc :: RuleInfo -> Html +viewRuleFunc ri = do + let code = lines $ _rRuleCode ri + let codeCutLines = 7 + let ref = "openModalCode" ++ (show $ _rNumber ri) + let assessedBy = case _rAssessedBy ri of + Nothing -> "not assessed" + Just 0 -> "the system" + Just a -> "rule " ++ show a + div ! A.id "showCodeLink" $ a ! (href $ toValue $ "#" ++ ref) $ "show more..." >> br + div ! A.id "codeDiv" $ displayCode $ unlines $ take codeCutLines code + div $ when (length code >= codeCutLines) $ fromString "(...)" + div ! A.id (toValue ref) ! class_ "modalDialog" $ do + div $ do + p "Code of the rule:" + a ! href "#close" ! title "Close" ! class_ "close" $ "X" + div ! A.id "modalCode" $ do + displayCode $ unlines code + br + case _rStatus ri of + Active -> (fromString $ "This rule was activated by " ++ assessedBy ++ ".") ! A.id "assessedBy" + Reject -> (fromString $ "This rule was deleted by " ++ assessedBy ++ ".") ! A.id "assessedBy" + Pending -> return () 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 @@ -1,16 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Help --- Copyright : --- License : OtherLicense --- --- Maintainer : corentin.dupont@gmail.com --- Stability : --- Portability : --- --- | --- ------------------------------------------------------------------------------ module Nomyx.Web.Help where upload = "In the following form you can upload your file containing custom rules. The file must be a haskell .hs file containing a module, \n" ++ @@ -33,7 +20,11 @@ variables = "Variables: Rules can create variables to store data. For example, a rule creating a bank account with instruction \"newVar\" will make a new variable appear here." view = "Only view a game. You will not be able to propose new rules." -join = "Be part of the game. You will be able to propose new rules, vote etc. Please register in the game's agora (see the link on game page) to follow the game." +joinGame = "Be part of the game. You will be able to propose new rules, vote etc. Please register in the game's forum (see the link on game page) to follow the game." + +fork = "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." + 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" ++ 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 @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -23,11 +24,20 @@ import Happstack.Server as HS import System.FilePath import qualified Nomyx.Web.Help as Help -import Nomyx.Web.Game import Nomyx.Web.Common as W import Nomyx.Web.Settings import Nomyx.Web.NewGame import Nomyx.Web.Login +import Nomyx.Web.Game.Infos +import Nomyx.Web.Game.Rules +import Nomyx.Web.Game.IOs +import Nomyx.Web.Game.NewRule +import Nomyx.Web.Game.Details +import Nomyx.Core.Profile as Profile +import Nomyx.Core.Utils +import Nomyx.Core.Types as T +import Nomyx.Core.Engine +import qualified Nomyx.Core.Session as S import Data.List import Data.Text(Text, pack) import Happstack.Auth @@ -35,52 +45,47 @@ import Control.Monad.Error import Control.Applicative import Safe -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 :: (Maybe PlayerNumber) -> FilePath -> Session -> RoutedNomyxServer Html viewMulti mpn saveDir s = do - (isAdmin, mgi, lr) <- case mpn of + (isAdmin, 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) + return (isAdmin, lr) + Nothing -> return (False, Nothing) + let gis = _gameInfos $ _multi s gns <- viewGamesTab (_gameInfos $ _multi s) isAdmin saveDir mpn - vg <- case mgi of - Just gi -> viewGameInfo gi mpn lr isAdmin - Nothing -> ok $ h3 "Not viewing any game" + vgs <- mapM (\gi -> viewGameInfo gi mpn lr isAdmin) gis ok $ do div ! A.id "gameList" $ gns - div ! A.id "game" $ vg + sequence_ vgs 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 mpn - let defLink a = if (isJust mpn) then showURL a else showURL (Auth $ AuthURL A_Login) + let vgi = viewGameName isAdmin mpn public <- mapM vgi (fst publicPrivate) private <- mapM vgi (snd publicPrivate) - newGameLink <- defLink NewGame - settingsLink <- defLink W.PlayerSettings - advLink <- defLink Advanced - logoutURL <- defLink (Auth $ AuthURL A_Logout) + newGameLink <- defLink NewGame (isJust mpn) + settingsLink <- defLink W.PlayerSettings (isJust mpn) + advLink <- defLink Advanced (isJust mpn) + logoutURL <- defLink (Auth $ AuthURL A_Logout) (isJust mpn) loginURL <- showURL (Auth $ AuthURL A_Login) fmods <- liftIO $ getUploadedModules saveDir ok $ do h3 "Main menu" >> br case public of [] -> b "No public games" - p -> do + p:ps -> do b "Public games:" - table $ sequence_ p + table $ do + p ! A.style "font-weight:bold;" + sequence_ ps br case private of [] -> "" @@ -101,49 +106,67 @@ H.a "Logout" ! (href $ toValue logoutURL) >> br H.a "Login" ! (href $ toValue loginURL) >> br +viewGameInfo :: GameInfo -> (Maybe PlayerNumber) -> Maybe LastRule -> Bool -> RoutedNomyxServer Html +viewGameInfo gi mpn mlr isAdmin = do + let g = getGame gi + let gn = _gameName g + (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) isGameAdmin (_gameName g) + vios <- viewIOs (fromMaybe pn playAs) g + vgd <- viewGameDesc g mpn playAs isGameAdmin + ok $ div ! A.id (fromString $ getIdBox "" gn) ! A.class_ (fromString $ (getClassBox "" "game") ++ " game") $ do + div ! A.id "titleBar" $ do + let attr :: String -> Attribute + attr name = A.id (fromString $ getIdButton gn name) <> A.class_ (fromString $ (getClassButton gn "gameBox") ++ " button") <> onclick (fromString $ divVisibility gn name "gameBox") + H.a "Description " ! attr "gameDesc" ! A.style "fontWeight:bold;" + H.a "Rules " ! attr "rules" + H.a "Inputs/Outputs " ! attr "ios" + H.a "New rule " ! attr "newRule" + H.a "Details " ! attr "details" + let attr name = A.id (fromString $ getIdBox gn name) <> A.class_ (fromString $ (getClassBox gn "gameBox") ++ " gameBox") + div ! attr "gameDesc" ! A.style "display:inline;" $ vgd + div ! attr "rules" ! A.style "display:none;" $ viewAllRules g + div ! attr "ios" ! A.style "display:none;" $ vios + div ! attr "newRule" ! A.style "display:none;" $ rf + div ! attr "details" ! A.style "display:none;" $ viewDetails pn g -viewGameName :: Bool -> Bool -> (Maybe PlayerNumber) -> GameInfo -> RoutedNomyxServer Html -viewGameName isAdmin canCreateGame mpn gi = do +viewGameName :: Bool -> (Maybe PlayerNumber) -> GameInfo -> RoutedNomyxServer Html +viewGameName isAdmin mpn gi = do let g = getGame 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 <- 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" $ 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) - when canDel $ td $ H.a "Del" ! (href $ toValue del) - when canFork $ td $ H.a "Fork" ! (href $ toValue $ "#openModalFork" ++ gn) - div ! A.id (toValue $ "openModalJoin" ++ gn) ! A.class_ "modalWindow" $ do - div $ do - 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) - div ! A.id (toValue $ "openModalLeave" ++ gn) ! A.class_ "modalWindow" $ do - div $ do - h2 "Do you really want to leave? You will loose your assets in the game (for example, your bank account)." - cancel - H.a "Leave" ! (href $ toValue leave) ! A.class_ "modalButton" - div ! A.id (toValue $ "openModalFork" ++ gn) ! A.class_ "modalWindow" $ do - div $ do - 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 "" + ok $ when canView $ do + let attr = A.id (fromString $ getIdButton "" gn) <> A.class_ (fromString $ (getClassButton "" "game") ++ " button") <> onclick (fromString $ divVisibility "" gn "game") + tr $ td $ H.a (fromString (gn ++ " ")) ! (A.title $ toValue Help.view) ! attr + +joinGame :: GameName -> TVar Session -> RoutedNomyxServer Response +joinGame gn ts = do + 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 <- fromJust <$> getPlayerNumber ts + webCommand ts (S.leaveGame gn pn) + link <- showURL MainPage + seeOther link $ toResponse "Redirecting..." + +delGame :: GameName -> TVar Session -> RoutedNomyxServer Response +delGame gn ts = do + webCommand ts (S.delGame gn) + link <- showURL MainPage + seeOther link $ toResponse "Redirecting..." + nomyxPage :: TVar Session -> RoutedNomyxServer Response nomyxPage ts = do mpn <- getPlayerNumber ts @@ -168,9 +191,7 @@ routedNomyxCommands MainPage = nomyxPage routedNomyxCommands (W.JoinGame game) = joinGame game routedNomyxCommands (W.LeaveGame game) = leaveGame game -routedNomyxCommands (ViewGame game) = viewGamePlayer game routedNomyxCommands (DelGame game) = delGame game -routedNomyxCommands (ForkGame game) = forkGame game routedNomyxCommands (NewRule game) = newRule game routedNomyxCommands NewGame = newGamePage routedNomyxCommands SubmitNewGame = newGamePost 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 @@ -18,30 +18,33 @@ import Data.Maybe import Nomyx.Core.Engine import Nomyx.Web.Common -import Nomyx.Core.Session +import qualified Nomyx.Core.Session as S import Nomyx.Core.Types default (Integer, Double, Data.Text.Text) - -data NewGameForm = NewGameForm GameName GameDesc Bool +data NewGameForm = NewGameForm GameName GameDesc Bool (Maybe GameName) -newGameForm :: Bool -> NomyxForm NewGameForm -newGameForm admin = pure NewGameForm <*> (br ++> errorList ++> label "Enter new game name: " ++> RB.inputText "" `transformEither` fieldRequired GameNameRequired `RBC.setAttr` placeholder "Game name" <++ br <++ br) - <*> newGameDesc - <*> if admin then label "Public game? " ++> (RB.inputCheckbox True) else pure False +newGameForm :: Bool -> [GameName] -> NomyxForm NewGameForm +newGameForm admin gns = pure NewGameForm + <*> (br ++> errorList ++> label "Enter new game name: " ++> RB.inputText "" `transformEither` fieldRequired GameNameRequired `RBC.setAttr` placeholder "Game name" <++ br <++ br) + <*> newGameDesc + <*> (if admin then label "Public game? " ++> (RB.inputCheckbox True) else pure False) <++ br + <*> (label "Fork from existing game (optional):" ++> RB.select ((Nothing, "--") : (map (\gn -> (Just gn, gn)) gns)) isNothing) <++ br <++ br newGameDesc :: NomyxForm GameDesc newGameDesc = pure GameDesc <*> label "Enter game description:" ++> br ++> textarea 40 3 "" `RBC.setAttr` placeholder "Enter game description" `RBC.setAttr` class_ "gameDesc" <++ br <++ br - <*> label "Enter a link to an agora (e.g. a forum, a mailing list...) where the players can discuss their rules: " ++> br ++> RB.inputText "" `RBC.setAttr` placeholder "Agora URL (including http://...)" `RBC.setAttr` class_ "agora" <++ br <++ br + <*> label "Enter a link to a place where the players can discuss their rules (e.g. a forum, a mailing list...): " ++> br ++> RB.inputText "" `RBC.setAttr` placeholder "Forum URL (including http://...)" `RBC.setAttr` class_ "forum" <++ br <++ br gameNameRequired :: String -> Either NomyxError String gameNameRequired = fieldRequired GameNameRequired newGamePage :: TVar Session -> RoutedNomyxServer Response newGamePage ts = toResponse <$> do - admin <- getIsAdmin ts + admin <- isAdmin ts + gis <- getPublicGames ts + let gameNames = map (_gameName . _game . _loggedGame) gis newGameLink <- showURL SubmitNewGame - mf <- lift $ viewForm "user" $ newGameForm admin + mf <- lift $ viewForm "user" $ newGameForm admin gameNames mainPage "New game" "New game" (blazeForm mf newGameLink) @@ -51,13 +54,17 @@ newGamePost :: TVar Session -> RoutedNomyxServer Response newGamePost ts = toResponse <$> do methodM POST - admin <- getIsAdmin ts - r <- liftRouteT $ eitherForm environment "user" (newGameForm admin) + admin <- isAdmin ts + gis <- getPublicGames ts + let gameNames = map (_gameName . _game . _loggedGame) gis + r <- liftRouteT $ eitherForm environment "user" (newGameForm admin gameNames) link <- showURL MainPage newGameLink <- showURL SubmitNewGame 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 + Right (NewGameForm name desc isPublic mforkFrom) -> do + case mforkFrom of + Nothing -> webCommand ts $ S.newGame name desc pn isPublic + Just forkFrom -> webCommand ts $ S.forkGame forkFrom name desc False pn 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 @@ -173,7 +173,6 @@ td ! A.class_ "td" $ "Name" td ! A.class_ "td" $ "mail" td ! A.class_ "td" $ "send mails" - td ! A.class_ "td" $ "viewing game" td ! A.class_ "td" $ "last rule" td ! A.class_ "td" $ "last upload" td ! A.class_ "td" $ "is admin" @@ -182,13 +181,12 @@ viewProfile :: ProfileData -> Html -viewProfile (ProfileData pn (Types.PlayerSettings playerName mail _ mailNewRule _ _) viewingGame lastRule lastUpload isAdmin) = +viewProfile (ProfileData pn (Types.PlayerSettings playerName mail _ mailNewRule _ _) lastRule lastUpload isAdmin) = tr $ do 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