Nomyx-Web (empty) → 0.5.0
raw patch · 14 files changed
+1695/−0 lines, 14 filesdep +Nomyx-Coredep +Nomyx-Languagedep +basesetup-changedbinary-added
Dependencies added: Nomyx-Core, Nomyx-Language, base, blaze-html, blaze-markup, bytestring, data-lens, data-lens-fd, fb, filepath, happstack-authenticate, happstack-server, hscolour, mtl, old-locale, reform, reform-blaze, reform-happstack, safe, stm, text, time, web-routes, web-routes-happstack, web-routes-regular, web-routes-th
Files
- LICENSE +27/−0
- Nomyx-Web.cabal +60/−0
- README.md +7/−0
- Setup.lhs +6/−0
- data/static/css/nomyx.css +301/−0
- data/static/nomyx.js +15/−0
- data/static/pictures/help.jpg binary
- src/Nomyx/Web/Common.hs +221/−0
- src/Nomyx/Web/Game.hs +416/−0
- src/Nomyx/Web/Help.hs +43/−0
- src/Nomyx/Web/Login.hs +70/−0
- src/Nomyx/Web/MainPage.hs +209/−0
- src/Nomyx/Web/NewGame.hs +63/−0
- src/Nomyx/Web/Settings.hs +257/−0
+ LICENSE view
@@ -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.
+ Nomyx-Web.cabal view
@@ -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
+ README.md view
@@ -0,0 +1,7 @@+[](https://travis-ci.org/cdupont/Nomyx-Web)+[](https://hackage.haskell.org/package/Nomyx-Web)++Nomyx-Web+========++Web interface for Nomyx
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ data/static/css/nomyx.css view
@@ -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;+}
+ data/static/nomyx.js view
@@ -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]';+ }+}
+ data/static/pictures/help.jpg view
binary file changed (absent → 725 bytes)
+ src/Nomyx/Web/Common.hs view
@@ -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 \<head\>+ -> Html -- ^ contents to put inside \<body\>+ -> 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 \<head\>+ -> Html -- ^ contents to put inside \<body\>+ -> 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+
+ src/Nomyx/Web/Game.hs view
@@ -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)
+ src/Nomyx/Web/Help.hs view
@@ -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-<version> \n" +++ "$> Nomyx -r <save file name>\n" +++ "Warning: Nomyx and Nomyx-Language should have the exact same version as the online instance.\n"
+ src/Nomyx/Web/Login.hs view
@@ -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"}
+ src/Nomyx/Web/MainPage.hs view
@@ -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+
+ src/Nomyx/Web/NewGame.hs view
@@ -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..."
+ src/Nomyx/Web/Settings.hs view
@@ -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..."