Nomyx 0.4.1 → 0.5.0
raw patch · 24 files changed
+158/−2781 lines, 24 filesdep +Nomyx-Coredep +Nomyx-Webdep +exceptionsdep −DebugTraceHelpersdep −MissingHdep −MonadCatchIO-mtldep ~Nomyx-Languagedep ~hint-server
Dependencies added: Nomyx-Core, Nomyx-Web, exceptions
Dependencies removed: DebugTraceHelpers, MissingH, MonadCatchIO-mtl, acid-state, blaze-html, blaze-markup, bytestring, containers, data-lens, data-lens-fd, data-lens-template, either-unwrap, fb, happstack-authenticate, happstack-server, hint, hscolour, ixset, mime-mail, old-locale, reform, reform-blaze, reform-happstack, safecopy, split, tar, template-haskell, temporary, text, unix, unix-compat, web-routes, web-routes-happstack, web-routes-regular, web-routes-th
Dependency ranges changed: Nomyx-Language, hint-server
Files
- AUTHORS +1/−1
- Nomyx.cabal +12/−53
- README +0/−40
- README.md +49/−0
- TODO +10/−15
- data/static/css/nomyx.css +0/−283
- data/static/nomyx.js +0/−15
- data/static/pictures/help.jpg binary
- src/Interpret.hs +0/−99
- src/Mail.hs +0/−89
- src/Main.hs +86/−86
- src/Multi.hs +0/−230
- src/Quotes.hs +0/−42
- src/Serialize.hs +0/−36
- src/Test.hs +0/−208
- src/Types.hs +0/−161
- src/Utils.hs +0/−176
- src/Web/Common.hs +0/−263
- src/Web/Game.hs +0/−361
- src/Web/Help.hs +0/−47
- src/Web/Login.hs +0/−68
- src/Web/MainPage.hs +0/−175
- src/Web/NewGame.hs +0/−61
- src/Web/Settings.hs +0/−272
AUTHORS view
@@ -1,1 +1,1 @@-Corentin Dupont <corentin.dupont@gmail.com>+Corentin Dupont <corentin.dupontDELAVEGAgmail.com> (remove DELAVEGA to obtain my email)
Nomyx.cabal view
@@ -1,5 +1,5 @@ name: Nomyx-version: 0.4.1+version: 0.5.0 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -13,70 +13,29 @@ category: game Homepage: http://www.nomyx.net author: Corentin Dupont-data-files: static/css/nomyx.css - static/nomyx.js- static/pictures/*.jpg-data-dir: data-extra-source-files: AUTHORS README TODO+extra-source-files: AUTHORS README.md TODO executable Nomyx- build-depends: Nomyx-Language == 0.4.1,- DebugTraceHelpers == 0.12.*,- MissingH == 1.2.*,- MonadCatchIO-mtl == 0.3.*,- acid-state == 0.12.*,+ build-depends: Nomyx-Core == 0.5.0,+ Nomyx-Language == 0.5.0, + Nomyx-Web == 0.5.0, base == 4.6.*,- blaze-html == 0.5.*,- blaze-markup == 0.5.*,- bytestring == 0.10.*,- containers == 0.5.*,- data-lens == 2.10.*,- data-lens-template == 2.1.*,- data-lens-fd == 2.0.*, directory == 1.2.*,- either-unwrap == 1.1.*,- fb == 0.14.*,+ exceptions == 0.3.*, filepath == 1.3.*,- happstack-authenticate == 0.10.*,- happstack-server == 7.1.*,- hint == 0.3.*,- hint-server == 1.2.*,- hscolour == 1.20.*,- ixset == 1.0.*,- mime-mail == 0.4.*,+ hint-server == 1.3.*, mtl == 2.1.*, network == 2.4.*,- old-locale == 1.0.*,- reform == 0.2.*,- reform-blaze == 0.2.*,- reform-happstack == 0.2.*, safe == 0.3.*,- safecopy == 0.8.*,- split == 0.2.*, stm == 2.4.*,- tar == 0.4.*,- temporary == 1.1.*,- template-haskell == 2.8.*,- text == 0.11.*,- time == 1.4.*,- -- cross-platform file handling- unix-compat == 0.4.*,- web-routes == 0.27.*,- web-routes-happstack == 0.23.*,- web-routes-regular == 0.19.*,- web-routes-th == 0.22.*- - if os(windows)- Cpp-options: -DWINDOWS- else- build-depends: unix == 2.6.*-+ time == 1.4.* main-is: Main.hs buildable: True extensions: CPP hs-source-dirs: src- other-modules: Types Mail Test Multi Serialize Utils Interpret- Quotes Web.Common Web.Help Web.NewGame Web.Game Web.Login- Web.Settings Web.MainPage+ other-modules: Main ghc-options: -W -threaded +source-repository head+ type: git+ location: git://github.com/cdupont/Nomyx.git
− README
@@ -1,40 +0,0 @@-Nomyx-=========--A Nomic game in Haskell--Nomyx is a fabulous and strange game where you have the right to change the rules in the middle of the game!-In fact, changing the rules is the goal of the game. Changing a rule is considered as a move. Of course even that could be changed!-In this game, the player can enter new rules in a dedicated language, modify existing ones, thus changing completely the behaviour of the game.-The original (paper) game: www.nomic.net--Installation-============--To install, follow this procedure:-- download the source tar.gz-- extract it somewhere--$ cd <name>/Nomyx-Language-$ cabal install-$ cd ../Nomyx -$ cabal install---Execution-=========--Launch with the command:--$ Nomyx--and follow the instructions. You may connect using a web browser to the given address.---Troubleshooting-===============-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
+ README.md view
@@ -0,0 +1,49 @@+[](https://travis-ci.org/cdupont/Nomyx)+[](https://hackage.haskell.org/package/Nomyx)++Nomyx+=====++A Nomic game in Haskell++Nomyx is a fabulous and strange game where you have the right to change the rules in the middle of the game!+In fact, changing the rules is the goal of the game. Changing a rule is considered as a move. Of course even that could be changed!+In this game, the player can enter new rules in a dedicated language, modify existing ones, thus changing completely the behaviour of the game!++The web site: www.nomyx.net++Installation+============++You need a [Haskell platform](www.haskell.org/platform) running on your system. +To install from the Hackage release, follow this procedure:++ cabal install Nomyx-Language --enable-documentation --haddock-hyperlink-source+ cabal install Nomyx++To install from the GitHub repo:++ git clone git@github.com:cdupont/Nomyx-Language.git+ cabal install Nomyx-Language/ --enable-documentation --haddock-hyperlink-source+ + git clone git@github.com:cdupont/Nomyx.git+ cabal install Nomyx/++Execution+=========++Launch with the command:++ $ Nomyx++and follow the instructions. You may connect using a web browser to the provided address.+++Troubleshooting+===============+See file TODO for known bugs.+Tested on Haskell-Platform 2012.1.0.0 and ghc 7.6.3++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
@@ -3,23 +3,19 @@ Bugs: - recurring event are making increasing memory size -- forbid void names -- import qualified Data.Map and Control.Category (or hide conflicting functions) - display bugs on MacOS (tabs, vertical size) - +- online documentation not working with cabal install --enable-documentation --haddock-hyperlink-source +- limit width collumn table +- fix facebook +- line separation code of the rule table Improvements: - make code instructions in the active rules table clickable to access haddock documentation -- option to read step by step the save file for analysis? - refresh web page when new event (currently, player needs to hit F5) -- secure interpreter with mueval: time limits, no unsafe instructions, memory limits... - add a name to events to be able to delete categories of them - use TH in addRuleParams - possibility to modify game details -- hide when no information -- cut rules too long - add examples with a game master, a castle.. -- fix facebook - vote: include new players, delete leaving players - make settings file with start up rules (?) - make/fix deployement: @@ -30,25 +26,24 @@ - HCI improvements: space player names, bold games - display viewer list - import qualified uploads (?) -- 15 characters max for names -- add a space before buttons (in HTML) - some files are accepted when uploaded but cause the game to crash when restarting. Check with GATDs for example. - display vote infos (modalities, date etc.) - parameterize the mail sender -- Short description field is too small - variable creation: use the definition (V...) ? - put a scroll on long IOs -- put settings at session level, not multi level - a way to overwrite uploads (automatically or with admin intervention) - tag the save file with the version +- use a test suite instead of ad-hoc tests +- add a game number +- login with guest account +- clean after testing +- use deepseq + Futur Nomic: - ability to analyse rules, proof system - first pass of compilation to check reference (avoid calls to non-existant variables for ex.) -- more stateless language - interpreter (like tryhaskell.org) on the web page to debug rules - make a command line client -Forum: -- start another VM to run Nomyx alone
− data/static/css/nomyx.css
@@ -1,283 +0,0 @@-h3{- color:#04B404;-}--#multi {- top:40px;- vertical-align:middle;--}---#gameList {- position:absolute;- background-color:#F4F4F4;- border:1px solid black;- width:250px;- padding:10px;- top:60px;- left:15px;- overflow: auto;-}--#game {- position:absolute;- background-color:#FFFFFF;- height:90%;- top:57px;- left:295px;- right:14px;- padding-right:20px;- overflow: auto;-}--#gameElem {- position:absolute;- height:90%;- top:20px;- left:250px;- right:20px;- /**/-}--/*-#IORuleTitle {- position:relative;- top:-30px;- background-color:#F4F4F4;-- height:20px;-}*/--#IORule {- border:1px dotted black;- padding:10px;- padding-bottom:0px;- padding-top:0px;- margin-bottom:10px;- display : block;-}--.table {- border:2px solid black;- border-collapse:collapse;- padding:6px;-}--.td {- border:1px solid black;- padding:6px;-}--pre {- white-space: pre-wrap; /* css-3 */- white-space: -moz-pre-wrap; /* Mozilla, since 1999 */- white-space: -pre-wrap; /* Opera 4-6 */- white-space: -o-pre-wrap; /* Opera 7 */- word-wrap: break-word; /* Internet Explorer 5.5+ */-}--thead {- font-weight:bold- }--#victory {- float:left;- margin-left:5%;- padding:10px;-}--#ios, #details, #rules, #newRule, #gameDesc {- float:left;- background-color:#F4F4F4;- border:1px solid black;- padding-left:10px;- padding-right:10px;- width:100%;- margin-bottom:5px;-}--#showCodeLink {- text-align:right;-}--#gameName {- padding-right: 10px;-}--/* #eventsBody {- display:none;-}*/--#header {- border-top:1px solid silver;- border-bottom:1px solid silver;- margin-top:10px;- margin-bottom:10px;- color:gray;- padding-top:10px;- padding-bottom:5px;- background-color:#F4F4F4;- top:0;- position:relative;- width:100%;-}--#footer {- border-top:1px solid silver;- border-bottom:1px solid silver;- margin-top:10px;- margin-bottom:10px;- color:gray;- padding-top:10px;- padding-bottom:5px;- background-color:#F4F4F4;- bottom:0;- position:absolute;- width:100%;-}---.code {- width:100%;- /* 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;-}--.modalButton {- background: #606061;- color: #FFFFFF;- line-height: 25px;- text-align: center;- text-decoration: none;- font-weight: bold;- -webkit-border-radius: 2px;- -moz-border-radius: 2px;- border-radius: 2px;- -moz-box-shadow: 1px 1px 3px #000;- -webkit-box-shadow: 1px 1px 3px #000;- box-shadow: 1px 1px 3px #000;- width:80px;- float:right;- margin-left:20px;--}- -.modalWindow:target {- opacity:1;- pointer-events: auto;-}-.modalWindow > div {-- width: 500px;- position: relative;- margin: 10% auto;- -webkit-border-radius: 5px;- -moz-border-radius: 5px;- border-radius: 5px;- background: #fff;- padding-left:20px; - padding-right:10px;- padding-top:5px;- padding-bottom:1px;- max-height: 70%;- }--#InputForm {- display:inline;-}--#modalCode {- overflow: auto;- height: 60%;-}--pre {- -moz-tab-size: 16;- -o-tab-size: 16;- -webkit-tab-size: 16;- -ms-tab-size: 16;- tab-size: 16;-}
− data/static/nomyx.js
@@ -1,15 +0,0 @@-function toggle_visibility(id_events, id_show) -{ - var events = document.getElementById(id_events);- var show = document.getElementById(id_show);- if (show.innerHTML == '[Click to show]') - {- events.style.display = 'block'; - show.innerHTML = '[Click to hide]';- }- else - {- events.style.display = 'none'; - show.innerHTML ='[Click to show]';- }-}
− data/static/pictures/help.jpg
binary file changed (725 → absent bytes)
− src/Interpret.hs
@@ -1,99 +0,0 @@--- | This module starts a Interpreter server that will read our strings representing rules to convert them to plain Rules. -module Interpret where - -import Language.Haskell.Interpreter -import Language.Haskell.Interpreter.Server -import Language.Nomyx -import System.Directory-import System.FilePath-import Control.Exception as CE-import Data.Either.Unwrap-import Utils-import Data.List-import Control.Monad--importList = ["Prelude",- "Language.Nomyx",- "Language.Nomyx.Examples",- "GHC.Base",- "Data.Maybe",- "Data.List",- "Control.Monad.State",- "Control.Applicative",- "Control.Monad.Error",- --"Data.Map",- "Safe",- "Data.Typeable",- --"Control.Category",- "Data.Lens",- "Control.Arrow"]- --- | the server handle -startInterpreter :: FilePath -> IO ServerHandle -startInterpreter saveDir = do - sh <- start- liftIO $ createDirectoryIfMissing True $ saveDir </> uploadDir - ir <- runIn sh $ initializeInterpreter saveDir - case ir of - Right r -> do - putStrLn "Interpreter Loaded" - return $ Just r - Left e -> error $ "sHandle: initialization error:\n" ++ show e - return sh ---- get all uploaded modules from the directory (may be empty)-getUploadModules :: FilePath -> IO([FilePath])-getUploadModules saveDir = do- files <- getUploadedModules saveDir- return $ map (\f -> joinPath [saveDir, uploadDir, f]) files-- --- | initializes the interpreter by loading some modules. -initializeInterpreter :: FilePath -> Interpreter () -initializeInterpreter saveDir = do - fmods <- liftIO $ getUploadModules saveDir- liftIO $ putStrLn $ "Loading modules: " ++ (concat $ intersperse ", " fmods)- loadModules fmods- setTopLevelModules $ map (dropExtension . takeFileName) fmods- set [searchPath := [saveDir], languageExtensions := [GADTs, ScopedTypeVariables]] --, installedModulesInScope := False- setImports importList- return () - ----- | reads maybe a Rule out of a string. -interpretRule :: String -> ServerHandle -> IO (Either InterpreterError 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---- | check an uploaded file and reload -loadModule :: FilePath -> FilePath -> ServerHandle -> FilePath -> IO (Either InterpreterError ()) -loadModule tempModName name sh saveDir = do- --copy the new module in the upload directory- let dest = (saveDir </> uploadDir </> name)- copyFile tempModName dest- setMode dest- inter <- runIn sh $ initializeInterpreter saveDir- res <- case inter of- Right _ -> return $ Right () - Left e -> do- --suppress the faulty module- removeFile dest- final <- runIn sh $ initializeInterpreter saveDir- when (isLeft final) $ putStrLn "Error: reinitialize interpreter failed"- return $ Left e- return res---showInterpreterError :: InterpreterError -> String-showInterpreterError (UnknownError s) = "Unknown Error\n" ++ s-showInterpreterError (WontCompile ers) = "Won't Compile\n" ++ concatMap (\(GhcError errMsg) -> errMsg ++ "\n") ers-showInterpreterError (NotAllowed s) = "Not Allowed (Probable cause: bad module or file name)\n" ++ s-showInterpreterError (GhcException s) = "Ghc Exception\n" ++ s--
− src/Mail.hs
@@ -1,89 +0,0 @@-{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules, OverloadedStrings, NamedFieldPuns#-}---module Mail where--import Text.Blaze.Html5 hiding (map, label, br)-import qualified Text.Blaze.Html5 as H-import Text.Blaze.Html.Renderer.String-import Network.Mail.Mime hiding (mailTo)-import Prelude hiding (div, (.))-import Text.Reform.Happstack()-import Control.Monad-import Types-import Language.Nomyx-import Language.Nomyx.Engine-import Data.Text(Text, pack)-import Control.Concurrent-import Data.Maybe-import Utils-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 Control.Applicative ((<$>))-import Safe-import Data.List-default (Integer, Double, Data.Text.Text)---sendMail :: String -> String -> String -> String-> IO()-sendMail to object htmlBody textBody = do- putStrLn $ "sending a mail to " ++ to- forkIO $ simpleMail (Address Nothing (pack to))- (Address (Just "Nomyx Game") "kau@nomyx.net")- (pack object)- (B.pack htmlBody)- (B.pack textBody)- [] >>= renderSendMail- putStrLn $ "done"---newRuleHtmlBody :: PlayerName -> SubmitRule -> PlayerName -> Network -> Html-newRuleHtmlBody playerName (SubmitRule name desc code) prop net = docTypeHtml $ do- (toHtml $ "Dear " ++ playerName ++ ",") >> H.br- (toHtml $ "a new rule has been proposed by player " ++ prop ++ ".") >> H.br- (toHtml $ "Name: " ++ name) >> H.br- (toHtml $ "Description: " ++ desc) >> 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--newRuleTextBody :: PlayerName -> SubmitRule -> PlayerName -> Network -> String-newRuleTextBody playerName (SubmitRule name desc code) prop net =- "Dear " ++ playerName ++ ",\n" ++- "a new rule has been proposed by player " ++ prop ++ ".\n" ++- "Name: " ++ name ++ "\n" ++- "Description: " ++ desc ++ "\n" ++- "Code: \n" ++ code ++ "\n\n" ++- "Please login into Nomyx for actions on this rule:\n" ++- nomyxURL net ++ "/Nomyx\n\n" ++- "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.\n"---newRuleObject :: PlayerName -> String-newRuleObject name = "[Nomyx] New rule posted by player " ++ name ++ "!"--sendMailsNewRule :: Session -> SubmitRule -> PlayerNumber -> IO ()-sendMailsNewRule s sr pn = when (_sendMails $ _mSettings $ _multi s) $ do- putStrLn "Sending mails"- gn <- fromJustNote "sendMailsNewRule" <$> getPlayersGame pn s- let sendMailsTo = delete pn (map _playerNumber (_players $ _game gn))- proposer <- Utils.getPlayerName pn s- profiles <- mapM (getProfile s) sendMailsTo- mapM_ (send proposer (_net $ _mSettings $ _multi s) sr) (_pPlayerSettings <$> catMaybes profiles)---send :: PlayerName -> Network -> SubmitRule -> PlayerSettings -> IO()-send prop net sr set = when (_mailNewRule set)- $ sendMail (_mail set)- (newRuleObject prop)- (newRuleTextBody (_pPlayerName set) sr prop net)- (renderHtml $ newRuleHtmlBody (_pPlayerName set) sr prop net)- -mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] -mapMaybeM f = liftM catMaybes . mapM f--
src/Main.hs view
@@ -11,41 +11,42 @@ -- | -- ----------------------------------------------------------------------------- -{-# LANGUAGE GADTs, DoAndIfThenElse, ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE ScopedTypeVariables #-} module Main (main) where import Prelude hiding ((.)) import System.Console.GetOpt import System.Environment -import Web.MainPage import Control.Concurrent-import Interpret import Control.Concurrent.STM-import Control.Monad.CatchIO (bracket) import Language.Nomyx.Engine.Test as LT import Data.Maybe import Safe import Network.BSD-import Types-import Serialize import Paths_Nomyx as PN+import Paths_Nomyx_Web as PNW import Paths_Nomyx_Language as PNL import System.Directory (removeDirectoryRecursive, canonicalizePath, removeFile, doesFileExist) import Data.Time.Clock import Language.Nomyx.Engine import Control.Exception as E hiding (bracket)-import Test-import Utils import Data.Version (showVersion)-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) import Control.Monad.State+import System.Exit+import Nomyx.Web.MainPage+import Nomyx.Core.Profile+import Nomyx.Core.Session+import Nomyx.Core.Multi as Multi+import Nomyx.Core.Utils+import Nomyx.Core.Types+import Nomyx.Core.Serialize as Serialize+import Nomyx.Core.Interpret+import Nomyx.Core.Test -- | Entry point of the program.@@ -53,10 +54,10 @@ main = do args <- getArgs (flags, _) <- nomyxOpts args - if (Version `elem` flags) then do+ if Version `elem` flags then do putStrLn $ "Nomyx " ++ showVersion PN.version return True- else if (Help `elem` flags) then do+ else if Help `elem` flags then do putStrLn $ usageInfo header options return True else do@@ -67,66 +68,76 @@ start :: [Flag] -> IO () start flags = do- defDataDir <- PN.getDataDir+ defWebDir <- PNW.getDataDir defSourceDir <- PNL.getDataDir+ let defSaveDir = PN.getDataDir hostName <- getHostName let port = read $ fromMaybe "8000" (findPort flags) let host = fromMaybe hostName (findHost flags) let adminPass = fromMaybe "NXPSD" (findAdminPass flags) let sendMail = Mails `elem` flags -- save directory: Nomyx.save and uploaded files- saveDir <- case (findTarFile flags) of+ saveDir <- case findTarFile flags of Just tarFile -> untar tarFile- Nothing -> case (findSaveDir flags) of+ Nothing -> case findSaveDir flags of Just f -> canonicalizePath f- Nothing -> PN.getDataDir+ Nothing -> defSaveDir -- data directory: web ressources and profiles- let dataDir = fromMaybe defDataDir (findDataDir flags)+ let webDir = fromMaybe defWebDir (findWebDir flags) -- source directory: Nomyx-Language files (used only for display in GUI, since this library is statically linked otherwise) let sourceDir = fromMaybe defSourceDir (findSourceDir flags)- let settings = Settings (Network host port) sendMail adminPass saveDir dataDir sourceDir- if Test `elem` flags then do- sh <- protectHandlers $ startInterpreter saveDir- 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 if (DeleteSaveFile `elem` flags) then do- putStrLn "Deleting save files"- let catchExp io = io `catch` (\(e::SomeException)-> putStrLn $ show e)- catchExp $ removeDirectoryRecursive $ dataDir </> profilesDir- catchExp $ removeDirectoryRecursive $ saveDir </> uploadDir- catchExp $ removeFile $ saveDir </> saveFile- else do- serverCommandUsage- --start the haskell interpreter- sh <- protectHandlers $ startInterpreter saveDir- --creating game structures- multi <- case (findLoadTest flags) of- Just testName -> loadTestName settings testName sh- Nothing -> Main.loadMulti settings sh- --main loop- withAcid (Just $ dataDir </> profilesDir) $ \acid -> do- tvSession <- atomically $ newTVar (Session sh multi acid)- --start the web server- forkIO $ launchWebServer tvSession (Network host port)- forkIO $ launchTimeEvents tvSession- serverLoop tvSession+ let settings = Settings (Network host port) sendMail adminPass saveDir webDir sourceDir+ let mLoad = findLoadTest flags+ when (Verbose `elem` flags) $ putStrLn $ "Directories:\n" ++ "save dir = " ++ saveDir ++ "\nweb dir = " ++ webDir ++ "\nsource dir = " ++ sourceDir+ if Test `elem` flags then runTests saveDir mLoad+ else if DeleteSaveFile `elem` flags then cleanFile saveDir+ else mainLoop settings saveDir host port ++mainLoop :: Settings -> FilePath -> HostName -> Port -> IO ()+mainLoop settings saveDir host port = do+ serverCommandUsage+ --start the haskell interpreter+ sh <- protectHandlers $ startInterpreter saveDir+ --creating game structures+ multi <- Main.loadMulti settings sh+ --main loop+ withAcid (Just $ saveDir </> profilesDir) $ \acid -> do+ tvSession <- atomically $ newTVar (Session sh multi acid)+ --start the web server+ forkIO $ launchWebServer tvSession (Network host port)+ forkIO $ launchTimeEvents tvSession+ serverLoop tvSession+ loadMulti :: Settings -> ServerHandle -> IO Multi loadMulti set sh = do fileExists <- doesFileExist $ getSaveFile set- multi <- case fileExists of- True -> do- putStrLn $ "Loading game: " ++ (getSaveFile set)- Serialize.loadMulti set sh `E.catch`- (\e -> (putStrLn $ "Error while loading logged events, log file discarded\n" ++ (show (e::ErrorCall))) >> (return $ defaultMulti set))- False -> do- let defMulti = defaultMulti set- execStateT (newGame' "Default game" (GameDesc "This is the default game." "") 0 sh) defMulti- return multi+ if fileExists then do+ putStrLn $ "Loading game: " ++ getSaveFile set+ Serialize.loadMulti set sh `E.catch` (\e -> (putStrLn $ "Error while loading logged events, log file discarded\n" ++ (show (e::ErrorCall))) >> (return $ defaultMulti set))+ else do+ let defMulti = defaultMulti set+ execStateT (newGame' "Default game" (GameDesc "This is the default game." "") 0 True sh) defMulti +runTests :: FilePath -> Maybe String -> IO ()+runTests saveDir mTestName = do+ sh <- protectHandlers $ startInterpreter saveDir+ putStrLn $ "\nNomyx Language Tests results:\n" ++ concatMap (\(a,b) -> a ++ ": " ++ (show b) ++ "\n") LT.tests+ ts <- playTests saveDir sh mTestName+ putStrLn $ "\nNomyx Game Tests results:\n" ++ concatMap (\(a,b) -> a ++ ": " ++ (show b) ++ "\n") ts+ let pass = allTests && all snd ts+ putStrLn $ "All Tests Pass: " ++ show pass+ if pass then exitSuccess else exitFailure++cleanFile :: FilePath -> IO ()+cleanFile saveDir = do+ putStrLn "Deleting save files"+ let catchExp io = io `catch` (\(e::SomeException)-> print e)+ catchExp $ removeDirectoryRecursive $ saveDir </> profilesDir+ catchExp $ removeDirectoryRecursive $ saveDir </> uploadDir+ catchExp $ removeFile $ saveDir </> saveFile+ -- | a loop that will handle server commands serverLoop :: TVar Session -> IO () serverLoop ts = do@@ -134,9 +145,9 @@ case s of "d" -> do s <- atomically $ readTVar ts- putStrLn $ displayMulti $ _multi s+ print $ _multi s pfs <- getAllProfiles s- putStrLn $ show pfs+ print pfs _ -> putStrLn "command not recognized" serverLoop ts @@ -158,7 +169,7 @@ | Mails | Help | SaveDir FilePath- | DataDir FilePath+ | WebDir FilePath | SourceDir FilePath | TarFile FilePath deriving (Show, Eq) @@ -168,16 +179,16 @@ options = [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" , Option ['V'] ["version"] (NoArg Version) "show version number" - , 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 ['n'] ["delete"] (NoArg DeleteSaveFile) "delete all save files"- , Option ['l'] ["loadtest"] (ReqArg LoadTest "TestName") "specify name of test to load"+ , Option ['t'] ["tests"] (NoArg Test) "perform routine check"+ , Option ['l'] ["loadtest"] (ReqArg LoadTest "TestName") "specify name of test to load (in combination with -t i.e. -t -l \"testName\")" , Option ['a'] ["adminPass"] (ReqArg AdminPass "AdminPass") "specify the admin password (default is NXPSD)" , Option ['m'] ["mails"] (NoArg Mails) "send mails (default is no)" , Option ['?'] ["help"] (NoArg Help) "display usage options (this screen)" , Option ['r'] ["saveDir"] (ReqArg SaveDir "SaveDir") "specify save directory (for Nomyx.save and uploads)"- , Option ['f'] ["dataDir"] (ReqArg DataDir "DataDir") "specify data directory (for profiles and website files)"+ , Option ['f'] ["dataDir"] (ReqArg WebDir "WebDir") "specify data directory (for profiles and website files)" , Option ['s'] ["sourceDir"] (ReqArg SourceDir "SourceDir") "specify source directory (for Nomyx-Language files)" , Option ['T'] ["tar"] (ReqArg TarFile "TarFile") "specify tar file (containing Nomyx.save and uploads)" ] @@ -192,42 +203,42 @@ header = "Usage: Nomyx [OPTION...]" findPort :: [Flag] -> Maybe String-findPort fs = headMay $ catMaybes $ map isPort fs where+findPort fs = headMay $ mapMaybe isPort fs where isPort (Port a) = Just a isPort _ = Nothing findHost :: [Flag] -> Maybe String-findHost fs = headMay $ catMaybes $ map isHost fs where+findHost fs = headMay $ mapMaybe isHost fs where isHost (HostName a) = Just a isHost _ = Nothing findLoadTest :: [Flag] -> Maybe String-findLoadTest fs = headMay $ catMaybes $ map isLoadTest fs where+findLoadTest fs = headMay $ mapMaybe isLoadTest fs where isLoadTest (LoadTest a) = Just a isLoadTest _ = Nothing findSaveDir :: [Flag] -> Maybe FilePath-findSaveDir fs = headMay $ catMaybes $ map isSaveDir fs where+findSaveDir fs = headMay $ mapMaybe isSaveDir fs where isSaveDir (SaveDir a) = Just a isSaveDir _ = Nothing findAdminPass :: [Flag] -> Maybe String-findAdminPass fs = headMay $ catMaybes $ map isAdminPass fs where+findAdminPass fs = headMay $ mapMaybe isAdminPass fs where isAdminPass (AdminPass a) = Just a isAdminPass _ = Nothing -findDataDir :: [Flag] -> Maybe String-findDataDir fs = headMay $ catMaybes $ map isDataDir fs where- isDataDir (DataDir a) = Just a- isDataDir _ = Nothing+findWebDir :: [Flag] -> Maybe String+findWebDir fs = headMay $ mapMaybe isWebDir fs where+ isWebDir (WebDir a) = Just a+ isWebDir _ = Nothing findSourceDir :: [Flag] -> Maybe String-findSourceDir fs = headMay $ catMaybes $ map isSourceDir fs where+findSourceDir fs = headMay $ mapMaybe isSourceDir fs where isSourceDir (SourceDir a) = Just a isSourceDir _ = Nothing findTarFile :: [Flag] -> Maybe String-findTarFile fs = headMay $ catMaybes $ map isTarFile fs where+findTarFile fs = headMay $ mapMaybe isTarFile fs where isTarFile (TarFile a) = Just a isTarFile _ = Nothing @@ -239,26 +250,15 @@ atomically $ writeTVar tm (Session sh m' a) save m' - launchTimeEvents :: TVar Session -> IO() launchTimeEvents tm = do now <- getCurrentTime --putStrLn $ "tick " ++ (show now) (Session _ m _) <- atomically $ readTVar tm timeEvents <- getTimeEvents now m- when (length timeEvents /= 0) $ putStrLn "found time event(s)"+ when (not $ null timeEvents) $ putStrLn "found time event(s)" mapM_ (Main.triggerTimeEvent tm) timeEvents --sleep 1 second roughly threadDelay 1000000 launchTimeEvents tm--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
@@ -1,230 +0,0 @@-{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, ScopedTypeVariables,- MultiParamTypeClasses, TemplateHaskell, TypeFamilies, TypeOperators, TemplateHaskell, QuasiQuotes,- TypeSynonymInstances, FlexibleInstances, GADTs, NamedFieldPuns, DoAndIfThenElse, RecordWildCards #-}---- | This module manages multi-player games and commands.-module Multi where--import Prelude-import Data.List-import Control.Monad.State-import Utils-import Interpret-import Data.Time as T-import Language.Haskell.Interpreter.Server (ServerHandle)-import Data.Maybe-import Types-import Control.Applicative-import Control.Exception-import Debug.Trace.Helpers-import Data.Lens-import Language.Nomyx-import Language.Nomyx.Engine as G-import Control.Category hiding ((.))-import qualified Data.Acid.Advanced as A (update', query')-import Quotes (cr)----- | add a new player-newPlayer :: PlayerNumber -> PlayerSettings -> StateT Session IO ()-newPlayer uid ms = do- s <- get- void $ A.update' (acidProfileData $ _profiles s) (NewProfileData uid ms)---- | starts a new game-newGame :: GameName -> GameDesc -> PlayerNumber -> StateT Session IO ()-newGame name desc pn = do- sh <- access sh- focus multi $ newGame' name desc pn sh--newGame' :: GameName -> GameDesc -> PlayerNumber -> ServerHandle -> StateT Multi IO ()-newGame' name desc pn sh = 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"---- | view a game.-viewGamePlayer :: GameName -> PlayerNumber -> StateT Session IO ()-viewGamePlayer game pn = do- mg <- focus multi $ getGameByName game- case mg of- Nothing -> tracePN pn "No game by that name"- Just _ -> modifyProfile pn (pViewingGame ^= Just game)---- | 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 $ Utils.getPlayerName pn s- inGameDo game $ G.execGameEvent $ JoinGame pn name- viewGamePlayer game pn---- | del a game.delGame :: GameName -> StateT Session IO ()-delGame name = focus multi $ void $ games %= filter ((/= name) . getL (game >>> gameName))----- | leave a game.-leaveGame :: GameName -> PlayerNumber -> StateT Session IO ()-leaveGame game pn = inGameDo game $ G.execGameEvent $ LeaveGame pn---- | insert a rule in pending rules.-submitRule :: SubmitRule -> PlayerNumber -> GameName -> ServerHandle -> StateT Session IO ()-submitRule sr@(SubmitRule _ _ code) pn gn sh = do- tracePN pn $ "proposed " ++ (show sr)- mrr <- liftIO $ interpretRule code sh- case mrr of- Right _ -> do- tracePN pn $ "proposed rule compiled OK "- inGameDo gn $ G.execGameEvent' (Just $ getRuleFunc sh) (ProposeRuleEv pn sr)- modifyProfile pn (pLastRule ^= Nothing)- Left e -> do- let errorMsg = showInterpreterError e- inGameDo gn $ execGameEvent $ GLog (Just pn) ("Error in submitted rule: " ++ errorMsg)- tracePN pn ("Error in submitted rule: " ++ errorMsg)- modifyProfile pn (pLastRule ^= Just (sr, errorMsg)) -- keep in memory the last rule proposed by the player to display it in case of error--adminSubmitRule :: SubmitRule -> PlayerNumber -> GameName -> ServerHandle -> StateT Session IO ()-adminSubmitRule sr@(SubmitRule _ _ code) pn gn sh = do- tracePN pn $ "admin proposed " ++ (show sr)- mrr <- liftIO $ interpretRule code sh- case mrr of- Right _ -> do- tracePN pn $ "proposed rule compiled OK "- inGameDo gn $ execGameEvent' (Just $ getRuleFunc sh) (SystemAddRule sr)- modifyProfile pn (pLastRule ^= Nothing)- Left e -> do- let errorMsg = showInterpreterError e- inGameDo gn $ execGameEvent $ GLog (Just pn) ("Error in submitted rule: " ++ errorMsg)- tracePN pn ("Error in submitted rule: " ++ errorMsg)- modifyProfile pn (pLastRule ^= Just (sr, errorMsg))---inputResult :: PlayerNumber -> EventNumber -> UInputData -> GameName -> StateT Session IO ()-inputResult pn en ir gn = inGameDo gn $ execGameEvent $ InputResult pn en ir---- | upload a rule file-inputUpload :: PlayerNumber -> FilePath -> String -> ServerHandle -> StateT Session IO ()-inputUpload pn temp mod sh = do- saveDir <- access (multi >>> mSettings >>> saveDir)- m <- liftIO $ loadModule temp mod sh saveDir- tracePN pn $ " uploaded " ++ (show mod)- case m of- Right _ -> do- inPlayersGameDo pn $ execGameEvent $ GLog (Just pn) ("File loaded: " ++ show temp ++ ", as " ++ show mod ++"\n")- tracePN pn "upload success"- modifyProfile pn (pLastUpload ^= UploadSuccess)- Left e -> do- let errorMsg = showInterpreterError e- inPlayersGameDo pn $ execGameEvent $ GLog (Just pn) ("Error in file: " ++ show e ++ "\n")- tracePN pn "upload failed"- modifyProfile pn (pLastUpload ^= UploadFailure (temp, errorMsg))---- | update player settings-playerSettings :: PlayerSettings -> PlayerNumber -> StateT Session IO ()-playerSettings playerSettings pn = modifyProfile pn (pPlayerSettings ^= playerSettings)--playAsSetting :: (Maybe PlayerNumber) -> PlayerNumber -> StateT Session IO ()-playAsSetting mpn pn = modifyProfile pn ((pAdmin >>> pPlayAs) ^= mpn)--adminPass :: String -> PlayerNumber -> StateT Session IO ()-adminPass pass pn = do- s <- get- if (pass == (_adminPassword $ _mSettings $ _multi s)) then do- tracePN pn "getting admin rights"- modifyProfile pn $ (pAdmin >>> isAdmin) ^= True- else do- tracePN pn "submitted wrong admin password"- modifyProfile pn $ (pAdmin >>> isAdmin) ^= False--globalSettings :: Bool -> StateT Session IO ()-globalSettings mails = void $ (multi >>> mSettings >>> sendMails) ~= mails---- | Utility functions--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 -> StateT LoggedGame IO a -> StateT Session IO (Maybe a)-inPlayersGameDo pn action = do- s <- get- t <- lift $ T.getCurrentTime- mg <- lift $ getPlayersGame pn s- case mg of- Nothing -> tracePN pn "You must be in a game" >> return Nothing- Just g -> do- (a, myg) <- lift $ runStateT action (setL (game >>> currentTime) t g)- focus multi $ modifyGame myg- return (Just a)--inGameDo :: GameName -> StateT LoggedGame IO () -> StateT Session IO ()-inGameDo gn action = focus multi $ do- (gs :: [LoggedGame]) <- access games- case find ((==gn) . getL (game >>> gameName)) gs of- Nothing -> traceM "No game by that name"- 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 <- access games- gs' <- lift $ mapM (\g -> trig t g) gs- void $ games ~= gs'---trig :: UTCTime -> LoggedGame -> IO LoggedGame-trig t g = do- g' <- execWithGame' t (execGameEvent $ TimeEvent t) g- evaluate 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 $ assessOnEveryVote |]--rVictory5Rules = SubmitRule "Victory 5 accepted rules"- "Victory is achieved if you have 5 active rules"- [cr|victoryXRules 5|]--rVoteMajority = SubmitRule "Majority Vote"- "A proposed rule will be activated if a majority of players is reached, with a minimum of 2 players, and within oone day"- [cr|onRuleProposed $ voteWith_ (majority `withQuorum` 2) $ assessOnEveryVote >> assessOnTimeDelay oneMinute |]---initialGame :: ServerHandle -> StateT LoggedGame IO ()-initialGame sh = mapM_ addR [rVoteUnanimity, rVictory5Rules]- where addR r = execGameEvent' (Just $ getRuleFunc sh) (SystemAddRule r)--initialLoggedGame :: GameName -> GameDesc -> UTCTime -> ServerHandle -> IO LoggedGame-initialLoggedGame name desc date sh = do- let lg = LoggedGame (emptyGame name desc date) []- execStateT (initialGame sh) lg--displayMulti :: Multi -> String-displayMulti m = concatMap (displayGame . _game) (_games m)
− src/Quotes.hs
@@ -1,42 +0,0 @@------------------------------------------------------------------------------------ Module : Quotes--- Copyright :--- License : BSD3------ Maintainer : corentin.dupont@gmail.com--- Stability :--- Portability :------ |----------------------------------------------------------------------------------{-# LANGUAGE NamedFieldPuns, TemplateHaskell, QuasiQuotes, FlexibleInstances, GADTs #-}--module Quotes where--import Language.Haskell.TH as TH-import Language.Haskell.TH.Quote-import Language.Haskell.Interpreter hiding (get)-import Interpret---cr :: QuasiQuoter-cr = QuasiQuoter { quoteExp = quoteRuleFunc,- quotePat = undefined,- quoteType = undefined,- quoteDec = undefined}--quoteRuleFunc :: String -> Q TH.Exp-quoteRuleFunc s = do- res <- runIO $ runInterpreter $ do- setImports importList- typeOf s- case res of- Right "Nomex RuleResp" -> [| s |]- Right "RuleFunc" -> [| s |]- Right a -> fail $ "Rule doesn't typecheck: " ++ (show a)- Left e -> fail $ show e---
− src/Serialize.hs
@@ -1,36 +0,0 @@--{-# LANGUAGE NamedFieldPuns, FlexibleInstances #-}--module Serialize where--import Prelude hiding (log)-import Language.Nomyx hiding (getCurrentTime)-import Language.Nomyx.Engine-import Control.Monad.State-import Types-import Data.Lens-import Language.Haskell.Interpreter.Server-import Interpret-import Utils--save :: Multi -> IO ()-save m = writeFile (getSaveFile $ _mSettings m) (show m)--save' :: StateT Multi IO ()-save' = get >>= lift . save--load :: FilePath -> IO Multi-load fp = do- s <- readFile fp- return $ read s--loadMulti :: Settings -> ServerHandle -> IO Multi-loadMulti set sh = do- m <- load (getSaveFile set)- gs' <- mapM (updateLoggedGame $ getRuleFunc sh) $ _games m- let m' = games `setL` gs' $ m- let m'' = mSettings `setL` set $ m'- return m''--updateLoggedGame :: (RuleCode -> IO RuleFunc) -> LoggedGame -> IO LoggedGame-updateLoggedGame f (LoggedGame g log) = getLoggedGame g f log
− src/Test.hs
@@ -1,208 +0,0 @@------------------------------------------------------------------------------------ Module : Test--- Copyright :--- License : BSD3------ Maintainer : corentin.dupont@gmail.com--- Stability :--- Portability :------ |----------------------------------------------------------------------------------{-# LANGUAGE TupleSections, ScopedTypeVariables, TemplateHaskell, GADTs, QuasiQuotes #-}---- | Test module-module Test where--import Prelude-import Types-import Control.Monad.State-import Multi-import Language.Haskell.Interpreter.Server (ServerHandle)-import Language.Nomyx hiding (getCurrentTime)-import Language.Nomyx.Engine-import Control.Applicative-import Control.Exception as E-import Language.Haskell.TH-import Language.Haskell.TH.Syntax as THS hiding (lift)-import System.IO.Unsafe-import Quotes-import Data.Lens-import Data.List-import Safe-import Data.Acid.Memory-import Happstack.Auth.Core.Auth (initialAuthState)-import Happstack.Auth.Core.Profile (initialProfileState)-import qualified Language.Nomyx.Engine 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---- | 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--test :: ServerHandle -> StateT Session IO () -> (Multi -> Bool) -> IO Bool-test sh tes cond = do- tp <- testProfiles- let s = Session sh (defaultMulti (Settings defaultNetwork False "" "" "" "")) tp- m' <- loadTest tes s- (evaluate $ cond m') `E.catch` (\(e::SomeException) -> (putStrLn $ "Exception in test: " ++ show e) >> return False)---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 :: Settings -> String -> ServerHandle -> IO Multi-loadTestName set testName sh = do- let mt = find (\(name, _, _) -> name == testName) tests- tp <- testProfiles- let s = Session sh (defaultMulti set) tp- case mt of- 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 :: StateT Session IO ()-onePlayerOneGame = do- newPlayer 1 (PlayerSettings {_pPlayerName = "Player 1", _mail = "", _mailNewInput = False, _mailNewRule = False, _mailNewOutput = False, _mailConfirmed = False})- newGame "test" (GameDesc "" "") 1- joinGame "test" 1- viewGamePlayer "test" 1--twoPlayersOneGame :: StateT Session IO ()-twoPlayersOneGame = do- onePlayerOneGame- newPlayer 2 (PlayerSettings {_pPlayerName = "Player 2", _mail = "", _mailNewInput = False, _mailNewRule = False, _mailNewOutput = False, _mailConfirmed = False})- joinGame "test" 2- viewGamePlayer "test" 2--submitR :: String -> StateT Session IO ()-submitR r = do- onePlayerOneGame- sh <- access sh- submitRule (SubmitRule "" "" r) 1 "test" sh- inputResult 1 3 (URadioData 0) "test"--gameHelloWorld :: StateT Session IO ()-gameHelloWorld = submitR [cr|helloWorld|]--condHelloWorld :: Multi -> Bool-condHelloWorld m = isOutput "hello, world!" m--gameHelloWorld2Players :: StateT Session IO ()-gameHelloWorld2Players = do- twoPlayersOneGame- sh <- access sh- submitRule (SubmitRule "" "" [cr|helloWorld|]) 1 "test" sh- inputResult 1 3 (URadioData 0) "test"- inputResult 2 4 (URadioData 0) "test"--condHelloWorld2Players :: Multi -> Bool-condHelloWorld2Players m = isOutput "hello, world!" m--partialFunction1 :: String-partialFunction1 = [cr|voidRule $ readMsgVar_ (msgVar "toto1" :: MsgVar String)|]--gamePartialFunction1 :: StateT Session IO ()-gamePartialFunction1 = submitR partialFunction1---- rule has not been accepted due to exception-condPartialFunction1 :: Multi -> Bool-condPartialFunction1 m = (_rStatus $ head $ _rules $ G._game $ head $ _games m) == Active &&- (take 5 $ _lMsg $ head $ _logs $ G._game $ head $ _games m) == "Error"--partialFunction2 :: String-partialFunction2 = [cr|voidRule $ do- t <- getCurrentTime- onEventOnce_ (Time $ addUTCTime 5 t) $ const $ readMsgVar_ (msgVar "toto2")|]--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 $ headNote "cond1 failed" $ _rules $ G._game $ headNote "cond2 failed" $ _games m) == Active &&- (take 5 $ _lMsg $ headNote "cond3 failed" $ _logs $ G._game $ headNote "cond4 failed" $ _games m) == "Error"--partialFunction3 :: String-partialFunction3 = [cr|voidRule $ onEvent_ (RuleEv Proposed) $ const $ readMsgVar_ (msgVar "toto3")|]--gamePartialFunction3 :: StateT Session IO ()-gamePartialFunction3 = do- submitR partialFunction3- submitR [cr|nothing|]---- rule has been accepted and also next one-condPartialFunction3 :: Multi -> Bool-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 :: StateT Session IO ()-gameMoneyTransfer = do- sh <- access sh- twoPlayersOneGame- submitRule (SubmitRule "" "" [cr|createBankAccount|]) 1 "test" sh- submitRule (SubmitRule "" "" [cr|winXEcuOnRuleAccepted 100|]) 1 "test" sh- submitRule (SubmitRule "" "" [cr|moneyTransfer|]) 2 "test" sh- inputResult 1 4 (URadioData 0) "test"- inputResult 2 3 (URadioData 0) "test"- inputResult 1 9 (URadioData 0) "test"- inputResult 2 8 (URadioData 0) "test"- inputResult 1 14 (URadioData 0) "test"- inputResult 2 13 (URadioData 0) "test"- inputResult 1 5 (URadioData 0) "test"- inputResult 1 0 (UTextData "50") "test"--TODO find event number--condMoneyTransfer :: Multi -> Bool-condMoneyTransfer m = (_vName $ head $ _variables $ G._game $ head $ _games m) == "Accounts"-----voidRule $ let a = a + 1 in outputAll (show a)--isOutput :: String -> Multi -> Bool-isOutput s g = any (\g -> any (\(Output _ _ _ mys SActive) -> mys == s) (_outputs $ G._game g)) (_games g)
− src/Types.hs
@@ -1,161 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances, TypeFamilies,- NamedFieldPuns, TemplateHaskell, FlexibleContexts, RecordWildCards, GeneralizedNewtypeDeriving #-}--module Types where-import Language.Nomyx-import Language.Nomyx.Engine-import Data.Typeable-import Text.Reform.Happstack()-import Network.BSD-import Data.Lens.Template-import Language.Haskell.Interpreter.Server (ServerHandle)-import Data.Acid (makeAcidic, Update, Query, AcidState)-import Happstack.Auth (ProfileState, AuthState)-import Data.Data (Data)-import Data.IxSet (toList, (@=), 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(..))-import Safe--type PlayerPassword = String-type Port = Int-type CompileError = String-type LastRule = (SubmitRule, CompileError)---data LastUpload = NoUpload- | UploadSuccess- | UploadFailure (FilePath, CompileError)- deriving (Eq, Ord, Read, Show, Typeable, Data)-$(deriveSafeCopy 1 'base ''LastUpload)--data Network = Network {_host :: HostName, _port :: Port}- deriving (Eq, Show, Read, Typeable)-defaultNetwork = Network "" 0--data PlayerSettings =- PlayerSettings { _pPlayerName :: PlayerName,- _mail :: String,- _mailNewInput :: Bool,- _mailNewRule :: Bool,- _mailNewOutput :: Bool,- _mailConfirmed :: Bool}- deriving (Eq, Show, Read, Data, Ord, Typeable)-$(deriveSafeCopy 1 'base ''PlayerSettings)---data Settings = Settings { _net :: Network, -- URL where the server is launched- _sendMails :: Bool, -- send mails or not- _adminPassword :: String, -- admin password- _saveDir :: FilePath, -- location of the save file and uploaded files- _dataDir :: FilePath, -- location of the static files (profiles + website)- _sourceDir :: FilePath} -- location of the language files (from Nomyx-Language)- deriving (Eq, Show, Read, Typeable)----- | A structure to hold the active games and players-data Multi = Multi { _games :: [LoggedGame],- _mSettings :: Settings}- deriving (Eq, Read, Show, Typeable)--data Admin = Admin { _isAdmin :: Bool,- _pPlayAs :: Maybe PlayerNumber}- deriving (Eq, Show, Read, Ord, Typeable, Data)-$(deriveSafeCopy 1 'base ''Admin)--defaultAdmin :: Admin-defaultAdmin = Admin False Nothing---- | 'ProfileData' contains application specific-data ProfileData =- ProfileData { _pPlayerNumber :: PlayerNumber, -- ^ same as UserId- _pPlayerSettings :: PlayerSettings,- _pViewingGame :: Maybe GameName,- _pLastRule :: Maybe LastRule,- _pLastUpload :: LastUpload,- _pAdmin :: Admin}- deriving (Eq, Ord, Read, Show, Typeable, Data)-$(deriveSafeCopy 1 'base ''ProfileData)-$(deriveSafeCopy 1 'base ''SubmitRule)--$(inferIxSet "ProfilesData" ''ProfileData 'noCalcs [''PlayerNumber]) -- , ''Text--data ProfileDataState =- ProfileDataState { profilesData :: ProfilesData }- deriving (Eq, Ord, Read, Show, Typeable, Data)-$(deriveSafeCopy 1 'base ''ProfileDataState)----- | 'Acid' holds all the 'AcidState' handles for this site.-data Profiles = Profiles- { acidAuth :: AcidState AuthState,- acidProfile :: AcidState ProfileState,- acidProfileData :: AcidState ProfileDataState}--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----- | get 'ProfileData' associated with 'UserId'-askProfileData :: PlayerNumber -> Query ProfileDataState (Maybe ProfileData)-askProfileData uid = do- ProfileDataState{..} <- ask- let pfs = toList profilesData- let filtered = filter (\a -> _pPlayerNumber a == uid) pfs- return $ headMay filtered- --return $ getOne $ profilesData @= uid---- | create the profile data, but only if it is missing-newProfileData :: PlayerNumber -> PlayerSettings -> Update ProfileDataState ProfileData-newProfileData uid ps =- do pds@(ProfileDataState {..}) <- get- case IxSet.getOne (profilesData @= uid) of- Nothing -> do let profileData = ProfileData uid ps Nothing Nothing NoUpload defaultAdmin- put $ pds { profilesData = IxSet.updateIx uid profileData profilesData }- return profileData- (Just profileData) -> return profileData---- | get number of-askProfileDataNumber :: Query ProfileDataState Int-askProfileDataNumber =- do pds <- ask- tracePN 1 (show $ profilesData pds)- return $ IxSet.size $ profilesData pds---- | get all profiles-askProfilesData :: Query ProfileDataState [ProfileData]-askProfilesData =- do pds <- ask- return $ toList $ profilesData pds--$(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, ''Admin] )--
− src/Utils.hs
@@ -1,176 +0,0 @@------------------------------------------------------------------------------ --- --- Module : Utils --- Copyright : --- License : AllRightsReserved --- --- Maintainer : --- Stability : --- Portability : --- --- | --- ------------------------------------------------------------------------------ --{-# LANGUAGE NamedFieldPuns #-}-{-# OPTIONS -cpp #-} -module Utils where - -import Data.Maybe -import Control.Monad.State-import Types-import Language.Nomyx-import Language.Nomyx.Engine-import Data.Lens-import Control.Category hiding ((.), id)-import Safe-import Control.Concurrent.STM-import qualified Data.Acid.Advanced as A (query', update')-import System.IO.Temp-import Codec.Archive.Tar as Tar-import System.Directory-import System.FilePath-import Control.Monad.CatchIO-import Data.Time-import Data.List-import System.PosixCompat.Files (getFileStatus, isRegularFile, setFileMode, ownerModes, groupModes)-#ifndef WINDOWS-import qualified System.Posix.Signals as S-#endif--saveFile, profilesDir, uploadDir, tarFile :: FilePath-saveFile = "Nomyx.save"-profilesDir = "profiles"-uploadDir = "uploads"-tarFile = "Nomyx.tar"- --- | 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) ---- | generic function to say things on transformers like GameState, ServerState etc.-say :: String -> StateT a IO () -say = lift . putStrLn--nomyxURL :: Network -> String-nomyxURL (Network host port) = "http://" ++ host ++ ":" ++ (show port)--getPlayerName :: PlayerNumber -> Session -> IO PlayerName-getPlayerName pn s = do- pfd <- A.query' (acidProfileData $ _profiles s) (AskProfileData pn)- return $ _pPlayerName $ _pPlayerSettings $ fromJustNote ("getPlayersName: no profile for pn=" ++ (show pn)) pfd--getPlayerInGameName :: Game -> PlayerNumber -> PlayerName-getPlayerInGameName g pn = do- case find ((==pn) . getL playerNumber) (_players g) of- Nothing -> error "getPlayersName': No player by that number in that game"- Just pm -> _playerName pm---- | returns the game the player is in-getPlayersGame :: PlayerNumber -> Session -> IO (Maybe LoggedGame)-getPlayersGame pn s = do- pfd <- A.query' (acidProfileData $ _profiles s) (AskProfileData pn)- let mgn = _pViewingGame $ fromJustNote "getPlayersGame" pfd- return $ do- gn <- mgn- find ((== gn) . getL (game >>> gameName)) (_games $ _multi s) --checks if any game by that name exists--getAllProfiles :: Session -> IO [ProfileData]-getAllProfiles s = A.query' (acidProfileData $ _profiles s) AskProfilesData---getPlayer :: Game -> PlayerNumber -> Maybe PlayerInfo-getPlayer g pn = find ((==pn) . getL playerNumber) (_players g)---- | finds the corresponding game in the multistate and replaces it.-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 lg gs- games ~= newgs- return ()--execWithMulti :: UTCTime -> StateT Multi IO () -> Multi -> IO Multi-execWithMulti t ms m = do- 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)- when (isJust pfd) $ void $ A.update' (acidProfileData $ _profiles s) (SetProfileData (mod $ fromJust pfd))--getProfile :: MonadIO m => Session -> PlayerNumber -> m (Maybe ProfileData)-getProfile s pn = A.query' (acidProfileData $ _profiles s) (AskProfileData pn)--getProfile' :: MonadIO m => (TVar Session) -> PlayerNumber -> m (Maybe ProfileData)-getProfile' ts pn = do- s <- liftIO $ atomically $ readTVar ts- getProfile s pn--getSaveFile :: Settings -> FilePath-getSaveFile set = (_saveDir set) </> saveFile--makeTar :: FilePath -> IO ()-makeTar saveDir = do- putStrLn $ "creating tar in " ++ (show saveDir)- Tar.create (saveDir </> tarFile) saveDir [saveFile, uploadDir]--untar :: FilePath -> IO (FilePath)-untar fp = do- dir <- createTempDirectory "/tmp" "Nomyx"- extract dir fp- return dir--getUploadedModules :: FilePath -> IO [FilePath]-getUploadedModules saveDir = do- mods <- getDirectoryContents $ saveDir </> uploadDir- getRegularFiles (saveDir </> uploadDir) mods--getRegularFiles :: FilePath -> [FilePath] -> IO [FilePath]-getRegularFiles dir fps = filterM (getFileStatus . (\f -> dir </> f) >=> return . isRegularFile) $ fps--setMode :: FilePath -> IO()-setMode file = setFileMode file (ownerModes + groupModes)--#ifdef WINDOWS----no signals under windows-protectHandlers :: MonadCatchIO m => m a -> m a-protectHandlers = id--#else--helper :: MonadCatchIO m => S.Handler -> S.Signal -> m S.Handler-helper handler signal = liftIO $ S.installHandler signal handler Nothing--signals :: [S.Signal]-signals = [ S.sigQUIT- , S.sigINT- , S.sigHUP- , S.sigTERM- ]--saveHandlers :: MonadCatchIO m => m [S.Handler]-saveHandlers = liftIO $ mapM (helper S.Ignore) signals--restoreHandlers :: MonadCatchIO m => [S.Handler] -> m [S.Handler]-restoreHandlers h = liftIO . sequence $ zipWith helper h signals---protectHandlers :: MonadCatchIO m => m a -> m a-protectHandlers a = bracket saveHandlers restoreHandlers $ const a--#endif
− src/Web/Common.hs
@@ -1,263 +0,0 @@-{-# LANGUAGE TemplateHaskell, OverloadedStrings, GADTs, ScopedTypeVariables, DeriveDataTypeable,- RecordWildCards, TypeFamilies, TypeSynonymInstances, DoAndIfThenElse#-}--module Web.Common where---import Prelude hiding (div)-import Text.Blaze.Html5 hiding (map, output, base)-import Text.Blaze.Html5.Attributes hiding (dir, id)-import qualified Text.Blaze.Html5 as H-import qualified Text.Blaze.Html5.Attributes as A-import Web.Routes.PathInfo-import Web.Routes.RouteT-import Web.Routes.TH (derivePathInfo)-import Control.Monad.State-import Control.Concurrent.STM-import Language.Nomyx-import Language.Nomyx.Engine-import Happstack.Server as HS-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 Happstack.Auth (UserId(..), getUserId, AuthProfileURL)-import Serialize-import Control.Concurrent- (putMVar, tryPutMVar, killThread, threadDelay, MVar, ThreadId,- takeMVar, forkIO, newEmptyMVar)-import qualified Control.Exception as CE (catchJust)-import System.IO.Error (isUserError)-import Data.Time as T (getCurrentTime)-import System.IO (stdout, hSetBuffering)-import GHC.IO.Handle.Types (BufferMode(..))-import Control.Exception (evaluate)-import Utils-import Data.Maybe-import qualified Data.Text as DT---data NomyxError = PlayerNameRequired- | GameNameRequired- | UniqueName- | UniqueEmail- | NomyxCFE (CommonFormError [HS.Input])- deriving Show--type NomyxForm a = Form (ServerPartT IO) [HS.Input] NomyxError Html () a--default (Integer, Double, Data.Text.Text)--data LoginName = LoginName { login :: PlayerName}- deriving (Show, Eq)----- | associate a player number with a handle-data PlayerClient = PlayerClient PlayerNumber deriving (Eq, Show)---- | A structure to hold the active games and players-data Server = Server [PlayerClient] deriving (Eq, Show)---data PlayerCommand = HomePage- | U_AuthProfile AuthProfileURL- | PostAuth- | MainPage- | ViewGame GameName- | JoinGame GameName- | LeaveGame GameName- | DelGame GameName- | DoInput EventNumber GameName- | NewRule GameName- | NewGame- | SubmitNewGame- | Upload- | PlayerSettings- | SubmitPlayerSettings- | Advanced- | SubmitPlayAs- | SubmitAdminPass- | SubmitSettings- deriving (Show)---type RoutedNomyxServer a = RouteT PlayerCommand (ServerPartT IO) a--$(derivePathInfo ''PlayerCommand)-$(derivePathInfo ''LoginName)--instance PathInfo Bool where- toPathSegments i = [pack $ show i]- fromPathSegments = pToken (const "bool") (checkBool . show)- where checkBool str =- case reads str of- [(n,[])] -> Just n- _ -> Nothing--evalCommand :: (TVar Session) -> StateT Session IO a -> RoutedNomyxServer a-evalCommand ts sm = liftIO $ do- s <- atomically $ readTVar ts- evalStateT sm s--webCommand :: (TVar Session) -> StateT Session IO () -> RoutedNomyxServer ()-webCommand ts sm = liftIO $ do- s <- atomically $ readTVar ts- s' <- execStateT sm s- atomically $ writeTVar ts s'- save (_multi s') --TODO not really nice to put that here---webCommand' :: (TVar Session) -> StateT Session IO () -> RoutedNomyxServer ()-webCommand' ts sm = liftIO $ do- s <- atomically $ readTVar ts- s' <- execStateT sm s- atomically $ writeTVar ts s'- save (_multi s') --TODO not really nice to put that here---protectedExecCommand :: (TVar Session) -> StateT Session IO a -> IO ()-protectedExecCommand ts ss = do- mv <- newEmptyMVar- before <- atomically $ readTVar ts- id <- forkIO $ CE.catchJust (\e -> if isUserError e then Just () else Nothing) (execBlocking ss before mv) (\e-> putStrLn $ show e)- forkIO $ watchDog' 10 id mv- T.getCurrentTime >>= (\a -> putStrLn $ "before takevar " ++ show a)- res <- takeMVar mv- case res of- Nothing -> (atomically $ writeTVar ts before) >> T.getCurrentTime >>= (\a -> putStrLn $ "writing before" ++ show a)- Just (_, after) -> (atomically $ writeTVar ts after) >> T.getCurrentTime >>= (\a -> putStrLn $ "writing after " ++ show a)--watchDog' :: Int -> ThreadId -> MVar (Maybe x) -> IO ()-watchDog' t tid mv = do- threadDelay $ t * 1000000- killThread tid- T.getCurrentTime >>= (\a -> putStrLn $ "process timeout " ++ show a)- tryPutMVar mv Nothing- return ()--execBlocking :: StateT Session IO a -> Session -> MVar (Maybe (a, Session)) -> IO ()-execBlocking ss s mv = do- hSetBuffering stdout NoBuffering- T.getCurrentTime >>= (\a -> putStrLn $ "before runstate " ++ show a)- res <- runStateT ss s --runStateT (inPlayersGameDo 1 $ liftT $ evalExp (do let (a::Int) = a in outputAll $ show a) 1) m --- T.getCurrentTime >>= (\a -> putStrLn $ "after runstate " ++ show a)- res' <- evaluate res- putMVar mv (Just res')---blazeResponse :: Html -> Response-blazeResponse html = toResponseBS (C.pack "text/html;charset=UTF-8") $ renderHtml html--blazeForm :: Html -> Text -> Html-blazeForm html link =- H.form ! A.action (toValue link)- ! A.method "POST"- ! A.enctype "multipart/form-data" $- do html- input ! A.type_ "submit" ! A.value "Submit"---- | Create a group of radio elements without BR between elements-inputRadio' :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, ToMarkup lbl) =>- [(a, lbl)] -- ^ value, label, initially checked- -> (a -> Bool) -- ^ isDefault- -> Form m input error Html () a-inputRadio' choices isDefault =- G.inputChoice isDefault choices mkRadios- where- mkRadios nm choices' = mconcat $ concatMap (mkRadio nm) choices'- mkRadio nm (i, val, lbl, checked) =- [ ((if checked then (! A.checked "checked") else id) $- input ! A.type_ "radio" ! A.id (toValue i) ! A.name (toValue nm) ! A.value (toValue val))- , " ", H.label ! A.for (toValue i) $ toHtml lbl]--mainPage' :: String -> Html -> Html -> Bool -> RoutedNomyxServer Response-mainPage' title header body footer = do- html <- mainPage title header body footer False- return $ toResponse html--mainPage :: String -> Html -> Html -> Bool -> Bool -> RoutedNomyxServer Html-mainPage title header body footer backLink = do- link <- showURL MainPage- if backLink then ok $ appTemplate' title header body footer (Just $ DT.unpack link)- else ok $ appTemplate' title header body footer Nothing--appTemplate' ::- String -- ^ title- -> Html -- ^ extra tags to include in \<head\>- -> Html -- ^ contents to put inside \<body\>- -> Bool -- ^ include footer- -> Maybe String -- ^ link to main page- -> Html-appTemplate' title headers body footer link = do- H.head $ do- H.title (string title)- H.link ! rel "stylesheet" ! type_ "text/css" ! href "/static/css/nomyx.css"- H.meta ! A.httpEquiv "Content-Type" ! content "text/html;charset=utf-8"- H.meta ! A.name "keywords" ! A.content "Nomyx, game, rules, Haskell, auto-reference"- H.script ! A.type_ "text/JavaScript" ! A.src "/static/nomyx.js" $ ""- H.body $ do- H.div ! A.id "container" $ do- H.div ! A.id "header" $ table ! width "100%" $ tr $ do- td $ headers- when (isJust link) $ td ! A.style "text-align:right;" $ H.a "Back to main page" ! (href $ toValue $ fromJust link)- body- when footer $ H.div ! A.id "footer" $ "Copyright Corentin Dupont 2012-2013"--appTemplate ::- ( Monad m)- => String -- ^ title- -> Html -- ^ extra tags to include in \<head\>- -> Html -- ^ contents to put inside \<body\>- -> m Response-appTemplate title headers body = do- return $ toResponse $ appTemplate' title headers body True Nothing---- | return the player number (user ID) based on the session cookie.-getPlayerNumber :: (TVar Session) -> RoutedNomyxServer PlayerNumber-getPlayerNumber ts = do- (T.Session _ _ (Profiles acidAuth acidProfile _)) <- liftIO $ readTVarIO ts- uid <- getUserId acidAuth acidProfile- case uid of- Nothing -> error "not logged in."- (Just (UserId userID)) -> return $ fromInteger userID---- return the pn to play as (by default self)-getPlayAs :: (TVar Session) -> RoutedNomyxServer PlayerNumber-getPlayAs ts = do- pn <- getPlayerNumber ts- pf <- getProfile' ts pn- case pf >>= _pPlayAs . _pAdmin of- Just playAs -> return playAs- Nothing -> return pn--getIsAdmin :: (TVar Session) -> RoutedNomyxServer Bool-getIsAdmin ts = do- pn <- getPlayerNumber ts- mpf <- getProfile' ts pn- case mpf of- Just pf -> return $ _isAdmin $ _pAdmin $ pf- Nothing -> error "not logged in."---fieldRequired :: NomyxError -> String -> Either NomyxError String-fieldRequired a [] = Left a-fieldRequired _ str = Right str--instance FormError NomyxError where- type ErrorInputType NomyxError = [HS.Input]- commonFormError = NomyxCFE--instance ToMarkup NomyxError where- toMarkup PlayerNameRequired = "Player Name is required"- toMarkup GameNameRequired = "Game Name is required"- toMarkup UniqueName = "Name already taken"- toMarkup UniqueEmail = "Email already taken"- toMarkup (NomyxCFE e) = toHtml $ e-
− src/Web/Game.hs
@@ -1,361 +0,0 @@--{-# LANGUAGE GADTs, OverloadedStrings, ExtendedDefaultRules, DoAndIfThenElse#-}--module Web.Game where--import Prelude hiding (div)-import qualified Prelude as P-import Text.Blaze.Html5 hiding (map, head)-import qualified Text.Blaze.Html5.Attributes as A-import Web.Routes.RouteT-import Text.Blaze.Internal hiding (Text)-import Control.Monad-import Control.Monad.State-import Data.Monoid-import Control.Concurrent.STM-import Language.Nomyx-import Language.Nomyx.Engine-import Data.Maybe-import Text.Reform.Happstack-import Text.Reform-import Happstack.Server hiding (Input)-import qualified Web.Help as Help-import Web.Common-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.List-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-import Data.List.Split-import Data.Typeable-import Data.Time-import System.Locale-import Data.Lens-import Control.Category hiding ((.))-import Safe-default (Integer, Double, Data.Text.Text)--viewGame :: Game -> PlayerNumber -> (Maybe LastRule) -> Bool -> RoutedNomyxServer Html-viewGame g pn mlr isAdmin = do- let inGame = isJust $ Utils.getPlayer g pn- rf <- viewRuleForm mlr inGame isAdmin (_gameName g)- vios <- viewIOs pn (_rules g) (_events g) (_outputs g) (_gameName g)- ok $ table $ do- tr $ td $ div ! A.id "gameDesc" $ viewGameDesc g pn- tr $ td $ div ! A.id "rules" $ viewAllRules g- tr $ td $ div ! A.id "ios" $ vios- tr $ td $ div ! A.id "newRule" $ rf- tr $ td $ div ! A.id "details" $ viewDetails pn g--viewGameDesc :: Game -> PlayerNumber -> Html-viewGameDesc g pn = do- p $ h3 $ string $ "Viewing game: " ++ _gameName g- p $ do- h4 $ "Description:"- string (_desc $ _gameDesc g)- p $ h4 $ "This game is discussed in the " >> a "Agora" ! (A.href $ toValue (_agora $ _gameDesc g)) >> "."- p $ h4 $ "Players in game:"- viewPlayers (_players g) pn- p $ viewVictory g--viewPlayers :: [PlayerInfo] -> PlayerNumber -> Html-viewPlayers pis pn = do- let plChunks = transpose $ chunksOf (1 + (length pis) `P.div` 3) (sort pis)- table $ mapM_ (\row -> tr $ mapM_ (viewPlayer pn) row) plChunks---viewPlayer :: PlayerNumber -> PlayerInfo -> Html-viewPlayer mypn (PlayerInfo pn name) = do- let inf = string ((show pn) ++ "\t" ++ name)- if mypn == pn- then td ! A.style "color: red;" $ inf- else td inf---viewVictory :: Game -> Html-viewVictory g = do- let vs = _playerName <$> mapMaybe (Utils.getPlayer g) (_victory g)- case vs of- [] -> br- a:[] -> h3 $ string $ "Player " ++ (show a) ++ " won the game!"- a:bs -> h3 $ string $ "Players " ++ (concat $ intersperse ", " $ bs) ++ " and " ++ a ++ " won the game!"--viewAllRules :: Game -> Html-viewAllRules g = do- titleWithHelpIcon (h3 "Rules") Help.rules- viewRules (activeRules g) "Active rules" True g >> br- viewRules (pendingRules g) "Pending rules" True g >> br- viewRules (rejectedRules g) "Suppressed rules" False g >> br--viewRules :: [Rule] -> String -> Bool -> Game -> Html-viewRules nrs title visible g = do- showHideTitle title visible (length nrs == 0) (h4 $ toHtml (title ++ ":") ) $ table ! A.class_ "table" $ do- thead $ do- td ! A.class_ "td" $ text "#"- td ! A.class_ "td" $ text "Name"- td ! A.class_ "td" $ text "Description"- td ! A.class_ "td" $ text "Proposed by"- td ! A.class_ "td" $ text "Code of the rule"- td ! A.class_ "td" $ text "Assessed by"- forM_ nrs (viewRule g)--viewRule :: Game -> Rule -> Html-viewRule g nr = tr $ do- let pl = fromMaybe ("Player " ++ (show $ _rProposedBy nr)) (_playerName <$> (Utils.getPlayer g $ _rProposedBy nr))- 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 pl- 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"- div ! A.id "modalCode"$ code--viewDetails :: PlayerNumber -> Game -> Html-viewDetails pn g = showHideTitle "Details" False False (h3 "Details") $ do- p $ titleWithHelpIcon (h4 "Variables:") Help.variables- viewVars (_variables g)- p $ titleWithHelpIcon (h4 "Events:") Help.events- viewEvents (_events g)- p $ h4 "Log:"- viewLogs (_logs g) pn---viewEvents :: [EventHandler] -> Html-viewEvents ehs = table ! 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 _ status) = if status == SActive then disp else disp ! A.style "background:gray;" where- disp = tr $ do- td ! A.class_ "td" $ string . show $ eventNumber- td ! A.class_ "td" $ string . show $ ruleNumber- td ! A.class_ "td" $ string . show $ event--viewIOs :: PlayerNumber -> [Rule] -> [EventHandler] -> [Output] -> GameName -> RoutedNomyxServer Html-viewIOs pn rs ehs os gn = do- vios <- mapM (viewIORule pn ehs os gn) (sort rs)- ok $ do- titleWithHelpIcon (h3 "Inputs/Ouputs") Help.inputsOutputs- mconcat vios--viewIORule :: PlayerNumber -> [EventHandler] -> [Output] -> GameName -> Rule -> RoutedNomyxServer Html-viewIORule pn ehs os gn r = do- vior <- viewIORuleM pn (_rNumber r) ehs os gn- ok $ when (isJust vior) $ div ! A.id "IORule" $ do- div ! A.id "IORuleTitle" $ h4 $ string $ "IO for Rule \"" ++ (_rName r) ++ "\" (#" ++ (show $ _rNumber r) ++ "):"- fromJust vior---viewIORuleM :: PlayerNumber -> RuleNumber -> [EventHandler] -> [Output] -> GameName -> RoutedNomyxServer (Maybe Html)-viewIORuleM pn rn ehs os gn = do- vir <- viewInputsRule pn rn ehs gn- let vor = viewOutputsRule pn rn os- if (isJust vir || isJust vor) then do- return $ Just $ do- when (isJust vir) $ fromJust vir- when (isJust vor) $ fromJust vor- else- return Nothing--viewInputsRule :: PlayerNumber -> RuleNumber -> [EventHandler] -> GameName -> RoutedNomyxServer (Maybe Html)-viewInputsRule pn rn ehs gn = do- let filtered = filter (\e -> _ruleNumber e == rn) ehs- mis <- mapM (viewInput pn gn) $ sort filtered- let is = catMaybes mis- case is of- [] -> return Nothing- i -> return $ Just $ table $ mconcat i--viewOutputsRule :: PlayerNumber -> RuleNumber -> [Output] -> (Maybe Html)-viewOutputsRule pn rn os = do- let filtered = filter (\o -> _oRuleNumber o == rn) os- let myos = map _output $ filter (isPn pn) (reverse filtered)- case myos of- [] -> Nothing- os -> Just $ mapM_ viewOutput os--isPn pn (Output _ _ (Just mypn) _ SActive) = mypn == pn-isPn _ (Output _ _ Nothing _ SActive) = True-isPn _ _ = False--viewInput :: PlayerNumber -> GameName -> EventHandler -> RoutedNomyxServer (Maybe Html)-viewInput me gn (EH eventNumber _ (InputEv (Input pn title iForm)) _ SActive) | me == pn = do- link <- showURL (DoInput eventNumber gn)- lf <- lift $ viewForm "user" $ inputForm iForm- return $ Just $ tr $ td $ do- string title- blazeForm lf (link) ! A.id "InputForm"-viewInput _ _ _ = return Nothing--viewOutput :: String -> Html-viewOutput s = pre $ string s >> br--viewVars :: [Var] -> Html-viewVars vs = table ! A.class_ "table" $ do- thead $ do- td ! A.class_ "td" $ text "Rule number"- td ! A.class_ "td" $ text "Name"- td ! A.class_ "td" $ text "Value"- mapM_ viewVar vs--viewVar :: Var -> Html-viewVar (Var vRuleNumber vName vData) = tr $ do- td ! A.class_ "td" $ string . show $ vRuleNumber- td ! A.class_ "td" $ string . show $ vName- td ! A.class_ "td" $ string . show $ vData---newRuleForm :: (Maybe SubmitRule) -> Bool -> NomyxForm (SubmitRule, Maybe String)-newRuleForm (Just lr) isAdmin = newRuleForm' lr isAdmin-newRuleForm Nothing isAdmin = newRuleForm' (SubmitRule "" "" "") isAdmin--newRuleForm' :: SubmitRule -> Bool -> NomyxForm (SubmitRule, Maybe String)-newRuleForm' (SubmitRule name desc code) isAdmin =- (,) <$> (SubmitRule <$> RB.label "Name: " ++> (RB.inputText name)- <*> RB.label " Short description: " ++> RB.inputText desc- <*> RB.label " Code: " ++> RB.textarea 80 15 code `RBC.setAttr` A.class_ "code" `RBC.setAttr` A.placeholder "Enter here your rule")- <*> if isAdmin then RB.inputSubmit "Admin submit" else pure Nothing---viewRuleForm :: Maybe LastRule -> Bool -> Bool -> GameName -> RoutedNomyxServer Html-viewRuleForm msr inGame isAdmin gn = do- link <- showURL (NewRule gn)- lf <- lift $ viewForm "user" (newRuleForm (fst <$> msr) isAdmin)- ok $ do- titleWithHelpIcon (h3 "Propose a new rule:") Help.code- if inGame then do- blazeForm lf (link)- let error = snd <$> msr- when (isJust error) $ do- h5 $ "Error in submitted rule: "- pre $ string $ fromJust error- else lf ! A.disabled ""--newRule :: (TVar Session) -> GameName -> RoutedNomyxServer Response-newRule ts gn = toResponse <$> do- methodM POST- s@(T.Session sh _ _) <- liftIO $ readTVarIO ts- admin <- getIsAdmin ts- r <- liftRouteT $ eitherForm environment "user" (newRuleForm Nothing admin)- link <- showURL MainPage- pn <- getPlayerNumber ts- case r of- Right (sr, Nothing) -> do- webCommand ts $ submitRule sr pn gn sh- liftIO $ do- s' <- readTVarIO ts --TODO clean this- gn <- getPlayersGame pn s- gn' <- getPlayersGame pn s'- let rs = _rules $ _game $ fromJustNote "newRule" gn- let rs' = _rules $ _game $ fromJustNote "newRule" gn'- when (length rs' > length rs) $ sendMailsNewRule s' sr pn- Right (sr, Just _) -> webCommand ts $ adminSubmitRule sr pn gn sh- (Left _) -> liftIO $ putStrLn $ "cannot retrieve form data"- seeOther link $ string "Redirecting..."--viewLogs :: [Log] -> PlayerNumber -> Html-viewLogs log pn = do- let ls = filter (\o -> (_lPlayerNumber o == Just pn) || (_lPlayerNumber o == Nothing)) log- table $ mapM_ viewLog (reverse ls)--viewLog :: Log -> Html-viewLog (Log _ t s) = do- tr $ do- td $ string $ formatTime defaultTimeLocale "%Y/%m/%d_%H:%M" t- td $ p $ string s--newInput :: (TVar Session) -> EventNumber -> GameName -> RoutedNomyxServer Response-newInput ts en gn = toResponse <$> do- pn <- getPlayerNumber ts- s <- liftIO $ atomically $ readTVar ts- let g = find ((== gn) . getL (game >>> gameName)) (_games $ _multi s)- let eventHandler = getEventHandler en (fromJust g)- methodM POST- r <- liftRouteT $ eitherForm environment "user" (getNomyxForm eventHandler)- link <- showURL MainPage- case r of- (Right c) -> do- webCommand ts $ M.inputResult pn en c gn- seeOther link $ string "Redirecting..."- (Left _) -> do- liftIO $ putStrLn $ "cannot retrieve form data"- seeOther link $ string "Redirecting..."--getNomyxForm :: EventHandler -> NomyxForm UInputData-getNomyxForm (EH _ _ (InputEv (Input _ _ iForm)) _ _) = inputForm iForm-getNomyxForm _ = error "Not an Input Event"--inputForm :: (Typeable a) => InputForm a -> NomyxForm UInputData-inputForm (Radio choices) = URadioData <$> inputRadio' (zip [0..] (snd <$> choices)) ((==) 0) <++ RB.label " "-inputForm Text = UTextData <$> RB.inputText "" <++ RB.label " "-inputForm TextArea = UTextAreaData <$> RB.textarea 50 5 "" <++ RB.label " "-inputForm Button = pure UButtonData-inputForm (Checkbox choices) = UCheckboxData <$> RB.inputCheckboxes (zip [0..] (snd <$> choices)) (const False) <++ RB.label " "--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 "[Click to hide]" else "[Click to 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..."--delGame :: (TVar Session) -> GameName -> RoutedNomyxServer Response-delGame ts gn = do- webCommand ts (M.delGame gn)- 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..."--titleWithHelpIcon :: Html -> String -> Html-titleWithHelpIcon title help = table ! A.width "100%" $ tr $ do- td ! A.style "text-align:left;" $ title- td ! A.style "text-align:right;" $ img ! A.src "/static/pictures/help.jpg" ! A.title (toValue help)
− src/Web/Help.hs
@@ -1,47 +0,0 @@------------------------------------------------------------------------------------ Module : Help--- Copyright :--- License : OtherLicense------ Maintainer : corentin.dupont@gmail.com--- Stability :--- Portability :------ |-----------------------------------------------------------------------------------module Web.Help where-upload = "In the following form you can upload your file containing custom rules. The file must be a haskell .hs file containing a module, \n" ++- "like the following example (file is named SimpleModule.hs). Once correctly loaded, the content of the file will be \"in scope\" and you will be able to propose the functions \n" ++- "contained in the file as new rules (in this example, you will be able to propose myRule).\n" ++- "Additionally, your file will appear as a link on the left hand side on the main page.\n" ++- "Warning, files uploaded here cannot be overwritten. If your uploaded file contains a mistake,\n" ++- "re-upload it with a different name (a version number suffixed for example) or ask the administrator to delete it.\n"--uploadExample = "module SimpleModule where\n" ++- "import Prelude\n" ++- "import Language.Nomyx\n" ++- "myRule :: RuleFunc\n" ++- "myRule = voidRule $ outputAll helperFunction\n" ++- "helperFunction :: String\n" ++- "helperFunction = \"Hello\"\n"--rules = "The rules are displayed here. The active rules are controlling the game. " ++- "When a player proposes a rule, it is set to pending. Only another, already active rule can activate a pending rule (with the instruction \"activateRule\")."-inputsOutputs = "The inputs and outputs triggered by the rules are displayed here.\n For example, a rules can trigger an input to gather data from the player, with the instruction \"onInputRadio\".\n" ++- "Rules can also display text message here, with the instruction \"output\"."-code = "You can type in your new rule in the box below. The text entered must have the type \"RuleFunc\" when compiled.\nAs a first rule, you can try to type \"nothing\", which is a rule that does nothing. Other examples can be found in the file Examples.hs accessible on the left tab."-events = "Rules can register on events, in order to be triggered when the event happens, for example with the instruction \"onEvent\".\n"-variables = "Variables: Rules can create variables to store data. For example, a rule creating a bank account with instruction \"newVar\" will make a new variable appear here."--view = "Only view a game. You will not be able to propose new rules."-join = "Be part of the game. You will be able to propose new rules, vote etc. Please register in the game's agora (see the link on game page) to follow the game."--getSaveFile = "With the following link, you can download the save file of the game. This allows you to load it in a local instance of the game.\n" ++- "This way, you will be able to compose and test the effects of your new rules locally, without affecting the online game. \n" ++- "The procedure is: \n" ++- "$> cabal install Nomyx-<version> \n" ++- "$> Nomyx -r <save file name>\n" ++- "Warning: Nomyx and Nomyx-Language should have the same exact version as the online instance.\n"
− src/Web/Login.hs
@@ -1,68 +0,0 @@-{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules, RecordWildCards#-}--module Web.Login where---import Prelude hiding (div)-import Text.Blaze.Html5 hiding (map, label, br)-import Text.Blaze.Html5.Attributes hiding (dir, label)-import qualified Text.Blaze.Html5 as H-import Web.Routes.RouteT-import Text.Blaze.Internal-import Control.Monad.State-import Control.Concurrent.STM-import Happstack.Server-import Types as T-import Multi as M-import Web.Common-import Web.Routes.Happstack()-import Data.Text hiding (map, zip, concatMap)-import Happstack.Auth (AuthProfileURL(..), AuthURL(..), handleAuthProfile)-import Happstack.Auth.Core.Profile-import Facebook (Credentials(..))-import Utils-default (Integer, Double, Data.Text.Text)---- | function which generates the homepage-homePage :: (TVar Session) -> RoutedNomyxServer Response-homePage ts = do- (T.Session _ _ (Profiles acidAuth acidProfile _)) <- liftIO $ readTVarIO ts- do mUserId <- getUserId acidAuth acidProfile- case mUserId of- Nothing ->- do loginURL <- showURL (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")---- | add a new player if not existing-postAuthenticate :: (TVar Session) -> RoutedNomyxServer Response-postAuthenticate ts = do- pn <- getPlayerNumber ts- pf <- getProfile' ts pn- case pf of- Just _ -> do- link <- showURL $ MainPage- seeOther link (toResponse $ string "to main page")- Nothing -> do- webCommand ts $ M.newPlayer pn defaultPlayerSettings- link <- showURL $ Web.Common.PlayerSettings- 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 PostAuth- nestURL U_AuthProfile $ handleAuthProfile acidAuth acidProfile appTemplate (Just facebookAuth) Nothing postPickedURL authProfileURL--facebookAuth =- Credentials {appName = "Nomyx",- appId = "161007670738608",- appSecret = "c0509c1c753f89d1d1fc181984042824"}
− src/Web/MainPage.hs
@@ -1,175 +0,0 @@--{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, TemplateHaskell,- EmptyDataDecls, TypeFamilies, MultiParamTypeClasses, DeriveDataTypeable, PackageImports, GADTs,- ScopedTypeVariables, NamedFieldPuns, Rank2Types, DoAndIfThenElse, StandaloneDeriving, OverloadedStrings,- ExtendedDefaultRules, RecordWildCards#-}--module Web.MainPage (launchWebServer) where--import Prelude hiding (div)-import Text.Blaze.Html5 hiding (map)-import Text.Blaze.Html5.Attributes hiding (dir)-import qualified Text.Blaze.Html5 as H-import qualified Text.Blaze.Html5.Attributes as A-import Web.Routes.Site-import Web.Routes.PathInfo-import Web.Routes.Happstack-import Web.Routes.RouteT-import Text.Blaze.Internal-import Control.Monad-import Control.Monad.State-import Data.Monoid-import Control.Concurrent.STM-import Language.Nomyx-import Language.Nomyx.Engine-import Happstack.Server as HS-import System.FilePath-import qualified Web.Help as Help-import Types as T-import Web.Game-import Web.Common as W-import Web.Settings-import Web.NewGame-import Web.Login-import Data.List-import Utils-import Data.Text(Text, pack)-import qualified Language.Nomyx.Engine as G-import Happstack.Auth-import Safe-import Paths_Nomyx_Language-default (Integer, Double, Data.Text.Text)--viewMulti :: PlayerNumber -> PlayerNumber -> FilePath -> Session -> RoutedNomyxServer Html-viewMulti pn playAs saveDir s = do- pfd <- getProfile s pn- let isAdmin = _isAdmin $ _pAdmin $ fromJustNote "viewMulti" pfd- gns <- viewGamesTab (map G._game $ _games $ _multi s) isAdmin saveDir- mgn <- liftRouteT $ lift $ getPlayersGame pn s- vg <- case mgn of- Just g -> viewGame (G._game g) playAs (_pLastRule $ fromJustNote "viewMulti" pfd) isAdmin- Nothing -> ok $ h3 "Not viewing any game"- ok $ do- div ! A.id "gameList" $ gns- div ! A.id "game" $ vg--viewGamesTab :: [Game] -> Bool -> FilePath -> RoutedNomyxServer Html-viewGamesTab gs isAdmin saveDir = do- gns <- mapM (viewGameName isAdmin) gs- newGameLink <- showURL NewGame- settingsLink <- showURL W.PlayerSettings- advLink <- showURL Advanced- logoutURL <- showURL (U_AuthProfile $ AuthURL A_Logout)- fmods <- liftIO $ getUploadedModules saveDir- ok $ do- h3 "Main menu" >> br- "Active games:" >> br- table $ do- case gs of- [] -> tr $ td "No Games"- _ -> sequence_ gns- when isAdmin $ H.a "Create a new game" ! (href $ toValue newGameLink) >> br- br >> "Help files:" >> br- H.a "Rules examples" ! (href $ "/html/Language-Nomyx-Examples.html") >> br- H.a "Nomyx language" ! (href $ "/html/Language-Nomyx.html") >> br- when (fmods /= []) $ do- br >> "Uploaded files:" >> br- mapM_ (\f -> (H.a $ toHtml f ) ! (href $ toValue (pathSeparator : uploadDir </> f)) >> br) (sort fmods)- br >> "Settings:" >> br- H.a "Player settings" ! (href $ toValue settingsLink) >> br- H.a "Advanced" ! (href $ toValue advLink) >> br- H.a "Logout" ! (href $ toValue logoutURL) >> br---viewGameName :: Bool -> Game -> RoutedNomyxServer Html-viewGameName isAdmin g = do- let gn = _gameName g- join <- showURL (W.JoinGame gn)- leave <- showURL (W.LeaveGame gn)- view <- showURL (W.ViewGame gn)- del <- showURL (W.DelGame gn)- ok $ tr $ do- td ! A.id "gameName" $ string $ (gn ++ " ")- td $ H.a "View" ! (href $ toValue view) ! (A.title $ toValue Help.view)- td $ H.a "Join" ! (href $ toValue $ "#openModalJoin" ++ gn) ! (A.title $ toValue Help.join)- td $ H.a "Leave" ! (href $ toValue $ "#openModalLeave" ++ gn)- when isAdmin $ td $ H.a "Del" ! (href $ toValue del)- div ! A.id (toValue $ "openModalJoin" ++ gn) ! A.class_ "modalWindow" $ do- div $ do- h2 "Joining the game. Please register in the Agora (see the link) and introduce yourself to the other players! \n \- If you do not wich to play, you can just view the game."- H.a "Join" ! (href $ toValue join) ! A.class_ "modalButton" ! (A.title $ toValue Help.join)- H.a "View" ! (href $ toValue view) ! A.class_ "modalButton" ! (A.title $ toValue Help.view)- div ! A.id (toValue $ "openModalLeave" ++ gn) ! A.class_ "modalWindow" $ do- div $ do- h2 "Do you really want to leave? You will loose your assets in the game (for example, your bank account)."- H.a "Leave" ! (href $ toValue leave) ! A.class_ "modalButton"- H.a "Stay" ! (href $ toValue view) ! A.class_ "modalButton"---nomyxPage :: (TVar Session) -> RoutedNomyxServer Response-nomyxPage ts = do- pn <- getPlayerNumber ts- s <- liftIO $ atomically $ readTVar ts- let saveDir = _saveDir $ _mSettings $ _multi s- name <- liftIO $ Utils.getPlayerName pn s- playAs <- getPlayAs ts- m <- viewMulti pn playAs saveDir s- let body = do- string $ "Welcome to Nomyx, " ++ name ++ "! "- when (playAs /= pn) $ (b ! A.style "color:red;" $ string ("Playing as Player #" ++ (show playAs)) )- mainPage' "Welcome to Nomyx!"- body- (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 PostAuth = postAuthenticate ts-routedNomyxCommands ts HomePage = homePage ts-routedNomyxCommands ts MainPage = nomyxPage ts-routedNomyxCommands ts (W.JoinGame game) = joinGame ts game-routedNomyxCommands ts (W.LeaveGame game) = leaveGame ts game-routedNomyxCommands ts (ViewGame game) = viewGamePlayer ts game-routedNomyxCommands ts (DelGame game) = delGame ts game-routedNomyxCommands ts (NewRule game) = newRule ts game-routedNomyxCommands _ NewGame = newGamePage-routedNomyxCommands ts SubmitNewGame = newGamePost ts-routedNomyxCommands ts (DoInput en game) = newInput ts en game-routedNomyxCommands ts Upload = newUpload ts-routedNomyxCommands ts W.PlayerSettings = playerSettings ts-routedNomyxCommands ts SubmitPlayerSettings = newPlayerSettings ts-routedNomyxCommands ts Advanced = advanced ts-routedNomyxCommands ts SubmitPlayAs = newPlayAsSettings ts-routedNomyxCommands ts SubmitAdminPass = newAdminPass ts-routedNomyxCommands ts SubmitSettings = newSettings ts--launchWebServer :: (TVar Session) -> Network -> IO ()-launchWebServer tm net = do- putStrLn $ "Starting web server...\nTo connect, drive your browser to \"" ++ nomyxURL net ++ "/Nomyx\""- simpleHTTP nullConf {HS.port = T._port net} $ server tm net----serving Nomyx web page as well as data from this package and the language library package-server :: (TVar Session) -> Network -> ServerPartT IO Response-server ts net = do- s <- liftIO $ atomically $ readTVar ts- let set = _mSettings $ _multi s- docdir <- liftIO $ getDocDir- mconcat [- serveDirectory DisableBrowsing [] (_saveDir set),- serveDirectory DisableBrowsing [] docdir,- serveDirectory DisableBrowsing [] (_dataDir set),- serveDirectory DisableBrowsing [] (_sourceDir set),- do decodeBody (defaultBodyPolicy "/tmp/" 102400 4096 4096)- html <- implSite (pack (nomyxURL net)) "/Nomyx" (nomyxSite ts)- return $ toResponse html]---getDocDir :: IO FilePath-getDocDir = do- datadir <- getDataDir- let (x:xs) = reverse $ splitDirectories datadir- return $ joinPath $ reverse $ (x:"doc":xs)
− src/Web/NewGame.hs
@@ -1,61 +0,0 @@-{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules, OverloadedStrings, NamedFieldPuns#-}---module Web.NewGame where--import Prelude hiding (div)-import Text.Reform-import Text.Blaze.Html5.Attributes hiding (label)-import Text.Reform.Blaze.String as RB hiding (form)-import qualified Text.Reform.Blaze.Common as RBC-import Text.Reform.Happstack()-import Control.Applicative-import Types-import Happstack.Server-import Text.Reform.Happstack-import Web.Common-import Control.Monad.State-import Language.Nomyx.Engine-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 GameDesc--newGameForm :: NomyxForm NewGameForm-newGameForm = pure NewGameForm <*> (br ++> errorList ++> label "Enter new game name: " ++> (RB.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 ++> (RB.inputText "") `RBC.setAttr` placeholder "Agora URL (including http://...)" `RBC.setAttr` class_ "agora" <++ br <++ br--gameNameRequired :: String -> Either NomyxError String-gameNameRequired = fieldRequired GameNameRequired--newGamePage :: RoutedNomyxServer Response-newGamePage = toResponse <$> do- newGameLink <- showURL SubmitNewGame- mf <- lift $ viewForm "user" $ newGameForm- mainPage "New game"- "New game"- (blazeForm mf newGameLink)- False- True--newGamePost :: (TVar Session) -> RoutedNomyxServer Response-newGamePost ts = toResponse <$> do- methodM POST- r <- liftRouteT $ eitherForm environment "user" newGameForm- link <- showURL MainPage- newGameLink <- showURL SubmitNewGame- pn <- getPlayerNumber ts- case r of- Left errorForm -> mainPage "New game" "New game" (blazeForm errorForm newGameLink) False True- Right (NewGameForm name desc) -> do- webCommand ts $ newGame name desc pn- seeOther link $ string "Redirecting..."
− src/Web/Settings.hs
@@ -1,272 +0,0 @@-{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules, OverloadedStrings, NamedFieldPuns#-}---module Web.Settings where--import Text.Blaze.Html5 hiding (map, label, br)--import Prelude hiding (div)-import Text.Reform-import Text.Reform.Blaze.String as RB hiding (form)-import Text.Reform.Happstack()-import Text.Blaze.Html5.Attributes as A hiding (dir, label)-import qualified Text.Blaze.Html5 as H-import Control.Applicative-import Types-import Happstack.Server-import Text.Reform.Happstack-import Web.Common-import Control.Monad.State-import Web.Routes.RouteT-import Control.Concurrent.STM-import Data.Maybe-import Data.Text(Text)-import Multi as M-import Utils-import Web.Help as Help-import Language.Nomyx-import qualified Language.Haskell.HsColour.HTML as HSC-import Language.Haskell.HsColour.Colourise hiding (string)-import Text.Blaze.Internal hiding (Text)-import Safe-import Paths_Nomyx as PN-import Paths_Nomyx_Language as PNL-import Data.Version (showVersion)-import System.FilePath-default (Integer, Double, Data.Text.Text)--playerSettingsForm :: (Maybe PlayerSettings) -> [PlayerName] -> [String] -> NomyxForm PlayerSettings-playerSettingsForm (Just prof) ns emails = playerSettingsForm' (_pPlayerName prof) (_mail prof) (_mailNewRule prof) ns emails-playerSettingsForm Nothing ns emails = playerSettingsForm' "" "" True ns emails--playerSettingsForm':: String -> String -> Bool -> [PlayerName] -> [String] -> NomyxForm PlayerSettings-playerSettingsForm' name mailTo mailNewRule names emails = pure Types.PlayerSettings- <*> errorList ++> label "Player Name: " ++> (RB.inputText name) `transformEither` (uniqueName names) `transformEither` (fieldRequired PlayerNameRequired) <++ br- <*> errorList ++> label "Please enter your mail: " ++> (RB.inputText mailTo) `transformEither` (uniqueEmail emails) <++ br- <*> pure True- <*> RB.inputCheckbox mailNewRule <++ label " I want to be notified by email when a player proposes a new rule in my game (recommended)" <++ br- <*> pure True- <*> pure True--readPlayAs :: NomyxForm Bool -> NomyxForm String -> NomyxForm (Maybe PlayerNumber)-readPlayAs = liftA2 f where- f b s = if b then (Just $ read s) else Nothing--uniqueName :: [String] -> String -> Either NomyxError String-uniqueName names name = case name `elem` names of- True -> Left UniqueName- False -> Right name--uniqueEmail :: [String] -> String -> Either NomyxError String-uniqueEmail names name = case name `elem` names of- True -> Left UniqueEmail- False -> Right name--settingsPage :: PlayerSettings -> [PlayerName] -> [String] -> RoutedNomyxServer Html-settingsPage ps names emails = do- settingsLink <- showURL SubmitPlayerSettings- mf <- lift $ viewForm "user" $ playerSettingsForm (Just ps) names emails- mainPage "Player settings"- "Player settings"- (blazeForm mf settingsLink)- False- True--playerSettings :: (TVar Session) -> RoutedNomyxServer Response-playerSettings ts = toResponse <$> do- pn <- getPlayerNumber ts- pfd <- getProfile' ts pn- names <- liftIO $ forbiddenNames ts pn- emails <- liftIO $ forbiddenEmails ts pn- settingsPage (_pPlayerSettings $ fromJustNote "playerSettings" pfd) names emails--newPlayerSettings :: (TVar Session) -> RoutedNomyxServer Response-newPlayerSettings ts = toResponse <$> do- methodM POST- pn <- getPlayerNumber ts- names <- liftIO $ forbiddenNames ts pn- emails <- liftIO $ forbiddenEmails ts pn- p <- liftRouteT $ eitherForm environment "user" $ playerSettingsForm Nothing names emails- case p of- Right ps -> do- webCommand ts $ M.playerSettings ps pn- link <- showURL MainPage- seeOther link $ string "Redirecting..."- (Left errorForm) -> do- settingsLink <- showURL SubmitPlayerSettings- mainPage "Player settings" "Player settings" (blazeForm errorForm settingsLink) False True--forbiddenNames :: (TVar Session) -> PlayerNumber -> IO [PlayerName]-forbiddenNames ts pn = liftIO $ do- session <- atomically $ readTVar ts- pfs <- getAllProfiles session- let filteredPfs = filter ((/= pn) . _pPlayerNumber) pfs- return $ (_pPlayerName . _pPlayerSettings) <$> filteredPfs--forbiddenEmails :: (TVar Session) -> PlayerNumber -> IO [PlayerName]-forbiddenEmails ts pn = liftIO $ do- session <- atomically $ readTVar ts- pfs <- getAllProfiles session- let filteredPfs = filter ((/= pn) . _pPlayerNumber) pfs- return $ filter (not . null) $ (_mail . _pPlayerSettings) <$> filteredPfs---advanced :: (TVar Session) -> RoutedNomyxServer Response-advanced ts = toResponse <$> do- session <- liftIO $ atomically $ readTVar ts- pn <- getPlayerNumber ts- pfd <- getProfile session pn- pfds <- liftIO $ getAllProfiles session- session <- liftIO $ atomically $ readTVar ts- page <- advancedPage (_pLastUpload $ fromJustNote "advanced" pfd) (_pAdmin $ fromJustNote "advanced" pfd) (_mSettings $ _multi session) pfds- mainPage "Advanced" "Advanced" page False True---advancedPage :: LastUpload -> Admin -> Settings -> [ProfileData] -> RoutedNomyxServer Html-advancedPage mlu (Admin admin mpn) settings pfds = do- uploadLink <- showURL Upload- submitAdminPass <- showURL SubmitAdminPass- submitPlayAs <- showURL SubmitPlayAs- submitSettings <- showURL SubmitSettings- up <- lift $ viewForm "user" uploadForm --TODO add the file name (missing Reform feature)- ap <- lift $ viewForm "user" $ adminPassForm- paf <- lift $ viewForm "user" $ playAsForm []- set <- lift $ viewForm "user" $ settingsForm (_sendMails settings)- liftIO $ makeTar (_saveDir settings)- ok $ do- p $ do- string $ "Versions:"- pre $ string $ "Nomyx " ++ showVersion PN.version ++ "\n" ++- "Nomyx-Language " ++ showVersion PNL.version- hr- p $ do- pre $ string Help.getSaveFile- H.a "get save file" ! (href $ toValue (pathSeparator : tarFile))- H.br- hr- p $ do- pre $ string Help.upload- preEscapedString $ HSC.hscolour defaultColourPrefs False $ Help.uploadExample- "Upload new rules file:" >> H.br- blazeForm up (uploadLink)- case mlu of- UploadFailure (_, error) -> do- h5 $ "Error in submitted file: "- pre $ string $ error- UploadSuccess -> h5 $ "File uploaded successfully!"- NoUpload -> p ""- hr- p $ do- h5 "Enter admin password to get admin rights (necessary to create a new game):"- blazeForm ap (submitAdminPass)- when admin $ h5 "You are admin"- when admin $ do- hr- p $ do- h5 "Enter the number of the player you want to play for:"- blazeForm paf submitPlayAs- when (isJust mpn) $ h5 $ string $ "Playing as player " ++ (show $ fromJust mpn)- hr- p $ do- h5 "Send mails:"- blazeForm set submitSettings- h5 $ string $ if (_sendMails settings) then "mails will be sent " else "mails will NOT be sent "- hr- p $ do- h5 "Players:"- table ! A.class_ "table" $ do- thead $ do- td ! A.class_ "td" $ "#"- td ! A.class_ "td" $ "Name"- td ! A.class_ "td" $ "mail"- td ! A.class_ "td" $ "send mails"- td ! A.class_ "td" $ "viewing game"- td ! A.class_ "td" $ "last rule"- td ! A.class_ "td" $ "last upload"- td ! A.class_ "td" $ "is admin"- td ! A.class_ "td" $ "play as"- mapM_ viewProfile pfds---viewProfile :: ProfileData -> Html-viewProfile (ProfileData pn (Types.PlayerSettings playerName mail _ mailNewRule _ _) viewingGame lastRule lastUpload (Admin isAdmin playAs)) =- tr $ do- td ! A.class_ "td" $ string $ show pn- td ! A.class_ "td" $ string playerName- td ! A.class_ "td" $ string mail- td ! A.class_ "td" $ string $ show mailNewRule- td ! A.class_ "td" $ string $ show viewingGame- td ! A.class_ "td" $ string $ show lastRule- td ! A.class_ "td" $ string $ show lastUpload- td ! A.class_ "td" $ string $ show isAdmin- td ! A.class_ "td" $ string $ show playAs---adminPassForm :: NomyxForm String-adminPassForm = RB.inputText ""--playAsForm :: [PlayerNumber] -> NomyxForm (Maybe PlayerNumber)-playAsForm _ = readPlayAs (label "Play as: " ++> RB.inputCheckbox False) (RB.inputText "")--newPlayAsSettings :: (TVar Session) -> RoutedNomyxServer Response-newPlayAsSettings ts = toResponse <$> do- methodM POST- p <- liftRouteT $ eitherForm environment "user" $ playAsForm []- pn <- getPlayerNumber ts- case p of- Right ps -> do- webCommand ts $ playAsSetting ps pn- link <- showURL Advanced- seeOther link $ string "Redirecting..."- (Left errorForm) -> do- settingsLink <- showURL SubmitPlayAs- mainPage "Admin settings" "Admin settings" (blazeForm errorForm settingsLink) False True---settingsForm :: Bool -> NomyxForm Bool-settingsForm sendMails = label "Send mails: " ++> RB.inputCheckbox sendMails--newSettings :: (TVar Session) -> RoutedNomyxServer Response-newSettings ts = toResponse <$> do- methodM POST- p <- liftRouteT $ eitherForm environment "user" $ settingsForm False- case p of- Right ps -> do- webCommand ts $ globalSettings ps- link <- showURL Advanced- seeOther link $ string "Redirecting..."- (Left errorForm) -> do- settingsLink <- showURL SubmitSettings- mainPage "Admin settings" "Admin settings" (blazeForm errorForm settingsLink) False True---uploadForm :: NomyxForm (FilePath, FilePath, ContentType)-uploadForm = RB.inputFile--newUpload :: (TVar Session) -> RoutedNomyxServer Response-newUpload ts = toResponse <$> do- methodM POST- pn <- getPlayerNumber ts- r <- liftRouteT $ eitherForm environment "user" uploadForm- link <- showURL Advanced- (Types.Session sh _ _) <- liftIO $ readTVarIO ts- case r of- (Right (temp,name,_)) -> webCommand ts $ M.inputUpload pn temp name sh- (Left _) -> liftIO $ putStrLn $ "cannot retrieve form data"- seeOther link $ string "Redirecting..."--newAdminPass :: (TVar Session) -> RoutedNomyxServer Response-newAdminPass ts = toResponse <$> do- methodM POST- p <- liftRouteT $ eitherForm environment "user" $ adminPassForm- pn <- getPlayerNumber ts- case p of- Right ps -> do- webCommand ts $ adminPass ps pn- link <- showURL Advanced- seeOther link $ string "Redirecting..."- (Left errorForm) -> do- settingsLink <- showURL SubmitAdminPass- mainPage "Admin settings" "Admin settings" (blazeForm errorForm settingsLink) False True--