Nomyx 0.1.0 → 0.2.0
raw patch · 24 files changed
+1207/−1513 lines, 24 filesdep +Cabaldep +MissingHdep +Nomyx-Languagedep −Nomyx-Rules
Dependencies added: Cabal, MissingH, Nomyx-Language, data-lens, data-lens-fd, data-lens-template, fb, happstack-authenticate, hscolour, ixset, lenses, safecopy, syb
Dependencies removed: Nomyx-Rules
Files
- Nomyx.cabal +23/−19
- README +4/−1
- TODO +25/−18
- data/static/css/nomyx.css +128/−6
- data/static/nomyx.js +15/−0
- src/Commands.hs +0/−149
- src/Game.hs +0/−86
- src/Interpret.hs +17/−9
- src/Mail.hs +24/−15
- src/Main.hs +68/−55
- src/Multi.hs +130/−229
- src/Quotes.hs +50/−5
- src/Serialize.hs +24/−67
- src/Server.hs +0/−256
- src/Test.hs +119/−89
- src/Types.hs +109/−62
- src/Utils.hs +43/−66
- src/Web/Common.hs +107/−54
- src/Web/Game.hs +124/−88
- src/Web/Help.hs +2/−0
- src/Web/Login.hs +39/−112
- src/Web/MainPage.hs +83/−78
- src/Web/NewGame.hs +27/−18
- src/Web/Settings.hs +46/−31
Nomyx.cabal view
@@ -1,41 +1,45 @@ name: Nomyx-version: 0.1.0+version: 0.2.0 cabal-version: >=1.6 build-type: Simple license: BSD3 license-file: LICENSE maintainer: corentin.dupont@gmail.com-synopsis: A Nomic game in haskell, featuring automatic, machine-executed rules written by the players+synopsis: A Nomic game in haskell description: A Nomic game in Haskell, with a dedicated language to create new rules. . Nomyx is a fabulous and strange game where you have the right to change the rules in the middle of the game! Indeed, changing the rules is the goal of the game. Changing a rule is considered as a move. Of course even that could be changed! The original (paper) game: www.nomic.net category: game author: Corentin Dupont-data-files: static/css/nomyx.css+data-files: static/css/nomyx.css static/nomyx.js data-dir: data extra-source-files: AUTHORS README TODO executable Nomyx- build-depends: DebugTraceHelpers -any, MonadCatchIO-mtl -any,- Nomyx-Rules ==0.1.0, QuickCheck -any, acid-state -any, base <5,- binary -any, blaze-html ==0.5.*, blaze-markup -any,- bytestring -any, containers -any, data-accessor-transformers -any,- directory -any, eprocess -any, extensible-exceptions -any,- filepath -any, happstack-server ==7.*, hdaemonize -any, hint -any,- hint-server -any, hslogger -any, mime-mail -any, monad-loops -any,- mtl ==2.*, mueval -any, network -any, process -any, reform -any,- reform-blaze -any, reform-happstack -any, regular -any, safe -any,- stm -any, template-haskell -any, text -any, time -any, unix -any,- utf8-string -any, web-routes ==0.27.*,+ build-depends: Cabal -any, DebugTraceHelpers -any, MissingH -any,+ MonadCatchIO-mtl -any, Nomyx-Language ==0.2.0, QuickCheck -any,+ acid-state -any, base <5, binary -any, blaze-html ==0.5.*,+ blaze-markup -any, bytestring -any, containers -any,+ data-accessor-transformers -any, data-lens -any, data-lens-fd -any,+ data-lens-template -any, directory -any, eprocess -any,+ extensible-exceptions -any, fb -any, filepath -any,+ happstack-authenticate -any, happstack-server ==7.*,+ hdaemonize -any, hint -any, hint-server -any, hscolour -any,+ hslogger -any, ixset -any, lenses -any, mime-mail -any,+ monad-loops -any, mtl ==2.*, mueval -any, network -any,+ process -any, reform -any, reform-blaze -any,+ reform-happstack -any, regular -any, safe -any, safecopy -any,+ stm -any, syb -any, template-haskell -any, text -any, time -any,+ unix -any, utf8-string -any, web-routes ==0.27.*, web-routes-happstack ==0.23.*, web-routes-regular ==0.19.*, web-routes-th -any main-is: Main.hs buildable: True extensions: CPP hs-source-dirs: src- other-modules: Quotes Types Mail Game Test Multi Server Serialize- Utils Interpret Commands Web.Common Web.Help Web.Game Web.Login- Web.Settings Web.MainPage Web.NewGame- ghc-options: -W - -- no-omit-yield+ other-modules: Multi Test Serialize Quotes Mail Types Utils+ Interpret Web.Game Web.Settings Web.MainPage Web.NewGame Web.Login+ Web.Help Web.Common+ ghc-options: -W+
README view
@@ -15,7 +15,7 @@ - download the source tar.gz - extract it somewhere -$ cd <name>/Nomyx-Rules+$ cd <name>/Nomyx-Language $ cabal install $ cd ../Nomyx $ cabal install@@ -35,3 +35,6 @@ =============== See file TODO for known bugs. Tested on Haskell-Platform 2012.1.0.0++Must be compiled with GHC option "-O1" or "-O0 -fno-omit-yields" (only available in GHC HEAD), to prevent attack with infinite non allocating loops:+http://hackage.haskell.org/trac/ghc/ticket/7528
TODO view
@@ -1,33 +1,40 @@ TODO list -Features to add: +Bugs: +- check when error on parameters (for victory for example) +- sendmail is blocking the game +- delete invalid events (in case of exception): events may be triggered twice if not deleted +- reading save file does not take absolute path +- add global option to not send mails +- store hide/show status of divs +- forbid creating a player with same name +- where clauses are not accepted by the interpreter +- suppress player from game when logout (?) -- interpreter (like tryhaskell.org) on the web page to debug rules -- make a command line client -- make a session system with cookie -- colorize code +Improvements: - make code instructions in the active rules table clickable to access haddock documentation - - -Improves: - +- option to read step by step the save file for analysis? - refresh web page when new event (currently, player needs to hit F5) -- input sanitization and error reporting - secure interpreter with mueval: time limits, no unsafe instructions, memory limits... - add a name to events to be able to delete categories of them - add "back to main page" links - recognize array vars to display them properly on HCI -- add command to rm save file +- use TH in addRuleParams +- possibility to modify game details +- add a proper log system (with levels) +- hide when no information +- cut rules too long +- purify some IO +- create an admin role +- add examples with a game master, a castle.. Futur Nomic: - ability to analyse rules, proof system +- first pass of compilation to check reference (avoid calls to non-existant variables for ex.) +- interpreter (like tryhaskell.org) on the web page to debug rules +- make a command line client -BUGS -- fix rule number for variables -- check when error on parameters (for victory for example) -- concurrent access to log file -- sendmail is blocking the game -- delete invalid events -- events may be triggered twice if not deleted (in case of exception) +Forum: +- start another VM to run Nomyx alone
data/static/css/nomyx.css view
@@ -62,17 +62,18 @@ 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 } -#gameName {- float:left;- margin-left:5%;- padding:10px;-}- #victory { float:left; margin-left:5%;@@ -90,8 +91,18 @@ margin-bottom:10px; } +#showCodeLink {+ text-align:right;+} +#gameName {+ padding-right: 10px;+} +/* #eventsBody {+ display:none;+}*/+ #header { border-top:1px solid silver; border-bottom:1px solid silver;@@ -126,13 +137,124 @@ /* height:150px;*/ } +.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;+}++.view, .join {+ 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:1px;+ }
+ 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 == '[Show]') + {+ events.style.display = 'block'; + show.innerHTML = '[Hide]';+ }+ else + {+ events.style.display = 'none'; + show.innerHTML ='[Show]';+ }+}
− src/Commands.hs
@@ -1,149 +0,0 @@---- | This module handles intrepreting players' commands.--- DEPRECATED-module Commands where--import Text.ParserCombinators.Parsec-import Data.List-import Utils-import Multi-import Data.Maybe-import Language.Nomic.Expression- --- | All commands issuable. -data Command = ListGame --- | Name - | NewGame - | JoinGame- | LeaveGame- | SubscribeGame- | UnsubscribeGame- | ShowSubscription- | ShowSubGame - | SubmitRule- | SubmitRuleI - | Constitution- | ShowAllRules - | ListPlayers- | ShowPendingActions- | ShowMyPendingActions- | ShowCompletedActions- | DoMyActions- | DoAction - | Amend- | Help - | QuitNomic- deriving (Eq, Show) - --- | Command's Strings -commands = [--("newPlayer", NewPlayer, ": Internal command."), - ("listGame", ListGame, ": list the active games"), --- ("name", Name, " <yourname>: change own name"), - ("newGame", NewGame, " <gamename>: start a new game"), - ("joinGame", JoinGame, " <gamename>: play in a game (you must be subscribed)"),- ("leaveGame", LeaveGame, " <gamename>: stop playing in a game (you remain subscribed)"),- ("subscribeGame", SubscribeGame, " <gamename>: subscribe to an existing game"),- ("unsubscribeGame", UnsubscribeGame," <gamename>: unsubscribe to an existing game"),- ("showSubscribtion", ShowSubscription, " <gamename>: show the subscribtions in the current game"),- ("showSubGame", ShowSubGame, " <gamename>: show the subscribtions to that game"), - ("submitRule", SubmitRule, " <name> <text> <code>: submit a rule. your code must be in \"\""),- ("iSubmitRule", SubmitRuleI, " submit a rule in interactive mode"), - ("showConstitution", Constitution, ": show the constitution (must be in a game)"),- ("showAllRules ", ShowAllRules, ": show every rules: Active (the current Constitution), Pending (currently proposed rules), Rejected (Proposed and rejected rules) and Suppressed (Once Active but suppressed rules)"), - ("listPlayers", ListPlayers, ": show the list of the players"), - ("amendConstitution", Amend, ": amend the constitution with the currently proposed rules"),- ("showPendingActions", ShowPendingActions, ": show all actions that has to be completed by players"), --TODO: verify "by players"- ("showMyPendingActions", ShowMyPendingActions, ": show all actions that has to be completed by you"),- ("iDoActions", DoMyActions, ": realize now all your actions, in interactive mode"),- ("doAction", DoAction, " <num> <result>: give the result of your action n°num (the number is given by showmypendingactions)."),- ("showCompletedActions", ShowCompletedActions, ": show all already completed actions"),- ("help", Help, ": show an help message"), - ("quit", QuitNomic, ": quit Nomic")]-- - - - --- | parseLine analysis the line and return a command with optionnal arguments -parseLine :: String -> Either ParseError (String, [String]) -parseLine = parse line "parse error" - --- | line is the parsec parser to analyse a command with optionnal arguments -line :: Parser (String, [String]) -line = do skipMany space- command <- simpleArg - skipMany space - args <- (quotedArg <|> simpleArg) `sepBy` spaces- skipMany space --TODO: trailing spaces- return (command, args)- --- | a simple argument's parser.-simpleArg :: Parser String-simpleArg = many1 $ noneOf " \n"---- | a rule parser.-quotedArg :: Parser String-quotedArg = between (char '"') (char '"') $ many $ noneOf ('"' : ['\NUL'..'\US'])-- - --- | runLine takes a String a executes the represented command, if any. -runLine :: String -> PlayerNumber -> Comm () -runLine s pn = do - let pl = parseLine s - case pl of - Left _ -> putCom "Command analysis error" - Right (comm, args) -> runCommand comm args pn- putCom "\n" - - --- | runCommand takes a String representing a command, optionnal arguments and runs it. -runCommand :: String -> [String] -> PlayerNumber -> Comm () -runCommand comm args pn = do- let comm' = toLowerS comm- let commands' = map (\(a,b,_) -> (toLowerS a, b)) commands- --lookup the commands...- case lookup comm' commands' of- Just c -> runCommand' c args pn- Nothing -> do- --if not found, try abbreviations- let mycomms = filter (\(sc, _) -> comm' `isPrefixOf` sc) commands' - case mycomms of - [] -> putCom "No command matchs your input" - (_ , c):[] -> runCommand' c args pn - _ -> putCom $ "Several commands match your input:\n\r" ++ concatMap (\(cs, _) -> cs ++ "\n\r") mycomms - - --- | commandMulti takes a command and optionnal arguments and runs it. -runCommand' :: Command -> [String] -> PlayerNumber -> Comm () -runCommand' ListGame _ = listGame ---runCommand' Name (a:[]) = newName a -runCommand' NewGame (g:[]) = newGame g -runCommand' JoinGame (g:[]) = joinGame g-runCommand' LeaveGame _ = leaveGame-runCommand' SubscribeGame (g:[]) = subscribeGame g-runCommand' UnsubscribeGame (g:[]) = unsubscribeGame g-runCommand' ShowSubscription _ = showSubscribtion-runCommand' ShowSubGame (g:[]) = showSubGame g -runCommand' SubmitRule (name:text:rule:[]) = submitRule name text rule-runCommand' SubmitRuleI _ = myCatch submitRuleI -runCommand' Constitution _ = showConstitution-runCommand' ShowAllRules _ = showAllRules -runCommand' ListPlayers _ = listPlayers -runCommand' Amend _ = amendConstitution-runCommand' ShowPendingActions _ = showPendingActions-runCommand' ShowMyPendingActions _ = showMyPendingActions-runCommand' DoMyActions _ = doActionsI-runCommand' DoAction (num:result:[]) = doAction num result-runCommand' ShowCompletedActions _ = showCompletedActions-runCommand' QuitNomic _ = quit-runCommand' Help _ = const help -runCommand' c _ = const $ putCom $ "the number of arguments doesn't match. \nUsage: \n" ++ getCommandUsage c - -getCommandUsage :: Command -> String-getCommandUsage c = fromMaybe (error "getCommandUsage: Usage not found") $ lookup c $ map (\(a,b,c) -> (b,a++c)) commands---- | issue an help message-help :: Comm ()-help = putCom $ "Nomic commands:\n" ++ concatMap (\(c, _, h) -> c ++"\t" ++ h ++ "\n\r") (tail commands)--}
− src/Game.hs
@@ -1,86 +0,0 @@-{-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable,- FlexibleContexts, GeneralizedNewtypeDeriving,- MultiParamTypeClasses, TemplateHaskell, TypeFamilies,- TypeOperators, FlexibleInstances, NoMonomorphismRestriction,- TypeSynonymInstances #-}---- | This module implements Game management.--- a game is a set of rules, and results of actions made by players (usually vote results)--- the module manages the effects of rules over each others.-module Game (initialGame, activeRules, execWithGame, pendingRules, rejectedRules) where--import Language.Nomyx.Rule-import Control.Monad.State-import Data.List-import Language.Nomyx.Expression-import Language.Nomyx.Evaluation-import Language.Nomyx.Examples---- | the initial rule set for a game.-rVoteUnanimity = Rule {- rNumber = 1,- rName = "Unanimity Vote",- rDescription = "A proposed rule will be activated if all players vote for it",- rProposedBy = 0,- rRuleCode = "onRuleProposed $ voteWith unanimity",- rRuleFunc = onRuleProposed $ voteWith unanimity,- rStatus = Active,- rAssessedBy = Nothing}--rVictory5Rules = Rule {- rNumber = 2,- rName = "Victory 5 accepted rules",- rDescription = "Victory is achieved if you have 5 active rules",- rProposedBy = 0,- rRuleCode = "victoryXRules 5",- rRuleFunc = victoryXRules 5,- rStatus = Active,- rAssessedBy = Nothing}--emptyGame name desc date = Game { gameName = name,- gameDesc = desc,- rules = [],- players = [],- variables = [],- events = [],- outputs = [],- victory = [],- currentTime = date}--initialGame :: GameName -> String -> UTCTime -> Game-initialGame name desc date = flip execState (emptyGame name desc date) $ do- evAddRule rVoteUnanimity- evActivateRule (rNumber rVoteUnanimity) 0- evAddRule rVictory5Rules- evActivateRule (rNumber rVictory5Rules) 0---- | the initial rule set for a game.-rApplicationMetaRule = Rule {- rNumber = 0,- rName = "Evaluate rule using meta-rules",- rDescription = "a proposed rule will be activated if all active metarules return true",- rProposedBy = 0,- rRuleCode = "applicationMetaRule",- rRuleFunc = onRuleProposed checkWithMetarules,- rStatus = Active,- rAssessedBy = Nothing}---- | An helper function to use the state transformer GameState.--- It additionally sets the current time.-execWithGame :: UTCTime -> State Game () -> Game -> Game-execWithGame t gs g = execState gs g {currentTime = t}-----accessors--activeRules :: Game -> [Rule]-activeRules = sort . filter (\(Rule {rStatus=rs}) -> rs==Active) . rules--pendingRules :: Game -> [Rule]-pendingRules = sort . filter (\(Rule {rStatus=rs}) -> rs==Pending) . rules--rejectedRules :: Game -> [Rule]-rejectedRules = sort . filter (\(Rule {rStatus=rs}) -> rs==Reject) . rules--instance Ord PlayerInfo where- h <= g = (playerNumber h) <= (playerNumber g)
src/Interpret.hs view
@@ -5,16 +5,15 @@ import Language.Haskell.Interpreter.Server import Control.Monad() import Paths_Nomyx -import Language.Nomyx.Expression +import Language.Nomyx import System.Directory import System.FilePath import System.Posix.Files-import Control.Monad import System.Posix.Resource+import Control.Exception as CE modDir = "modules"-importList = ["Prelude", "Language.Nomyx.Rule", "Language.Nomyx.Expression", "Language.Nomyx.Test",- "Language.Nomyx.Examples", "GHC.Base", "Data.Maybe"]+importList = ["Prelude", "Language.Nomyx", "GHC.Base", "Data.Maybe"] -- | the server handle startInterpreter :: IO ServerHandle @@ -45,16 +44,23 @@ setTopLevelModules $ map (dropExtension . takeFileName) fmods dataDir <- liftIO getDataDir set [searchPath := [dataDir], languageExtensions := [GADTs, ScopedTypeVariables]] --, languageExtensions := [], installedModulesInScope := False- --TODO: get all exported modules of Nomyx library+ --TODO: get all exported modules of Nomyx library from cabal setImports importList return () ---- | reads maybe a Rule out of a string. interpretRule :: String -> ServerHandle -> IO (Either InterpreterError RuleFunc) -interpretRule s sh = liftIO $ runIn sh $ do- liftIO $ mapM_ (uncurry setResourceLimit) limits- interpret s (as :: RuleFunc)- +interpretRule s sh = (liftIO $ runIn sh $ interpret s (as :: RuleFunc))+ `CE.catch` (\e -> return $ Left $ NotAllowed $ "Caught exception: " ++ (show (e:: IOException)))++getRuleFunc :: ServerHandle -> RuleCode -> IO RuleFunc+getRuleFunc sh rc = do+ res <- interpretRule rc sh+ case res of+ Right ruleFunc -> return ruleFunc+ Left e -> error $ show e++--liftIO $ mapM_ (uncurry setResourceLimit) limits cpuTimeLimitSoft = ResourceLimit 4 cpuTimeLimitHard = ResourceLimit 5 @@ -83,4 +89,6 @@ fmods <- liftIO getUploadModules liftIO $ putStrLn $ concat $ fmods loadModules (dir:fmods)++
src/Mail.hs view
@@ -7,24 +7,31 @@ import qualified Text.Blaze.Html5 as H import Text.Blaze.Html.Renderer.String import Network.Mail.Mime hiding (mailTo)-import Prelude hiding (div)+import Prelude hiding (div, (.)) import Text.Reform.Happstack() import Control.Monad import Types-import Language.Nomyx.Expression+import Language.Nomyx+import Language.Nomyx.Game import Data.Text(Text, pack) import Control.Concurrent import Data.Maybe import Utils import Control.Exception import qualified Data.Text.Lazy as B+import qualified Language.Haskell.HsColour.HTML as HSC+import Language.Haskell.HsColour.Colourise hiding (string)+import Text.Blaze.Internal+import Control.Category+import qualified Data.Acid.Advanced as A (query')+import Control.Applicative ((<$>)) default (Integer, Double, Data.Text.Text) sendMail :: String -> String -> String -> IO() sendMail to object body = do putStrLn $ "sending a mail to " ++ to- forkIO $ simpleMail (Address Nothing (pack to)) (Address (Just "Nomyx Game") "corentin.dupont@gmail.com") (pack object) "" (B.pack body) [] >>= renderSendMail+ forkIO $ simpleMail (Address Nothing (pack to)) (Address (Just "Nomyx Game") "Nomyx.Game@gmail.com") (pack object) "" (B.pack body) [] >>= renderSendMail putStrLn $ "done" return () @@ -34,7 +41,7 @@ (toHtml $ "a new rule has been proposed by player " ++ prop ++ ".") >> H.br (toHtml $ "Name: " ++ name) >> H.br (toHtml $ "Description: " ++ desc) >> H.br- (toHtml $ "Code: " ++ code) >> H.br >> H.br+ (toHtml $ "Code: ") >> H.br >> (preEscapedString $ HSC.hscolour defaultColourPrefs False $ code) >> H.br >> H.br (toHtml $ "Please login into Nomyx for actions on this rule:") >> H.br (toHtml $ nomyxURL net ++ "/Nomyx") >> H.br >> H.br (toHtml $ "You received this mail because you subscribed to Nomyx. To stop receiving mails, login to Nomyx with the above address, go to Settings and uncheck the corresponding box.") >> H.br@@ -42,24 +49,26 @@ newRuleObject :: PlayerName -> String newRuleObject name = "[Nomyx] New rule posted by player " ++ name ++ "!" -sendMailsNewRule :: Multi -> SubmitRule -> PlayerNumber -> IO()-sendMailsNewRule m sr pn = do- evaluate m- let gn = gameName $ fromJust $ getPlayersGame pn m- let proposer = getPlayersName pn m- forM_ (mPlayers m) $ send proposer gn- where send prop gn pm = when ((Just gn == inGame pm) && (mailNewRule $ mMail pm)) $ \- sendMail (mailTo $ mMail pm) (newRuleObject prop) (renderHtml $ newRuleBody (mPlayerName pm) sr prop (net m))+sendMailsNewRule :: Session -> SubmitRule -> PlayerNumber -> IO()+sendMailsNewRule s sr pn = do+ evaluate s+ gn <- fromJust <$> getPlayersGame pn s+ proposer <- getPlayersName pn s+ pfd <- A.query' (acidProfileData $ _profiles s) AskProfilesData+ let pls = [ p { _pPlayerNumber = mypn} | p <- pfd, mypn <- map _playerNumber $ _players $ _game gn]+ forM_ pls $ send proposer (_net $ _mSettings $ _multi s)+ where+ send :: PlayerName -> Network -> ProfileData -> IO()+ send prop net pfd = when (_mailNewRule $ _pPlayerSettings pfd)+ $ sendMail (_mailTo $ _pPlayerSettings $ pfd) (newRuleObject prop) (renderHtml $ newRuleBody (_pPlayerName $ _pPlayerSettings $ pfd) sr prop net) mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM f = liftM catMaybes . mapM f -getOutputs :: Multi -> [Output]-getOutputs m = concatMap outputs $ games m newRulebody :: Rule -> String-newRulebody (Rule {rNumber, rProposedBy}) = "Rule number " ++ (show rNumber) ++ " has been proposed by player " ++ (show rProposedBy)+newRulebody (Rule {_rNumber, _rProposedBy}) = "Rule number " ++ (show _rNumber) ++ " has been proposed by player " ++ (show _rProposedBy)
src/Main.hs view
@@ -15,7 +15,7 @@ module Main (main) where -import Prelude hiding (catch) +import Prelude hiding (catch, (.)) import System.Console.GetOpt import System.Environment import Web.MainPage@@ -33,14 +33,21 @@ import Types import Serialize import Paths_Nomyx as PN-import Language.Haskell.Interpreter.Server hiding (start) import System.Directory import Data.Time.Clock-import Language.Nomyx.Expression-import Control.Monad+import Language.Nomyx hiding (getCurrentTime) import Control.Exception hiding (bracket) import Test import Utils+import Data.Version (showVersion)+import Control.Category+import Multi+import Language.Haskell.Interpreter.Server hiding (start)+import Data.Acid (openLocalStateFrom)+import System.FilePath ((</>))+import Happstack.Auth.Core.Auth (initialAuthState)+import Data.Acid.Local (createCheckpointAndClose)+import Happstack.Auth.Core.Profile (initialProfileState) defaultLogFile :: FilePath defaultLogFile = "Nomyx.save"@@ -48,24 +55,28 @@ -- | Entry point of the program. main :: IO Bool main = do - putStrLn "Welcome to Nomyx!" args <- getArgs (flags, _) <- nomyxOpts args - --parseActions flags- --let verbose = Verbose `elem` flags - case (Daemon `elem` flags) of- True -> (daemonize $ start flags) >> return True- False -> start flags >> return True+ if (Version `elem` flags) then do+ putStrLn $ "Nomyx " ++ showVersion version+ return True+ else do+ putStrLn "Welcome to Nomyx!" + case (Daemon `elem` flags) of+ True -> (daemonize $ start flags) >> return True+ False -> start flags >> return True start :: [Flag] -> IO () start flags = do serverCommandUsage+ --start the haskell interpreter sh <- protectHandlers startInterpreter if Test `elem` flags then do putStrLn $ "\nNomyx Language Tests results:\n" ++ (concatMap (\(a,b) -> a ++ ": " ++ (show b) ++ "\n") LT.tests) ts <- playTests sh putStrLn $ "\nNomyx Game Tests results:\n" ++ (concatMap (\(a,b) -> a ++ ": " ++ (show b) ++ "\n") ts)+ putStrLn $ "All Tests Pass: " ++ (show $ allTests && (all snd ts)) else do --creating game structures logFile <- case (findSaveFile flags) of@@ -78,59 +89,61 @@ Just h -> return h Nothing -> getHostName >>= return logFilePath <- getDataFileName logFile+ let settings sendMail = Settings logFilePath (Network host port) sendMail multi <- case (findLoadTest flags) of- Just testName -> loadTestName logFilePath sh (Network host port) testName- Nothing -> loadMulti logFilePath sh (Network host port)- tvMulti <- atomically $ newTVar multi- --start the web server- forkIO $ launchWebServer tvMulti (Network host port)- forkIO $ launchTimeEvents tvMulti+ Just testName -> loadTestName (settings False) testName sh+ Nothing -> Main.loadMulti (settings True) (not $ NoReadSaveFile `elem` flags) sh --main loop- serverLoop tvMulti logFile+ profilePath <- getDataDir+ withAcid (Just $ profilePath </> "profiles") $ \acid -> do+ tvSession <- atomically $ newTVar (Session sh multi acid)+ --start the web server+ forkIO $ launchWebServer tvSession (Network host port)+ forkIO $ launchTimeEvents tvSession+ serverLoop tvSession logFile -loadMulti :: FilePath -> ServerHandle -> Network -> IO Multi-loadMulti fp sh net = do- fileExists <- doesFileExist fp- t <- getCurrentTime- multi <- case fileExists of+loadMulti :: Settings -> Bool -> ServerHandle -> IO Multi+loadMulti set readSaveFile sh = do+ fileExists <- doesFileExist $ _logFilePath $ set+ multi <- case fileExists && readSaveFile of True -> do putStrLn "Loading previous game"- (loadEvents fp sh net) `catch`- (\e -> (putStrLn $ "Error while loading logged events, log file discarded\n" ++ (show (e::ErrorCall))) >> (return $ defaultMulti sh fp net t))- False -> return $ defaultMulti sh fp net t+ Serialize.loadMulti set sh `catch`+ (\e -> (putStrLn $ "Error while loading logged events, log file discarded\n" ++ (show (e::ErrorCall))) >> (return $ defaultMulti set))+ False -> return $ defaultMulti set return multi -- | a loop that will handle server commands -serverLoop :: TVar Multi -> FilePath -> IO () -serverLoop tm f = do+serverLoop :: TVar Session -> FilePath -> IO () +serverLoop ts f = do s <- getLine case s of "d" -> do- m <- atomically $ readTVar tm+ (Session _ m _) <- atomically $ readTVar ts putStrLn $ show m- serverLoop tm f+ serverLoop ts f "s" -> do putStrLn "saving state..."- m <- atomically $ readTVar tm+ (Session _ m _) <- atomically $ readTVar ts fp <- getDataFileName f- save fp $ logEvents $ logs m- serverLoop tm f+ save fp m+ serverLoop ts f "q" -> return () _ -> do putStrLn "command not recognized"- serverLoop tm f+ serverLoop ts f serverCommandUsage :: IO () serverCommandUsage = do putStrLn "Server commands:"- --putStrLn "s -> save state"+ putStrLn "s -> save state" putStrLn "d -> debug" putStrLn "q -> quit" -- | Launch mode data Flag - = Verbose | Version | Test | HostName String | Port String | LogFile FilePath | Daemon | LoadTest String + = Verbose | Version | Test | HostName String | Port String | LogFile FilePath | Daemon | LoadTest String | NoReadSaveFile deriving (Show, Eq) -- | launch options description @@ -141,7 +154,8 @@ , Option ['t'] ["tests"] (NoArg Test) "perform routine check" , Option ['h'] ["host"] (ReqArg HostName "Hostname") "specify host name" , Option ['p'] ["port"] (ReqArg Port "Port") "specify port"- , Option ['r'] ["read"] (ReqArg LogFile "SaveFile") "specify save file"+ , Option ['r'] ["read"] (ReqArg LogFile "SaveFile") "specify save file (default is Nomyx.save)"+ , Option ['n'] ["noread"] (NoArg NoReadSaveFile) "don't read save file, just overwrite" , Option ['d'] ["daemon"] (NoArg Daemon) "run in daemon mode" , Option ['l'] ["loadtest"] (ReqArg LoadTest "TestName") "specify name of test to load" ] @@ -193,33 +207,32 @@ protectHandlers :: MonadCatchIO m => m a -> m a protectHandlers a = bracket saveHandlers restoreHandlers $ const a -triggerTimeEvent :: TVar Multi -> UTCTime -> IO()+triggerTimeEvent :: TVar Session -> UTCTime -> IO() triggerTimeEvent tm t = do- m <- atomically $ readTVar tm- m' <- execWithMulti t (update (TE t (MultiTimeEvent t)) Nothing) m- atomically $ writeTVar tm m'----- | get all events that has not been triggered yet-getTimeEvents :: UTCTime -> TVar Multi -> IO([UTCTime])-getTimeEvents now tm = do- m <- atomically $ readTVar tm- let times = catMaybes $ map getTimes $ concatMap events $ games m- return $ filter (\t -> t <= now && t > (-2) `addUTCTime` now) times+ (Session sh m a) <- atomically $ readTVar tm+ m' <- execWithMulti t (Multi.triggerTimeEvent t) m+ atomically $ writeTVar tm (Session sh m' a)+ save (_mSettings >>>_logFilePath $ m') m' -launchTimeEvents :: TVar Multi -> IO()+launchTimeEvents :: TVar Session -> IO() launchTimeEvents tm = do now <- getCurrentTime --putStrLn $ "tick " ++ (show now)- timeEvents <- getTimeEvents now tm+ (Session _ m _) <- atomically $ readTVar tm+ timeEvents <- getTimeEvents now m when (length timeEvents /= 0) $ putStrLn "found time event(s)"- mapM_ (triggerTimeEvent tm) timeEvents+ mapM_ (Main.triggerTimeEvent tm) timeEvents --sleep 1 second roughly threadDelay 1000000 launchTimeEvents tm --getTimes :: EventHandler -> Maybe UTCTime-getTimes (EH _ _ (Time t) _) = Just t-getTimes _ = Nothing+withAcid :: Maybe FilePath -- ^ state directory+ -> (Profiles -> IO a) -- ^ action+ -> IO a+withAcid mBasePath f =+ let basePath = fromMaybe "_state" mBasePath in+ bracket (openLocalStateFrom (basePath </> "auth") initialAuthState) (createCheckpointAndClose) $ \auth ->+ bracket (openLocalStateFrom (basePath </> "profile") initialProfileState) (createCheckpointAndClose) $ \profile ->+ bracket (openLocalStateFrom (basePath </> "profileData") initialProfileDataState) (createCheckpointAndClose) $ \profileData ->+ f (Profiles auth profile profileData)
src/Multi.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, ScopedTypeVariables,- MultiParamTypeClasses, TemplateHaskell, TypeFamilies, TypeOperators,- TypeSynonymInstances, FlexibleInstances, GADTs, NamedFieldPuns, DoAndIfThenElse #-}+ MultiParamTypeClasses, TemplateHaskell, TypeFamilies, TypeOperators, TemplateHaskell, QuasiQuotes,+ TypeSynonymInstances, FlexibleInstances, GADTs, NamedFieldPuns, DoAndIfThenElse, RecordWildCards #-} -- | This module manages multi-player games and commands. module Multi where@@ -14,289 +14,190 @@ import Prelude hiding (catch) import Data.List import Control.Monad.State-import Game import Utils import Interpret-import Debug.Trace.Helpers()-import Language.Nomyx.Expression-import Data.Time+import Data.Time as T import Language.Haskell.Interpreter.Server (ServerHandle)-import Language.Nomyx.Evaluation import Data.Maybe import Types import Control.Applicative import Control.Exception import Debug.Trace.Helpers---- | helper function to change a player's ingame status.-mayJoinGame :: Maybe GameName -> PlayerNumber -> [PlayerMulti] -> [PlayerMulti]-mayJoinGame maybename pn pl = case find (\(PlayerMulti mypn _ _ _ _ _) -> mypn == pn) pl of- Just o -> replace o o{ inGame = maybename} pl- Nothing -> pl--newPlayerU :: PlayerMulti -> State Multi ()-newPlayerU pm = do- pms <- gets mPlayers- modify (\multi -> multi { mPlayers = pm : pms})---getNewPlayerNumber :: State Multi PlayerNumber-getNewPlayerNumber = do- ps <- gets mPlayers- return $ length ps + 1---addNewGame :: Game -> State Multi ()-addNewGame new = modify (\multi@Multi {games=gs} -> multi {games = new:gs})--getGameByName :: GameName -> State Multi (Maybe Game)-getGameByName gn = fmap (find (\(Game {gameName = n}) -> n==gn)) (gets games)--joinGamePlayer :: PlayerNumber -> GameName -> State Multi ()-joinGamePlayer pn game = modify (\multi -> multi {mPlayers = mayJoinGame (Just game) pn (mPlayers multi)})+import Data.Lens+import Language.Nomyx+import Language.Nomyx.Game as G+import Control.Category hiding ((.))+import qualified Data.Acid.Advanced as A (update', query')+import Quotes (cr) -leaveGameU :: PlayerNumber -> State Multi ()-leaveGameU pn = modify (\multi -> multi {mPlayers = mayJoinGame Nothing pn (mPlayers multi)})---- | list the active games-listGame :: PlayerNumber -> State Multi ()-listGame _ = do- gs <- gets games- case length gs of- 0 -> traceM "No active games"- _ -> do- traceM "Active games:"- traceM $ concatMap (\g -> gameName g ++ "\n") gs+-- | add a new player+newPlayer :: PlayerNumber -> PlayerSettings -> Maybe GameName -> Maybe SubmitRule -> StateT Session IO ()+newPlayer uid ms gn sr = do+ s <- get+ A.update' (acidProfileData $ _profiles s) (NewProfileData uid ms gn sr)+ return () -- | starts a new game-newGame :: GameName -> String -> PlayerNumber -> State Multi ()-newGame name desc _ = do- gs <- gets games- case null $ filter (\p -> gameName p == name) gs of- True -> do- traceM $ "Creating a new game of name: " ++ name- t <- gets mCurrentTime- -- create a game with zero players- modify (\m -> m {games = (initialGame name desc t):gs})- False -> traceM $ "this name is already used"--uniqueGame :: String -> [Game] -> Bool-uniqueGame s gs = null $ filter (\p -> gameName p == s) gs+newGame :: GameName -> GameDesc -> PlayerNumber -> StateT Session IO ()+newGame name desc pn = do+ sh <- access sh+ focus multi $ do+ gs <- access games+ case null $ filter ((== name) . getL (game >>> gameName)) gs of+ True -> do+ tracePN pn $ "Creating a new game of name: " ++ name+ t <- lift $ T.getCurrentTime+ -- create a game with zero players+ lg <- lift $ initialLoggedGame name desc t sh+ void $ games %= (lg : )+ False -> tracePN pn "this name is already used" --- | join a game.-joinGame :: GameName -> PlayerNumber -> State Multi ()-joinGame game pn = do- mg <- getGameByName game+-- | view a game.+viewGamePlayer :: GameName -> PlayerNumber -> StateT Session IO ()+viewGamePlayer game pn = do+ mg <- focus multi $ getGameByName game case mg of- Nothing -> traceM $ "No game by that name"- Just g -> do- traceM "subscribing first."- subscribeGame (gameName g) pn- traceM $ "Joining game: " ++ game- joinGamePlayer pn game----- | leave a game (you remain subscribed).-leaveGame :: PlayerNumber -> State Multi ()-leaveGame pn = do- leaveGameU pn- traceM "You left the game (you remain subscribed)."----- | subcribe to a game.-subscribeGame :: GameName -> PlayerNumber -> State Multi ()-subscribeGame game pn = do- m <- get- inGameDo game $ do- g <- get- case find (\(PlayerInfo { playerNumber=mypn}) -> mypn == pn ) (players g) of- Just _ -> traceM "Already subscribed!"- Nothing -> do- traceM $ "Subscribing to game: " ++ game- let player = PlayerInfo { playerNumber = pn, playerName = getPlayersName pn m}- put g {players = player : (players g)}- triggerEvent (Player Arrive) (PlayerData player)----- | subcribe to a game.-unsubscribeGame :: GameName -> PlayerNumber -> State Multi ()-unsubscribeGame game pn = inGameDo game $ do- g <- get- case find (\(PlayerInfo { playerNumber=mypn}) -> mypn == pn ) (players g) of- Nothing -> traceM "Not subscribed!"- Just _ -> do- traceM $ "Unsubscribing to game: " ++ game- let player = PlayerInfo { playerNumber = pn, playerName = getPlayersName' g pn}- put g {players = filter (\PlayerInfo { playerNumber = mypn} -> mypn /= pn) (players g)}- triggerEvent (Player Leave) (PlayerData player)---showSubGame :: GameName -> PlayerNumber -> State Multi ()-showSubGame g _ = inGameDo g $ do- ps <- gets players- traceM $ concatMap show ps+ Nothing -> tracePN pn "No game by that name"+ Just _ -> modifyProfile pn (pViewingGame ^= Just game) -showSubscribtion :: PlayerNumber -> State Multi ()-showSubscribtion pn = inPlayersGameDo_ pn $ do- ps <- gets players- traceM $ concatMap show ps+-- | unview a game.+unviewGamePlayer :: PlayerNumber -> StateT Session IO ()+unviewGamePlayer pn = modifyProfile pn (pViewingGame ^= Nothing) +-- | join a game (also view it for conveniency)+joinGame :: GameName -> PlayerNumber -> StateT Session IO ()+joinGame game pn = do+ s <- get+ name <- lift $ getPlayersName pn s+ focus multi $ inGameDo game $ G.update $ JoinGame pn name+ viewGamePlayer game pn +-- | leave a game.+leaveGame :: GameName -> PlayerNumber -> StateT Session IO ()+leaveGame game pn = focus multi $ inGameDo game $ G.update $ LeaveGame pn -- | insert a rule in pending rules.-submitRule :: SubmitRule -> PlayerNumber -> ServerHandle -> StateT Multi IO ()-submitRule sr pn sh = do- mnr <- enterRule sr pn sh- case mnr of- Just nr -> do- inPlayersGameDo' pn $ do- r <- evProposeRule nr- if r == True then traceM $ "Your rule has been added to pending rules."- else traceM $ "Error: Rule could not be proposed"- liftT $ updateLastRule Nothing pn- Nothing -> liftT $ updateLastRule (Just sr) pn----- | reads a rule.-enterRule :: SubmitRule -> PlayerNumber -> ServerHandle -> StateT Multi IO (Maybe Rule)-enterRule (SubmitRule name desc code) pn sh = do+submitRule :: SubmitRule -> PlayerNumber -> ServerHandle -> StateT Session IO ()+submitRule sr@(SubmitRule _ _ code) pn sh = do+ tracePN pn $ "proposed " ++ (show sr) mrr <- lift $ interpretRule code sh- join <$> (inPlayersGameDo' pn $ do- rs <- gets rules- let rn = getFreeNumber $ map rNumber rs+ case mrr of+ Right _ -> do+ tracePN pn $ "proposed rule compiled OK "+ inPlayersGameDo_ pn $ G.update' (Just $ getRuleFunc sh) (ProposeRuleEv pn sr)+ modifyProfile pn (pLastRule ^= Nothing)+ Left e -> do+ inPlayersGameDo_ pn $ update $ OutputPlayer pn ("Compiler error: " ++ show e ++ "\n")+ tracePN pn ("Compiler error: " ++ show e ++ "\n")+ modifyProfile pn (pLastRule ^= Just sr) -- keep in memory the last rule proposed by the player to display it in case of error - case mrr of- Right ruleFunc -> return $ Just Rule {rNumber = rn,- rName = name,- rDescription = desc,- rProposedBy = pn,- rRuleCode = code,- rRuleFunc = ruleFunc,- rStatus = Pending,- rAssessedBy = Nothing}- Left e -> do- output ("Compiler error: " ++ show e ++ "\n") pn- return Nothing) -updateLastRule :: Maybe SubmitRule -> PlayerNumber -> State Multi ()-updateLastRule msr pn = do- pm <- fromJust <$> findPlayer' pn- pls <- gets mPlayers- let pls' = replace pm (pm {lastRule = msr}) pls- modify (\m -> m{mPlayers = pls'})----cpuTimeLimitSoft = ResourceLimit 4---cpuTimeLimitHard = ResourceLimit 5---limits :: [(Resource, ResourceLimits)]---limits = [ (ResourceCPUTime, ResourceLimits cpuTimeLimitSoft cpuTimeLimitHard)]--inputChoiceResult :: EventNumber -> Int -> PlayerNumber -> State Multi ()-inputChoiceResult eventNumber choiceIndex pn = inPlayersGameDo_ pn $ triggerChoice eventNumber choiceIndex+-- | result of choice with radio buttons+inputChoiceResult :: EventNumber -> Int -> PlayerNumber -> StateT Session IO ()+inputChoiceResult eventNumber choiceIndex pn = do+ tracePN pn $ "input choice result: Event " ++ (show eventNumber) ++ ", choice " ++ (show choiceIndex)+ inPlayersGameDo_ pn $ update $ InputChoiceResult pn eventNumber choiceIndex -- TODO maybe homogeneise both inputs event-inputStringResult :: Event InputString -> String -> PlayerNumber -> State Multi ()-inputStringResult event input pn = inPlayersGameDo_ pn $ triggerEvent event (InputStringData input)+-- | result of choice with text field+inputStringResult :: Event InputString -> String -> PlayerNumber -> StateT Session IO ()+inputStringResult (InputString _ ti) input pn = inPlayersGameDo_ pn $ update $ InputStringResult pn ti input -inputUpload :: PlayerNumber -> FilePath -> String -> ServerHandle -> StateT Multi IO ()+-- | upload a rule file+inputUpload :: PlayerNumber -> FilePath -> String -> ServerHandle -> StateT Session IO () inputUpload pn dir mod sh = do- m <- lift $ loadModule dir mod sh- case m of+ m <- liftIO $ loadModule dir mod sh+ tracePN pn $ " uploaded " ++ (show mod)+ case m of Right _ -> do- inPlayersGameDo'_ pn $ output ("File loaded: " ++ show dir ++ " Module " ++ show mod ++"\n") pn+ inPlayersGameDo_ pn $ update $ OutputPlayer pn ("File loaded: " ++ show dir ++ " Module " ++ show mod ++"\n")+ tracePN pn "upload success" return () Left e -> do- inPlayersGameDo'_ pn $ output ("Compiler error: " ++ show e ++ "\n") pn+ inPlayersGameDo_ pn $ update $ OutputPlayer pn ("Compiler error: " ++ show e ++ "\n")+ tracePN pn "upload failed" return () --mailSettings :: MailSettings -> PlayerNumber -> State Multi ()-mailSettings mailSettings pn = do- mps <- gets mPlayers- case find (\(PlayerMulti {mPlayerNumber}) -> pn==mPlayerNumber) mps of- Nothing -> traceM "settings not modified!"- Just pm -> do- let newmps = replace pm pm{mMail=mailSettings} mps- modify (\m -> m{mPlayers = newmps})---- | show the constitution.-showConstitution :: PlayerNumber -> State Multi ()-showConstitution pn = inPlayersGameDo_ pn $ get >>= (traceM . show . activeRules)----- | show every rules (including pendings and deleted)-showAllRules :: PlayerNumber -> State Multi () -showAllRules pn = inPlayersGameDo_ pn $ get >>= (traceM . show . rules)--displayPlayer :: PlayerMulti -> String-displayPlayer (PlayerMulti pn name _ _ (Just game) _) = show pn ++ ": " ++ name ++ " in game: " ++ game ++ "\n"-displayPlayer (PlayerMulti pn name _ _ Nothing _) = show pn ++ ": " ++ name ++ "\n"+-- | update player settings+playerSettings :: PlayerSettings -> PlayerNumber -> StateT Session IO ()+playerSettings playerSettings pn = modifyProfile pn (pPlayerSettings ^= playerSettings) -- | Utility functions --- | replace the player's name in the list-setName :: String -> PlayerNumber -> [PlayerMulti] -> [PlayerMulti]-setName name pn pl = case find (\(PlayerMulti h _ _ _ _ _) -> h == pn) pl of- Just o -> replace o o{ mPlayerName = name} pl- Nothing -> pl+getNewPlayerNumber :: StateT Session IO PlayerNumber+getNewPlayerNumber = do+ s <- get+ pfd <- A.query' (acidProfileData $ _profiles s) AskProfileDataNumber+ return $ pfd + 1 +getGameByName :: GameName -> StateT Multi IO (Maybe LoggedGame)+getGameByName gn = (find ((==gn) . getL (game >>> gameName))) <$> (access games) -- | this function apply the given game actions to the game the player is in.-inPlayersGameDo :: PlayerNumber -> State Game a -> State Multi (Maybe a)+inPlayersGameDo :: PlayerNumber -> StateT LoggedGame IO a -> StateT Session IO (Maybe a) inPlayersGameDo pn action = do- multi <- get- t <- gets mCurrentTime- let mg = getPlayersGame pn multi+ s <- get+ t <- lift $ T.getCurrentTime+ mg <- lift $ getPlayersGame pn s case mg of- Nothing -> traceM "You must be in a game" >> return Nothing+ Nothing -> tracePN pn "You must be in a game" >> return Nothing Just g -> do- (a, myg) <- lift $ runStateT action (g { currentTime = t})- modifyGame myg+ (a, myg) <- lift $ runStateT action (setL (game >>> currentTime) t g)+ focus multi $ modifyGame myg return (Just a) -inPlayersGameDo_ :: PlayerNumber -> State Game a -> State Multi ()+inPlayersGameDo_ :: PlayerNumber -> StateT LoggedGame IO a -> StateT Session IO () inPlayersGameDo_ pn action = inPlayersGameDo pn action >> return () -inPlayersGameDo' :: PlayerNumber -> State Game a -> StateT Multi IO (Maybe a)-inPlayersGameDo' pn gs = do- m <- get- let (a, m') = runState (inPlayersGameDo pn gs) m- put m'- return a--inPlayersGameDo'_ :: PlayerNumber -> State Game a -> StateT Multi IO ()-inPlayersGameDo'_ pn action = inPlayersGameDo' pn action >> return ()--inGameDo :: GameName -> State Game () -> State Multi ()-inGameDo game action = do- gs <- gets games- case find (\(Game {gameName =n}) -> n==game) gs of+inGameDo :: GameName -> StateT LoggedGame IO () -> StateT Multi IO ()+inGameDo gn action = do+ (gs :: [LoggedGame]) <- access games+ case find ((==gn) . getL (game >>> gameName)) gs of Nothing -> traceM "No game by that name"- Just g -> do- t <- gets mCurrentTime- let myg = execWithGame t action g+ Just (g::LoggedGame) -> do+ t <- lift $ T.getCurrentTime+ myg <- lift $ execWithGame' t action g modifyGame myg triggerTimeEvent :: UTCTime -> StateT Multi IO () triggerTimeEvent t = do- gs <- gets games- gs' <- lift $ mapM (\g -> trig t g `catch` timeExceptionHandler t g) gs- modify(\m -> m{games = gs'})+ gs <- access games+ gs' <- lift $ mapM (\g -> trig t g) gs+ void $ games ~= gs' -trig :: UTCTime -> Game -> IO Game+trig :: UTCTime -> LoggedGame -> IO LoggedGame trig t g = do- let g' = execWithGame t (evTriggerTime t) g+ g' <- execWithGame' t (update $ TimeEvent t) g evaluate g'- return g' -timeExceptionHandler :: UTCTime -> Game -> ErrorCall -> IO Game-timeExceptionHandler t g e = do- putStrLn $ "Error in triggerTimeEvent: " ++ (show e)- return $ execWithGame t (outputAll $ "Error while triggering a time event: " ++ (show e) ++- "\nThe event have been canceled. Please remove/fix the faulty rule.") g+-- | get all events that has not been triggered yet+getTimeEvents :: UTCTime -> Multi -> IO([UTCTime])+getTimeEvents now m = do+ let times = catMaybes $ map getTimes $ (concatMap (getL $ game >>> events)) $ _games m+ return $ filter (\t -> t <= now && t > (-2) `addUTCTime` now) times +-- | the initial rule set for a game.+rVoteUnanimity = SubmitRule "Unanimity Vote"+ "A proposed rule will be activated if all players vote for it"+ [cr|onRuleProposed $ voteWith unanimity $ assessOnEveryVotes|]++rVictory5Rules = SubmitRule "Victory 5 accepted rules"+ "Victory is achieved if you have 5 active rules"+ [cr|victoryXRules 5|]+++initialGame :: ServerHandle -> StateT LoggedGame IO ()+initialGame sh = do+ update' (Just $ getRuleFunc sh) $ SystemAddRule rVoteUnanimity+ update' (Just $ getRuleFunc sh) $ SystemAddRule rVictory5Rules++initialLoggedGame :: GameName -> GameDesc -> UTCTime -> ServerHandle -> IO LoggedGame+initialLoggedGame name desc date sh = do+ let lg = LoggedGame (emptyGame name desc date) []+ execStateT (initialGame sh) lg
src/Quotes.hs view
@@ -11,7 +11,7 @@ -- | -- ------------------------------------------------------------------------------{-# LANGUAGE NamedFieldPuns, TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE NamedFieldPuns, TemplateHaskell, QuasiQuotes, FlexibleInstances, GADTs #-} module Quotes where @@ -20,11 +20,12 @@ import Language.Haskell.Interpreter hiding (get) import Interpret + cr :: QuasiQuoter-cr = QuasiQuoter { quoteExp = quoteRuleFunc,- quotePat = undefined,+cr = QuasiQuoter { quoteExp = quoteRuleFunc,+ quotePat = undefined, quoteType = undefined,- quoteDec = undefined}+ quoteDec = undefined} quoteRuleFunc :: String -> Q TH.Exp quoteRuleFunc s = do@@ -32,9 +33,53 @@ setImports importList typeOf s case res of+ Right "Nomex RuleResp" -> [| s |] Right "RuleFunc" -> [| s |]- Right _ -> fail $ "Rule doesn't typecheck"+ Right a -> fail $ "Rule doesn't typecheck: " ++ (show a) Left e -> fail $ show e ++--cr2 :: QuasiQuoter+--cr2 = QuasiQuoter { quoteExp = quoteRuleFunc2,+-- quotePat = undefined,+-- quoteType = undefined,+-- quoteDec = undefined}+--+--quoteRuleFunc2 :: String -> Q TH.Exp+--quoteRuleFunc2 s = do+-- res <- runIO $ runInterpreter $ do+-- setImports importList+-- interpret s (as::RuleFunc)+-- case res of+-- Right f -> [| (s,f) |]+-- Left e -> fail $ show e+++ --do --[| putParens s |]+-- s_0 <- newName "s"+-- return $ LamE [VarP s_0] (InfixE (Just (LitE (StringL "(")))+-- (VarE GHC.Base.++)+-- (Just (InfixE (Just (VarE s_0))+--+--+--putParens :: String -> String+--putParens s = "(" ++ s ++ ",\"" ++ s ++ "\")"+--+--putParens' :: Q TH.Exp -> Q TH.Exp+--putParens' (LitE (StringL s)) = (LitE (StringL s))++--t :: (Int, String)+--t = $( [| 1 |] )+--RuleName -> RuleFunc -> RuleCode -> RuleNumber -> String -> Nomex ()++---- $( quoteRuleFunc2 "voidRule $ return ()")+--putParens :: String -> IO (String, RuleFunc)+--putParens s = do+-- res <- runIO $ runInterpreter $ do+-- setImports importList+-- interpret s (as::RuleFunc)+-- case res of+-- Right f -> return (s, f)+-- Left e -> fail $ show e
src/Serialize.hs view
@@ -3,81 +3,38 @@ module Serialize where -import Prelude hiding (log, catch)-import Language.Nomyx.Expression+import Prelude hiding (log, (.))+import Language.Nomyx hiding (getCurrentTime)+import Language.Nomyx.Game import Control.Monad.State import Types-import Multi+import Control.Category+import Data.Lens import Language.Haskell.Interpreter.Server-import Control.Applicative-import Data.Time.Clock-import Utils-import Control.Exception+import Interpret -save :: FilePath -> [TimedEvent] -> IO()-save fp ges = writeFile fp $ concatMap (\a -> show a ++ "\n") ges+save :: FilePath -> Multi -> IO()+save fp m = do+ putStrLn "saving"+ writeFile fp (show m) save' :: StateT Multi IO () save' = do- lgs <- gets logs- lift $ save (logFilePath lgs) (logEvents lgs)--load :: FilePath -> IO([TimedEvent])-load fp = (map read . lines) <$> readFile fp--logEvent :: TimedEvent -> StateT Multi IO ()-logEvent le = do- m <- get- ls <- gets logs- put m { logs = ls { logEvents = (logEvents $ logs m) ++ [le]}}--putTime :: UTCTime -> StateT Multi IO ()-putTime t = modify (\m -> m{mCurrentTime = t})--enactTimedEvent :: TimedEvent -> StateT Multi IO ()-enactTimedEvent (TE t e) = do- putTime t- enactEvent e--enactEvent :: MultiEvent -> StateT Multi IO ()-enactEvent (MultiNewPlayer pm) = liftT $ newPlayerU pm-enactEvent (MultiNewGame s d pn) = liftT $ newGame s d pn-enactEvent (MultiJoinGame gn pn) = liftT $ joinGame gn pn-enactEvent (MultiLeaveGame pn) = liftT $ leaveGame pn-enactEvent (MultiSubscribeGame gn pn) = liftT $ subscribeGame gn pn-enactEvent (MultiUnsubscribeGame gn pn) = liftT $ unsubscribeGame gn pn-enactEvent (MultiSubmitRule sr pn) = gets sh >>= submitRule sr pn-enactEvent (MultiInputChoiceResult en ci pn) = liftT $ inputChoiceResult en ci pn-enactEvent (MultiInputStringResult ti res pn) = liftT $ inputStringResult (InputString pn ti) res pn-enactEvent (MultiInputUpload pn dir mod) = gets sh >>= inputUpload pn dir mod-enactEvent (MultiTimeEvent t) = triggerTimeEvent t-enactEvent (MultiMailSettings mms pn) = liftT $ mailSettings mms pn--update :: TimedEvent -> (Maybe PlayerNumber) -> StateT Multi IO ()-update te mpn = logEvent te >> update' te mpn >> save'--update' :: TimedEvent -> (Maybe PlayerNumber) -> StateT Multi IO ()-update' te mpn = do+ lfp <- access (mSettings >>> logFilePath) m <- get- m' <- lift $ (enactTimedEvent' te m) `catch` commandExceptionHandler mpn m- put m'--enactTimedEvent' te m = do- m' <- (execStateT (enactTimedEvent te) m)- evaluate m'- return m'+ lift $ save lfp m -loadEvents :: FilePath -> ServerHandle -> Network -> IO Multi-loadEvents fp sh net = do- t <- getCurrentTime- execStateT (loadEvents' fp) (defaultMulti sh fp net t)+load :: FilePath -> IO(Multi)+load fp = do+ s <- readFile fp+ return $ read s -loadEvents' :: FilePath -> StateT Multi IO ()-loadEvents' fp = do- les <- liftIO $ load fp- loadTimedEvents les+loadMulti :: Settings -> ServerHandle -> IO Multi+loadMulti set sh = do+ m <- load $ _logFilePath set+ gs' <- mapM (updateLoggedGame $ getRuleFunc sh) $ _games m+ let m' = games `setL` gs' $ m+ return m' -loadTimedEvents :: [TimedEvent] -> StateT Multi IO ()-loadTimedEvents les = do- modify(\m -> m { logs = (logs m) { logEvents = les}})- mapM_ (\a -> update' a (Just 1)) les --(lift $ putStrLn $ "loading " ++ (show a)) >>+updateLoggedGame :: (RuleCode -> IO RuleFunc) -> LoggedGame -> IO LoggedGame+updateLoggedGame f (LoggedGame g log) = getLoggedGame g f log
− src/Server.hs
@@ -1,256 +0,0 @@--- | This server handles asynchronous text connections.--- It has 4 threads:--- mainLoop: dispatch messages between every threads (this is the main program thread, not forked)--- acceptLoop: handles new client connections--- multiLoop: handles game commands. It contains the whole game state.--- clientLoop: one per client, handles clients communications.---- And 5 channels:--- acceptChan: used by acceptLoop to publish new clients connections to mainLoop.--- gameChan: used for the communication between mainLoop and multiLoop.--- clientChan: one per client, use by the clients to communicate with mainLoop.--- handleFree: one per client, used for upstream comunication with clientLoops, to control usage of the Handle.--- debugChan: used to pass debug commands-- -module Server where --{- --- Module Network is the simple networking library, presenting a Handle-based interface. -import Network (listenOn, accept, sClose, Socket, - withSocketsDo, PortID(..)) - -import Control.Exception (finally)-import Control.Concurrent -import Control.Concurrent.STM -import Multi -import Control.Monad.State -import System.IO -import Data.Char -import Control.Applicative -import Data.List -import Network.BSD-import Language.Haskell.Interpreter.Server --TODO: hide in Interpret-import Control.Concurrent.Process hiding (Handle)-import Commands-import Data.Function (on)-import Language.Nomic.Expression--type ClientNumber = Int---- | associate a player number with a handle -data PlayerClient = PlayerClient { cPlayerNumber :: PlayerNumber, - cHandle :: Handle} - deriving (Eq, Show) - --- | A structure to hold the active games and players -data Server = Server { playerClients :: [PlayerClient],- interpreterHandle :: ServerHandle}- --deriving (Eq)---- | A State to pass around active games and players. --- Furthermore, the output are to be made with Comm to output to the right console. -type ServerState = StateT Server IO ()- --- the channels to pass commands-type CommandChan = TChan String---- type of the channel to pass commands upstream to the client thread---data ClientCommands = Ready | Quit-type ClientChan = TChan String- --- | communication between clients and server -data ClientComm = ClientComm {inChan :: TChan String,- outChan :: TChan String,- handle :: Handle} ---- | a channel where to publish new clients connection-type AcceptChan = TChan ClientComm- -defaultServer :: ServerHandle -> Server -defaultServer = Server []- --type DebugServer = (ServerState, TChan Server)--defaultDebugServer = do- debugChan <- atomically newTChan- return (debugViewState, debugChan)-- --- | An helper function that makes it clear how to use the state transformer Server. -runWithServer :: Server -> ServerState -> IO () -runWithServer = flip evalStateT - - --- | a loop that will handle game commands -runMulti :: AcceptChan -> DebugServer -> ServerHandle -> IO () -runMulti acceptChan debug sh = runWithServer (defaultServer sh) (mainLoop acceptChan [] debug)-- --- | Start Nomic in server mode-serverStart :: PortNumber -> ServerHandle -> IO () -serverStart port sh = withSocketsDo $ do - servSock <- listenOn $ PortNumber port - host <- getHostName- putStrLn $ "Starting telnet server...\nTo connect, try \"telnet " ++ host ++ " " ++ (show port) ++ "\" in a shell window" - startAll servSock sh `catch` (\_ -> putStrLn "serverStart: Closing") `finally` sClose servSock - - --- | starts every threads-startAll :: Socket -> ServerHandle -> IO ()-startAll servSock sh = do - -- Fork the loop that will handle new client connections along with its channel - acceptChan <- atomically newTChan -- --start the loop that will handle client's connections- --forkIO $ acceptLoop servSock acceptChan- spawn $ makeProcess id (acceptLoop servSock acceptChan)-- `catch` (\_ -> do putStrLn "acceptLoop: Closing"; return ())-- -- the multi loop will centralize and dispatch communications- def <- defaultDebugServer- runMulti acceptChan def sh-- - - --- | the loop will handle new client connections and fork a subsequent thread for each client -acceptLoop :: Socket -> AcceptChan -> Process () () -acceptLoop servSock acceptChan = do -- acceptChan - (cHandle, _, _) <- lift $ accept servSock - --hSetEcho cHandle True - liftIO $ hSetBuffering cHandle NoBuffering - - -- Fork loops that will handle client communication - cc <- liftIO $ newClientComm cHandle - liftIO $ forkIO $ clientIn cc `catch` (\_ -> putStrLn "acceptLoop: clientIn exception")- liftIO $ forkIO $ clientOut cc `catch` (\_ -> putStrLn "acceptLoop: clientOut exception")- - -- publish new client connection with its chan and handle on acceptChan - lift $ atomically $ writeTChan acceptChan cc - acceptLoop servSock acceptChan ---newClientComm :: Handle -> IO ClientComm -newClientComm h = do- inChan <- liftIO $ atomically newTChan- outChan <- liftIO $ atomically newTChan- return ClientComm {inChan = inChan,- outChan = outChan,- handle = h}-- --- | a loop that will handle client communication -clientIn :: ClientComm -> IO () -clientIn cc = do- s <- hGetLine $ handle cc- atomically $ writeTChan (inChan cc) s- clientIn cc---- | a loop that will handle client communication -clientOut :: ClientComm -> IO () -clientOut cc = do- s <- atomically $ readTChan (outChan cc)- hPutStr (handle cc) s- clientOut cc-- --selectIn :: [ClientComm] -> STM (String, ClientComm) -selectIn l = do- let f cc@ClientComm {inChan = ic} = do- s <- readTChan ic- return (s, cc)- foldl orElse retry (map f l)--selectOut :: [ClientComm] -> STM (String, ClientComm) -selectOut l = do- let f cc@ClientComm {outChan = oc} = do- s <- readTChan oc- return (s, cc)- foldl orElse retry (map f l)--data ClientData = ClientAccept ClientComm- | ClientInput (String, ClientComm)- --- | the server loop will dispatch messages between threads -mainLoop :: AcceptChan -> [ClientComm] -> DebugServer -> ServerState -mainLoop acceptChan clients d@(debugState, debugChan) = do-- --read on both acceptChan and all client's chans - r <- lift $ atomically $ (ClientAccept `fmap` readTChan acceptChan) - `orElse` - (ClientInput `fmap` selectIn clients)-- case r of - -- new data on the accept chan (CommandChan, ClientChan, Handle) - ClientAccept ca -> do- --register new client- newClient ca- --loop - mainLoop acceptChan (ca:clients) d - - -- new data on the clients chan (String, ClientChan, Handle) - ClientInput (l,cc) -> do - -- do some filtering - let myLine = filter isPrint l - --putStrLn $ "data: " ++ myLine ++ " from handle: " ++ show h - case myLine of - "debug read" -> do- s <- get- --write state into the channel (for external reading).- lift $ atomically $ writeTChan debugChan s- "debug write" -> do- --execute the debug monad.- debugState- "quit" -> playerQuit (handle cc)- "" -> return ()- -- every other command is passed through- _ -> issuePlayerCommand myLine cc---- --loop- mainLoop acceptChan clients d - --newClient :: ClientComm -> ServerState-newClient cc = do- (Server pcs sh) <- get- let comm = (Communication (inChan cc) (outChan cc) sh)- pn <- liftIO $ evalStateT newPlayer comm- modify (\ser -> ser { playerClients = PlayerClient { cPlayerNumber = pn, - cHandle = (handle cc)} : pcs})-- - --- | issue the player's command with the right Comm and Multi environnement-issuePlayerCommand :: String -> ClientComm -> ServerState-issuePlayerCommand l cc = do- (Server pcs sh) <- get- let comm = (Communication (inChan cc) (outChan cc) sh) - --issue the player's command - case getPlayerNumber (handle cc) pcs of - Nothing -> error "issuePlayerCommand: player's handle not found" - Just pn -> liftIO $ evalStateT (runLine l pn) comm---playerQuit :: Handle -> ServerState-playerQuit h = do- pcs <- gets playerClients- -- erase player client - modify (\ser -> ser { playerClients = filter (\PlayerClient {cHandle = myh} -> myh /= h) pcs})---- | gives the player's number associated to that handle -getPlayerNumber :: Handle -> [PlayerClient] -> Maybe PlayerNumber -getPlayerNumber h ps = cPlayerNumber <$> find (\PlayerClient {cHandle = myh} -> myh==h) ps --debugViewState :: ServerState-debugViewState = lift . print =<< get --instance Ord PlayerClient where - (<=) = (<=) `on`cPlayerNumber--instance Show Server where- show Server{playerClients =pcs} = "\n" ++ (show $ sort pcs)--}
src/Test.hs view
@@ -13,162 +13,192 @@ ----------------------------------------------------------------------------- {-# LANGUAGE TupleSections, ScopedTypeVariables, TemplateHaskell, GADTs, QuasiQuotes #-} +-- | Test module module Test where import Prelude hiding (catch) import Types-import Data.Time hiding (getCurrentTime) import Control.Monad.State-import Serialize+import Multi import Language.Haskell.Interpreter.Server (ServerHandle)-import Language.Nomyx.Expression+import Language.Nomyx hiding (getCurrentTime) import Control.Applicative import Control.Exception import Language.Haskell.TH-import Language.Haskell.TH.Syntax as THS+import Language.Haskell.TH.Syntax as THS hiding (lift) import System.IO.Unsafe import Quotes-import Data.List-import Data.Time.Clock+import Data.Lens+import Safe+import Data.Acid.Memory+import Happstack.Auth.Core.Auth (initialAuthState)+import Happstack.Auth.Core.Profile (initialProfileState)+import qualified Language.Nomyx.Game as G+import Control.Arrow ((>>>))+import Data.Time hiding (getCurrentTime) playTests :: ServerHandle -> IO [(String, Bool)] playTests sh = mapM (\(title, t, cond) -> (title,) <$> test sh t cond) tests -tests :: [(String, [TimedEvent], Multi -> Bool)]-tests = [("hello World", noTime gameHelloWorld, condHelloWorld),- ("hello World 2 players", noTime gameHelloWorld2Players, condHelloWorld2Players),- ("Partial Function 1", noTime gamePartialFunction1, condPartialFunction1),- ("Partial Function 2", gamePartialFunction2, condPartialFunction2),- ("Partial Function 3", noTime gamePartialFunction3, condPartialFunction3),- ("Money transfer", noTime gameMoneyTransfer, condMoneyTransfer)]+-- | test list.+-- each test can be loaded individually in Nomyx with the command line:+-- Nomyx -l <"test name">+tests :: [(String, StateT Session IO (), Multi -> Bool)]+tests = [("hello World", gameHelloWorld, condHelloWorld),+ ("hello World 2 players", gameHelloWorld2Players, condHelloWorld2Players),+ ("Partial Function 1", gamePartialFunction1, condPartialFunction1),+ ("Partial Function 2", gamePartialFunction2, condPartialFunction2),+ ("Partial Function 3", gamePartialFunction3, condPartialFunction3),+ ("Money transfer", gameMoneyTransfer, condMoneyTransfer)] dayZero :: UTCTime dayZero = UTCTime (ModifiedJulianDay 0) 0 -noTime :: [MultiEvent] -> [TimedEvent]-noTime mes = map (TE dayZero) mes+--noTime :: [MultiEvent] -> [TimedEvent]+--noTime mes = map (TE dayZero) mes -test :: ServerHandle -> [TimedEvent] -> (Multi -> Bool) -> IO Bool+test :: ServerHandle -> StateT Session IO () -> (Multi -> Bool) -> IO Bool test sh tes cond = do- --putStrLn $ "\n\n\nTEST"- let m = defaultMulti sh "" defaultNetwork dayZero- m' <- (loadTest tes m)- --putStrLn $ show m'- (return $ cond m') `catch` (\(e::IOError) -> (putStrLn $ show e) >> return False)+ tp <- testProfiles+ let s = Session sh (defaultMulti (Settings "" defaultNetwork False)) tp+ m' <- loadTest tes s+ (evaluate $ cond m') `catch` (\(e::SomeException) -> (putStrLn $ "Exception in test: " ++ show e) >> return False) -loadTest :: [TimedEvent] -> Multi -> IO Multi-loadTest tes m = do- m' <- execStateT (loadTimedEvents tes) m- evaluate m'- return m' +loadTest :: StateT Session IO () -> Session -> IO Multi+loadTest tes s = do+ s' <- execStateT tes s+ evaluate s'+ return $ _multi s'+ testException :: Multi -> SomeException -> IO Multi testException m e = do putStrLn $ "Test Exception: " ++ show e return m -loadTestName :: FilePath -> ServerHandle -> Network -> String -> IO Multi-loadTestName fp sh net testName = do+loadTestName :: Settings -> String -> ServerHandle -> IO Multi+loadTestName set testName sh = do let mt = find (\(name, _, _) -> name == testName) tests- t <- getCurrentTime- let m = defaultMulti sh fp net t+ tp <- testProfiles+ let s = Session sh (defaultMulti set) tp case mt of- Just (n, t, _) -> putStrLn ("Loading test game: " ++ n) >> loadTest t m- Nothing -> putStrLn "Test name not found" >> return m+ Just (n, t, _) -> putStrLn ("Loading test game: " ++ n) >> loadTest t s+ Nothing -> do+ putStrLn "Test name not found"+ return $ _multi s +testProfiles :: IO Profiles+testProfiles = do+ ias <- openMemoryState initialAuthState+ ips <- openMemoryState initialProfileState+ ipds <- openMemoryState initialProfileDataState+ return $ Profiles ias ips ipds+ printRule :: Q THS.Exp -> String printRule r = unsafePerformIO $ do expr <- runQ r return $ pprint expr -onePlayerOneGame :: [MultiEvent]-onePlayerOneGame =- [MultiNewPlayer (PlayerMulti {mPlayerNumber = 1, mPlayerName = "coco", mPassword = "coco", mMail = MailSettings {mailTo = "", mailNewInput = False, mailNewRule = False, mailNewOutput = False, mailConfirmed = False}, inGame = Nothing, lastRule = Nothing}),- MultiMailSettings (MailSettings {mailTo = "c", mailNewInput = True, mailNewRule = True, mailNewOutput = True, mailConfirmed = True}) 1,- MultiNewGame "test" "" 1,- MultiJoinGame "test" 1]--twoPlayersOneGame :: [MultiEvent]-twoPlayersOneGame = onePlayerOneGame ++- [MultiNewPlayer (PlayerMulti {mPlayerNumber = 2, mPlayerName = "bat", mPassword = "bat", mMail = MailSettings {mailTo = "", mailNewInput = False, mailNewRule = False, mailNewOutput = False, mailConfirmed = False}, inGame = Nothing, lastRule = Nothing}),- MultiMailSettings (MailSettings {mailTo = "c", mailNewInput = True, mailNewRule = True, mailNewOutput = True, mailConfirmed = True}) 2,- MultiJoinGame "test" 2]--submitRule :: String -> [MultiEvent]-submitRule r = onePlayerOneGame ++- [MultiSubmitRule (SubmitRule "" "" r) 1,- MultiInputChoiceResult 4 0 1]+onePlayerOneGame :: StateT Session IO ()+onePlayerOneGame = do+ newPlayer 1 (PlayerSettings {_pPlayerName = "Player 1", _mailTo = "", _mailNewInput = False, _mailNewRule = False, _mailNewOutput = False, _mailConfirmed = False}) Nothing Nothing+ newGame "test" (GameDesc "" "") 1+ joinGame "test" 1+ viewGamePlayer "test" 1 +twoPlayersOneGame :: StateT Session IO ()+twoPlayersOneGame = do+ onePlayerOneGame+ newPlayer 2 (PlayerSettings {_pPlayerName = "Player 2", _mailTo = "", _mailNewInput = False, _mailNewRule = False, _mailNewOutput = False, _mailConfirmed = False}) Nothing Nothing+ joinGame "test" 2+ viewGamePlayer "test" 2 +submitR :: String -> StateT Session IO ()+submitR r = do+ onePlayerOneGame+ sh <- access sh+ submitRule (SubmitRule "" "" r) 1 sh+ inputChoiceResult 3 0 1 -gameHelloWorld :: [MultiEvent]-gameHelloWorld = onePlayerOneGame ++ submitRule [cr|helloWorld|]+gameHelloWorld :: StateT Session IO ()+gameHelloWorld = submitR [cr|helloWorld|] condHelloWorld :: Multi -> Bool-condHelloWorld m = (head $ outputs $ head $ games m) == (1, "hello, world!")+condHelloWorld m = (head $ _outputs $ G._game $ head $ _games m) == (1, "hello, world!") -gameHelloWorld2Players :: [MultiEvent]-gameHelloWorld2Players = twoPlayersOneGame ++- [MultiSubmitRule (SubmitRule "" "" [cr|helloWorld|]) 1,- MultiInputChoiceResult 5 0 1,- MultiInputChoiceResult 4 0 2]+gameHelloWorld2Players :: StateT Session IO ()+gameHelloWorld2Players = do+ twoPlayersOneGame+ sh <- access sh+ submitRule (SubmitRule "" "" [cr|helloWorld|]) 1 sh+ inputChoiceResult 3 0 1+ inputChoiceResult 4 0 2 condHelloWorld2Players :: Multi -> Bool-condHelloWorld2Players m = (head $ outputs $ head $ games m) == (1, "hello, world!")+condHelloWorld2Players m = (head $ _outputs $ G._game $ head $ _games m) == (1, "hello, world!") partialFunction1 :: String-partialFunction1 = [cr|VoidRule $ readVar_ (V "toto1")|]+partialFunction1 = [cr|voidRule $ readVar_ (V "toto1")|] -gamePartialFunction1 :: [MultiEvent]-gamePartialFunction1 = onePlayerOneGame ++ (submitRule partialFunction1)+gamePartialFunction1 :: StateT Session IO ()+gamePartialFunction1 = submitR partialFunction1 -- rule has not been accepted due to exception condPartialFunction1 :: Multi -> Bool-condPartialFunction1 m = (rStatus $ head $ rules $ head $ games m) == Pending &&- (take 5 $ snd $ head $ outputs $ head $ games m) == "Error"+condPartialFunction1 m = (_rStatus $ head $ _rules $ G._game $ head $ _games m) == Active &&+ (take 5 $ snd $ head $ _outputs $ G._game $ head $ _games m) == "Error" partialFunction2 :: String-partialFunction2 = [cr|VoidRule $ do+partialFunction2 = [cr|voidRule $ do t <- getCurrentTime onEventOnce_ (Time $ addUTCTime 5 t) $ const $ readVar_ (V "toto2")|] -gamePartialFunction2 :: [TimedEvent]-gamePartialFunction2 = noTime onePlayerOneGame ++ (noTime $ submitRule partialFunction2) ++- [TE (5 `addUTCTime` dayZero) $ (MultiTimeEvent $ 5 `addUTCTime` dayZero)]+gamePartialFunction2 :: StateT Session IO ()+gamePartialFunction2 = do+ onePlayerOneGame+ submitR partialFunction2+ gs <- (access $ multi >>> games)+ let now = _currentTime $ G._game (head gs)+ focus multi $ triggerTimeEvent (5 `addUTCTime` now) -- rule has been accepted but exception happened later condPartialFunction2 :: Multi -> Bool-condPartialFunction2 m = (rStatus $ head $ rules $ head $ games m) == Active &&- (take 5 $ snd $ head $ outputs $ head $ games m) == "Error"+condPartialFunction2 m = (_rStatus $ headNote "cond1 failed" $ _rules $ G._game $ headNote "cond2 failed" $ _games m) == Active &&+ (take 5 $ snd $ headNote "cond3 failed" $ _outputs $ G._game $ headNote "cond4 failed" $ _games m) == "Error" --This rule blocks the game: the exception (variable not existing) is triggered during a "rule proposed" event, --thus preventing to propose any new rule to the game. partialFunction3 :: String-partialFunction3 = [cr|VoidRule $ do- onEvent_ (RuleEv Proposed) $ const $ readVar_ (V "toto3")|]+partialFunction3 = [cr|voidRule $ onEvent_ (RuleEv Proposed) $ const $ readVar_ (V "toto3")|] -gamePartialFunction3 :: [MultiEvent]-gamePartialFunction3 = onePlayerOneGame ++ (submitRule partialFunction3) ++ (submitRule [cr|nothing|])+gamePartialFunction3 :: StateT Session IO ()+gamePartialFunction3 = do+ submitR partialFunction3+ submitR [cr|nothing|] --- rule has been accepted but no more rule can be proposed+-- rule has been accepted and also next one condPartialFunction3 :: Multi -> Bool-condPartialFunction3 m = (length $ rules $ head $ games m) == 3+condPartialFunction3 m = (length $ _rules $ G._game $ head $ games ^$ m) == 4 --Create bank accounts, win 100 Ecu on rule accepted (so 100 Ecu is won for each player), transfer 50 Ecu-gameMoneyTransfer :: [MultiEvent]-gameMoneyTransfer = twoPlayersOneGame ++- [MultiSubmitRule (SubmitRule "" "" [cr|createBankAccount|]) 1,- (MultiInputChoiceResult 5 0 1),- (MultiInputChoiceResult 4 0 2),- (MultiSubmitRule (SubmitRule "" "" [cr|winXEcuOnRuleAccepted 100|]) 1),- (MultiInputChoiceResult 7 0 1),- (MultiInputChoiceResult 6 0 2),- (MultiSubmitRule (SubmitRule "" "" [cr|moneyTransfer|]) 2),- (MultiInputChoiceResult 8 0 1),- (MultiInputChoiceResult 7 0 2),- (MultiInputChoiceResult 7 0 1),- (MultiInputStringResult "Select Amount to transfert to player: 2" "50" 1)]+gameMoneyTransfer :: StateT Session IO ()+gameMoneyTransfer = do+ sh <- access sh+ twoPlayersOneGame+ submitRule (SubmitRule "" "" [cr|createBankAccount|]) 1 sh+ submitRule (SubmitRule "" "" [cr|winXEcuOnRuleAccepted 100|]) 1 sh+ submitRule (SubmitRule "" "" [cr|moneyTransfer|]) 2 sh+ inputChoiceResult 4 0 1+ inputChoiceResult 3 0 2+ inputChoiceResult 9 0 1+ inputChoiceResult 8 0 2+ inputChoiceResult 14 0 1+ inputChoiceResult 13 0 2+ inputChoiceResult 5 0 1+ inputStringResult (InputString 1 "Select Amount to transfert to player: 2") "50" 1 condMoneyTransfer :: Multi -> Bool-condMoneyTransfer m = (vName $ head $ variables $ head $ games m) == "Accounts"+condMoneyTransfer m = (_vName $ head $ _variables $ G._game $ head $ _games m) == "Accounts"++
src/Types.hs view
@@ -1,91 +1,138 @@ {-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances, TypeFamilies,- NamedFieldPuns #-}+ NamedFieldPuns, TemplateHaskell, FlexibleContexts, RecordWildCards #-} module Types where-import Language.Nomyx.Expression+import Language.Nomyx import Data.Typeable-import Data.List-import Data.Function-import Language.Haskell.Interpreter.Server (ServerHandle)-import Text.Blaze.Html5 hiding (map, label)-import Text.Reform-import Happstack.Server import Text.Reform.Happstack() import Network.BSD-import Data.Time-+import Data.Lens.Template+import Language.Nomyx.Game+import Language.Haskell.Interpreter.Server (ServerHandle)+import Data.Acid (makeAcidic, Update, Query, AcidState)+import Happstack.Auth (ProfileState, AuthState)+import Data.Text (Text)+import Data.Data (Data)+import Data.IxSet (toList, (@=), getOne, inferIxSet, noCalcs)+import qualified Data.IxSet as IxSet+import Data.SafeCopy (base, deriveSafeCopy)+import Control.Monad.Reader.Class (MonadReader(..))+import Control.Monad.State.Class (MonadState(..)) type PlayerPassword = String type Port = Int-data Network = Network {host :: HostName, port :: Port}++data Network = Network {_host :: HostName, _port :: Port}+ deriving (Eq, Show, Read, Typeable) defaultNetwork = Network "" 0 -data PlayerMulti = PlayerMulti { mPlayerNumber :: PlayerNumber,- mPlayerName :: PlayerName,- mPassword :: PlayerPassword,- mMail :: MailSettings,- inGame :: Maybe GameName,- lastRule :: Maybe SubmitRule}- deriving (Eq, Show, Read, Typeable)+data PlayerSettings =+ PlayerSettings { _pPlayerName :: PlayerName,+ _mailTo :: String,+ _mailNewInput :: Bool,+ _mailNewRule :: Bool,+ _mailNewOutput :: Bool,+ _mailConfirmed :: Bool }+ deriving (Eq, Show, Read, Data, Ord, Typeable)+$(deriveSafeCopy 1 'base ''PlayerSettings) ++data Settings = Settings { _logFilePath :: FilePath,+ _net :: Network,+ _sendMails :: Bool}+ deriving (Eq, Show, Read, Typeable)+ --- | A structure to hold the active games and players-data Multi = Multi { games :: [Game],- mPlayers :: [PlayerMulti],- logs :: Log,- sh :: ServerHandle,- net :: Network,- mCurrentTime :: UTCTime}- deriving (Typeable)+data Multi = Multi { _games :: [LoggedGame],+ _mSettings :: Settings}+ deriving (Eq, Read, Show, Typeable) -instance Show Multi where- show Multi{games, mPlayers} = "Games: " ++ show (sort games) ++ "\n" ++- "Players: " ++ show (sort mPlayers) ++ "\n" -defaultMulti :: ServerHandle -> FilePath -> Network -> UTCTime -> Multi-defaultMulti sh fp net t = Multi [] [] (defaultLog fp) sh net t+-- | 'ProfileData' contains application specific+data ProfileData =+ ProfileData { _pPlayerNumber :: PlayerNumber, -- ^ same as UserId+ _pPlayerSettings :: PlayerSettings,+ _pViewingGame :: Maybe GameName,+ _pLastRule :: Maybe SubmitRule}+ deriving (Eq, Ord, Read, Show, Typeable, Data)+$(deriveSafeCopy 1 'base ''ProfileData)+$(deriveSafeCopy 1 'base ''SubmitRule) -data Log = Log { logEvents :: [TimedEvent],- logFilePath :: FilePath } deriving (Eq)+$(inferIxSet "ProfilesData" ''ProfileData 'noCalcs [''PlayerNumber, ''Text]) -defaultLog :: FilePath ->Log-defaultLog fp = Log [] fp+data ProfileDataState =+ ProfileDataState { profilesData :: ProfilesData }+ deriving (Eq, Ord, Read, Show, Typeable, Data)+$(deriveSafeCopy 1 'base ''ProfileDataState) -data SubmitRule = SubmitRule RuleName String RuleCode deriving (Show, Read, Eq) -data TimedEvent = TE UTCTime MultiEvent deriving (Show, Read, Eq)+-- | 'Acid' holds all the 'AcidState' handles for this site.+data Profiles = Profiles+ { acidAuth :: AcidState AuthState+ , acidProfile :: AcidState ProfileState+ , acidProfileData :: AcidState ProfileDataState+ } -data MultiEvent = MultiNewPlayer PlayerMulti- | MultiNewGame GameName String PlayerNumber- | MultiJoinGame GameName PlayerNumber- | MultiLeaveGame PlayerNumber- | MultiSubscribeGame GameName PlayerNumber- | MultiUnsubscribeGame GameName PlayerNumber- | MultiSubmitRule SubmitRule PlayerNumber- | MultiInputChoiceResult EventNumber Int PlayerNumber- | MultiInputStringResult String String PlayerNumber- | MultiInputUpload PlayerNumber FilePath String- | MultiTimeEvent UTCTime- | MultiMailSettings MailSettings PlayerNumber- deriving (Show, Read, Eq)+data Session = Session { _sh :: ServerHandle,+ _multi :: Multi,+ _profiles :: Profiles} +-- | set 'ProfileData' for UserId+setProfileData :: ProfileData -> Update ProfileDataState ProfileData+setProfileData profileData =+ do pds@(ProfileDataState {..}) <- get+ put $ pds { profilesData = IxSet.updateIx (_pPlayerNumber profileData) profileData profilesData }+ return profileData -instance Ord PlayerMulti where- (<=) = (<=) `on` mPlayerNumber -type NomyxForm a = Form (ServerPartT IO) [Input] String Html () a+-- | get 'ProfileData' associated with 'UserId'+askProfileData :: PlayerNumber -> Query ProfileDataState (Maybe ProfileData)+askProfileData uid =+ do ProfileDataState{..} <- ask+ return $ getOne $ profilesData @= uid +-- | create the profile data, but only if it is missing+newProfileData :: PlayerNumber -> PlayerSettings -> Maybe GameName -> Maybe SubmitRule -> Update ProfileDataState ProfileData+newProfileData uid ps gn sr =+ do pds@(ProfileDataState {..}) <- get+ case IxSet.getOne (profilesData @= uid) of+ Nothing -> do let profileData = ProfileData uid ps gn sr+ put $ pds { profilesData = IxSet.updateIx uid profileData profilesData }+ return profileData+ (Just profileData) -> return profileData -data MailSettings = MailSettings { mailTo :: String,- mailNewInput :: Bool,- mailNewRule :: Bool,- mailNewOutput :: Bool,- mailConfirmed :: Bool } deriving (Eq, Show, Read)+-- | get number of+askProfileDataNumber :: Query ProfileDataState Int+askProfileDataNumber =+ do pds <- ask+ return $ IxSet.size $ profilesData pds -defaultMailSettings :: MailSettings-defaultMailSettings = MailSettings "" False False False False+-- | get all profiles+askProfilesData :: Query ProfileDataState [ProfileData]+askProfilesData =+ do pds <- ask+ return $ toList $ profilesData pds -instance FormError String where- type ErrorInputType String = [Input]- commonFormError _ = "common error"+$(makeAcidic ''ProfileDataState+ [ 'setProfileData+ , 'askProfileData+ , 'newProfileData+ , 'askProfileDataNumber+ , 'askProfilesData+ ]+ )++initialProfileDataState :: ProfileDataState+initialProfileDataState = ProfileDataState { profilesData = IxSet.empty }+++defaultMulti :: Settings -> Multi+defaultMulti set = Multi [] set++defaultPlayerSettings :: PlayerSettings+defaultPlayerSettings = PlayerSettings "" "" False False False False++$( makeLenses [''Multi, ''Settings, ''Network, ''PlayerSettings, ''Session, ''ProfileData] )+
src/Utils.hs view
@@ -20,29 +20,23 @@ import Data.Char import Control.Monad.State import Types-import Language.Nomyx.Expression-import Data.List-import Control.Applicative -import Control.Exception-import Data.Time--- +import Language.Nomyx+import Language.Nomyx.Game+import Data.Lens+import Control.Category hiding ((.))+import qualified Data.Acid.Advanced as A (query', update')+ -- | this function will return just a if it can cast it to an a. maybeRead :: Read a => String -> Maybe a maybeRead = fmap fst . listToMaybe . reads - - -- | Replaces all instances of a value in a list by another value. replace :: Eq a => a -- ^ Value to search -> a -- ^ Value to replace it with -> [a] -- ^ Input list -> [a] -- ^ Output list replace x y = map (\z -> if z == x then y else z) - - yes = ["o", "oui", "y", "yes", "v", "vrai", "true"] toLowerS = map toLower isYes a = toLowerS a `elem` yes@@ -51,79 +45,62 @@ say :: String -> StateT a IO () say = lift . putStrLn -liftT :: Show s => State s a -> StateT s IO a-liftT st = do- s1 <- get- let (a, s) = runState st s1- put s- return a---findPlayer :: PlayerName -> State Multi (Maybe PlayerMulti)-findPlayer name = find (\PlayerMulti {mPlayerName = pname} -> pname==name) <$> gets mPlayers--findPlayer' :: PlayerNumber -> State Multi (Maybe PlayerMulti)-findPlayer' pn = find (\PlayerMulti {mPlayerNumber} -> pn==mPlayerNumber) <$> gets mPlayers- nomyxURL :: Network -> String nomyxURL (Network host port) = "http://" ++ host ++ ":" ++ (show port) -getPlayersName :: PlayerNumber -> Multi -> PlayerName-getPlayersName pn multi = do- case find (\(PlayerMulti n _ _ _ _ _) -> n==pn) (mPlayers multi) of- Nothing -> error "getPlayersName: No player by that number"- Just pm -> mPlayerName pm+getPlayersName :: PlayerNumber -> Session -> IO PlayerName+getPlayersName pn s = do+ pfd <- A.query' (acidProfileData $ _profiles s) (AskProfileData pn)+ return $ _pPlayerName $ _pPlayerSettings $ fromJust pfd getPlayersName' :: Game -> PlayerNumber -> PlayerName getPlayersName' g pn = do- case find (\(PlayerInfo n _) -> n==pn) (players g) of+ case find ((==pn) . getL playerNumber) (_players g) of Nothing -> error "getPlayersName: No player by that number in that game"- Just pm -> playerName pm+ Just pm -> _playerName pm -- | returns the game the player is in-getPlayersGame :: PlayerNumber -> Multi -> Maybe Game-getPlayersGame pn multi = do- pi <- find (\(PlayerMulti n _ _ _ _ _) -> n==pn) (mPlayers multi)- gn <- inGame pi- find (\(Game {gameName=name}) -> name==gn) (games multi)+getPlayersGame :: PlayerNumber -> Session -> IO (Maybe LoggedGame)+getPlayersGame pn s = do+ pfd <- A.query' (acidProfileData $ _profiles s) (AskProfileData pn)+ let mgn = _pViewingGame $ fromJust pfd+ return $ do+ gn <- mgn+ find ((== gn) . getL (game >>> gameName)) (_games $ _multi s) --checks if any game by that name exists -getPlayersNameMay :: Game -> PlayerNumber -> Maybe PlayerName-getPlayersNameMay g pn = do- case find (\(PlayerInfo n _) -> n==pn) (players g) of- Nothing -> Nothing- Just pm -> Just $ playerName pm+getAllProfiles :: Session -> IO [ProfileData]+getAllProfiles s = A.query' (acidProfileData $ _profiles s) AskProfilesData -commandExceptionHandler :: Maybe PlayerNumber -> Multi -> ErrorCall -> IO Multi-commandExceptionHandler mpn m e = do- putStrLn $ "Exception in rule: " ++ (show e)- case mpn of- Just pn -> do- let g = fromJust $ getPlayersGame pn m- let g' = execState (output ("Error in command: " ++ (show e)) pn) g- return $ execState (modifyGame g') m- Nothing -> return m +getPlayers :: Game -> PlayerNumber -> Maybe PlayerInfo+getPlayers g pn = find ((==pn) . getL playerNumber) (_players g) -- | finds the corresponding game in the multistate and replaces it.-modifyGame :: Game -> State Multi ()-modifyGame g = do- m@(Multi {games=gs}) <- get- case find (\myg -> gameName g == gameName myg) gs of+modifyGame :: LoggedGame -> StateT Multi IO ()+modifyGame lg = do+ gs <- access games+ case find (== lg) gs of Nothing -> error "modifyGame: No game by that name" Just oldg -> do- let newgs = replace oldg g gs- put (m {games=newgs})--output :: String -> PlayerNumber -> State Game ()-output s pn = modify (\game -> game { outputs = (pn, s) : (outputs game)})--outputAll :: String -> State Game () -outputAll s = gets players >>= mapM_ ((output s) . playerNumber)-+ let newgs = replace oldg lg gs+ games ~= newgs+ return () execWithMulti :: UTCTime -> StateT Multi IO () -> Multi -> IO Multi execWithMulti t ms m = do- let m' = m { games = map (\g -> g {currentTime = t}) (games m)}+ let setTime g = (game >>> currentTime) ^= t $ g+ let m' = games `modL` (map setTime) $ m execStateT ms m'++modifyProfile :: PlayerNumber -> (ProfileData -> ProfileData) -> StateT Session IO ()+modifyProfile pn mod = do+ s <- get+ pfd <- A.query' (acidProfileData $ _profiles s) (AskProfileData pn)+ A.update' (acidProfileData $ _profiles s) (SetProfileData (mod $ fromJust pfd))+ return ()++getProfile :: MonadIO m => PlayerNumber -> Session -> m (Maybe ProfileData)+getProfile pn s = A.query' (acidProfileData $ _profiles s) (AskProfileData pn)+
src/Web/Common.hs view
@@ -1,10 +1,11 @@-{-# LANGUAGE TemplateHaskell, OverloadedStrings, GADTs, ScopedTypeVariables#-}+{-# LANGUAGE TemplateHaskell, OverloadedStrings, GADTs, ScopedTypeVariables, DeriveDataTypeable,+ RecordWildCards, TypeFamilies, TypeSynonymInstances#-} module Web.Common where import Prelude hiding (div, catch)-import Text.Blaze.Html5 hiding (map, output)+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@@ -13,25 +14,34 @@ import Web.Routes.TH (derivePathInfo) import Control.Monad.State import Control.Concurrent.STM-import Language.Nomyx.Expression+import Language.Nomyx import Happstack.Server-import Types+import Types as T import qualified Data.ByteString.Char8 as C import Text.Blaze.Html.Renderer.Utf8 (renderHtml) import Text.Reform.Happstack() import Text.Reform import Text.Reform.Blaze.String() import Text.Reform.Happstack()+import Text.Blaze.Internal import qualified Text.Reform.Generalized as G import Data.Text(Text, pack) import Web.Routes.Happstack()-import Data.Time+import Happstack.Auth (UserId(..), getUserId, AuthProfileURL)+import Control.Category ((>>>)) import Serialize-default (Integer, Double, Data.Text.Text) +data NomyxError = PlayerNameRequired+ | GameNameRequired+ | UniquePlayerName+ | NomyxCFE (CommonFormError [Input])+ deriving Show -data LoginPass = LoginPass { login :: PlayerName,- password :: PlayerPassword}+type NomyxForm a = Form (ServerPartT IO) [Input] NomyxError Html () a++default (Integer, Double, Data.Text.Text)++data LoginName = LoginName { login :: PlayerName} deriving (Show, Eq) @@ -42,27 +52,29 @@ data Server = Server [PlayerClient] deriving (Eq, Show) -data PlayerCommand = Login- | PostLogin- | NewPlayer LoginPass- | NewPlayerLogin LoginPass- | Noop PlayerNumber- | JoinGame PlayerNumber GameName- | LeaveGame PlayerNumber- | SubscribeGame PlayerNumber GameName- | UnsubscribeGame PlayerNumber GameName- | DoInputChoice PlayerNumber EventNumber- | DoInputString PlayerNumber String- | NewRule PlayerNumber- | NewGame PlayerNumber- | SubmitNewGame PlayerNumber- | Upload PlayerNumber- | Settings PlayerNumber- | SubmitSettings PlayerNumber+data PlayerCommand =+ HomePage+ | U_AuthProfile AuthProfileURL+ | NewPlayer+ | MainPage+ | ViewGame GameName+ | JoinGame GameName+ | LeaveGame GameName+ | DoInputChoice EventNumber+ | DoInputString String+ | NewRule+ | NewGame+ | SubmitNewGame+ | Upload+ | PSettings+ | SubmitPlayerSettings deriving (Show) ++type RoutedNomyxServer a = RouteT PlayerCommand (ServerPartT IO) a+ $(derivePathInfo ''PlayerCommand)-$(derivePathInfo ''LoginPass)+$(derivePathInfo ''LoginName) instance PathInfo Bool where toPathSegments i = [pack $ show i]@@ -75,22 +87,17 @@ modDir :: FilePath modDir = "modules" -type NomyxServer = ServerPartT IO-type RoutedNomyxServer = RouteT PlayerCommand NomyxServer---evalCommand :: (TVar Multi) -> State Multi a -> RoutedNomyxServer a-evalCommand tm sm = do- m <- liftRouteT $ lift $ atomically $ readTVar tm- return $ evalState sm m-+evalCommand :: (TVar Session) -> StateT Session IO a -> RoutedNomyxServer a+evalCommand ts sm = liftRouteT $ lift $ do+ s <- atomically $ readTVar ts+ evalStateT sm s -webCommand :: (TVar Multi) -> PlayerNumber -> MultiEvent -> RoutedNomyxServer ()-webCommand tm pn me = liftRouteT $ lift $ do- t <- getCurrentTime- m <- atomically $ readTVar tm- m' <- execStateT (update (TE t me) (Just pn)) m- atomically $ writeTVar tm m'+webCommand :: (TVar Session) -> StateT Session IO () -> RoutedNomyxServer ()+webCommand ts sm = liftRouteT $ lift $ do+ s <- atomically $ readTVar ts+ s' <- execStateT sm s+ atomically $ writeTVar ts s'+ save (_multi >>> _mSettings >>>_logFilePath $ s) (_multi s') --TODO not really nice to put that here blazeResponse :: Html -> Response@@ -118,16 +125,62 @@ 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 :: Html -> Html -> Html -> Bool -> RoutedNomyxServer Html-mainPage body title header footer = do- ok $ H.html $ do- H.head $ do- H.title 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.body $ do- H.div ! A.id "container" $ do- H.div ! A.id "header" $ header- body- when footer $ H.div ! A.id "footer" $ "Copyright Corentin Dupont 2012-2013"+mainPage' :: String -> Html -> Html -> Bool -> RoutedNomyxServer Response+mainPage' title header body footer = do+ html <- mainPage title header body footer+ return $ toResponse html++mainPage :: String -> Html -> Html -> Bool -> RoutedNomyxServer Html+mainPage title header body footer = ok $ appTemplate' title header body footer++appTemplate' ::+ String -- ^ title+ -> Html -- ^ extra tags to include in \<head\>+ -> Html -- ^ contents to put inside \<body\>+ -> Bool -- ^ include footer+ -> Html+appTemplate' title headers body footer = 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 $ do+ H.div ! A.id "container" $ do+ H.div ! A.id "header" $ headers+ 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 = do+ return $ toResponse $ appTemplate' title headers body True++getPlayerNumber :: (TVar Session) -> RoutedNomyxServer PlayerNumber+getPlayerNumber ts = do+ (T.Session _ _ (Profiles acidAuth acidProfile _)) <- liftRouteT $ lift $ readTVarIO ts+ uid <- getUserId acidAuth acidProfile+ case uid of+ Nothing -> error "not logged in."+ (Just (UserId userID)) -> return $ fromInteger userID++fieldRequired :: NomyxError -> String -> Either NomyxError String+fieldRequired a [] = Left a+fieldRequired _ str = Right str++instance FormError NomyxError where+ type ErrorInputType NomyxError = [Input]+ commonFormError = NomyxCFE++instance ToMarkup NomyxError where+ toMarkup PlayerNameRequired = "Player Name is required"+ toMarkup GameNameRequired = "Game Name is required"+ toMarkup UniquePlayerName = "Name already taken"+ toMarkup (NomyxCFE e) = toHtml $ e+
src/Web/Game.hs view
@@ -1,5 +1,5 @@ -{-# LANGUAGE GADTs, OverloadedStrings, ExtendedDefaultRules#-}+{-# LANGUAGE GADTs, OverloadedStrings, ExtendedDefaultRules, DoAndIfThenElse#-} module Web.Game where @@ -8,50 +8,55 @@ import qualified Text.Blaze.Html5.Attributes as A import Web.Routes.RouteT import Text.Blaze.Internal-import Game import Control.Monad import Control.Monad.State import Data.Monoid import Control.Concurrent.STM-import Language.Nomyx.Expression-import Language.Nomyx.Evaluation+import Language.Nomyx+import Language.Nomyx.Game import Data.Maybe import Text.Reform.Happstack import Text.Reform import Happstack.Server-import Data.List import qualified Web.Help as Help import Web.Common-import Types+import Types as T import Web.Routes.Happstack() import qualified Text.Reform.Blaze.String as RB hiding (form) import Control.Applicative import Utils import Mail+import Text.Printf+import Data.String import Data.Text(Text) import qualified Text.Reform.Blaze.Common as RBC+import qualified Language.Haskell.HsColour.HTML as HSC+import Language.Haskell.HsColour.Colourise hiding (string)+import Multi as M default (Integer, Double, Data.Text.Text) viewGame :: Game -> PlayerNumber -> (Maybe SubmitRule) -> RoutedNomyxServer Html viewGame g pn sr = do- rf <- viewRuleForm pn sr- vi <- viewInputs pn $ events g+ let inGame = isJust $ Utils.getPlayers g pn+ rf <- viewRuleForm sr inGame+ vi <- viewInputs pn $ _events g ok $ table $ do td ! A.id "gameCol" $ do table $ do- tr $ td $ h3 $ string $ "Viewing game: " ++ gameName g- tr $ td $ (string $ "Description: " ++ gameDesc g ++ "\n\n") >> br >> br- tr $ td $ viewPlayers $ players g+ tr $ td $ h3 $ string $ "Viewing game: " ++ _gameName g+ tr $ td $ "Description:" >> br >> string (_desc $ _gameDesc g) >> br+ tr $ td $ (a "Agora" ! (A.href $ toValue (_agora $ _gameDesc g))) >> br >> br+ tr $ td $ viewPlayers $ _players g tr $ td $ viewVictory g td ! A.id "gameElem" $ do table $ do tr $ td $ div ! A.id "rules" $ viewAllRules g- tr $ td $ div ! A.id "inputs" ! A.title (toValue Help.inputs) $ vi- tr $ td $ div ! A.id "events" ! A.title (toValue Help.events) $ viewEvents $ events g- tr $ td $ div ! A.id "variables" ! A.title (toValue Help.variables)$ viewVars $ variables g+ tr $ td $ div ! A.id "inputs" ! A.title (toValue Help.inputs) $ vi+ tr $ td $ div ! A.id "events" ! A.title (toValue Help.events) $ viewEvents $ _events g+ tr $ td $ div ! A.id "variables" ! A.title (toValue Help.variables) $ viewVars $ _variables g tr $ td $ div ! A.id "newRule" $ rf- tr $ td $ div ! A.id "outputs" ! A.title (toValue Help.outputs)$ viewOutput (outputs g) pn+ tr $ td $ div ! A.id "outputs" ! A.title (toValue Help.outputs) $ viewOutput (_outputs g) pn viewPlayers :: [PlayerInfo] -> Html viewPlayers pis = do@@ -61,12 +66,12 @@ viewPlayer :: PlayerInfo -> Html viewPlayer pi = tr $ do- td $ string $ show $ playerNumber pi- td $ string $ playerName pi+ td $ string $ show $ _playerNumber pi+ td $ string $ _playerName pi viewVictory :: Game -> Html viewVictory g = do- let vs = mapMaybe (getPlayersNameMay g) (victory g)+ let vs = _playerName <$> mapMaybe (Utils.getPlayers g) (_victory g) case vs of [] -> br a:[] -> h3 $ string $ "Player " ++ (show a) ++ " won the game!"@@ -75,15 +80,13 @@ viewAllRules :: Game -> Html viewAllRules g = do h3 "Rules"- viewRules "Active rules:" (activeRules g) ! (A.title $ toValue Help.actives)- viewRules "Pending rules:" (pendingRules g) ! (A.title $ toValue Help.pendings)- viewRules "Suppressed rules:" $ rejectedRules g+ viewRules "Active rules" (activeRules g) True ! (A.title $ toValue Help.actives) >> br+ viewRules "Pending rules" (pendingRules g) True ! (A.title $ toValue Help.pendings) >> br+ viewRules "Suppressed rules" (rejectedRules g) False >> br -viewRules :: Html -> [Rule] -> Html-viewRules _ [] = return ()-viewRules title nrs = do- table ! A.class_ "table" $ do- caption $ h4 title+viewRules :: String -> [Rule] -> Bool -> Html+viewRules title nrs visible = do+ showHideTitle title visible (length nrs == 0) (h4 ! A.style "text-align:center;" $ toHtml title ) $ table ! A.class_ "table" $ do thead $ do td ! A.class_ "td" $ text "Number" td ! A.class_ "td" $ text "Name"@@ -95,27 +98,41 @@ viewRule :: Rule -> Html viewRule nr = tr $ do- td ! A.class_ "td" $ string . show $ rNumber nr- td ! A.class_ "td" $ string $ rName nr- td ! A.class_ "td" $ string $ rDescription nr- td ! A.class_ "td" $ string $ if rProposedBy nr == 0 then "System" else "Player " ++ (show $ rProposedBy nr)- td ! A.class_ "td" $ string $ rRuleCode nr- td ! A.class_ "td" $ string $ case rAssessedBy nr of+ td ! A.class_ "td" $ string . show $ _rNumber nr+ td ! A.class_ "td" $ string $ _rName nr+ td ! A.class_ "td" $ string $ _rDescription nr+ td ! A.class_ "td" $ string $ if _rProposedBy nr == 0 then "System" else "Player " ++ (show $ _rProposedBy nr)+ td ! A.class_ "td" $ viewRuleFunc $ nr+ td ! A.class_ "td" $ string $ case _rAssessedBy nr of Nothing -> "Not assessed" Just 0 -> "System" Just a -> "Rule " ++ (show $ a) +viewRuleFunc :: Rule -> Html+viewRuleFunc nr = do+ let code = preEscapedString $ HSC.hscolour defaultColourPrefs False $ _rRuleCode nr+ let ref = "openModalCode" ++ (show $ _rNumber nr)+ div ! A.id "showCodeLink" $ a ! (A.href $ toValue $ "#" ++ ref) $ "show code" >> br+ code+ div ! A.id (toValue ref) ! A.class_ "modalDialog" $ do+ div $ do+ p $ "Code of the rule:"+ a ! A.href "#close" ! A.title "Close" ! A.class_ "close" $ "X"+ code++concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]+concatMapM f xs = liftM concat (mapM f xs)+ viewEvents :: [EventHandler] -> Html-viewEvents [] = h3 "Events" >> h5 "No Events" viewEvents ehs = do- h3 "Events"- table ! A.class_ "table" $ do- thead $ do- td ! A.class_ "td" $ text "Event Number"- td ! A.class_ "td" $ text "By Rule"- td ! A.class_ "td" $ text "Event"- mapM_ viewEvent $ sort ehs+ showHideTitle "Events" False (length ehs == 0) (h3 "Events") $ table ! A.class_ "table" $ do+ thead $ do+ td ! A.class_ "td" $ text "Event Number"+ td ! A.class_ "td" $ text "By Rule"+ td ! A.class_ "td" $ text "Event"+ mapM_ viewEvent $ sort ehs + viewEvent :: EventHandler -> Html viewEvent (EH eventNumber ruleNumber event _) = tr $ do td ! A.class_ "td" $ string . show $ eventNumber@@ -126,29 +143,22 @@ viewInputs pn ehs = do mis <- mapM (viewInput pn) $ sort ehs let is = catMaybes mis- case length is of- 0 -> ok $ h3 "Inputs" >> h5 "No Inputs"- _ -> ok $ do- h3 "Inputs"- table $ do- mconcat is+ ok $ showHideTitle "Inputs" True (length is == 0) (h3 "Inputs") $ table $ mconcat is viewInput :: PlayerNumber -> EventHandler -> RoutedNomyxServer (Maybe Html) viewInput me (EH eventNumber _ (InputChoice pn title choices def) _) | me == pn = do- link <- showURL (DoInputChoice pn eventNumber)+ link <- showURL (DoInputChoice eventNumber) lf <- lift $ viewForm "user" $ inputChoiceForm title (map show choices) (show def) return $ Just $ tr $ td $ blazeForm lf (link) viewInput me (EH _ _ (InputString pn title) _) | me == pn = do- link <- showURL (DoInputString pn title)+ link <- showURL (DoInputString title) lf <- lift $ viewForm "user" $ inputStringForm title return $ Just $ tr $ td $ blazeForm lf (link) viewInput _ _ = return Nothing viewVars :: [Var] -> Html-viewVars [] = h3 "Variables" >> h5 "No Variables" viewVars vs = do- h3 "Variables"- table ! A.class_ "table" $ do+ showHideTitle "Variables" False (length vs == 0) (h3 "Variables") $ table ! A.class_ "table" $ do thead $ do td ! A.class_ "td" $ text "Rule number" td ! A.class_ "td" $ text "Name"@@ -173,81 +183,79 @@ `RBC.setAttr` A.class_ "code" `RBC.setAttr` A.placeholder "Enter here your rule" `RBC.setAttr` (A.title (toValue Help.code)) -viewRuleForm :: PlayerNumber -> (Maybe SubmitRule) -> RoutedNomyxServer Html-viewRuleForm pn sr = do- link <- showURL (NewRule pn)+viewRuleForm :: (Maybe SubmitRule) -> Bool -> RoutedNomyxServer Html+viewRuleForm sr inGame = do+ link <- showURL NewRule lf <- lift $ viewForm "user" $ newRuleForm sr ok $ do h3 "Propose a new rule:"- blazeForm lf (link)+ if inGame then blazeForm lf (link) ! A.disabled ""+ else lf ! A.disabled "" -newRule :: PlayerNumber -> (TVar Multi) -> RoutedNomyxServer Html-newRule pn tm = do+newRule :: (TVar Session) -> RoutedNomyxServer Html+newRule ts = do methodM POST- m <- liftRouteT $ lift $ readTVarIO tm+ s@(T.Session sh _ _) <- liftIO $ readTVarIO ts r <- liftRouteT $ eitherForm environment "user" (newRuleForm Nothing)- link <- showURL $ Noop pn+ link <- showURL MainPage+ pn <- getPlayerNumber ts case r of Right sr -> do- --t <- liftRouteT $ lift $ getCurrentTime- --liftRouteT $ lift $ putStrLn $ "before: " ++ (show m) ++"\n" ++ (show t) ++"\n"-- --t' <- liftRouteT $ lift $ getCurrentTime- --liftRouteT $ lift $ putStrLn $ "after: " ++ (show m) ++"\n" ++ (show t') ++"\n"- webCommand tm pn $ MultiSubmitRule sr pn- m' <- liftRouteT $ lift $ readTVarIO tm- let rs = rules $ fromJust $ getPlayersGame pn m- let rs' = rules $ fromJust $ getPlayersGame pn m'- when (length rs' > length rs) $ liftRouteT $ lift $ sendMailsNewRule m' sr pn- (Left _) -> liftRouteT $ lift $ putStrLn $ "cannot retrieve form data"+ webCommand ts $ submitRule sr pn sh+ liftIO $ do+ s' <- readTVarIO ts --TODO clean this+ gn <- getPlayersGame pn s+ gn' <- getPlayersGame pn s'+ let rs = _rules $ _game $ fromJust gn+ let rs' = _rules $ _game $ fromJust gn'+ when (length rs' > length rs) $ sendMailsNewRule s' sr pn+ (Left _) -> liftIO $ putStrLn $ "cannot retrieve form data" seeOther link $ string "Redirecting..." viewOutput :: [Output] -> PlayerNumber -> Html-viewOutput [] _ = h3 "Output" >> h5 "No Output" viewOutput os pn = do- h3 "Output" let myos = map snd $ filter (\o -> fst o == pn) os- mapM_ viewMessages [myos]+ showHideTitle "Output" True (length myos == 0) (h3 "Output") $ mapM_ viewMessages [myos] viewMessages :: [String] -> Html viewMessages = mapM_ (\s -> string s >> br) -newInputChoice :: PlayerNumber -> EventNumber -> (TVar Multi) -> RoutedNomyxServer Html-newInputChoice pn en tm = do- multi <- liftRouteT $ lift $ atomically $ readTVar tm- let mg = fromJust $ getPlayersGame pn multi- let eventHandler = fromJust $ findEvent en (events mg)+newInputChoice :: EventNumber -> (TVar Session) -> RoutedNomyxServer Html+newInputChoice en ts = do+ pn <- getPlayerNumber ts+ s <- liftIO $ atomically $ readTVar ts+ mgn <- liftIO $ getPlayersGame pn s+ let eventHandler = fromJust $ findEvent en (_events $ _game $ fromJust mgn) methodM POST let (title, choices, def) = getChoices eventHandler r <- liftRouteT $ eitherForm environment "user" (inputChoiceForm title choices def)- link <- showURL $ Noop pn+ link <- showURL MainPage case r of (Right c) -> do- liftRouteT $ lift $ putStrLn $ "choice:" ++ (show c)- webCommand tm pn $ MultiInputChoiceResult en c pn+ webCommand ts $ M.inputChoiceResult en c pn seeOther link $ string "Redirecting..." (Left _) -> do- liftRouteT $ lift $ putStrLn $ "cannot retrieve form data"+ liftIO $ putStrLn $ "cannot retrieve form data" seeOther link $ string "Redirecting..." getChoices :: EventHandler -> (String, [String], String) getChoices (EH _ _ (InputChoice _ title choices def) _) = (title, map show choices, show def) getChoices _ = error "InputChoice event expected" -newInputString :: PlayerNumber -> String -> (TVar Multi) -> RoutedNomyxServer Html-newInputString pn title tm = do+newInputString :: String -> (TVar Session) -> RoutedNomyxServer Html+newInputString title ts = do methodM POST+ pn <- getPlayerNumber ts r <- liftRouteT $ eitherForm environment "user" (inputStringForm title)- link <- showURL $ Noop pn+ link <- showURL MainPage case r of (Right c) -> do- liftRouteT $ lift $ putStrLn $ "entered:" ++ (show c)- webCommand tm pn $ MultiInputStringResult title c pn+ webCommand ts $ M.inputStringResult (InputString pn title) c pn seeOther link $ string "Redirecting..." (Left _) -> do- liftRouteT $ lift $ putStrLn $ "cannot retrieve form data"+ liftIO $ putStrLn $ "cannot retrieve form data" seeOther link $ string "Redirecting..." @@ -257,3 +265,31 @@ inputStringForm :: String -> NomyxForm String inputStringForm title = RB.label (title ++ " ") ++> RB.inputText "" +showHideTitle :: String -> Bool -> Bool -> Html -> Html -> Html+showHideTitle id visible empty title rest = do+ div ! A.onclick (fromString $ printf "toggle_visibility('%sBody', '%sShow')" id id) $ table ! A.width "100%" $ tr $ do+ td $ title ! A.width "80%"+ td ! A.style "text-align:right;" $ h5 (if visible then "[Hide]" else "[Show]") ! A.id (fromString $ printf "%sShow" id) ! A.width "20%"+ div ! A.id (fromString $ printf "%sBody" id) ! A.style (fromString $ "display:" ++ (if visible then "block;" else "none;")) $+ if (empty) then (toHtml $ "No " ++ id) else rest++joinGame :: (TVar Session) -> GameName -> RoutedNomyxServer Response+joinGame ts gn = do+ pn <- getPlayerNumber ts+ webCommand ts (M.joinGame gn pn)+ link <- showURL MainPage+ seeOther link $ toResponse "Redirecting..."++leaveGame :: (TVar Session) -> GameName -> RoutedNomyxServer Response+leaveGame ts gn = do+ pn <- getPlayerNumber ts+ webCommand ts (M.leaveGame gn pn)+ link <- showURL MainPage+ seeOther link $ toResponse "Redirecting..."++viewGamePlayer :: (TVar Session) -> GameName -> RoutedNomyxServer Response+viewGamePlayer ts gn = do+ pn <- getPlayerNumber ts+ webCommand ts (M.viewGamePlayer gn pn)+ link <- showURL MainPage+ seeOther link $ toResponse "Redirecting..."
src/Web/Help.hs view
@@ -21,3 +21,5 @@ events = "Rules can register on events, in order to be triggered when the event happens, for example with the instruction \"onEvent\"." 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." outputs = "Rules can display text on players screen, with instruction \"output\"."+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."
src/Web/Login.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules#-}+{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules, RecordWildCards#-} module Web.Login where @@ -11,123 +11,50 @@ import Text.Blaze.Internal import Control.Monad.State import Control.Concurrent.STM-import Language.Nomyx.Expression-import Utils-import Text.Reform.Happstack-import Text.Reform-import Debug.Trace.Helpers import Happstack.Server-import Types-import Multi --TODO to remove+import Types as T+import Multi as M import Web.Common-import Web.Settings import Web.Routes.Happstack()-import Control.Applicative-import Text.Reform.Blaze.String hiding (form) import Data.Text hiding (map, zip, concatMap)+import Happstack.Auth (AuthProfileURL(..), AuthURL(..), handleAuthProfile)+import Happstack.Auth.Core.Profile+import Facebook (Credentials(..)) default (Integer, Double, Data.Text.Text) --loginForm :: Maybe LoginPass -> NomyxForm LoginPass-loginForm (Just (LoginPass login _)) = loginForm' login-loginForm Nothing = loginForm' ""--loginForm' :: String -> NomyxForm LoginPass-loginForm' login = LoginPass <$> br ++> label "Please enter your login and password (if you don't have one, just invent it):" ++> br ++> br- ++> label "Login: " ++> (inputText login) <*> label " Password: " ++> inputPassword <++ label " "---loginPage :: RoutedNomyxServer Html-loginPage = do- link <- showURL PostLogin- lf <- lift $ viewForm "user" $ loginForm Nothing- mainPage (blazeForm lf link)- "Login to Nomyx"- "Login to Nomyx"- True--newPlayerPage :: LoginPass -> RoutedNomyxServer Html-newPlayerPage lp = do- link <- showURL $ NewPlayerLogin lp- lf <- lift $ viewForm "user" $ loginForm (Just lp)- mf <- lift $ viewForm "user" $ settingsForm Nothing- mainPage (do- lf ! (disabled "")- H.br >> H.br- "New Player? Welcome!" >> H.br- (blazeForm mf link))- "Login to Nomyx"- "New Player"- True---newPlayerLogin :: (TVar Multi) -> LoginPass -> RoutedNomyxServer Html-newPlayerLogin tm (LoginPass login password) = do- methodM POST- liftRouteT $ lift $ putStrLn $ "newPlayerLogin"- r <- liftRouteT $ eitherForm environment "user" $ settingsForm Nothing- case r of- (Right ms) -> do- mpn <- evalCommand tm $ checkLoginWeb login password- case mpn of- LoginOK pn -> do- link <- showURL $ Noop pn- webCommand tm pn $ MultiMailSettings ms pn- seeOther link $ string "Redirecting..."- WrongPassword -> do- link <- showURL $ Login- seeOther link $ string "Redirecting..."- NewLogin -> do- pn <- evalCommand tm $ getNewPlayerNumber- link <- showURL $ Noop pn- webCommand tm pn $ MultiNewPlayer PlayerMulti { mPlayerNumber = pn, mPlayerName = login, mPassword = password, inGame = Nothing, mMail = defaultMailSettings, lastRule = Nothing}- webCommand tm pn $ MultiMailSettings ms pn- seeOther link $ string "Redirecting..."- (Left _) -> seeOther ("/Login?status=fail" :: String) $ string "Redirecting..."----postLogin :: (TVar Multi) -> RoutedNomyxServer Html-postLogin tm = do- methodM POST- r <- liftRouteT $ eitherForm environment "user" $ loginForm Nothing- case r of- (Right lp) -> checkLoginPassword lp tm- (Left _) -> seeOther ("/Login?status=fail" :: String) $ string "Redirecting..."--checkLoginPassword :: LoginPass -> (TVar Multi) -> RoutedNomyxServer Html-checkLoginPassword lp@(LoginPass login password) tm = do- liftRouteT $ lift $ putStrLn $ "login:" ++ login- liftRouteT $ lift $ putStrLn $ "password:" ++ password- mpn <- evalCommand tm $ checkLoginWeb login password- case mpn of- LoginOK pn -> do- link <- showURL $ Noop pn- seeOther link $ string "Redirecting..."- WrongPassword -> do- link <- showURL $ Login- seeOther link $ string "Redirecting..."- NewLogin -> do- link <- showURL $ NewPlayer lp- seeOther link $ string "Redirecting..."--data LoginResult = LoginOK PlayerNumber | WrongPassword | NewLogin+-- | 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 (U_AuthProfile $ 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") -checkLoginWeb :: PlayerName -> PlayerPassword -> State Multi LoginResult-checkLoginWeb name pwd = do- mpn <- findPlayer name- case mpn of- Just pl -> do- traceM $ "Trying name:" ++ mPlayerName pl- case pwd == mPassword pl of- True -> do- traceM "password OK"- return $ LoginOK $ mPlayerNumber pl- False -> do- traceM "password false"- return WrongPassword- Nothing -> do- traceM "New player"- return NewLogin+-- | add a new player+createNewPlayer :: (TVar Session) -> RoutedNomyxServer Response+createNewPlayer ts = do+ pn <- getPlayerNumber ts+ webCommand ts $ M.newPlayer pn defaultPlayerSettings Nothing Nothing+ link <- showURL $ PSettings+ seeOther link (toResponse $ string "to settings page") +authenticate :: (TVar Session) -> AuthProfileURL -> RoutedNomyxServer Response+authenticate ts authProfileURL = do+ (T.Session _ _ Profiles{..}) <- liftIO $ atomically $ readTVar ts+ postPickedURL <- showURL NewPlayer+ nestURL U_AuthProfile $ handleAuthProfile acidAuth acidProfile appTemplate (Just facebookAuth) Nothing postPickedURL authProfileURL +facebookAuth =+ Credentials {appName = "Nomyx",+ appId = "161007670738608",+ appSecret = "c0509c1c753f89d1d1fc181984042824"}
src/Web/MainPage.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, TemplateHaskell, EmptyDataDecls, TypeFamilies, MultiParamTypeClasses, DeriveDataTypeable, PackageImports, GADTs,- ScopedTypeVariables, NamedFieldPuns, Rank2Types, DoAndIfThenElse, StandaloneDeriving, OverloadedStrings, ExtendedDefaultRules#-}+ ScopedTypeVariables, NamedFieldPuns, Rank2Types, DoAndIfThenElse, StandaloneDeriving, OverloadedStrings,+ ExtendedDefaultRules, RecordWildCards#-} module Web.MainPage (launchWebServer) where @@ -17,11 +18,11 @@ import Text.Blaze.Internal import Control.Monad import Paths_Nomyx as PN-import Paths_Nomyx_Rules as PNR+import Paths_Nomyx_Language as PNL import Control.Monad.State import Data.Monoid import Control.Concurrent.STM-import Language.Nomyx.Expression+import Language.Nomyx import Text.Reform.Happstack import Text.Reform import Happstack.Server as HS@@ -29,37 +30,41 @@ import System.FilePath import System.Posix.Files import qualified Web.Help as Help-import Types+import Types as T import Web.Game import Web.Common-import Web.Login import Web.Settings import Web.NewGame+import Web.Login import qualified Text.Reform.Blaze.String as RB import Utils import Data.Maybe-import Data.List import Data.Text(Text, pack)+import qualified Language.Nomyx.Game as G+import qualified Multi as M+import Happstack.Auth default (Integer, Double, Data.Text.Text) -viewMulti :: PlayerNumber -> Multi -> RoutedNomyxServer Html-viewMulti pn m = do- let pl = fromJust $ find (\PlayerMulti {mPlayerNumber} -> pn==mPlayerNumber) (mPlayers m)- gns <- viewGamesTab pn (games m)- g <- case getPlayersGame pn m of- Just g -> viewGame g pn (lastRule pl)- Nothing -> ok $ h3 "Not in game"+viewMulti :: PlayerNumber -> Session -> RoutedNomyxServer Html+viewMulti pn s = do+ pfd <- getProfile pn s+ gns <- viewGamesTab (map G._game $ _games $ _multi s) (pn == 1)+ mgn <- liftRouteT $ lift $ getPlayersGame pn s+ g <- case mgn of+ Just g -> viewGame (G._game g) pn (_pLastRule $ fromJust pfd)+ Nothing -> ok $ h3 "Not viewing any game" ok $ do div ! A.id "gameList" $ gns div ! A.id "game" $ g -viewGamesTab :: PlayerNumber -> [Game] -> RoutedNomyxServer Html-viewGamesTab pn gs = do- gns <- mapM (viewGameName pn) gs- newGameLink <- showURL (NewGame pn)- uploadLink <- showURL (Upload pn)- settingsLink <- showURL (Settings pn)+viewGamesTab :: [Game] -> Bool -> RoutedNomyxServer Html+viewGamesTab gs admin = do+ gns <- mapM viewGameName gs+ newGameLink <- showURL NewGame+ uploadLink <- showURL Upload+ settingsLink <- showURL PSettings+ logoutURL <- showURL (U_AuthProfile $ AuthURL A_Logout) up <- lift $ viewForm "user" uploadForm dd <- lift $ lift $ PN.getDataDir mods <- lift $ lift $ getDirectoryContents $ dd </> modDir@@ -72,70 +77,68 @@ [] -> tr $ td "No Games" _ -> sequence_ gns br >> "Nomyx language files:" >> br- H.a "Rules examples" ! (href $ "/src/Language/Nomyx/Examples.hs") >> br- H.a "Rules definitions" ! (href $ "/src/Language/Nomyx/Rule.hs") >> br- H.a "Rules types" ! (href $ "/src/Language/Nomyx/Expression.hs") >> br+ H.a "Rules examples" ! (href $ "/src/Language/Nomyx/Examples.hs") >> br+ H.a "Basic rules" ! (href $ "/src/Language/Nomyx/Rule.hs") >> br+ H.a "Rules definitions" ! (href $ "/src/Language/Nomyx/Definition.hs") >> br+ H.a "Rules types" ! (href $ "/src/Language/Nomyx/Expression.hs") >> br mapM_ (\f -> (H.a $ toHtml f ) ! (href $ toValue (pathSeparator : modDir </> f)) >> br) fmods br >> "Upload new rules file:" >> br blazeForm up (uploadLink) ! (A.title $ toValue Help.upload) br >> "Settings:" >> br- H.a "Create a new game" ! (href $ toValue newGameLink) >> br+ when admin $ H.a "Create a new game" ! (href $ toValue newGameLink) >> br H.a "Player settings" ! (href $ toValue settingsLink) >> br+ H.a "Logout " ! href (toValue logoutURL) >> br -viewGameName :: PlayerNumber -> Game -> RoutedNomyxServer Html-viewGameName pn g = do- let gn = gameName g- join <- showURL (JoinGame pn gn)- leave <- showURL (LeaveGame pn)- --subscribe <- showURL (SubscribeGame pn gn)- unsubscribe <- showURL (UnsubscribeGame pn gn)+viewGameName :: Game -> RoutedNomyxServer Html+viewGameName g = do+ let gn = _gameName g+ join <- showURL (JoinGame gn)+ leave <- showURL (LeaveGame gn)+ view <- showURL (ViewGame gn) ok $ do tr $ do- td $ string $ gn- td $ H.a "Join" ! (href $ toValue join)+ 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 leave)- --td $ H.a "Subscribe" ! (href $ toValue subscribe)- td $ H.a "Unsubscribe" ! (href $ toValue unsubscribe)----nomyxPage :: Multi -> PlayerNumber -> RoutedNomyxServer Html-nomyxPage multi pn = do- m <- viewMulti pn multi- mainPage (H.div ! A.id "multi" $ m)- "Welcome to Nomyx!"- (string $ "Welcome to Nomyx, " ++ (getPlayersName pn multi) ++ "!")- False--nomyxPageServer :: PlayerNumber -> (TVar Multi) -> RoutedNomyxServer Html-nomyxPageServer pn tm = do- multi <- liftRouteT $ lift $ atomically $ readTVar tm- nomyxPage multi pn--nomyxSite :: (TVar Multi) -> Site PlayerCommand (ServerPartT IO Html)-nomyxSite tm = setDefault Login $ mkSitePI (runRouteT $ routedNomyxCommands tm)+ div ! A.id (toValue $ "openModalJoin" ++ gn) ! A.class_ "modalWindow" $ do+ div $ do+ h2 "Joining the game. Please register in the Agora and introduce yourself to the other players! \n \+ If you do not which to play, you can just view the game."+ H.a "Join" ! (href $ toValue join) ! A.class_ "join" ! (A.title $ toValue Help.join)+ H.a "View" ! (href $ toValue view) ! A.class_ "view" ! (A.title $ toValue Help.view) -routedNomyxCommands :: (TVar Multi) -> PlayerCommand -> RoutedNomyxServer Html-routedNomyxCommands _ (Login) = loginPage-routedNomyxCommands _ (NewPlayer lp) = newPlayerPage lp-routedNomyxCommands tm (NewPlayerLogin lp) = newPlayerLogin tm lp-routedNomyxCommands tm (PostLogin) = postLogin tm-routedNomyxCommands tm (Noop pn) = nomyxPageServer pn tm-routedNomyxCommands tm (JoinGame pn game) = webCommand tm pn (MultiJoinGame game pn) >> nomyxPageServer pn tm-routedNomyxCommands tm (LeaveGame pn) = webCommand tm pn (MultiLeaveGame pn) >> nomyxPageServer pn tm-routedNomyxCommands tm (SubscribeGame pn game) = webCommand tm pn (MultiSubscribeGame game pn) >> nomyxPageServer pn tm-routedNomyxCommands tm (UnsubscribeGame pn game) = webCommand tm pn (MultiUnsubscribeGame game pn) >> nomyxPageServer pn tm-routedNomyxCommands tm (NewRule pn) = newRule pn tm-routedNomyxCommands _ (NewGame pn) = newGamePage pn-routedNomyxCommands tm (SubmitNewGame pn) = newGame pn tm-routedNomyxCommands tm (DoInputChoice pn en) = newInputChoice pn en tm-routedNomyxCommands tm (DoInputString pn en) = newInputString pn en tm-routedNomyxCommands tm (Upload pn) = newUpload pn tm-routedNomyxCommands tm (Settings pn) = settings pn tm-routedNomyxCommands tm (SubmitSettings pn) = newSettings pn tm+nomyxPage :: (TVar Session) -> RoutedNomyxServer Response+nomyxPage ts = do+ pn <- getPlayerNumber ts+ s <- liftRouteT $ lift $ atomically $ readTVar ts+ m <- viewMulti pn s+ name <- liftRouteT $ lift $ getPlayersName pn 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 $ routedNomyxCommands tm) +routedNomyxCommands :: (TVar Session) -> PlayerCommand -> RoutedNomyxServer Response+routedNomyxCommands ts (U_AuthProfile auth) = authenticate ts auth+routedNomyxCommands ts NewPlayer = createNewPlayer ts+routedNomyxCommands ts HomePage = homePage ts+routedNomyxCommands ts MainPage = nomyxPage ts+routedNomyxCommands ts (JoinGame game) = joinGame ts game+routedNomyxCommands ts (LeaveGame game) = leaveGame ts game+routedNomyxCommands ts (ViewGame game) = viewGamePlayer ts game+routedNomyxCommands ts NewRule = newRule ts >>= return . toResponse+routedNomyxCommands _ NewGame = newGamePage >>= return . toResponse+routedNomyxCommands ts SubmitNewGame = newGamePost ts >>= return . toResponse+routedNomyxCommands ts (DoInputChoice en) = newInputChoice en ts >>= return . toResponse+routedNomyxCommands ts (DoInputString en) = newInputString en ts >>= return . toResponse+routedNomyxCommands ts Upload = newUpload ts >>= return . toResponse+routedNomyxCommands ts PSettings = settings ts >>= return . toResponse+routedNomyxCommands ts SubmitPlayerSettings = newSettings ts >>= return . toResponse {- nomyxPageComm' :: PlayerNumber -> (TVar Multi) -> StateT Multi IO () -> RoutedNomyxServer Html@@ -178,26 +181,28 @@ uploadForm :: NomyxForm (FilePath, FilePath, ContentType) uploadForm = RB.inputFile -newUpload :: PlayerNumber -> (TVar Multi) -> RoutedNomyxServer Html-newUpload pn tm = do+newUpload :: (TVar Session) -> RoutedNomyxServer Html+newUpload ts = do methodM POST+ pn <- getPlayerNumber ts r <- liftRouteT $ eitherForm environment "user" uploadForm- link <- showURL $ Noop pn+ link <- showURL MainPage+ (T.Session sh _ _) <- liftRouteT $ lift $ readTVarIO ts case r of- (Right (path,name,_)) -> webCommand tm pn $ MultiInputUpload pn path name+ (Right (path,name,_)) -> webCommand ts $ M.inputUpload pn path name sh (Left _) -> liftRouteT $ lift $ putStrLn $ "cannot retrieve form data" seeOther link $ string "Redirecting..." -launchWebServer :: (TVar Multi) -> Network -> IO ()+launchWebServer :: (TVar Session) -> Network -> IO () launchWebServer tm net = do putStrLn $ "Starting web server...\nTo connect, drive your browser to \"" ++ nomyxURL net ++ "/Nomyx\"" d <- PN.getDataDir- d' <- PNR.getDataDir- simpleHTTP nullConf {HS.port = Types.port net} $ server d d' tm net+ d' <- PNL.getDataDir+ simpleHTTP nullConf {HS.port = T._port net} $ server d d' tm net --serving Nomyx web page as well as data from this package and the language library package-server :: FilePath -> FilePath -> (TVar Multi) -> Network -> NomyxServer Response+server :: FilePath -> FilePath -> (TVar Session) -> Network -> ServerPartT IO Response server d d' tm net = mconcat [ serveDirectory EnableBrowsing [] d, serveDirectory EnableBrowsing [] d', do
src/Web/NewGame.hs view
@@ -16,37 +16,46 @@ import Text.Reform.Happstack import Web.Common import Control.Monad.State-import Language.Nomyx.Expression+import Language.Nomyx import Web.Routes.RouteT import Control.Concurrent.STM import Data.Text(Text) import Text.Blaze.Internal(string)+import Multi default (Integer, Double, Data.Text.Text) -data NewGameForm = NewGameForm GameName String+data NewGameForm = NewGameForm GameName GameDesc newGameForm :: NomyxForm NewGameForm-newGameForm = pure NewGameForm <*> br ++> label "Enter new game name: " ++> (inputText "") `RBC.setAttr` placeholder "Game name" <++ br <++ br- <*> label "Enter game description, including a link to a place (e.g. a forum, a mailing list...) where the players can discuss their rules: " ++> br- ++> (textarea 40 3 "") `RBC.setAttr` placeholder "Enter game description" `RBC.setAttr` class_ "gameDesc"+newGameForm = pure NewGameForm <*> (br ++> errorList ++> label "Enter new game name: " ++> (inputText "") `transformEither` (fieldRequired GameNameRequired) `RBC.setAttr` placeholder "Game name" <++ br <++ br)+ <*> newGameDesc +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 ++> (inputText "") `RBC.setAttr` placeholder "Agora URL (including http://...)" `RBC.setAttr` class_ "agora" <++ br <++ br -newGamePage :: PlayerNumber -> RoutedNomyxServer Html-newGamePage pn = do- newGameLink <- showURL (SubmitNewGame pn)+gameNameRequired :: String -> Either NomyxError String+gameNameRequired = fieldRequired GameNameRequired++newGamePage :: RoutedNomyxServer Html+newGamePage = do+ newGameLink <- showURL SubmitNewGame mf <- lift $ viewForm "user" $ newGameForm- mainPage (blazeForm mf newGameLink)- "New game"- "New game"- False+ mainPage "New game"+ "New game"+ (blazeForm mf newGameLink)+ False -newGame :: PlayerNumber -> (TVar Multi) -> RoutedNomyxServer Html-newGame pn tm = do+newGamePost :: (TVar Session) -> RoutedNomyxServer Html+newGamePost ts = do methodM POST r <- liftRouteT $ eitherForm environment "user" newGameForm- link <- showURL $ Noop pn+ link <- showURL MainPage+ newGameLink <- showURL SubmitNewGame+ pn <- getPlayerNumber ts case r of- Left _ -> error $ "error: newGame"- Right (NewGameForm name desc) -> webCommand tm pn $ MultiNewGame name desc pn- seeOther link $ string "Redirecting..."+ Left errorForm -> mainPage "New game" "New game" (blazeForm errorForm newGameLink) False+ Right (NewGameForm name desc) -> do+ webCommand ts $ newGame name desc pn+ seeOther link $ string "Redirecting..."
src/Web/Settings.hs view
@@ -15,50 +15,65 @@ import Text.Reform.Happstack import Web.Common import Control.Monad.State-import Language.Nomyx.Expression import Web.Routes.RouteT-import Utils import Control.Concurrent.STM import Data.Maybe import Data.Text(Text) import Text.Blaze.Internal(string)+import Multi+import Utils+import Language.Nomyx+import Debug.Trace (trace) default (Integer, Double, Data.Text.Text) -settingsForm :: (Maybe MailSettings) -> NomyxForm MailSettings-settingsForm (Just (MailSettings {mailTo, mailNewRule})) = settingsForm' mailTo mailNewRule-settingsForm Nothing = settingsForm' "" True+settingsForm :: (Maybe PlayerSettings) -> [PlayerName]-> NomyxForm PlayerSettings+settingsForm (Just prof) ns = settingsForm' (_pPlayerName prof) (_mailTo prof) (_mailNewRule prof) ns+settingsForm Nothing ns = settingsForm' "" "" True ns -settingsForm':: String -> Bool -> NomyxForm MailSettings-settingsForm' mailTo mailNewRule = pure MailSettings <*> label "Please enter your mail: " ++> inputText mailTo <++ br- <*> pure True --label " send mail on new input needed from you: " ++> inputCheckbox True <++ label " " <++ br- <*> inputCheckbox mailNewRule <++ label " I want to be notified by email if a player proposes a new rule (recommended)" <++ br- <*> pure True --label " send mail on new output: " ++> inputCheckbox True <++ label " "- <*> pure True+settingsForm':: String -> String -> Bool -> [PlayerName] -> NomyxForm PlayerSettings+settingsForm' name mailTo mailNewRule names = pure Types.PlayerSettings+ <*> errorList ++> label "Player Name: " ++> (inputText name) `transformEither` (uniqueName names) `transformEither` (fieldRequired PlayerNameRequired) <++ br+ <*> label "Please enter your mail: " ++> inputText mailTo <++ br+ <*> pure True --label " send mail on new input needed from you: " ++> inputCheckbox True <++ label " " <++ br+ <*> inputCheckbox mailNewRule <++ label " I want to be notified by email when a player proposes a new rule in my game (recommended)" <++ br+ <*> pure True --label " send mail on new output: " ++> inputCheckbox True <++ label " "+ <*> pure True -settingsPage :: PlayerNumber -> MailSettings -> RoutedNomyxServer Html-settingsPage pn ms = do- settingsLink <- showURL (SubmitSettings pn)- mf <- lift $ viewForm "user" $ settingsForm (Just ms)- mainPage (blazeForm mf settingsLink)- "Player settings"- "Player settings"- False+uniqueName :: [String] -> String -> Either NomyxError String+uniqueName names name = case trace (name ++ (show names) ++ (show (name `elem` names))) $ (name `elem` names) of+ True -> trace "left" $ Left UniquePlayerName+ False ->trace "right" $ Right name -settings :: PlayerNumber -> (TVar Multi) -> RoutedNomyxServer Html-settings pn tm = do- pm <- evalCommand tm $ findPlayer' pn- settingsPage pn $ mMail $ fromJust pm+settingsPage :: PlayerSettings-> [PlayerName] -> RoutedNomyxServer Html+settingsPage ps ns = do+ settingsLink <- showURL SubmitPlayerSettings+ mf <- lift $ viewForm "user" $ settingsForm (Just ps) ns+ mainPage "Player settings"+ "Player settings"+ (blazeForm mf settingsLink)+ False +settings :: (TVar Session) -> RoutedNomyxServer Html+settings ts = do+ s <- liftIO $ atomically $ readTVar ts+ pn <- getPlayerNumber ts+ pfd <- getProfile pn s+ pfs <- liftIO $ getAllProfiles s+ let pfs' = filter (\a -> (_pPlayerNumber a /= pn)) pfs+ settingsPage (_pPlayerSettings $ fromJust pfd) ((_pPlayerName . _pPlayerSettings) <$> pfs') -newSettings :: PlayerNumber -> (TVar Multi) -> RoutedNomyxServer Html-newSettings pn tm = do+newSettings :: (TVar Session) -> RoutedNomyxServer Html+newSettings ts = do methodM POST- r <- liftRouteT $ eitherForm environment "user" $ settingsForm Nothing- link <- showURL $ Noop pn- case r of- Right ms -> webCommand tm pn $ MultiMailSettings ms pn- (Left _) -> liftRouteT $ lift $ putStrLn $ "cannot retrieve form data"- seeOther link $ string "Redirecting..."+ pn <- getPlayerNumber ts+ p <- liftRouteT $ eitherForm environment "user" $ settingsForm Nothing []+ link <- showURL MainPage+ settingsLink <- showURL SubmitPlayerSettings+ case p of+ Right ps -> do+ webCommand ts $ playerSettings ps pn+ seeOther link $ string "Redirecting..."+ (Left errorForm) -> mainPage "Player settings" "Player settings" (blazeForm errorForm settingsLink) False