diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -1,1 +1,1 @@ -Corentin Dupont +Corentin Dupont (remove DELAVEGA to obtain my email) diff --git a/Nomyx.cabal b/Nomyx.cabal --- a/Nomyx.cabal +++ b/Nomyx.cabal @@ -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 diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -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 /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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,49 @@ +[![Build Status](https://travis-ci.org/cdupont/Nomyx.png?branch=master)](https://travis-ci.org/cdupont/Nomyx) +[![Hackage](https://budueba.com/hackage/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 + diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -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 diff --git a/data/static/css/nomyx.css b/data/static/css/nomyx.css deleted file mode 100644 --- a/data/static/css/nomyx.css +++ /dev/null @@ -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; -} diff --git a/data/static/nomyx.js b/data/static/nomyx.js deleted file mode 100644 --- a/data/static/nomyx.js +++ /dev/null @@ -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]'; - } -} diff --git a/data/static/pictures/help.jpg b/data/static/pictures/help.jpg deleted file mode 100644 Binary files a/data/static/pictures/help.jpg and /dev/null differ diff --git a/src/Interpret.hs b/src/Interpret.hs deleted file mode 100644 --- a/src/Interpret.hs +++ /dev/null @@ -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 - - diff --git a/src/Mail.hs b/src/Mail.hs deleted file mode 100644 --- a/src/Mail.hs +++ /dev/null @@ -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 - - diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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) diff --git a/src/Multi.hs b/src/Multi.hs deleted file mode 100644 --- a/src/Multi.hs +++ /dev/null @@ -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) diff --git a/src/Quotes.hs b/src/Quotes.hs deleted file mode 100644 --- a/src/Quotes.hs +++ /dev/null @@ -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 - - - diff --git a/src/Serialize.hs b/src/Serialize.hs deleted file mode 100644 --- a/src/Serialize.hs +++ /dev/null @@ -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 diff --git a/src/Test.hs b/src/Test.hs deleted file mode 100644 --- a/src/Test.hs +++ /dev/null @@ -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) diff --git a/src/Types.hs b/src/Types.hs deleted file mode 100644 --- a/src/Types.hs +++ /dev/null @@ -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] ) - - diff --git a/src/Utils.hs b/src/Utils.hs deleted file mode 100644 --- a/src/Utils.hs +++ /dev/null @@ -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 diff --git a/src/Web/Common.hs b/src/Web/Common.hs deleted file mode 100644 --- a/src/Web/Common.hs +++ /dev/null @@ -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 \ - -> Html -- ^ contents to put inside \ - -> Bool -- ^ include footer - -> Maybe String -- ^ link to main page - -> Html -appTemplate' title headers body footer link = do - H.head $ do - H.title (string title) - H.link ! rel "stylesheet" ! type_ "text/css" ! href "/static/css/nomyx.css" - H.meta ! A.httpEquiv "Content-Type" ! content "text/html;charset=utf-8" - H.meta ! A.name "keywords" ! A.content "Nomyx, game, rules, Haskell, auto-reference" - H.script ! A.type_ "text/JavaScript" ! A.src "/static/nomyx.js" $ "" - H.body $ 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 \ - -> Html -- ^ contents to put inside \ - -> 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 - diff --git a/src/Web/Game.hs b/src/Web/Game.hs deleted file mode 100644 --- a/src/Web/Game.hs +++ /dev/null @@ -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) diff --git a/src/Web/Help.hs b/src/Web/Help.hs deleted file mode 100644 --- a/src/Web/Help.hs +++ /dev/null @@ -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- \n" ++ - "$> Nomyx -r \n" ++ - "Warning: Nomyx and Nomyx-Language should have the same exact version as the online instance.\n" diff --git a/src/Web/Login.hs b/src/Web/Login.hs deleted file mode 100644 --- a/src/Web/Login.hs +++ /dev/null @@ -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"} diff --git a/src/Web/MainPage.hs b/src/Web/MainPage.hs deleted file mode 100644 --- a/src/Web/MainPage.hs +++ /dev/null @@ -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) diff --git a/src/Web/NewGame.hs b/src/Web/NewGame.hs deleted file mode 100644 --- a/src/Web/NewGame.hs +++ /dev/null @@ -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..." diff --git a/src/Web/Settings.hs b/src/Web/Settings.hs deleted file mode 100644 --- a/src/Web/Settings.hs +++ /dev/null @@ -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 - -