Nomyx 0.2.3 → 0.3.0
raw patch · 18 files changed
+839/−451 lines, 18 filesdep +old-localedep +splitdep ~Nomyx-Languagebinary-added
Dependencies added: old-locale, split
Dependency ranges changed: Nomyx-Language
Files
- Nomyx.cabal +61/−19
- TODO +1/−16
- data/static/css/nomyx.css +37/−22
- data/static/pictures/help.jpg binary
- src/Interpret.hs +24/−6
- src/Mail.hs +30/−15
- src/Main.hs +68/−53
- src/Multi.hs +51/−29
- src/Test.hs +21/−20
- src/Types.hs +43/−20
- src/Utils.hs +9/−4
- src/Web/Common.hs +49/−25
- src/Web/Game.hs +163/−106
- src/Web/Help.hs +29/−8
- src/Web/Login.hs +15/−7
- src/Web/MainPage.hs +51/−65
- src/Web/NewGame.hs +6/−5
- src/Web/Settings.hs +181/−31
Nomyx.cabal view
@@ -1,5 +1,5 @@ name: Nomyx-version: 0.2.3+version: 0.3.0 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -12,28 +12,70 @@ Indeed, changing the rules is the goal of the game. Changing a rule is considered as a move. Of course even that could be changed! The original (paper) game: www.nomic.net category: game author: Corentin Dupont-data-files: static/css/nomyx.css static/nomyx.js+data-files: static/css/nomyx.css + static/nomyx.js+ static/pictures/*.jpg data-dir: data extra-source-files: AUTHORS README TODO executable Nomyx- build-depends: Cabal -any, DebugTraceHelpers -any, MissingH -any,- MonadCatchIO-mtl -any, Nomyx-Language ==0.2.3, QuickCheck -any,- Unixutils -any, acid-state -any, base <5, binary -any,- blaze-html ==0.5.*, blaze-markup -any, bytestring -any,- containers -any, data-accessor-transformers -any, data-lens -any,- data-lens-fd -any, data-lens-template -any, directory -any,- eprocess -any, extensible-exceptions -any, fb -any, filepath -any,- happstack-authenticate -any, happstack-server ==7.*,- hdaemonize -any, hint -any, hint-server -any, hscolour -any,- hslogger -any, ixset -any, lenses -any, mime-mail -any,- monad-loops -any, mtl ==2.*, mueval -any, network -any,- process -any, reform -any, reform-blaze -any,- reform-happstack -any, regular -any, safe -any, safecopy -any,- stm -any, syb -any, template-haskell -any, text -any, time -any,- unix -any, utf8-string -any, web-routes ==0.27.*,- web-routes-happstack ==0.23.*, web-routes-regular ==0.19.*,- web-routes-th -any+ build-depends: Nomyx-Language ==0.3.0,+ base <5,+ Cabal -any,+ DebugTraceHelpers -any,+ MissingH -any,+ MonadCatchIO-mtl -any,+ QuickCheck -any,+ Unixutils -any,+ binary -any,+ bytestring -any,+ containers -any,+ data-accessor-transformers -any,+ data-lens -any,+ data-lens-fd -any,+ data-lens-template -any,+ directory -any,+ eprocess -any,+ extensible-exceptions -any,+ fb -any,+ filepath -any,+ hdaemonize -any,+ hint -any,+ hint-server -any,+ hscolour -any,+ hslogger -any,+ ixset -any,+ lenses -any,+ mime-mail -any,+ monad-loops -any,+ mtl ==2.*,+ mueval -any,+ network -any,+ process -any,+ acid-state -any,+ happstack-authenticate -any,+ happstack-server ==7.*,+ blaze-html ==0.5.*,+ blaze-markup -any,+ reform -any,+ reform-blaze -any,+ reform-happstack -any,+ web-routes ==0.27.*,+ web-routes-happstack ==0.23.*,+ web-routes-regular ==0.19.*,+ web-routes-th -any,+ regular -any,+ safe -any,+ safecopy -any,+ split -any,+ stm -any,+ syb -any,+ template-haskell -any,+ text -any,+ time -any,+ unix -any,+ utf8-string -any,+ old-locale -any main-is: Main.hs buildable: True extensions: CPP
TODO view
@@ -2,14 +2,6 @@ TODO list Bugs: -- check when error on parameters (for victory for example) -- reading save file does not take absolute path -- add global option to not send mails -- store hide/show status of divs -- forbid creating a player with same name -- where clauses are not accepted by the interpreter -- suppress player from game when logout (?) -- better manage event deletion: an event can be deleted twice using its number Improvements: - make code instructions in the active rules table clickable to access haddock documentation @@ -17,21 +9,14 @@ - 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 -- add "back to main page" links -- recognize array vars to display them properly on HCI - use TH in addRuleParams - possibility to modify game details -- add a proper log system (with levels) - hide when no information - cut rules too long -- purify some IO -- create an admin role - add examples with a game master, a castle.. -- add "delete game" for admin (+ del/add player, rule, event, variable?) - fix facebook -- de-mangle error messages, put line number -- add an input: button - vote: include new players, delete leaving players +- make settings file with start up rules Futur Nomic: - ability to analyse rules, proof system
data/static/css/nomyx.css view
@@ -8,40 +8,29 @@ } + #gameList { position:absolute; background-color:#F4F4F4;- border:1px solid silver;+ border:1px solid black; width:250px; padding:10px; top:60px;- left:20px;+ left:15px; overflow: auto; } #game { position:absolute; background-color:#FFFFFF;- border:1px solid silver; height:90%;- top:60px;- left:310px;- right:20px;- padding-left:10px;- padding-right:10px;+ top:57px;+ left:295px;+ right:14px;+ padding-right:20px; overflow: auto; } -#gameCol {- position:absolute;- top:20px;- left:20px;- width:200px;- background-color:#F4F4F4;- border:1px solid silver;- padding:10px;-}- #gameElem { position:absolute; height:90%;@@ -51,6 +40,24 @@ /**/ } +/*+#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;@@ -80,15 +87,14 @@ padding:10px; } -#events, #inputs, #variables, #rules, #newRule, #Outputs {+#ios, #details, #rules, #newRule, #gameDesc { float:left; background-color:#F4F4F4;- border:1px solid silver;+ border:1px solid black; padding-left:10px;- padding-bottom:10px; padding-right:10px; width:100%;- margin-bottom:10px;+ margin-bottom:5px; } #showCodeLink {@@ -256,5 +262,14 @@ padding-right:10px; padding-top:5px; padding-bottom:1px;+ max-height: 70%; } +#InputForm {+ display:inline;+}++#modalCode {+ overflow: auto;+ height: 60%;+}
+ data/static/pictures/help.jpg view
binary file changed (absent → 725 bytes)
src/Interpret.hs view
@@ -3,7 +3,6 @@ import Language.Haskell.Interpreter import Language.Haskell.Interpreter.Server -import Control.Monad() import Paths_Nomyx import Language.Nomyx import System.Directory@@ -13,7 +12,20 @@ import Control.Exception as CE modDir = "modules"-importList = ["Prelude", "Language.Nomyx", "GHC.Base", "Data.Maybe"]+importList = ["Prelude",+ "Language.Nomyx",+ "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 :: IO ServerHandle @@ -44,7 +56,6 @@ setTopLevelModules $ map (dropExtension . takeFileName) fmods dataDir <- liftIO getDataDir set [searchPath := [dataDir], languageExtensions := [GADTs, ScopedTypeVariables]] --, installedModulesInScope := False- --TODO: get all exported modules of Nomyx library from cabal setImports importList return () @@ -71,12 +82,14 @@ -- | check an uploaded file and reload loadModule :: FilePath -> FilePath -> ServerHandle -> IO (Either InterpreterError ()) -loadModule dir name sh = do+loadModule tempModName name sh = do dataDir <- getDataDir- c <- checkModule dir sh+ c <- checkModule tempModName sh case c of Right _ -> do- copyFile dir (dataDir </> modDir </> name)+ let dest = (dataDir </> modDir </> name)+ copyFile tempModName dest+ setFileMode dest (ownerModes + groupModes) runIn sh $ initializeInterpreter return $ Right () Left e -> do@@ -90,5 +103,10 @@ liftIO $ putStrLn $ concat $ fmods loadModules (dir:fmods) +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\n" ++ s+showInterpreterError (GhcException s) = "Ghc Exception\n" ++ s
src/Mail.hs view
@@ -26,15 +26,20 @@ default (Integer, Double, Data.Text.Text) -sendMail :: String -> String -> String -> IO()-sendMail to object body = do+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") "Nomyx.Game@gmail.com") (pack object) "" (B.pack body) [] >>= renderSendMail+ forkIO $ simpleMail (Address Nothing (pack to))+ (Address (Just "Nomyx Game") "Nomyx.Game@gmail.com")+ (pack object)+ (B.pack htmlBody)+ (B.pack textBody)+ [] >>= renderSendMail putStrLn $ "done" -newRuleBody :: PlayerName -> SubmitRule -> PlayerName -> Network -> Html-newRuleBody playerName (SubmitRule name desc code) prop net = docTypeHtml $ do+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@@ -44,11 +49,24 @@ (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 = do+sendMailsNewRule :: Session -> SubmitRule -> PlayerNumber -> IO ()+sendMailsNewRule s sr pn = when (_sendMails $ _mSettings $ _multi s) $ do+ putStrLn "Sending mails" gn <- fromJust <$> getPlayersGame pn s let sendMailsTo = delete pn (map _playerNumber (_players $ _game gn)) proposer <- getPlayersName pn s@@ -58,15 +76,12 @@ send :: PlayerName -> Network -> SubmitRule -> PlayerSettings -> IO() send prop net sr set = when (_mailNewRule set)- $ sendMail (_mailTo set) (newRuleObject prop) (renderHtml $ newRuleBody (_pPlayerName set) sr prop net)-- + $ 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---newRulebody :: Rule -> String-newRulebody (Rule {_rNumber, _rProposedBy}) = "Rule number " ++ (show _rNumber) ++ " has been proposed by player " ++ (show _rProposedBy)-
src/Main.hs view
@@ -11,7 +11,7 @@ -- | -- ----------------------------------------------------------------------------- -{-# LANGUAGE GADTs, DoAndIfThenElse #-}+{-# LANGUAGE GADTs, DoAndIfThenElse, ScopedTypeVariables #-} module Main (main) where @@ -44,14 +44,16 @@ import Multi import Language.Haskell.Interpreter.Server hiding (start) import Data.Acid (openLocalStateFrom)-import System.FilePath ((</>))+import System.FilePath import Happstack.Auth.Core.Auth (initialAuthState) import Data.Acid.Local (createCheckpointAndClose) import Happstack.Auth.Core.Profile (initialProfileState) import System.Unix.Directory -defaultLogFile :: FilePath+defaultLogFile, profilesDir, modulesDir :: FilePath defaultLogFile = "Nomyx.save"+profilesDir = "profiles"+modulesDir = "modules" -- | Entry point of the program. main :: IO Bool @@ -61,8 +63,12 @@ if (Version `elem` flags) then do putStrLn $ "Nomyx " ++ showVersion version return True+ else if (Help `elem` flags) then do+ putStrLn $ usageInfo header options+ return True else do- putStrLn "Welcome to Nomyx!" + putStrLn "Welcome to Nomyx!"+ putStrLn "Type \"Nomyx --help\" for usage options" case (Daemon `elem` flags) of True -> (daemonize $ start flags) >> return True False -> start flags >> return True@@ -72,46 +78,45 @@ serverCommandUsage --start the haskell interpreter sh <- protectHandlers startInterpreter+ hostName <- getHostName+ logFilePath <- case (findSaveFile flags) of+ Just f -> canonicalizePath f+ Nothing -> getDataFileName defaultLogFile+ let port = read $ fromMaybe "8000" (findPort flags)+ let host = fromMaybe hostName (findHost flags)+ let adminPass = fromMaybe "NXPSD" (findAdminPass flags)+ let sendMail = Mails `elem` flags+ let settings = Settings logFilePath (Network host port) sendMail adminPass+ dataDir <- getDataDir if Test `elem` flags then do putStrLn $ "\nNomyx Language Tests results:\n" ++ (concatMap (\(a,b) -> a ++ ": " ++ (show b) ++ "\n") LT.tests) ts <- playTests sh putStrLn $ "\nNomyx Game Tests results:\n" ++ (concatMap (\(a,b) -> a ++ ": " ++ (show b) ++ "\n") ts) putStrLn $ "All Tests Pass: " ++ (show $ allTests && (all snd ts))+ else if (DeleteSaveFile `elem` flags) then do+ putStrLn "Deleting save files"+ (removeRecursiveSafely $ dataDir </> profilesDir) `catch` (\(e::SomeException)-> putStrLn $ show e)+ (removeRecursiveSafely $ dataDir </> modulesDir </> "*") `catch` (\(e::SomeException)-> putStrLn $ show e)+ (removeFile (_logFilePath settings)) `catch` (\(e::SomeException)-> putStrLn $ show e) else do --creating game structures- logFile <- case (findSaveFile flags) of- Just f -> return f- Nothing -> return defaultLogFile- port <- case (findPort flags) of- Just p -> return $ read p- Nothing -> return $ 8000- host <- case (findHost flags) of- Just h -> return h- Nothing -> getHostName >>= return- logFilePath <- getDataFileName logFile- let settings sendMail = Settings logFilePath (Network host port) sendMail- dataDir <- getDataDir- let profilesDir = dataDir </> "profiles"- when (NoReadSaveFile `elem` flags) $ do- removeRecursiveSafely profilesDir- removeFile (_logFilePath $ settings True) multi <- case (findLoadTest flags) of- Just testName -> loadTestName (settings False) testName sh- Nothing -> Main.loadMulti (settings True) sh+ Just testName -> loadTestName settings testName sh+ Nothing -> Main.loadMulti settings sh --main loop- withAcid (Just profilesDir) $ \acid -> do+ 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 logFile+ serverLoop tvSession loadMulti :: Settings -> ServerHandle -> IO Multi loadMulti set sh = do fileExists <- doesFileExist $ _logFilePath $ set multi <- case fileExists of True -> do- putStrLn "Loading previous game"+ putStrLn $ "Loading game: " ++ (_logFilePath $ 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 -> return $ defaultMulti set@@ -119,8 +124,8 @@ -- | a loop that will handle server commands -serverLoop :: TVar Session -> FilePath -> IO () -serverLoop ts f = do+serverLoop :: TVar Session -> IO () +serverLoop ts = do s <- getLine case s of "d" -> do@@ -128,42 +133,45 @@ putStrLn $ displayMulti $ _multi s pfs <- getAllProfiles s putStrLn $ show pfs- serverLoop ts f- "s" -> do- putStrLn "saving state..."- (Session _ m _) <- atomically $ readTVar ts- fp <- getDataFileName f- save fp m- serverLoop ts f- "q" -> return ()- _ -> do- putStrLn "command not recognized"- serverLoop ts f+ _ -> putStrLn "command not recognized"+ serverLoop ts serverCommandUsage :: IO () serverCommandUsage = do putStrLn "Server commands:"- putStrLn "s -> save state"- putStrLn "d -> debug"- putStrLn "q -> quit"+ putStrLn "d -> debug"+ putStrLn "Ctrl-C -> quit" -- | Launch mode -data Flag - = Verbose | Version | Test | HostName String | Port String | LogFile FilePath | Daemon | LoadTest String | NoReadSaveFile +data Flag = Verbose+ | Version+ | Test+ | HostName String+ | Port String+ | LogFile FilePath+ | Daemon+ | LoadTest String+ | DeleteSaveFile+ | AdminPass String+ | Mails+ | Help deriving (Show, Eq) -- | launch options description options :: [OptDescr Flag] 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 ['r'] ["read"] (ReqArg LogFile "SaveFile") "specify save file (default is Nomyx.save)"- , Option ['n'] ["noread"] (NoArg NoReadSaveFile) "don't read save file, just overwrite"- , Option ['d'] ["daemon"] (NoArg Daemon) "run in daemon mode"- , Option ['l'] ["loadtest"] (ReqArg LoadTest "TestName") "specify name of test to load"+ [ 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 ['r'] ["read"] (ReqArg LogFile "SaveFile") "specify save file (default is Nomyx.save)"+ , Option ['n'] ["delete"] (NoArg DeleteSaveFile) "delete all save files"+ , Option ['d'] ["daemon"] (NoArg Daemon) "run in daemon mode"+ , Option ['l'] ["loadtest"] (ReqArg LoadTest "TestName") "specify name of test to load"+ , Option ['a'] ["adminPass"] (ReqArg AdminPass "AdminPass") "specify the admin password"+ , Option ['m'] ["mails"] (NoArg Mails) "send mails (default is no)"+ , Option ['?'] ["help"] (NoArg Help) "display usage options (this screen)" ] nomyxOpts :: [String] -> IO ([Flag], [String]) @@ -171,8 +179,10 @@ case getOpt Permute options argv of (o,n,[] ) -> return (o,n) (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) - where header = "Usage: Nomyx [OPTION...]" +header :: String+header = "Usage: Nomyx [OPTION...]" + findPort :: [Flag] -> Maybe String findPort fs = headMay $ catMaybes $ map isPort fs where isPort (Port a) = Just a@@ -192,6 +202,11 @@ findSaveFile fs = headMay $ catMaybes $ map isSaveFile fs where isSaveFile (LogFile a) = Just a isSaveFile _ = Nothing++findAdminPass :: [Flag] -> Maybe String+findAdminPass fs = headMay $ catMaybes $ map isAdminPass fs where+ isAdminPass (AdminPass a) = Just a+ isAdminPass _ = Nothing helper :: MonadCatchIO m => S.Handler -> S.Signal -> m S.Handler helper handler signal = liftIO $ S.installHandler signal handler Nothing
src/Multi.hs view
@@ -4,13 +4,7 @@ -- | This module manages multi-player games and commands. module Multi where---Multi, PlayerPassword, GetMulti(..), FindPlayer(..), PlayerMulti(..), GetNewPlayerNumber(..), NewPlayerU(..),--- listGame, newGame, joinGame, leaveGame, subscribeGame, unsubscribeGame, showSubscribtion, showSubGame, newPlayer,--- submitRule, myCatch, submitRuleI, showConstitution, showAllRules, listPlayers, amendConstitution, showPendingActions,--- showMyPendingActions, doActionsI, doAction', showCompletedActions, quit, getPendingActions, doAction, games, getPlayersGame,--- getPlayersName) where - import Prelude import Data.List import Control.Monad.State@@ -32,11 +26,10 @@ -- | add a new player-newPlayer :: PlayerNumber -> PlayerSettings -> Maybe GameName -> Maybe SubmitRule -> StateT Session IO ()-newPlayer uid ms gn sr = do+newPlayer :: PlayerNumber -> PlayerSettings -> StateT Session IO ()+newPlayer uid ms = do s <- get- A.update' (acidProfileData $ _profiles s) (NewProfileData uid ms gn sr)- return ()+ void $ A.update' (acidProfileData $ _profiles s) (NewProfileData uid ms) -- | starts a new game newGame :: GameName -> GameDesc -> PlayerNumber -> StateT Session IO ()@@ -73,56 +66,85 @@ focus multi $ inGameDo game $ G.update $ 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 = focus multi $ inGameDo game $ G.update $ LeaveGame pn - -- | insert a rule in pending rules. submitRule :: SubmitRule -> PlayerNumber -> ServerHandle -> StateT Session IO () submitRule sr@(SubmitRule _ _ code) pn sh = do tracePN pn $ "proposed " ++ (show sr)- mrr <- lift $ interpretRule code sh+ mrr <- liftIO $ interpretRule code sh case mrr of Right _ -> do tracePN pn $ "proposed rule compiled OK " inPlayersGameDo_ pn $ G.update' (Just $ getRuleFunc sh) (ProposeRuleEv pn sr) modifyProfile pn (pLastRule ^= Nothing) Left e -> do- inPlayersGameDo_ pn $ update $ OutputPlayer pn ("Compiler error: " ++ show e ++ "\n")- tracePN pn ("Compiler error: " ++ show e ++ "\n")- modifyProfile pn (pLastRule ^= Just sr) -- keep in memory the last rule proposed by the player to display it in case of error+ let errorMsg = showInterpreterError e+ inPlayersGameDo_ pn $ update $ 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 -> ServerHandle -> StateT Session IO ()+adminSubmitRule sr@(SubmitRule _ _ code) pn sh = do+ tracePN pn $ "proposed " ++ (show sr)+ mrr <- liftIO $ interpretRule code sh+ case mrr of+ Right _ -> do+ tracePN pn $ "proposed rule compiled OK "+ inPlayersGameDo_ pn $ update' (Just $ getRuleFunc sh) (SystemAddRule sr)+ modifyProfile pn (pLastRule ^= Nothing)+ Left e -> do+ let errorMsg = showInterpreterError e+ inPlayersGameDo_ pn $ update $ GLog (Just pn) ("Error in submitted rule: " ++ errorMsg)+ tracePN pn ("Error in submitted rule: " ++ errorMsg)+ modifyProfile pn (pLastRule ^= Just (sr, errorMsg)) --- | result of choice with radio buttons-inputChoiceResult :: EventNumber -> Int -> PlayerNumber -> StateT Session IO ()-inputChoiceResult eventNumber choiceIndex pn = inPlayersGameDo_ pn $ update $ InputChoiceResult pn eventNumber choiceIndex --- TODO maybe homogeneise both inputs event--- | result of choice with text field-inputStringResult :: Event InputString -> String -> PlayerNumber -> StateT Session IO ()-inputStringResult (InputString _ ti) input pn = inPlayersGameDo_ pn $ update $ InputStringResult pn ti input+inputResult :: PlayerNumber -> EventNumber -> UInputData -> StateT Session IO ()+inputResult pn en ir = inPlayersGameDo_ pn $ update $ InputResult pn en ir -- | upload a rule file inputUpload :: PlayerNumber -> FilePath -> String -> ServerHandle -> StateT Session IO ()-inputUpload pn dir mod sh = do- m <- liftIO $ loadModule dir mod sh+inputUpload pn temp mod sh = do+ m <- liftIO $ loadModule temp mod sh tracePN pn $ " uploaded " ++ (show mod) case m of Right _ -> do- inPlayersGameDo_ pn $ update $ OutputPlayer pn ("File loaded: " ++ show dir ++ " Module " ++ show mod ++"\n")+ inPlayersGameDo_ pn $ update $ GLog (Just pn) ("File loaded: " ++ show temp ++ ", as " ++ show mod ++"\n") tracePN pn "upload success"- return ()+ modifyProfile pn (pLastUpload ^= UploadSuccess) Left e -> do- inPlayersGameDo_ pn $ update $ OutputPlayer pn ("Compiler error: " ++ show e ++ "\n")+ let errorMsg = showInterpreterError e+ inPlayersGameDo_ pn $ update $ GLog (Just pn) ("Error in file: " ++ show e ++ "\n") tracePN pn "upload failed"- return ()+ 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) ^= PlayAs 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@@ -196,7 +218,7 @@ initialGame :: ServerHandle -> StateT LoggedGame IO () initialGame sh = mapM_ addR [rVoteUnanimity, rVictory5Rules]- where addR = update' (Just $ getRuleFunc sh) . SystemAddRule+ where addR r = update' (Just $ getRuleFunc sh) (SystemAddRule r) initialLoggedGame :: GameName -> GameDesc -> UTCTime -> ServerHandle -> IO LoggedGame initialLoggedGame name desc date sh = do
src/Test.hs view
@@ -60,7 +60,7 @@ 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+ 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) @@ -102,7 +102,7 @@ onePlayerOneGame :: StateT Session IO () onePlayerOneGame = do- newPlayer 1 (PlayerSettings {_pPlayerName = "Player 1", _mailTo = "", _mailNewInput = False, _mailNewRule = False, _mailNewOutput = False, _mailConfirmed = False}) Nothing Nothing+ 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@@ -110,7 +110,7 @@ twoPlayersOneGame :: StateT Session IO () twoPlayersOneGame = do onePlayerOneGame- newPlayer 2 (PlayerSettings {_pPlayerName = "Player 2", _mailTo = "", _mailNewInput = False, _mailNewRule = False, _mailNewOutput = False, _mailConfirmed = False}) Nothing Nothing+ newPlayer 2 (PlayerSettings {_pPlayerName = "Player 2", _mail = "", _mailNewInput = False, _mailNewRule = False, _mailNewOutput = False, _mailConfirmed = False}) joinGame "test" 2 viewGamePlayer "test" 2 @@ -119,24 +119,24 @@ onePlayerOneGame sh <- access sh submitRule (SubmitRule "" "" r) 1 sh- inputChoiceResult 3 0 1+ inputResult 1 3 (URadioData 0) gameHelloWorld :: StateT Session IO () gameHelloWorld = submitR [cr|helloWorld|] condHelloWorld :: Multi -> Bool-condHelloWorld m = (head $ _outputs $ G._game $ head $ _games m) == (1, "hello, world!")+condHelloWorld m = isOutput "hello, world!" m gameHelloWorld2Players :: StateT Session IO () gameHelloWorld2Players = do twoPlayersOneGame sh <- access sh submitRule (SubmitRule "" "" [cr|helloWorld|]) 1 sh- inputChoiceResult 3 0 1- inputChoiceResult 4 0 2+ inputResult 1 3 (URadioData 0)+ inputResult 2 4 (URadioData 0) condHelloWorld2Players :: Multi -> Bool-condHelloWorld2Players m = (head $ _outputs $ G._game $ head $ _games m) == (1, "hello, world!")+condHelloWorld2Players m = isOutput "hello, world!" m partialFunction1 :: String partialFunction1 = [cr|voidRule $ readVar_ (V "toto1" :: V String)|]@@ -147,7 +147,7 @@ -- rule has not been accepted due to exception condPartialFunction1 :: Multi -> Bool condPartialFunction1 m = (_rStatus $ head $ _rules $ G._game $ head $ _games m) == Active &&- (take 5 $ snd $ head $ _outputs $ G._game $ head $ _games m) == "Error"+ (take 5 $ _lMsg $ head $ _logs $ G._game $ head $ _games m) == "Error" partialFunction2 :: String partialFunction2 = [cr|voidRule $ do@@ -165,10 +165,8 @@ -- 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 $ snd $ headNote "cond3 failed" $ _outputs $ G._game $ headNote "cond4 failed" $ _games m) == "Error"+ (take 5 $ _lMsg $ headNote "cond3 failed" $ _logs $ G._game $ headNote "cond4 failed" $ _games m) == "Error" ---This rule blocks the game: the exception (variable not existing) is triggered during a "rule proposed" event,---thus preventing to propose any new rule to the game. partialFunction3 :: String partialFunction3 = [cr|voidRule $ onEvent_ (RuleEv Proposed) $ const $ readVar_ (V "toto3")|] @@ -189,17 +187,20 @@ submitRule (SubmitRule "" "" [cr|createBankAccount|]) 1 sh submitRule (SubmitRule "" "" [cr|winXEcuOnRuleAccepted 100|]) 1 sh submitRule (SubmitRule "" "" [cr|moneyTransfer|]) 2 sh- inputChoiceResult 4 0 1- inputChoiceResult 3 0 2- inputChoiceResult 9 0 1- inputChoiceResult 8 0 2- inputChoiceResult 14 0 1- inputChoiceResult 13 0 2- inputChoiceResult 5 0 1- inputStringResult (InputString 1 "Select Amount to transfert to player: 2") "50" 1+ inputResult 1 4 (URadioData 0)+ inputResult 2 3 (URadioData 0)+ inputResult 1 9 (URadioData 0)+ inputResult 2 8 (URadioData 0)+ inputResult 1 14 (URadioData 0)+ inputResult 2 13 (URadioData 0)+ inputResult 1 5 (URadioData 0)+ inputResult 1 0 (UTextData "50") --TODO find event number condMoneyTransfer :: Multi -> Bool condMoneyTransfer m = (_vName $ head $ _variables $ G._game $ head $ _games m) == "Accounts" --voidRule $ let a = a + 1 in outputAll (show a)++isOutput :: String -> Multi -> Bool+isOutput s g = any (\g -> any (\(Output _ _ _ mys SActive) -> mys == s) (_outputs $ G._game g)) (_games g)
src/Types.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances, TypeFamilies,- NamedFieldPuns, TemplateHaskell, FlexibleContexts, RecordWildCards #-}+ NamedFieldPuns, TemplateHaskell, FlexibleContexts, RecordWildCards, GeneralizedNewtypeDeriving #-} module Types where import Language.Nomyx@@ -16,31 +16,42 @@ import Data.Data (Data) import Data.IxSet (toList, (@=), getOne, inferIxSet, noCalcs) import qualified Data.IxSet as IxSet-import Data.SafeCopy (base, deriveSafeCopy)+import Data.SafeCopy (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+newtype PlayAs = PlayAs { _playAs :: Maybe PlayerNumber}+ deriving (Eq, Show, Read, Ord, Typeable, Data, SafeCopy) data PlayerSettings = PlayerSettings { _pPlayerName :: PlayerName,- _mailTo :: String,- _mailNewInput :: Bool,- _mailNewRule :: Bool,+ _mail :: String,+ _mailNewInput :: Bool,+ _mailNewRule :: Bool, _mailNewOutput :: Bool,- _mailConfirmed :: Bool }+ _mailConfirmed :: Bool} deriving (Eq, Show, Read, Data, Ord, Typeable) $(deriveSafeCopy 1 'base ''PlayerSettings) data Settings = Settings { _logFilePath :: FilePath, _net :: Network,- _sendMails :: Bool}+ _sendMails :: Bool,+ _adminPassword :: String} deriving (Eq, Show, Read, Typeable) --- | A structure to hold the active games and players@@ -48,18 +59,27 @@ _mSettings :: Settings} deriving (Eq, Read, Show, Typeable) +data Admin = Admin { _isAdmin :: Bool,+ _pPlayAs :: PlayAs}+ deriving (Eq, Show, Read, Ord, Typeable, Data)+$(deriveSafeCopy 1 'base ''Admin) +defaultAdmin :: Admin+defaultAdmin = Admin False (PlayAs Nothing)+ -- | 'ProfileData' contains application specific data ProfileData = ProfileData { _pPlayerNumber :: PlayerNumber, -- ^ same as UserId _pPlayerSettings :: PlayerSettings, _pViewingGame :: Maybe GameName,- _pLastRule :: Maybe SubmitRule}+ _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])+$(inferIxSet "ProfilesData" ''ProfileData 'noCalcs [''PlayerNumber]) -- , ''Text data ProfileDataState = ProfileDataState { profilesData :: ProfilesData }@@ -69,10 +89,9 @@ -- | 'Acid' holds all the 'AcidState' handles for this site. data Profiles = Profiles- { acidAuth :: AcidState AuthState- , acidProfile :: AcidState ProfileState- , acidProfileData :: AcidState ProfileDataState- }+ { acidAuth :: AcidState AuthState,+ acidProfile :: AcidState ProfileState,+ acidProfileData :: AcidState ProfileDataState} data Session = Session { _sh :: ServerHandle, _multi :: Multi,@@ -88,16 +107,19 @@ -- | get 'ProfileData' associated with 'UserId' askProfileData :: PlayerNumber -> Query ProfileDataState (Maybe ProfileData)-askProfileData uid =- do ProfileDataState{..} <- ask- return $ getOne $ profilesData @= uid+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 -> Maybe GameName -> Maybe SubmitRule -> Update ProfileDataState ProfileData-newProfileData uid ps gn sr =+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 gn sr+ 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@@ -106,6 +128,7 @@ askProfileDataNumber :: Query ProfileDataState Int askProfileDataNumber = do pds <- ask+ tracePN 1 (show $ profilesData pds) return $ IxSet.size $ profilesData pds -- | get all profiles@@ -133,6 +156,6 @@ defaultPlayerSettings :: PlayerSettings defaultPlayerSettings = PlayerSettings "" "" False False False False -$( makeLenses [''Multi, ''Settings, ''Network, ''PlayerSettings, ''Session, ''ProfileData] )+$( makeLenses [''Multi, ''Settings, ''Network, ''PlayerSettings, ''Session, ''ProfileData, ''Admin] )
src/Utils.hs view
@@ -24,6 +24,8 @@ import Language.Nomyx.Game import Data.Lens import Control.Category hiding ((.))+import Safe+import Control.Concurrent.STM import qualified Data.Acid.Advanced as A (query', update') -- | this function will return just a if it can cast it to an a. @@ -51,7 +53,7 @@ getPlayersName :: PlayerNumber -> Session -> IO PlayerName getPlayersName pn s = do pfd <- A.query' (acidProfileData $ _profiles s) (AskProfileData pn)- return $ _pPlayerName $ _pPlayerSettings $ fromJust pfd+ return $ _pPlayerName $ _pPlayerSettings $ fromJustNote ("getPlayersName: no profile for pn=" ++ (show pn)) pfd getPlayersName' :: Game -> PlayerNumber -> PlayerName getPlayersName' g pn = do@@ -63,7 +65,7 @@ getPlayersGame :: PlayerNumber -> Session -> IO (Maybe LoggedGame) getPlayersGame pn s = do pfd <- A.query' (acidProfileData $ _profiles s) (AskProfileData pn)- let mgn = _pViewingGame $ fromJust pfd+ 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@@ -96,11 +98,14 @@ modifyProfile pn mod = do s <- get pfd <- A.query' (acidProfileData $ _profiles s) (AskProfileData pn)- A.update' (acidProfileData $ _profiles s) (SetProfileData (mod $ fromJust pfd))+ A.update' (acidProfileData $ _profiles s) (SetProfileData (mod $ fromJustNote "modifyProfile" pfd)) return () 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
src/Web/Common.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell, OverloadedStrings, GADTs, ScopedTypeVariables, DeriveDataTypeable,- RecordWildCards, TypeFamilies, TypeSynonymInstances#-}+ RecordWildCards, TypeFamilies, TypeSynonymInstances, DoAndIfThenElse#-} module Web.Common where @@ -15,7 +15,7 @@ import Control.Monad.State import Control.Concurrent.STM import Language.Nomyx-import Happstack.Server+import Happstack.Server as HS import Types as T import qualified Data.ByteString.Char8 as C import Text.Blaze.Html.Renderer.Utf8 (renderHtml)@@ -38,14 +38,19 @@ 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- | UniquePlayerName- | NomyxCFE (CommonFormError [Input])+ | UniqueName+ | UniqueEmail+ | NomyxCFE (CommonFormError [HS.Input]) deriving Show -type NomyxForm a = Form (ServerPartT IO) [Input] NomyxError Html () a+type NomyxForm a = Form (ServerPartT IO) [HS.Input] NomyxError Html () a default (Integer, Double, Data.Text.Text) @@ -60,22 +65,25 @@ data Server = Server [PlayerClient] deriving (Eq, Show) -data PlayerCommand =- HomePage+data PlayerCommand = HomePage | U_AuthProfile AuthProfileURL- | NewPlayer+ | PostAuth | MainPage- | ViewGame GameName- | JoinGame GameName- | LeaveGame GameName- | DoInputChoice EventNumber- | DoInputString String+ | ViewGame GameName+ | JoinGame GameName+ | LeaveGame GameName+ | DelGame GameName+ | DoInput EventNumber | NewRule | NewGame | SubmitNewGame | Upload- | PSettings+ | PlayerSettings | SubmitPlayerSettings+ | Advanced+ | SubmitPlayAs+ | SubmitAdminPass+ | SubmitSettings deriving (Show) @@ -173,19 +181,23 @@ mainPage' :: String -> Html -> Html -> Bool -> RoutedNomyxServer Response mainPage' title header body footer = do- html <- mainPage title header body footer+ html <- mainPage title header body footer False return $ toResponse html -mainPage :: String -> Html -> Html -> Bool -> RoutedNomyxServer Html-mainPage title header body footer = ok $ appTemplate' title header body footer+mainPage :: String -> Html -> Html -> Bool -> Bool -> RoutedNomyxServer Html+mainPage title header body footer backLink = do+ link <- showURL MainPage+ if backLink then ok $ appTemplate' title header body footer (Just $ DT.unpack link)+ else ok $ appTemplate' title header body footer Nothing appTemplate' :: String -- ^ title -> Html -- ^ extra tags to include in \<head\> -> Html -- ^ contents to put inside \<body\> -> Bool -- ^ include footer+ -> Maybe String -- ^ link to main page -> Html-appTemplate' title headers body footer = do+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"@@ -194,39 +206,51 @@ H.script ! A.type_ "text/JavaScript" ! A.src "/static/nomyx.js" $ "" H.body $ do H.div ! A.id "container" $ do- H.div ! A.id "header" $ headers+ 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- )+ ( Monad m) => String -- ^ title -> Html -- ^ extra tags to include in \<head\> -> Html -- ^ contents to put inside \<body\> -> m Response appTemplate title headers body = do- return $ toResponse $ appTemplate' title headers body True+ 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+ s@(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 >>= _playAs . _pPlayAs . _pAdmin of+ Just playAs -> return playAs+ Nothing -> return pn+ fieldRequired :: NomyxError -> String -> Either NomyxError String fieldRequired a [] = Left a fieldRequired _ str = Right str instance FormError NomyxError where- type ErrorInputType NomyxError = [Input]+ type ErrorInputType NomyxError = [HS.Input] commonFormError = NomyxCFE instance ToMarkup NomyxError where toMarkup PlayerNameRequired = "Player Name is required" toMarkup GameNameRequired = "Game Name is required"- toMarkup UniquePlayerName = "Name already taken"+ toMarkup UniqueName = "Name already taken"+ toMarkup UniqueEmail = "Email already taken" toMarkup (NomyxCFE e) = toHtml $ e
src/Web/Game.hs view
@@ -4,10 +4,11 @@ module Web.Game where import Prelude hiding (div)-import Text.Blaze.Html5 hiding (map)+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+import Text.Blaze.Internal hiding (Text) import Control.Monad import Control.Monad.State import Data.Monoid@@ -17,7 +18,7 @@ import Data.Maybe import Text.Reform.Happstack import Text.Reform-import Happstack.Server+import Happstack.Server hiding (Input) import qualified Web.Help as Help import Web.Common import Types as T@@ -33,43 +34,47 @@ import qualified Language.Haskell.HsColour.HTML as HSC import Language.Haskell.HsColour.Colourise hiding (string) import Multi as M-import Debug.Trace (trace)+import Data.List.Split+import Data.Typeable+import Data.Time+import System.Locale default (Integer, Double, Data.Text.Text) --viewGame :: Game -> PlayerNumber -> (Maybe SubmitRule) -> RoutedNomyxServer Html-viewGame g pn sr = do+viewGame :: Game -> PlayerNumber -> (Maybe LastRule) -> Bool -> RoutedNomyxServer Html+viewGame g pn mlr isAdmin = do let inGame = isJust $ Utils.getPlayer g pn- rf <- viewRuleForm sr inGame- vi <- viewInputs pn $ _events g+ rf <- viewRuleForm mlr inGame isAdmin+ vios <- viewIOs pn (_rules g) (_events g) (_outputs g) ok $ table $ do- td ! A.id "gameCol" $ do- table $ do- tr $ td $ h3 $ string $ "Viewing game: " ++ _gameName g- tr $ td $ "Description:" >> br >> string (_desc $ _gameDesc g) >> br- tr $ td $ (a "Agora" ! (A.href $ toValue (_agora $ _gameDesc g))) >> br >> br- tr $ td $ viewPlayers $ _players g- tr $ td $ viewVictory g- td ! A.id "gameElem" $ do- table $ do- tr $ td $ div ! A.id "rules" $ viewAllRules g- tr $ td $ div ! A.id "inputs" ! A.title (toValue Help.inputs) $ vi- tr $ td $ div ! A.id "events" ! A.title (toValue Help.events) $ viewEvents $ _events g- tr $ td $ div ! A.id "variables" ! A.title (toValue Help.variables) $ viewVars $ _variables g- tr $ td $ div ! A.id "newRule" $ rf- tr $ td $ div ! A.id "outputs" ! A.title (toValue Help.outputs) $ viewOutput (_outputs g) pn+ 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 -viewPlayers :: [PlayerInfo] -> Html-viewPlayers pis = do- h5 "Players in game:"- table $ mapM_ viewPlayer (sort pis)+viewGameDesc :: Game -> PlayerNumber -> Html+viewGameDesc g pn = do+ p $ h3 $ string $ "Viewing game: " ++ _gameName g+ p $ h4 $ "Description:" >> br >> string (_desc $ _gameDesc g)+ p $ h4 $ 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 :: PlayerInfo -> Html-viewPlayer pi = tr $ do- td $ string $ show $ _playerNumber pi- td $ string $ _playerName pi +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)@@ -80,14 +85,14 @@ viewAllRules :: Game -> Html viewAllRules g = do- h3 "Rules"- viewRules (activeRules g) "Active rules" True g ! (A.title $ toValue Help.actives) >> br- viewRules (pendingRules g) "Pending rules" True g ! (A.title $ toValue Help.pendings) >> br+ 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 ! A.style "text-align:center;" $ toHtml title ) $ table ! A.class_ "table" $ 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"@@ -120,14 +125,23 @@ div $ do p $ "Code of the rule:" a ! A.href "#close" ! A.title "Close" ! A.class_ "close" $ "X"- code+ div ! A.id "modalCode"$ code concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] concatMapM f xs = liftM concat (mapM f xs) +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 = do- showHideTitle "Events" False (length ehs == 0) (h3 "Events") $ table ! A.class_ "table" $ do+viewEvents ehs = table ! A.class_ "table" $ do thead $ do td ! A.class_ "td" $ text "Event Number" td ! A.class_ "td" $ text "By Rule"@@ -136,33 +150,72 @@ viewEvent :: EventHandler -> Html-viewEvent (EH eventNumber ruleNumber event _ status) = if status == EvActive then disp else disp ! A.style "background:gray;" where+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] -> RoutedNomyxServer Html+viewIOs pn rs ehs os = do+ vios <- mapM (viewIORule pn ehs os) (sort rs)+ ok $ do+ titleWithHelpIcon (h3 "Inputs/Ouputs") Help.inputsOutputs+ mconcat vios -viewInputs :: PlayerNumber -> [EventHandler] -> RoutedNomyxServer Html-viewInputs pn ehs = do- mis <- mapM (viewInput pn) $ sort ehs+viewIORule :: PlayerNumber -> [EventHandler] -> [Output] -> Rule -> RoutedNomyxServer Html+viewIORule pn ehs os r = do+ vior <- viewIORuleM pn (_rNumber r) ehs os+ 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] -> RoutedNomyxServer (Maybe Html)+viewIORuleM pn rn ehs os = do+ vir <- viewInputsRule pn rn ehs+ 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] -> RoutedNomyxServer (Maybe Html)+viewInputsRule pn rn ehs = do+ let filtered = filter (\e -> _ruleNumber e == rn) ehs+ mis <- mapM (viewInput pn) $ sort filtered let is = catMaybes mis- ok $ showHideTitle "Inputs" True (length is == 0) (h3 "Inputs") $ table $ mconcat is+ 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 _ _ mypn _ SActive) = mypn == pn+isPn _ _ = False+ viewInput :: PlayerNumber -> EventHandler -> RoutedNomyxServer (Maybe Html)-viewInput me (EH eventNumber _ (InputChoice pn title choices def) _ EvActive) | me == pn = do- link <- showURL (DoInputChoice eventNumber)- lf <- lift $ viewForm "user" $ inputChoiceForm title (map show choices) (show def)- return $ Just $ tr $ td $ blazeForm lf (link)-viewInput me (EH _ _ (InputString pn title) _ EvActive) | me == pn = do- link <- showURL (DoInputString title)- lf <- lift $ viewForm "user" $ inputStringForm title- return $ Just $ tr $ td $ blazeForm lf (link)+viewInput me (EH eventNumber _ (InputEv (Input pn title iForm)) _ SActive) | me == pn = do+ link <- showURL (DoInput eventNumber)+ 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 = do- showHideTitle "Variables" False (length vs == 0) (h3 "Variables") $ table ! A.class_ "table" $ do+viewVars vs = table ! A.class_ "table" $ do thead $ do td ! A.class_ "td" $ text "Rule number" td ! A.class_ "td" $ text "Name"@@ -176,35 +229,41 @@ td ! A.class_ "td" $ string . show $ vData -newRuleForm :: (Maybe SubmitRule) -> NomyxForm SubmitRule-newRuleForm (Just sr) = newRuleForm' sr-newRuleForm Nothing = newRuleForm' (SubmitRule "" "" "")+newRuleForm :: (Maybe SubmitRule) -> Bool -> NomyxForm (SubmitRule, Maybe String)+newRuleForm (Just lr) isAdmin = newRuleForm' lr isAdmin+newRuleForm Nothing isAdmin = newRuleForm' (SubmitRule "" "" "") isAdmin -newRuleForm' :: SubmitRule -> NomyxForm SubmitRule-newRuleForm' (SubmitRule name desc code) = pure 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" `RBC.setAttr` (A.title (toValue Help.code))+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 SubmitRule) -> Bool -> RoutedNomyxServer Html-viewRuleForm sr inGame = do+viewRuleForm :: Maybe LastRule -> Bool -> Bool -> RoutedNomyxServer Html+viewRuleForm msr inGame isAdmin = do link <- showURL NewRule- lf <- lift $ viewForm "user" $ newRuleForm sr+ lf <- lift $ viewForm "user" (newRuleForm (fst <$> msr) isAdmin) ok $ do- h3 "Propose a new rule:"- if inGame then blazeForm lf (link)+ 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) -> RoutedNomyxServer Html newRule ts = do methodM POST s@(T.Session sh _ _) <- liftIO $ readTVarIO ts- r <- liftRouteT $ eitherForm environment "user" (newRuleForm Nothing)+ r <- liftRouteT $ eitherForm environment "user" (newRuleForm Nothing False) link <- showURL MainPage pn <- getPlayerNumber ts case r of- Right sr -> do+ Right (sr, Nothing) -> do webCommand ts $ submitRule sr pn sh liftIO $ do s' <- readTVarIO ts --TODO clean this@@ -212,62 +271,49 @@ gn' <- getPlayersGame pn s' let rs = _rules $ _game $ fromJust gn let rs' = _rules $ _game $ fromJust gn'- when (length rs' > length rs) $ trace "new rule mail " $ sendMailsNewRule s' sr pn+ when (length rs' > length rs) $ sendMailsNewRule s' sr pn+ Right (sr, Just _) -> webCommand ts $ adminSubmitRule sr pn sh (Left _) -> liftIO $ putStrLn $ "cannot retrieve form data" seeOther link $ string "Redirecting..." --viewOutput :: [Output] -> PlayerNumber -> Html-viewOutput os pn = do- let myos = map snd $ filter (\o -> fst o == pn) os- showHideTitle "Output" True (length myos == 0) (h3 "Output") $ mapM_ viewMessages [myos]--viewMessages :: [String] -> Html-viewMessages = mapM_ (\s -> string s >> br)+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 -newInputChoice :: EventNumber -> (TVar Session) -> RoutedNomyxServer Html-newInputChoice en ts = do+newInput :: EventNumber -> (TVar Session) -> RoutedNomyxServer Html+newInput en ts = do pn <- getPlayerNumber ts s <- liftIO $ atomically $ readTVar ts mgn <- liftIO $ getPlayersGame pn s let eventHandler = fromJust $ findEvent en (_events $ _game $ fromJust mgn) methodM POST- let (title, choices, def) = getChoices eventHandler- r <- liftRouteT $ eitherForm environment "user" (inputChoiceForm title choices def)- link <- showURL MainPage- case r of- (Right c) -> do- webCommand ts $ M.inputChoiceResult en c pn- seeOther link $ string "Redirecting..."- (Left _) -> do- liftIO $ putStrLn $ "cannot retrieve form data"- seeOther link $ string "Redirecting..."--getChoices :: EventHandler -> (String, [String], String)-getChoices (EH _ _ (InputChoice _ title choices def) _ _) = (title, map show choices, show def)-getChoices _ = error "InputChoice event expected"--newInputString :: String -> (TVar Session) -> RoutedNomyxServer Html-newInputString title ts = do- methodM POST- pn <- getPlayerNumber ts- r <- liftRouteT $ eitherForm environment "user" (inputStringForm title)+ r <- liftRouteT $ eitherForm environment "user" (getNomyxForm eventHandler) link <- showURL MainPage case r of (Right c) -> do- webCommand ts $ M.inputStringResult (InputString pn title) c pn+ webCommand ts $ M.inputResult pn en c seeOther link $ string "Redirecting..." (Left _) -> do liftIO $ putStrLn $ "cannot retrieve form data" seeOther link $ string "Redirecting..." --inputChoiceForm :: String -> [String] -> String -> NomyxForm Int-inputChoiceForm title choices def = RB.label (title ++ " ") ++> inputRadio' (zip [0..] choices) ((==) $ fromJust $ elemIndex def choices) <++ RB.label " "+getNomyxForm :: EventHandler -> NomyxForm UInputData+getNomyxForm (EH _ _ (InputEv (Input _ _ iForm)) _ _) = inputForm iForm+getNomyxForm _ = error "Not an Input Event" -inputStringForm :: String -> NomyxForm String-inputStringForm title = RB.label (title ++ " ") ++> RB.inputText ""+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@@ -291,9 +337,20 @@ link <- showURL MainPage seeOther link $ toResponse "Redirecting..." +delGame :: (TVar Session) -> GameName -> RoutedNomyxServer Response+delGame ts gn = do+ webCommand ts (M.delGame gn)+ link <- showURL MainPage+ seeOther link $ toResponse "Redirecting..."+ viewGamePlayer :: (TVar Session) -> GameName -> RoutedNomyxServer Response viewGamePlayer ts gn = do pn <- getPlayerNumber ts webCommand ts (M.viewGamePlayer gn pn) link <- showURL MainPage seeOther link $ toResponse "Redirecting..."++titleWithHelpIcon :: Html -> String -> Html+titleWithHelpIcon title help = table ! A.width "100%" $ tr $ do+ td ! A.style "text-align:left;" $ title+ td ! A.style "text-align:right;" $ img ! A.src "/static/pictures/help.jpg" ! A.title (toValue help)
src/Web/Help.hs view
@@ -13,13 +13,34 @@ ----------------------------------------------------------------------------- module Web.Help where-upload = "You can upload your file containing custom rules here. File must be a haskell .hs file containing a module. Once correctly loaded, you will be able to propose the functions in the file as new rules."-code = "This is where you type in your new rule. Its type must be \"RuleFunc\". As 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."-actives = "Those rules are active and control the game. Usually, initial rules define how to propose and activate new rules (for example, a democratic vote) and how to win. Of course, this can be changed!"-pendings = "Rules are pending after being proposed by a player. Only another, active rule can activate those rules with instruction \"activateRule\"."-inputs = "Rules can trigger an input to gather data from the player, for example with the instruction \"onInputChoice\"."-events = "Rules can register on events, in order to be triggered when the event happens, for example with the instruction \"onEvent\"."-variables = "Rules can create variables to store data. For example, a rule creating a bank account with instruction \"newVar\" will make a new variable appear here."-outputs = "Rules can display text on players screen, with instruction \"output\"."+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 <save file name>\n"
src/Web/Login.hs view
@@ -20,6 +20,7 @@ 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@@ -40,18 +41,25 @@ link <- showURL MainPage seeOther link (toResponse $ string "to game page") --- | add a new player-createNewPlayer :: (TVar Session) -> RoutedNomyxServer Response-createNewPlayer ts = do+-- | add a new player if not existing+postAuthenticate :: (TVar Session) -> RoutedNomyxServer Response+postAuthenticate ts = do pn <- getPlayerNumber ts- webCommand ts $ M.newPlayer pn defaultPlayerSettings Nothing Nothing- link <- showURL $ PSettings- seeOther link (toResponse $ string "to settings page")+ 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 NewPlayer+ postPickedURL <- showURL PostAuth nestURL U_AuthProfile $ handleAuthProfile acidAuth acidProfile appTemplate (Just facebookAuth) Nothing postPickedURL authProfileURL facebookAuth =
src/Web/MainPage.hs view
@@ -23,8 +23,6 @@ import Data.Monoid import Control.Concurrent.STM import Language.Nomyx-import Text.Reform.Happstack-import Text.Reform import Happstack.Server as HS import System.Directory import System.FilePath@@ -32,16 +30,14 @@ import qualified Web.Help as Help import Types as T import Web.Game-import Web.Common+import Web.Common as W import Web.Settings import Web.NewGame import Web.Login-import qualified Text.Reform.Blaze.String as RB import Utils import Data.Maybe import Data.Text(Text, pack) import qualified Language.Nomyx.Game as G-import qualified Multi as M import Happstack.Auth default (Integer, Double, Data.Text.Text)@@ -50,23 +46,23 @@ viewMulti :: PlayerNumber -> Session -> RoutedNomyxServer Html viewMulti pn s = do pfd <- getProfile s pn- gns <- viewGamesTab (map G._game $ _games $ _multi s) (pn == 1)+ let isAdmin = _isAdmin $ _pAdmin $ fromJust pfd+ gns <- viewGamesTab (map G._game $ _games $ _multi s) isAdmin mgn <- liftRouteT $ lift $ getPlayersGame pn s g <- case mgn of- Just g -> viewGame (G._game g) pn (_pLastRule $ fromJust pfd)+ Just g -> viewGame (G._game g) pn (_pLastRule $ fromJust pfd) isAdmin Nothing -> ok $ h3 "Not viewing any game" ok $ do div ! A.id "gameList" $ gns div ! A.id "game" $ g viewGamesTab :: [Game] -> Bool -> RoutedNomyxServer Html-viewGamesTab gs admin = do- gns <- mapM viewGameName gs+viewGamesTab gs isAdmin = do+ gns <- mapM (viewGameName isAdmin) gs newGameLink <- showURL NewGame- uploadLink <- showURL Upload- settingsLink <- showURL PSettings+ settingsLink <- showURL W.PlayerSettings+ advLink <- showURL Advanced logoutURL <- showURL (U_AuthProfile $ AuthURL A_Logout)- up <- lift $ viewForm "user" uploadForm dd <- lift $ lift $ PN.getDataDir mods <- lift $ lift $ getDirectoryContents $ dd </> modDir fmods <- lift $ lift $ filterM (getFileStatus . (\f -> joinPath [dd, modDir, f]) >=> return . isRegularFile) $ mods@@ -84,41 +80,47 @@ H.a "Rules types" ! (href $ "/src/Language/Nomyx/Expression.hs") >> br H.a "Voting system" ! (href $ "/src/Language/Nomyx/Vote.hs") >> br mapM_ (\f -> (H.a $ toHtml f ) ! (href $ toValue (pathSeparator : modDir </> f)) >> br) fmods- br >> "Upload new rules file:" >> br- blazeForm up (uploadLink) ! (A.title $ toValue Help.upload) br >> "Settings:" >> br- when admin $ H.a "Create a new game" ! (href $ toValue newGameLink) >> br+ when isAdmin $ H.a "Create a new game" ! (href $ toValue newGameLink) >> br H.a "Player settings" ! (href $ toValue settingsLink) >> br- H.a "Logout " ! href (toValue logoutURL) >> br+ H.a "Advanced" ! (href $ toValue advLink) >> br+ H.a "Logout " ! (href $ toValue logoutURL) >> br -viewGameName :: Game -> RoutedNomyxServer Html-viewGameName g = do+viewGameName :: Bool -> Game -> RoutedNomyxServer Html+viewGameName isAdmin g = do let gn = _gameName g- join <- showURL (JoinGame gn)+ join <- showURL (JoinGame gn) leave <- showURL (LeaveGame gn)- view <- showURL (ViewGame gn)- ok $ do- 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 leave)- 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_ "join" ! (A.title $ toValue Help.join)- H.a "View" ! (href $ toValue view) ! A.class_ "view" ! (A.title $ toValue Help.view)+ view <- showURL (ViewGame gn)+ del <- showURL (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 leave)+ 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_ "join" ! (A.title $ toValue Help.join)+ H.a "View" ! (href $ toValue view) ! A.class_ "view" ! (A.title $ toValue Help.view) + nomyxPage :: (TVar Session) -> RoutedNomyxServer Response nomyxPage ts = do pn <- getPlayerNumber ts s <- liftIO $ atomically $ readTVar ts m <- viewMulti pn s name <- liftIO $ getPlayersName pn s+ playAs <- getPlayAs ts+ playAsName <- liftIO $ getPlayersName playAs s+ let body = do+ string $ "Welcome to Nomyx, " ++ name ++ "! "+ when (playAs /= pn) $ (b ! A.style "color:red;" $ string ("Playing as: " ++ playAsName ++ " (Player #" ++ (show playAs) ++ ")") ) mainPage' "Welcome to Nomyx!"- (string $ "Welcome to Nomyx, " ++ name ++ "!")+ body (H.div ! A.id "multi" $ m) False @@ -127,40 +129,24 @@ routedNomyxCommands :: (TVar Session) -> PlayerCommand -> RoutedNomyxServer Response routedNomyxCommands ts (U_AuthProfile auth) = authenticate ts auth-routedNomyxCommands ts NewPlayer = createNewPlayer ts+routedNomyxCommands ts PostAuth = postAuthenticate ts routedNomyxCommands ts HomePage = homePage ts routedNomyxCommands ts MainPage = nomyxPage ts routedNomyxCommands ts (JoinGame game) = joinGame ts game routedNomyxCommands ts (LeaveGame game) = leaveGame ts game routedNomyxCommands ts (ViewGame game) = viewGamePlayer ts game-routedNomyxCommands ts NewRule = newRule ts >>= return . toResponse-routedNomyxCommands _ NewGame = newGamePage >>= return . toResponse-routedNomyxCommands ts SubmitNewGame = newGamePost ts >>= return . toResponse-routedNomyxCommands ts (DoInputChoice en) = newInputChoice en ts >>= return . toResponse-routedNomyxCommands ts (DoInputString en) = newInputString en ts >>= return . toResponse-routedNomyxCommands ts Upload = newUpload ts >>= return . toResponse-routedNomyxCommands ts PSettings = settings ts >>= return . toResponse-routedNomyxCommands ts SubmitPlayerSettings = newSettings ts >>= return . toResponse------uploadForm :: NomyxForm (FilePath, FilePath, ContentType)-uploadForm = RB.inputFile--newUpload :: (TVar Session) -> RoutedNomyxServer Html-newUpload ts = do- methodM POST- pn <- getPlayerNumber ts- r <- liftRouteT $ eitherForm environment "user" uploadForm- link <- showURL MainPage- (T.Session sh _ _) <- liftIO $ readTVarIO ts- case r of- (Right (path,name,_)) -> webCommand ts $ M.inputUpload pn path name sh- (Left _) -> liftIO $ putStrLn $ "cannot retrieve form data"- seeOther link $ string "Redirecting..."-+routedNomyxCommands ts (DelGame game) = delGame ts game+routedNomyxCommands ts NewRule = newRule ts >>= return . toResponse+routedNomyxCommands _ NewGame = newGamePage >>= return . toResponse+routedNomyxCommands ts SubmitNewGame = newGamePost ts >>= return . toResponse+routedNomyxCommands ts (DoInput en) = newInput en ts >>= return . toResponse+routedNomyxCommands ts Upload = newUpload ts >>= return . toResponse+routedNomyxCommands ts W.PlayerSettings = playerSettings ts >>= return . toResponse+routedNomyxCommands ts SubmitPlayerSettings = newPlayerSettings ts >>= return . toResponse+routedNomyxCommands ts Advanced = advanced ts >>= return . toResponse+routedNomyxCommands ts SubmitPlayAs = newPlayAsSettings ts >>= return . toResponse+routedNomyxCommands ts SubmitAdminPass = newAdminPass ts >>= return . toResponse+routedNomyxCommands ts SubmitSettings = newSettings ts >>= return . toResponse launchWebServer :: (TVar Session) -> Network -> IO () launchWebServer tm net = do@@ -172,9 +158,9 @@ --serving Nomyx web page as well as data from this package and the language library package server :: FilePath -> FilePath -> (TVar Session) -> Network -> ServerPartT IO Response server d d' tm net = mconcat [- serveDirectory EnableBrowsing [] d,- serveDirectory EnableBrowsing [] d', do- decodeBody (defaultBodyPolicy "/tmp/" 102400 4096 4096)+ serveDirectory DisableBrowsing [] d,+ serveDirectory DisableBrowsing [] d',+ do decodeBody (defaultBodyPolicy "/tmp/" 102400 4096 4096) html <- implSite (pack (nomyxURL net)) "/Nomyx" (nomyxSite tm) return $ toResponse html]
src/Web/NewGame.hs view
@@ -7,7 +7,7 @@ import Prelude hiding (div) import Text.Reform import Text.Blaze.Html5.Attributes hiding (label)-import Text.Reform.Blaze.String hiding (form)+import Text.Reform.Blaze.String as RB hiding (form) import qualified Text.Reform.Blaze.Common as RBC import Text.Reform.Happstack() import Control.Applicative@@ -28,12 +28,12 @@ data NewGameForm = NewGameForm GameName GameDesc newGameForm :: NomyxForm NewGameForm-newGameForm = pure NewGameForm <*> (br ++> errorList ++> label "Enter new game name: " ++> (inputText "") `transformEither` (fieldRequired GameNameRequired) `RBC.setAttr` placeholder "Game name" <++ br <++ br)- <*> newGameDesc+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 ++> (inputText "") `RBC.setAttr` placeholder "Agora URL (including http://...)" `RBC.setAttr` class_ "agora" <++ 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@@ -46,6 +46,7 @@ "New game" (blazeForm mf newGameLink) False+ True newGamePost :: (TVar Session) -> RoutedNomyxServer Html newGamePost ts = do@@ -55,7 +56,7 @@ newGameLink <- showURL SubmitNewGame pn <- getPlayerNumber ts case r of- Left errorForm -> mainPage "New game" "New game" (blazeForm errorForm newGameLink) False+ Left errorForm -> mainPage "New game" "New game" (blazeForm errorForm newGameLink) False True Right (NewGameForm name desc) -> do webCommand ts $ newGame name desc pn seeOther link $ string "Redirecting..."
src/Web/Settings.hs view
@@ -7,8 +7,10 @@ import Prelude hiding (div) import Text.Reform-import Text.Reform.Blaze.String hiding (form)+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@@ -19,60 +21,208 @@ import Control.Concurrent.STM import Data.Maybe import Data.Text(Text)-import Text.Blaze.Internal(string)-import Multi+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) default (Integer, Double, Data.Text.Text) ---settingsForm :: (Maybe PlayerSettings) -> [PlayerName]-> NomyxForm PlayerSettings-settingsForm (Just prof) ns = settingsForm' (_pPlayerName prof) (_mailTo prof) (_mailNewRule prof) ns-settingsForm Nothing ns = settingsForm' "" "" True ns+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 -settingsForm':: String -> String -> Bool -> [PlayerName] -> NomyxForm PlayerSettings-settingsForm' name mailTo mailNewRule names = pure Types.PlayerSettings- <*> errorList ++> label "Player Name: " ++> (inputText name) `transformEither` (uniqueName names) `transformEither` (fieldRequired PlayerNameRequired) <++ br- <*> label "Please enter your mail: " ++> inputText mailTo <++ br- <*> pure True --label " send mail on new input needed from you: " ++> inputCheckbox True <++ label " " <++ br- <*> inputCheckbox mailNewRule <++ label " I want to be notified by email when a player proposes a new rule in my game (recommended)" <++ br- <*> pure True --label " send mail on new output: " ++> inputCheckbox True <++ label " "+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 UniquePlayerName+ 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] -> RoutedNomyxServer Html-settingsPage ps ns = do+settingsPage :: PlayerSettings -> [PlayerName] -> [String] -> RoutedNomyxServer Html+settingsPage ps names emails = do settingsLink <- showURL SubmitPlayerSettings- mf <- lift $ viewForm "user" $ settingsForm (Just ps) ns+ mf <- lift $ viewForm "user" $ playerSettingsForm (Just ps) names emails mainPage "Player settings" "Player settings" (blazeForm mf settingsLink) False+ True -settings :: (TVar Session) -> RoutedNomyxServer Html-settings ts = do- s <- liftIO $ atomically $ readTVar ts+playerSettings :: (TVar Session) -> RoutedNomyxServer Html+playerSettings ts = do pn <- getPlayerNumber ts- pfd <- getProfile s pn- pfs <- liftIO $ getAllProfiles s- let pfs' = filter (\a -> (_pPlayerNumber a /= pn)) pfs- settingsPage (_pPlayerSettings $ fromJust pfd) ((_pPlayerName . _pPlayerSettings) <$> pfs')+ pfd <- getProfile' ts pn+ names <- liftIO $ forbiddenNames ts pn+ emails <- liftIO $ forbiddenEmails ts pn+ settingsPage (_pPlayerSettings $ fromJust pfd) names emails +newPlayerSettings :: (TVar Session) -> RoutedNomyxServer Html+newPlayerSettings ts = 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 Html+advanced ts = do+ pn <- getPlayerNumber ts+ pfd <- getProfile' ts pn+ session <- liftIO $ atomically $ readTVar ts+ page <- advancedPage (_pLastUpload $ fromJust pfd) (_pAdmin $ fromJust pfd) (_mSettings $ _multi session)+ mainPage "Advanced" "Advanced" page False True+++advancedPage :: LastUpload -> Admin -> Settings -> RoutedNomyxServer Html+advancedPage mlu (Admin admin (PlayAs mpn)) settings = 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)+ ok $ do+ p $ do+ pre $ string Help.getSaveFile+ H.a "get save file" ! (href $ "/Nomyx.save")+ 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:"+ 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)+ p $ do+ h5 "Send mails:"+ blazeForm set submitSettings+ h5 $ string $ if (_sendMails settings) then "mails will be sent " else "mails will NOT be sent "++++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 Html+newPlayAsSettings ts = 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 Html newSettings ts = 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 Html+newUpload ts = 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 Html+newAdminPass ts = do+ methodM POST+ p <- liftRouteT $ eitherForm environment "user" $ adminPassForm pn <- getPlayerNumber ts- p <- liftRouteT $ eitherForm environment "user" $ settingsForm Nothing []- link <- showURL MainPage- settingsLink <- showURL SubmitPlayerSettings case p of Right ps -> do- webCommand ts $ playerSettings ps pn+ webCommand ts $ adminPass ps pn+ link <- showURL Advanced seeOther link $ string "Redirecting..."- (Left errorForm) -> mainPage "Player settings" "Player settings" (blazeForm errorForm settingsLink) False+ (Left errorForm) -> do+ settingsLink <- showURL SubmitAdminPass+ mainPage "Admin settings" "Admin settings" (blazeForm errorForm settingsLink) False True