diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright 2012, Corentin Dupont. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Nomyx-Web.cabal b/Nomyx-Web.cabal new file mode 100644 --- /dev/null +++ b/Nomyx-Web.cabal @@ -0,0 +1,60 @@ +name: Nomyx-Web +version: 0.5.0 +cabal-version: >=1.6 +build-type: Simple +license: BSD3 +license-file: LICENSE +maintainer: corentin.dupont@gmail.com +synopsis: Web gui for Nomyx +category: game +Homepage: http://www.nomyx.net +author: Corentin Dupont +data-files: static/css/nomyx.css + static/nomyx.js + static/pictures/*.jpg +data-dir: data +extra-source-files: README.md + +library + build-depends: Nomyx-Language == 0.5.0, + Nomyx-Core == 0.5.0, + base == 4.6.*, + blaze-html == 0.7.*, + blaze-markup == 0.6.*, + bytestring == 0.10.*, + data-lens == 2.10.*, + data-lens-fd == 2.0.*, + fb == 0.15.*, + filepath == 1.3.*, + happstack-authenticate == 0.10.*, + happstack-server == 7.3.*, + hscolour == 1.20.*, + mtl == 2.1.*, + old-locale == 1.0.*, + reform == 0.2.*, + reform-blaze == 0.2.*, + reform-happstack == 0.2.*, + safe == 0.3.*, + stm == 2.4.*, + text == 1.1.*, + time == 1.4.*, + web-routes == 0.27.*, + web-routes-happstack == 0.23.*, + web-routes-regular == 0.19.*, + web-routes-th == 0.22.* + buildable: True + extensions: CPP + hs-source-dirs: src + exposed-modules:Nomyx.Web.MainPage + Paths_Nomyx_Web + other-modules: Nomyx.Web.Common + Nomyx.Web.Help + Nomyx.Web.NewGame + Nomyx.Web.Game + Nomyx.Web.Login + Nomyx.Web.Settings + ghc-options: -W -threaded + +source-repository head + type: git + location: git://github.com/cdupont/Nomyx-Web.git diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +[![Build Status](https://travis-ci.org/cdupont/Nomyx-Web.png?branch=master)](https://travis-ci.org/cdupont/Nomyx-Web) +[![Hackage](https://budueba.com/hackage/Nomyx-Web)](https://hackage.haskell.org/package/Nomyx-Web) + +Nomyx-Web +======== + +Web interface for Nomyx diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/data/static/css/nomyx.css b/data/static/css/nomyx.css new file mode 100644 --- /dev/null +++ b/data/static/css/nomyx.css @@ -0,0 +1,301 @@ +h3{ + color:#04B404; +} + +#multi { + top:40px; + vertical-align:middle; + +} + + +#gameList { + position:absolute; + background-color:#F4F4F4; + border:1px solid black; + width:250px; + padding:10px; + top:60px; + left:15px; + overflow: auto; +} + +#game { + position:absolute; + background-color:#FFFFFF; + height:90%; + top:57px; + left:295px; + right:14px; + padding-right:20px; + overflow: auto; +} + +#gameElem { + position:absolute; + height:90%; + top:20px; + left:250px; + right:20px; + /**/ +} + +/* +#IORuleTitle { + position:relative; + top:-30px; + background-color:#F4F4F4; + + height:20px; +}*/ + +#IORule { + border:1px dotted black; + padding:10px; + padding-bottom:0px; + padding-top:0px; + margin-bottom:10px; + display : block; +} + +.table { + border:2px solid black; + border-collapse:collapse; + padding:6px; +} + +.td { + border:1px solid black; + padding:6px; +} + +.codetd { + border:1px solid black; + padding:6px; +} + +pre { + white-space: pre-wrap; /* css-3 */ + white-space: -moz-pre-wrap; /* Mozilla, since 1999 */ + white-space: -pre-wrap; /* Opera 4-6 */ + white-space: -o-pre-wrap; /* Opera 7 */ + word-wrap: break-word; /* Internet Explorer 5.5+ */ +} + +thead { + font-weight:bold + } + +#victory { + float:left; + margin-left:5%; + padding:10px; +} + +#ios, #details, #rules, #newRule, #gameDesc { + float:left; + background-color:#F4F4F4; + border:1px solid black; + padding-left:10px; + padding-right:10px; + width:100%; + margin-bottom:5px; +} + +#showCodeLink { + text-align:right; +} + +#gameName { + padding-right: 10px; +} + +/* #eventsBody { + display:none; +}*/ + +#header { + border-top:1px solid silver; + border-bottom:1px solid silver; + margin-top:10px; + margin-bottom:10px; + color:gray; + padding-top:10px; + padding-bottom:5px; + background-color:#F4F4F4; + top:0; + position:relative; + width:100%; +} + +#footer { + border-top:1px solid silver; + border-bottom:1px solid silver; + margin-top:10px; + margin-bottom:10px; + color:gray; + padding-top:10px; + padding-bottom:5px; + background-color:#F4F4F4; + bottom:0; + position:absolute; + width:100%; +} + + +.ruleCode { + width:100%; +} + +.ruleName { +} + +.ruleDescr { + width:50%; +} + + +.agora { + width:400px; +} + +input[type="file"]{ + font: normal 11px Arial; +} + +#description { + width:50%; +} + +.modalDialog { + position: fixed; + font-family: Arial, Helvetica, sans-serif; + top: 0; + right: 0; + bottom: 0; + left: 0; + background: rgba(0,0,0,0.8); + z-index: 99999; + opacity:0; + -webkit-transition: opacity 400ms ease-in; + -moz-transition: opacity 400ms ease-in; + transition: opacity 400ms ease-in; + pointer-events: none; +} + +.modalDialog:target { + opacity:1; + pointer-events: auto; +} + +.modalDialog > div { + width: 1000px; + position: relative; + margin: 10% auto; + padding: 5px 20px 13px 20px; + border-radius: 10px; + background: #fff; + /* background: -moz-linear-gradient(#fff, #999); + background: -webkit-linear-gradient(#fff, #999); + background: -o-linear-gradient(#fff, #999);*/ +} + +.close { + background: #606061; + color: #FFFFFF; + line-height: 25px; + position: absolute; + right: -12px; + text-align: center; + top: -10px; + width: 24px; + text-decoration: none; + font-weight: bold; + -webkit-border-radius: 12px; + -moz-border-radius: 12px; + border-radius: 12px; + -moz-box-shadow: 1px 1px 3px #000; + -webkit-box-shadow: 1px 1px 3px #000; + box-shadow: 1px 1px 3px #000; +} + +.close:hover { background: #00d9ff; } + +.modalWindow { + position: fixed; + font-family: arial; + font-size:80%; + top: 0; + right: 0; + bottom: 0; + left: 0; + background: rgba(0,0,0,0.2); + z-index: 99999; + opacity:0; + -webkit-transition: opacity 400ms ease-in; + -moz-transition: opacity 400ms ease-in; + transition: opacity 400ms ease-in; + pointer-events: none; +} + +.modalButton { + background: #606061; + color: #FFFFFF; + line-height: 25px; + text-align: center; + text-decoration: none; + font-weight: bold; + -webkit-border-radius: 2px; + -moz-border-radius: 2px; + border-radius: 2px; + -moz-box-shadow: 1px 1px 3px #000; + -webkit-box-shadow: 1px 1px 3px #000; + box-shadow: 1px 1px 3px #000; + width:80px; + float:right; + margin-left:20px; + +} + +.modalWindow:target { + opacity:1; + pointer-events: auto; +} +.modalWindow > div { + + width: 500px; + position: relative; + margin: 10% auto; + -webkit-border-radius: 5px; + -moz-border-radius: 5px; + border-radius: 5px; + background: #fff; + padding-left:20px; + padding-right:10px; + padding-top:5px; + padding-bottom:10px; + max-height: 70%; + } + +#InputForm { + display:inline; +} + +#modalCode { + overflow: auto; + height: 60%; +} + +pre { + -moz-tab-size: 16; + -o-tab-size: 16; + -webkit-tab-size: 16; + -ms-tab-size: 16; + tab-size: 16; +} + +.playasform { + font-size: large; + font-weight: bold; + padding-bottom:10px; +} diff --git a/data/static/nomyx.js b/data/static/nomyx.js new file mode 100644 --- /dev/null +++ b/data/static/nomyx.js @@ -0,0 +1,15 @@ +function toggle_visibility(id_events, id_show) +{ + var events = document.getElementById(id_events); + var show = document.getElementById(id_show); + if (show.innerHTML == '[Click to show]') + { + events.style.display = 'block'; + show.innerHTML = '[Click to hide]'; + } + else + { + events.style.display = 'none'; + show.innerHTML ='[Click to show]'; + } +} diff --git a/data/static/pictures/help.jpg b/data/static/pictures/help.jpg new file mode 100644 Binary files /dev/null and b/data/static/pictures/help.jpg differ diff --git a/src/Nomyx/Web/Common.hs b/src/Nomyx/Web/Common.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Web/Common.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Nomyx.Web.Common where + + +import Prelude hiding (div) +import Text.Blaze.Html5 hiding (map, output, base) +import Text.Blaze.Html5.Attributes hiding (dir, id) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import Text.Blaze.Html.Renderer.Utf8 (renderHtml) +import Web.Routes.PathInfo +import Web.Routes.RouteT +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 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.Session +import Nomyx.Core.Profile +import Nomyx.Core.Serialize +import Nomyx.Core.Types as T + +data NomyxError = PlayerNameRequired + | GameNameRequired + | UniqueName + | UniqueEmail + | FieldTooLong Int + | NomyxCFE (CommonFormError [HS.Input]) + deriving Show + +type NomyxForm a = Form (ServerPartT IO) [HS.Input] NomyxError Html () a + +default (Integer, Double, Data.Text.Text) + +data LoginName = LoginName { login :: PlayerName} + deriving (Show, Eq) + + +-- | associate a player number with a handle +data PlayerClient = PlayerClient PlayerNumber deriving (Eq, Show) + +-- | A structure to hold the active games and players +data Server = Server [PlayerClient] deriving (Eq, Show) + + +data PlayerCommand = HomePage + | UAuthProfile AuthProfileURL + | PostAuth + | MainPage + | ViewGame GameName + | JoinGame GameName + | LeaveGame GameName + | DelGame GameName + | ForkGame GameName + | DoInput EventNumber GameName + | NewRule GameName + | NewGame + | SubmitNewGame + | Upload + | PlayerSettings + | SubmitPlayerSettings + | Advanced + | SubmitPlayAs GameName + | SubmitAdminPass + | SubmitSettings + | SaveFilePage + deriving (Show) + +ruleFormAnchor, inputAnchor :: Text +ruleFormAnchor = "RuleForm" +inputAnchor = "Input" + +type RoutedNomyxServer a = RouteT PlayerCommand (ServerPartT IO) a + +$(derivePathInfo ''PlayerCommand) +$(derivePathInfo ''LoginName) + +instance PathInfo Bool where + toPathSegments i = [pack $ show i] + fromPathSegments = pToken (const "bool") (checkBool . show) + where checkBool str = + case reads str of + [(n,[])] -> Just n + _ -> Nothing + +blazeResponse :: Html -> Response +blazeResponse html = toResponseBS (C.pack "text/html;charset=UTF-8") $ renderHtml html + +blazeForm :: Html -> Text -> Html +blazeForm html link = + H.form ! A.action (toValue link) + ! A.method "POST" + ! A.enctype "multipart/form-data" $ + do html + input ! A.type_ "submit" ! A.value "Submit" + +-- | Create a group of radio elements without BR between elements +inputRadio' :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, ToMarkup lbl) => + [(a, lbl)] -- ^ value, label, initially checked + -> (a -> Bool) -- ^ isDefault + -> Form m input error Html () a +inputRadio' choices isDefault = + G.inputChoice isDefault choices mkRadios + where + mkRadios nm choices' = mconcat $ concatMap (mkRadio nm) choices' + mkRadio nm (i, val, lbl, checked) = + [ (if checked then (! A.checked "checked") else id) $ input ! A.type_ "radio" ! A.id (toValue i) ! A.name (toValue nm) ! A.value (toValue val) + , " ", H.label ! A.for (toValue i) $ toHtml lbl] + +mainPage' :: String -> Html -> Html -> Bool -> RoutedNomyxServer Response +mainPage' title header body footer = do + html <- mainPage title header body footer False + return $ toResponse html + +mainPage :: String -> Html -> Html -> Bool -> Bool -> RoutedNomyxServer Html +mainPage title header body footer backLink = do + link <- showURL MainPage + ok $ if backLink then appTemplate' title header body footer (Just $ unpack link) + else appTemplate' title header body footer Nothing + +appTemplate' :: + String -- ^ title + -> Html -- ^ extra tags to include in \ + -> Html -- ^ contents to put inside \ + -> Bool -- ^ include footer + -> Maybe String -- ^ link to main page + -> Html +appTemplate' title headers body footer link = do + H.head $ do + H.title (string 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" + H.script ! A.type_ "text/JavaScript" ! A.src "/static/nomyx.js" $ "" + H.body $ H.div ! A.id "container" $ do + H.div ! A.id "header" $ table ! width "100%" $ tr $ do + td headers + when (isJust link) $ td ! A.style "text-align:right;" $ H.a "Back to main page" ! (href $ toValue $ fromJust link) + body + when footer $ H.div ! A.id "footer" $ "Copyright Corentin Dupont 2012-2013" + +appTemplate :: + ( Monad m) + => String -- ^ title + -> Html -- ^ extra tags to include in \ + -> Html -- ^ contents to put inside \ + -> m Response +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 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 + +--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 + +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." + + +fieldRequired :: NomyxError -> String -> Either NomyxError String +fieldRequired a [] = Left a +fieldRequired _ str = Right str + +appendAnchor :: Text -> Text -> Text +appendAnchor url a = url `append` "#" `append` a + +displayCode :: String -> Html +displayCode s = preEscapedString $ hscolour defaultColourPrefs False s + +getGame :: GameInfo -> Game +getGame = _game . _loggedGame + +numberOfGamesOwned :: [GameInfo] -> PlayerNumber -> Int +numberOfGamesOwned gis pn = length $ filter (maybe False (==pn) . _ownedBy) gis + +instance FormError NomyxError where + type ErrorInputType NomyxError = [HS.Input] + commonFormError = NomyxCFE + +instance ToMarkup NomyxError where + toMarkup PlayerNameRequired = "Player Name is required" + 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 (NomyxCFE e) = toHtml e + diff --git a/src/Nomyx/Web/Game.hs b/src/Nomyx/Web/Game.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Web/Game.hs @@ -0,0 +1,416 @@ +{-# 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.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) +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 +import Nomyx.Core.Types as T +import Nomyx.Core.Mail +import Nomyx.Core.Utils +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 + let g = getGame gi + let pi = Profile.getPlayerInfo g pn + let isGameAdmin = isAdmin || maybe False (== pn) (_ownedBy gi) + let playAs = maybe Nothing _playAs pi + 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 + 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 + p $ do + h4 "Description:" + string (_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)" + vp + p $ viewVictory g + + +viewPlayers :: [PlayerInfo] -> GameName -> Bool -> RoutedNomyxServer Html +viewPlayers pis gn gameAdmin = do + vp <- mapM (viewPlayer gn gameAdmin) (sort pis) + ok $ table $ mconcat vp + --let plChunks = transpose $ chunksOf (1 + (length pis) `Prelude.div` 3) (sort pis) + --table $ mapM_ (\row -> tr $ mapM_ (viewPlayer pn) row) plChunks + + +viewPlayer :: GameName -> Bool -> PlayerInfo -> RoutedNomyxServer Html +viewPlayer gn gameAdmin (PlayerInfo pn name _) = do + pad <- playAsDiv pn gn + ok $ tr $ do + let inf = string (show pn ++ "\t" ++ name) + pad + td $ 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 $ 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 + 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 $ string $ "Player " ++ show a ++ " won the game!" + a:bs -> h3 $ string $ "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" $ 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" + 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_ "codetd" $ viewRuleFunc nr + td ! class_ "td" $ string $ case _rAssessedBy nr of + Nothing -> "Not assessed" + Just 0 -> "System" + Just a -> "Rule " ++ show a + +viewRuleFunc :: RuleInfo -> Html +viewRuleFunc nr = do + let code = displayCode $ _rRuleCode nr + let ref = "openModalCode" ++ (show $ _rNumber nr) + div ! A.id "showCodeLink" $ a ! (href $ toValue $ "#" ++ ref) $ "show code" >> br + code + 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" $ code + +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 (_events g) + p $ h4 "Log:" + viewLogs (_logs g) pn + + +viewEvents :: [EventHandler] -> 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" + mapM_ viewEvent $ sort ehs + + +viewEvent :: EventHandler -> Html +viewEvent (EH eventNumber ruleNumber event _ status) = 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 + +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 $ string $ "IO for Rule \"" ++ _rName r ++ "\" (#" ++ (show $ _rNumber r) ++ "):" + fromJust vior + + +viewIORuleM :: PlayerNumber -> RuleNumber -> Game -> RoutedNomyxServer (Maybe Html) +viewIORuleM pn rn g = do + vir <- viewInputsRule pn rn (_events g) (_gameName 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 -> [EventHandler] -> 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 + 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 + tracePN 0 "in viewOutputsRule" + let filtered = filter (\o -> _oRuleNumber o == rn) (_outputs g) + let myos = filter (isPn pn) (reverse filtered) + case myos of + [] -> Nothing + os -> Just $ mapM_ (viewOutput g) os + +isPn pn (Output _ _ (Just mypn) _ SActive) = mypn == pn +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 _ _ _ = return Nothing + +viewOutput :: Game -> Output -> Html +viewOutput g o = pre $ string (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" + 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 + + +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 $ string $ 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 <- 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) $ string "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 $ string $ formatTime defaultTimeLocale "%Y/%m/%d_%H:%M" t + td $ p $ string s + +newInput :: EventNumber -> GameName -> TVar Session -> RoutedNomyxServer Response +newInput en gn ts = toResponse <$> do + pn <- getPlayerNumber ts + s <- liftIO $ atomically $ readTVar ts + let g = find ((== gn) . getL gameNameLens) (_gameInfos $ _multi s) + let eventHandler = getEventHandler 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..." + + +newPlayAs :: GameName -> TVar Session -> RoutedNomyxServer Response +newPlayAs gn ts = toResponse <$> do + methodM POST + p <- liftRouteT $ eitherForm environment "user" $ playAsForm Nothing + pn <- getPlayerNumber ts + case p of + Right playAs -> do + webCommand ts $ S.playAs (read playAs) pn gn + link <- showURL MainPage + seeOther link $ string "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 " " + +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 <- 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 + 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 <- 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 + 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/Help.hs b/src/Nomyx/Web/Help.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Web/Help.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- +-- 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" ++ + "like in the given example. Once correctly loaded, the content of the file will be \"in scope\" and you will be able to propose the functions \n" ++ + "contained in the file as new rules (in this example, you will be able to propose myRule).\n" ++ + "Additionally, your file will appear as a link on the left hand side on the main page.\n" ++ + "Warning, files uploaded here cannot be overwritten. If your uploaded file contains a mistake,\n" ++ + "re-upload it with a different name (a version number suffixed for example) or ask the administrator to delete it.\n" + +rules = "The rules are displayed here. The active rules are controlling the game. " ++ + "When a player proposes a rule, it is set to pending. Only another, already active rule can activate a pending rule (with the instruction \"activateRule\")." +inputsOutputs = "The inputs and outputs triggered by the rules are displayed here.\n For example, a rules can trigger an input to gather data from the player, with the instruction \"onInputRadio\".\n" ++ + "Rules can also display text message here, with the instruction \"output\"." + +code = "You can type in your new rule in the box below. The text entered must have the type \"Rule\" when compiled.\n" ++ + "When you are done, you can press \"Check\" to verify if the rule compiles.\n" ++ + "If OK, press \"Submit\" to propose the new rule.\n" ++ + "As a first rule, you can try to type \"nothing\", which is a rule that does nothing. Other examples can be found in the examples link on the left tab." +events = "Rules can register on events, in order to be triggered when the event happens, for example with the instruction \"onEvent\".\n" +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." + +getSaveFile = "With the following link, you can download the save file of the game. This allows you to load it in a local instance of the game.\n" ++ + "This way, you will be able to compose and test the effects of your new rules locally, without affecting the online game. \n" ++ + "The procedure is: \n" ++ + "$> cabal install Nomyx- \n" ++ + "$> Nomyx -r \n" ++ + "Warning: Nomyx and Nomyx-Language should have the exact same version as the online instance.\n" diff --git a/src/Nomyx/Web/Login.hs b/src/Nomyx/Web/Login.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Web/Login.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Nomyx.Web.Login where + + +import Prelude hiding (div) +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 Happstack.Server +import Web.Routes.Happstack() +import Data.Text hiding (map, zip, concatMap) +import Happstack.Auth (AuthProfileURL(..), AuthURL(..), handleAuthProfile) +import Happstack.Auth.Core.Profile +import Facebook (Credentials(..)) +import Nomyx.Core.Profile +import Nomyx.Core.Types as T hiding (PlayerSettings) +import Nomyx.Core.Session as S +import Nomyx.Web.Common + +default (Integer, Double, Data.Text.Text) + +-- | function which generates the homepage +homePage :: TVar Session -> RoutedNomyxServer Response +homePage 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) + mainPage' "Nomyx" + "Not logged in" + (H.div $ p $ do + "Welcome to Nomyx! You can login " + H.a ! href (toValue loginURL) $ "here.") + True + (Just _) -> do + link <- showURL MainPage + seeOther link (toResponse $ string "to game page") + +-- | add a new player if not existing +postAuthenticate :: TVar Session -> RoutedNomyxServer Response +postAuthenticate ts = do + pn <- getPlayerNumber ts + pf <- getProfile' ts pn + case pf of + Just _ -> do + link <- showURL MainPage + seeOther link (toResponse $ string "to main page") + Nothing -> do + webCommand ts $ S.newPlayer pn defaultPlayerSettings + link <- showURL PlayerSettings + seeOther link (toResponse $ string "to settings page") + + +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 + +facebookAuth = + Credentials {appName = "Nomyx", + appId = "161007670738608", + appSecret = "c0509c1c753f89d1d1fc181984042824"} diff --git a/src/Nomyx/Web/MainPage.hs b/src/Nomyx/Web/MainPage.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Web/MainPage.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Nomyx.Web.MainPage (launchWebServer) where + +import Prelude hiding (div) +import Text.Blaze.Html5 hiding (map) +import Text.Blaze.Html5.Attributes hiding (dir) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import Web.Routes.Site +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 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 +import Nomyx.Web.Game +import Nomyx.Web.Common as W +import Nomyx.Web.Settings +import Nomyx.Web.NewGame +import Nomyx.Web.Login +import Data.List +import Data.Text(Text, pack) +import Happstack.Auth +import Paths_Nomyx_Language +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 + +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 + vg <- case mgi of + Just gi -> viewGameInfo gi pn (_pLastRule $ fromJustNote "viewMulti" pfd) 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 + let publicPrivate = partition ((== True) . _isPublic) gis + let vgi = viewGameName isAdmin canCreateGame pn + 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) + fmods <- liftIO $ getUploadedModules saveDir + ok $ do + h3 "Main menu" >> br + case public of + [] -> b "No public games" + p -> do + b "Public games:" + table $ sequence_ p + br + case private of + [] -> "" + p -> do + b "Private games:" + table $ sequence_ p + br + when canCreateGame $ H.a "Create a new game" ! (href $ toValue newGameLink) >> br + br >> b "Help files:" >> br + H.a "Rules examples" ! (href "/html/Language-Nomyx-Examples.html") ! target "_blank" >> br + H.a "Nomyx language" ! (href "/html/Language-Nomyx.html") ! target "_blank" >> br + when (fmods /= []) $ do + br >> "Uploaded files:" >> br + mapM_ (\f -> (H.a $ toHtml f ) ! (href $ toValue (pathSeparator : uploadDir f)) >> br) (sort fmods) + br >> b "Settings:" >> br + H.a "Player settings" ! (href $ toValue settingsLink) >> br + H.a "Advanced" ! (href $ toValue advLink) >> br + H.a "Logout" ! (href $ toValue logoutURL) >> br + + +viewGameName :: Bool -> Bool -> PlayerNumber -> GameInfo -> RoutedNomyxServer Html +viewGameName isAdmin canCreateGame pn gi = do + let g = getGame gi + let isGameAdmin = isAdmin || maybe False (==pn) (_ownedBy gi) + let gn = _gameName g + let canFork = canCreateGame + let canDel = isGameAdmin + let canView = isGameAdmin || _isPublic gi + 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) + ok $ if canView then tr $ do + let cancel = H.a "Cancel" ! (href $ toValue main) ! A.class_ "modalButton" + td ! A.id "gameName" $ string (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 $ string $ "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 $ 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." + cancel + H.a "Fork" ! (href $ toValue fork) ! A.class_ "modalButton" + else "" + +nomyxPage :: TVar Session -> RoutedNomyxServer Response +nomyxPage ts = do + pn <- 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 + mainPage' "Welcome to Nomyx!" + (string $ "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) + +routedNomyxCommands :: PlayerCommand -> (TVar Session) -> RoutedNomyxServer Response +routedNomyxCommands (UAuthProfile auth) = authenticate auth +routedNomyxCommands PostAuth = postAuthenticate +routedNomyxCommands HomePage = homePage +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 +routedNomyxCommands (DoInput en game) = newInput en game +routedNomyxCommands Upload = newUpload +routedNomyxCommands W.PlayerSettings = playerSettings +routedNomyxCommands SubmitPlayerSettings = newPlayerSettings +routedNomyxCommands Advanced = advanced +routedNomyxCommands (SubmitPlayAs game) = newPlayAs game +routedNomyxCommands SubmitAdminPass = newAdminPass +routedNomyxCommands SubmitSettings = newSettings +routedNomyxCommands SaveFilePage = saveFilePage + +launchWebServer :: TVar Session -> Network -> IO () +launchWebServer tm net = do + putStrLn $ "Starting web server...\nTo connect, drive your browser to \"" ++ nomyxURL net ++ "/Nomyx\"" + simpleHTTP nullConf {HS.port = T._port net} $ server tm net + +--serving Nomyx web page as well as data from this package and the language library package +server :: TVar Session -> Network -> ServerPartT IO Response +server ts net = do + s <- liftIO $ atomically $ readTVar ts + let set = _mSettings $ _multi s + docdir <- liftIO getDocDir + mconcat [ + serveDirectory EnableBrowsing [] (_saveDir set), + serveDirectory EnableBrowsing [] docdir, + serveDirectory EnableBrowsing [] (_webDir set), + serveDirectory EnableBrowsing [] (_sourceDir set), + do decodeBody (defaultBodyPolicy "/tmp/" 102400 4096 4096) + html <- implSite (pack (nomyxURL net)) "/Nomyx" (nomyxSite ts) + return $ toResponse html] + +catchRouteError :: RoutedNomyxServer Response -> RoutedNomyxServer Response +catchRouteError page = page `catchError` const backToLogin where + +backToLogin :: RoutedNomyxServer Response +backToLogin = toResponse <$> do + link <- showURL HomePage + seeOther link $ string "Redirecting..." + +getDocDir :: IO FilePath +getDocDir = do + datadir <- getDataDir + let (as, _:bs) = break (== "share") $ splitDirectories datadir + return $ joinPath $ as ++ ["share", "doc"] ++ bs + diff --git a/src/Nomyx/Web/NewGame.hs b/src/Nomyx/Web/NewGame.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Web/NewGame.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE OverloadedStrings #-} + +module Nomyx.Web.NewGame where + +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 +import Control.Applicative +import Control.Monad.State +import Control.Concurrent.STM +import Happstack.Server +import Web.Routes.RouteT +import Data.Text(Text) +import Language.Nomyx.Engine +import Nomyx.Web.Common +import Nomyx.Core.Session +import Nomyx.Core.Types +default (Integer, Double, Data.Text.Text) + + +data NewGameForm = NewGameForm GameName GameDesc Bool + +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 + +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 + +gameNameRequired :: String -> Either NomyxError String +gameNameRequired = fieldRequired GameNameRequired + +newGamePage :: TVar Session -> RoutedNomyxServer Response +newGamePage ts = toResponse <$> do + admin <- getIsAdmin ts + newGameLink <- showURL SubmitNewGame + mf <- lift $ viewForm "user" $ newGameForm admin + mainPage "New game" + "New game" + (blazeForm mf newGameLink) + False + True + +newGamePost :: TVar Session -> RoutedNomyxServer Response +newGamePost ts = toResponse <$> do + methodM POST + admin <- getIsAdmin ts + r <- liftRouteT $ eitherForm environment "user" (newGameForm admin) + link <- showURL MainPage + newGameLink <- showURL SubmitNewGame + pn <- 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..." diff --git a/src/Nomyx/Web/Settings.hs b/src/Nomyx/Web/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Web/Settings.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE OverloadedStrings #-} + +module Nomyx.Web.Settings where + +import Text.Blaze.Html5 hiding (map, label, br) + +import Prelude hiding (div) +import Text.Reform +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 +import Control.Applicative +import Control.Monad.State +import Control.Concurrent.STM +import Safe +import Data.Text(Text) +import Data.Version (showVersion) +import System.FilePath +import Paths_Nomyx_Web as PNW +import Language.Nomyx +import Nomyx.Web.Common +import Nomyx.Web.Help as Help +import Nomyx.Core.Profile +import Nomyx.Core.Utils +import Nomyx.Core.Types as Types +import Nomyx.Core.Session as S + +default (Integer, Double, Data.Text.Text) + +playerSettingsForm :: Maybe PlayerSettings -> [PlayerName] -> [String] -> NomyxForm PlayerSettings +playerSettingsForm (Just prof) ns emails = playerSettingsForm' (_pPlayerName prof) (_mail prof) (_mailNewRule prof) ns emails +playerSettingsForm Nothing ns emails = playerSettingsForm' "" "" True ns emails + +playerSettingsForm':: String -> String -> Bool -> [PlayerName] -> [String] -> NomyxForm PlayerSettings +playerSettingsForm' name mailTo mailNewRule names emails = pure Types.PlayerSettings + <*> errorList ++> label "Player Name: " ++> (RB.inputText name) `transformEither` uniqueName names + `transformEither` fieldRequired PlayerNameRequired + `transformEither` maxLength 15 <++ br + <*> errorList ++> label "Please enter your mail: " ++> (RB.inputText mailTo) `transformEither` uniqueEmail emails <++ br + <*> pure True + <*> RB.inputCheckbox mailNewRule <++ label " I want to be notified by email when a player proposes a new rule in my game (recommended)" <++ br + <*> 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 + +uniqueEmail :: [String] -> String -> Either NomyxError String +uniqueEmail names name = if name `elem` names then Left UniqueEmail else Right name + +maxLength :: Int -> String -> Either NomyxError String +maxLength l name = if length name > l then Left (FieldTooLong l) else Right name + +settingsPage :: PlayerSettings -> [PlayerName] -> [String] -> RoutedNomyxServer Html +settingsPage ps names emails = do + settingsLink <- showURL SubmitPlayerSettings + mf <- lift $ viewForm "user" $ playerSettingsForm (Just ps) names emails + mainPage "Player settings" + "Player settings" + (blazeForm mf settingsLink) + False + True + +playerSettings :: TVar Session -> RoutedNomyxServer Response +playerSettings ts = toResponse <$> do + pn <- getPlayerNumber ts + pfd <- getProfile' ts pn + names <- liftIO $ forbiddenNames ts pn + emails <- liftIO $ forbiddenEmails ts pn + settingsPage (_pPlayerSettings $ fromJustNote "playerSettings" pfd) names emails + +newPlayerSettings :: TVar Session -> RoutedNomyxServer Response +newPlayerSettings ts = toResponse <$> do + methodM POST + pn <- getPlayerNumber ts + names <- liftIO $ forbiddenNames ts pn + emails <- liftIO $ forbiddenEmails ts pn + p <- liftRouteT $ eitherForm environment "user" $ playerSettingsForm Nothing names emails + case p of + Right ps -> do + webCommand ts $ S.playerSettings ps pn + link <- showURL MainPage + seeOther link $ string "Redirecting..." + (Left errorForm) -> do + settingsLink <- showURL SubmitPlayerSettings + mainPage "Player settings" "Player settings" (blazeForm errorForm settingsLink) False True + +forbiddenNames :: TVar Session -> PlayerNumber -> IO [PlayerName] +forbiddenNames ts pn = liftIO $ do + session <- atomically $ readTVar ts + pfs <- getAllProfiles session + let filteredPfs = filter ((/= pn) . _pPlayerNumber) pfs + return $ (_pPlayerName . _pPlayerSettings) <$> filteredPfs + +forbiddenEmails :: TVar Session -> PlayerNumber -> IO [PlayerName] +forbiddenEmails ts pn = liftIO $ do + session <- atomically $ readTVar ts + pfs <- getAllProfiles session + let filteredPfs = filter ((/= pn) . _pPlayerNumber) pfs + return $ filter (not . null) $ (_mail . _pPlayerSettings) <$> filteredPfs + + +advanced :: TVar Session -> RoutedNomyxServer Response +advanced ts = toResponse <$> do + session <- liftIO $ atomically $ readTVar ts + pn <- getPlayerNumber ts + pfd <- getProfile session pn + pfds <- liftIO $ getAllProfiles session + session <- liftIO $ atomically $ readTVar ts + let prof = fromJustNote "advanced" pfd + page <- advancedPage (_pLastUpload prof) + (_pIsAdmin prof) + (_mSettings $ _multi session) + pfds + mainPage "Advanced" "Advanced" page False True + + +advancedPage :: LastUpload -> Bool -> Settings -> [ProfileData] -> RoutedNomyxServer Html +advancedPage mlu isAdmin settings pfds = do + uploadLink <- showURL Upload + submitAdminPass <- showURL SubmitAdminPass + submitSettings <- showURL SubmitSettings + getSaveFile <- showURL SaveFilePage + up <- lift $ viewForm "user" uploadForm --TODO add the file name (missing Reform feature) + ap <- lift $ viewForm "user" adminPassForm + set <- lift $ viewForm "user" $ settingsForm (_sendMails settings) + let uploadExample = pathSeparator : testDir "SimpleModule.hs" + ok $ do + p $ do + string "Version:" + pre $ string $ "Nomyx " ++ showVersion PNW.version ++ "\n" + hr + p $ do + pre $ string Help.getSaveFile + H.a "get save file" ! (href $ toValue getSaveFile) + H.br + hr + p $ do + pre $ string Help.upload + H.a "example upload file" ! (href $ toValue uploadExample) + H.br >> H.br + "Upload new rules file:" >> H.br + blazeForm up uploadLink + case mlu of + UploadFailure (_, error) -> do + h5 "Error in submitted file: " + pre $ string error + UploadSuccess -> h5 "File uploaded successfully!" + NoUpload -> p "" + hr + p $ do + h5 "Enter admin password to get admin rights (necessary to create a new game):" + blazeForm ap submitAdminPass + when isAdmin $ h5 "You are admin" + when isAdmin $ do + hr + p $ do + h5 "Send mails:" + blazeForm set submitSettings + h5 $ string $ if _sendMails settings then "mails will be sent " else "mails will NOT be sent " + hr + p $ do + h5 "Players:" + table ! A.class_ "table" $ do + thead $ do + td ! A.class_ "td" $ "#" + 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" + td ! A.class_ "td" $ "play as" + mapM_ viewProfile pfds + + +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 + + +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 + +newSettings :: TVar Session -> RoutedNomyxServer Response +newSettings ts = toResponse <$> do + methodM POST + p <- liftRouteT $ eitherForm environment "user" $ settingsForm False + case p of + Right ps -> do + webCommand ts $ globalSettings ps + link <- showURL Advanced + seeOther link $ string "Redirecting..." + (Left errorForm) -> do + settingsLink <- showURL SubmitSettings + mainPage "Admin settings" "Admin settings" (blazeForm errorForm settingsLink) False True + + +uploadForm :: NomyxForm (FilePath, FilePath, ContentType) +uploadForm = RB.inputFile + +newUpload :: TVar Session -> RoutedNomyxServer Response +newUpload ts = toResponse <$> do + methodM POST + pn <- 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..." + + +newAdminPass :: TVar Session -> RoutedNomyxServer Response +newAdminPass ts = toResponse <$> do + methodM POST + p <- liftRouteT $ eitherForm environment "user" adminPassForm + pn <- getPlayerNumber ts + case p of + Right ps -> do + webCommand ts $ adminPass ps pn + link <- showURL Advanced + seeOther link $ string "Redirecting..." + (Left errorForm) -> do + settingsLink <- showURL SubmitAdminPass + mainPage "Admin settings" "Admin settings" (blazeForm errorForm settingsLink) False True + +saveFilePage :: TVar Session -> RoutedNomyxServer Response +saveFilePage ts = toResponse <$> do + session <- liftIO $ atomically $ readTVar ts + liftIO $ makeTar (_saveDir $ _mSettings $ _multi session) + seeOther (pathSeparator : tarFile) $ string "Redirecting..."