diff --git a/Nomyx.cabal b/Nomyx.cabal --- a/Nomyx.cabal +++ b/Nomyx.cabal @@ -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 diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -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 diff --git a/data/static/css/nomyx.css b/data/static/css/nomyx.css --- a/data/static/css/nomyx.css +++ b/data/static/css/nomyx.css @@ -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%; +} diff --git a/data/static/pictures/help.jpg b/data/static/pictures/help.jpg new file mode 100644 Binary files /dev/null and b/data/static/pictures/help.jpg differ diff --git a/src/Interpret.hs b/src/Interpret.hs --- a/src/Interpret.hs +++ b/src/Interpret.hs @@ -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 diff --git a/src/Mail.hs b/src/Mail.hs --- a/src/Mail.hs +++ b/src/Mail.hs @@ -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) - diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Multi.hs b/src/Multi.hs --- a/src/Multi.hs +++ b/src/Multi.hs @@ -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 diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -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) diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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] ) diff --git a/src/Utils.hs b/src/Utils.hs --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 diff --git a/src/Web/Common.hs b/src/Web/Common.hs --- a/src/Web/Common.hs +++ b/src/Web/Common.hs @@ -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 \ -> Html -- ^ contents to put inside \ -> 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 \ -> Html -- ^ contents to put inside \ -> 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 diff --git a/src/Web/Game.hs b/src/Web/Game.hs --- a/src/Web/Game.hs +++ b/src/Web/Game.hs @@ -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) diff --git a/src/Web/Help.hs b/src/Web/Help.hs --- a/src/Web/Help.hs +++ b/src/Web/Help.hs @@ -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 \n" diff --git a/src/Web/Login.hs b/src/Web/Login.hs --- a/src/Web/Login.hs +++ b/src/Web/Login.hs @@ -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 = diff --git a/src/Web/MainPage.hs b/src/Web/MainPage.hs --- a/src/Web/MainPage.hs +++ b/src/Web/MainPage.hs @@ -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] diff --git a/src/Web/NewGame.hs b/src/Web/NewGame.hs --- a/src/Web/NewGame.hs +++ b/src/Web/NewGame.hs @@ -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..." diff --git a/src/Web/Settings.hs b/src/Web/Settings.hs --- a/src/Web/Settings.hs +++ b/src/Web/Settings.hs @@ -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