diff --git a/Nomyx.cabal b/Nomyx.cabal --- a/Nomyx.cabal +++ b/Nomyx.cabal @@ -1,5 +1,5 @@ name: Nomyx -version: 0.3.0 +version: 0.3.1 cabal-version: >=1.6 build-type: Simple license: BSD3 @@ -11,6 +11,7 @@ Nomyx is a fabulous and strange game where you have the right to change the rules in the middle of the game! Indeed, changing the rules is the goal of the game. Changing a rule is considered as a move. Of course even that could be changed! The original (paper) game: www.nomic.net category: game +Homepage: www.nomyx.net author: Corentin Dupont data-files: static/css/nomyx.css static/nomyx.js @@ -19,7 +20,7 @@ extra-source-files: AUTHORS README TODO executable Nomyx - build-depends: Nomyx-Language ==0.3.0, + build-depends: Nomyx-Language ==0.3.1, base <5, Cabal -any, DebugTraceHelpers -any, diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -17,6 +17,12 @@ - fix facebook - vote: include new players, delete leaving players - make settings file with start up rules +- make/fix deployement: + - the interpreter needs GHC to be installed: is that right? + - the Web application needs to access files from the library (Nomyx-Language) + - the interpreter needs the library to be installed to read the modules +- rules should communicate by message passing instead of shared variables + Futur Nomic: - ability to analyse rules, proof system 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 Paths_Nomyx import Language.Nomyx import System.Directory import System.FilePath @@ -28,12 +27,11 @@ "Control.Arrow"] -- | the server handle -startInterpreter :: IO ServerHandle -startInterpreter = do +startInterpreter :: FilePath -> IO ServerHandle +startInterpreter dataDir = do h <- start - dataDir <- liftIO getDataDir liftIO $ createDirectoryIfMissing True $ dataDir modDir - ir <- runIn h initializeInterpreter + ir <- runIn h $ initializeInterpreter dataDir case ir of Right r -> do putStrLn "Interpreter Loaded" @@ -41,20 +39,18 @@ Left e -> error $ "sHandle: initialization error:\n" ++ show e return h -getUploadModules :: IO([FilePath]) -getUploadModules = do - dataDir <- getDataDir +getUploadModules :: FilePath -> IO([FilePath]) +getUploadModules dataDir = do all <- getDirectoryContents $ dataDir modDir files <- filterM (getFileStatus . (\f -> joinPath [dataDir, modDir, f]) >=> return . isRegularFile) all return $ map (\f -> joinPath [dataDir, modDir, f]) files -- | initializes the interpreter by loading some modules. -initializeInterpreter :: Interpreter () -initializeInterpreter = do - fmods <- liftIO getUploadModules +initializeInterpreter :: FilePath -> Interpreter () +initializeInterpreter dataDir = do + fmods <- liftIO $ getUploadModules dataDir loadModules fmods setTopLevelModules $ map (dropExtension . takeFileName) fmods - dataDir <- liftIO getDataDir set [searchPath := [dataDir], languageExtensions := [GADTs, ScopedTypeVariables]] --, installedModulesInScope := False setImports importList return () @@ -81,25 +77,24 @@ -- | check an uploaded file and reload -loadModule :: FilePath -> FilePath -> ServerHandle -> IO (Either InterpreterError ()) -loadModule tempModName name sh = do - dataDir <- getDataDir - c <- checkModule tempModName sh +loadModule :: FilePath -> FilePath -> ServerHandle -> FilePath -> IO (Either InterpreterError ()) +loadModule tempModName name sh dataDir = do + c <- checkModule tempModName sh dataDir case c of Right _ -> do let dest = (dataDir modDir name) copyFile tempModName dest setFileMode dest (ownerModes + groupModes) - runIn sh $ initializeInterpreter + runIn sh $ initializeInterpreter dataDir return $ Right () Left e -> do - runIn sh $ initializeInterpreter + runIn sh $ initializeInterpreter dataDir return $ Left e ---- | check if a module is valid. Context will be reset. -checkModule :: FilePath -> ServerHandle -> IO (Either InterpreterError ()) -checkModule dir sh = runIn sh $ do - fmods <- liftIO getUploadModules +checkModule :: FilePath -> ServerHandle -> FilePath -> IO (Either InterpreterError ()) +checkModule dir sh dataDir = runIn sh $ do + fmods <- liftIO $ getUploadModules dataDir liftIO $ putStrLn $ concat $ fmods loadModules (dir:fmods) diff --git a/src/Mail.hs b/src/Mail.hs --- a/src/Mail.hs +++ b/src/Mail.hs @@ -69,7 +69,7 @@ putStrLn "Sending mails" gn <- fromJust <$> getPlayersGame pn s let sendMailsTo = delete pn (map _playerNumber (_players $ _game gn)) - proposer <- getPlayersName pn s + proposer <- Utils.getPlayerName pn s profiles <- mapM (getProfile s) sendMailsTo mapM_ (send proposer (_net $ _mSettings $ _multi s) sr) (_pPlayerSettings <$> catMaybes profiles) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -33,6 +33,7 @@ import Types import Serialize import Paths_Nomyx as PN +import Paths_Nomyx_Language as PNL import System.Directory import Data.Time.Clock import Language.Nomyx hiding (getCurrentTime) @@ -61,7 +62,7 @@ args <- getArgs (flags, _) <- nomyxOpts args if (Version `elem` flags) then do - putStrLn $ "Nomyx " ++ showVersion version + putStrLn $ "Nomyx " ++ showVersion PN.version return True else if (Help `elem` flags) then do putStrLn $ usageInfo header options @@ -76,18 +77,21 @@ start :: [Flag] -> IO () start flags = do serverCommandUsage - --start the haskell interpreter - sh <- protectHandlers startInterpreter + defDataDir <- PN.getDataDir + defSourceDir <- PNL.getDataDir hostName <- getHostName logFilePath <- case (findSaveFile flags) of Just f -> canonicalizePath f - Nothing -> getDataFileName defaultLogFile + Nothing -> PN.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 + let dataDir = fromMaybe defDataDir (findDataDir flags) + let sourceDir = fromMaybe defSourceDir (findSourceDir flags) + let settings = Settings logFilePath (Network host port) sendMail adminPass dataDir sourceDir + --start the haskell interpreter + sh <- protectHandlers $ startInterpreter dataDir if Test `elem` flags then do putStrLn $ "\nNomyx Language Tests results:\n" ++ (concatMap (\(a,b) -> a ++ ": " ++ (show b) ++ "\n") LT.tests) ts <- playTests sh @@ -154,7 +158,9 @@ | DeleteSaveFile | AdminPass String | Mails - | Help + | Help + | DataDir FilePath + | SourceDir FilePath deriving (Show, Eq) -- | launch options description @@ -172,6 +178,8 @@ , 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)" + , Option ['f'] ["dataDir"] (ReqArg DataDir "DataDir") "set data directory" + , Option ['s'] ["sourceDir"] (ReqArg SourceDir "SourceDir") "set source directory" ] nomyxOpts :: [String] -> IO ([Flag], [String]) @@ -207,6 +215,16 @@ findAdminPass fs = headMay $ catMaybes $ map isAdminPass fs where isAdminPass (AdminPass a) = Just a isAdminPass _ = Nothing + +findDataDir :: [Flag] -> Maybe String +findDataDir fs = headMay $ catMaybes $ map isDataDir fs where + isDataDir (DataDir a) = Just a + isDataDir _ = Nothing + +findSourceDir :: [Flag] -> Maybe String +findSourceDir fs = headMay $ catMaybes $ map isSourceDir fs where + isSourceDir (SourceDir a) = Just a + isSourceDir _ = 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 @@ -62,8 +62,8 @@ joinGame :: GameName -> PlayerNumber -> StateT Session IO () joinGame game pn = do s <- get - name <- lift $ getPlayersName pn s - focus multi $ inGameDo game $ G.update $ JoinGame pn name + name <- lift $ Utils.getPlayerName pn s + inGameDo game $ G.update $ JoinGame pn name viewGamePlayer game pn -- | del a game.delGame :: GameName -> StateT Session IO () @@ -72,56 +72,57 @@ -- | leave a game. leaveGame :: GameName -> PlayerNumber -> StateT Session IO () -leaveGame game pn = focus multi $ inGameDo game $ G.update $ LeaveGame pn +leaveGame game pn = 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 +submitRule :: SubmitRule -> PlayerNumber -> GameName -> ServerHandle -> StateT Session IO () +submitRule sr@(SubmitRule _ _ code) pn gn sh = do tracePN pn $ "proposed " ++ (show sr) mrr <- liftIO $ interpretRule code sh case mrr of Right _ -> do tracePN pn $ "proposed rule compiled OK " - inPlayersGameDo_ pn $ G.update' (Just $ getRuleFunc sh) (ProposeRuleEv pn sr) + inGameDo gn $ G.update' (Just $ getRuleFunc sh) (ProposeRuleEv pn sr) modifyProfile pn (pLastRule ^= Nothing) Left e -> do let errorMsg = showInterpreterError e - inPlayersGameDo_ pn $ update $ GLog (Just pn) ("Error in submitted rule: " ++ errorMsg) + inGameDo gn $ 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 +adminSubmitRule :: SubmitRule -> PlayerNumber -> GameName -> ServerHandle -> StateT Session IO () +adminSubmitRule sr@(SubmitRule _ _ code) pn gn sh = do tracePN pn $ "proposed " ++ (show sr) mrr <- liftIO $ interpretRule code sh case mrr of Right _ -> do tracePN pn $ "proposed rule compiled OK " - inPlayersGameDo_ pn $ update' (Just $ getRuleFunc sh) (SystemAddRule sr) + inGameDo gn $ 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) + inGameDo gn $ update $ GLog (Just pn) ("Error in submitted rule: " ++ errorMsg) tracePN pn ("Error in submitted rule: " ++ errorMsg) modifyProfile pn (pLastRule ^= Just (sr, errorMsg)) -inputResult :: PlayerNumber -> EventNumber -> UInputData -> StateT Session IO () -inputResult pn en ir = inPlayersGameDo_ pn $ update $ InputResult pn en ir +inputResult :: PlayerNumber -> EventNumber -> UInputData -> GameName -> StateT Session IO () +inputResult pn en ir gn = inGameDo gn $ update $ InputResult pn en ir -- | upload a rule file inputUpload :: PlayerNumber -> FilePath -> String -> ServerHandle -> StateT Session IO () inputUpload pn temp mod sh = do - m <- liftIO $ loadModule temp mod sh + dataDir <- access (multi >>> mSettings >>> dataDir) + m <- liftIO $ loadModule temp mod sh dataDir tracePN pn $ " uploaded " ++ (show mod) case m of Right _ -> do - inPlayersGameDo_ pn $ update $ GLog (Just pn) ("File loaded: " ++ show temp ++ ", as " ++ show mod ++"\n") + inPlayersGameDo pn $ update $ GLog (Just pn) ("File loaded: " ++ show temp ++ ", as " ++ show mod ++"\n") tracePN pn "upload success" modifyProfile pn (pLastUpload ^= UploadSuccess) Left e -> do let errorMsg = showInterpreterError e - inPlayersGameDo_ pn $ update $ GLog (Just pn) ("Error in file: " ++ show e ++ "\n") + inPlayersGameDo pn $ update $ GLog (Just pn) ("Error in file: " ++ show e ++ "\n") tracePN pn "upload failed" modifyProfile pn (pLastUpload ^= UploadFailure (temp, errorMsg)) @@ -130,7 +131,7 @@ playerSettings playerSettings pn = modifyProfile pn (pPlayerSettings ^= playerSettings) playAsSetting :: (Maybe PlayerNumber) -> PlayerNumber -> StateT Session IO () -playAsSetting mpn pn = modifyProfile pn ((pAdmin >>> pPlayAs) ^= PlayAs mpn) +playAsSetting mpn pn = modifyProfile pn ((pAdmin >>> pPlayAs) ^= mpn) adminPass :: String -> PlayerNumber -> StateT Session IO () adminPass pass pn = do @@ -170,11 +171,8 @@ focus multi $ modifyGame myg return (Just a) -inPlayersGameDo_ :: PlayerNumber -> StateT LoggedGame IO a -> StateT Session IO () -inPlayersGameDo_ pn action = inPlayersGameDo pn action >> return () - -inGameDo :: GameName -> StateT LoggedGame IO () -> StateT Multi IO () -inGameDo gn action = do +inGameDo :: GameName -> StateT LoggedGame IO () -> StateT Session IO () +inGameDo gn action = focus multi $ do (gs :: [LoggedGame]) <- access games case find ((==gn) . getL (game >>> gameName)) gs of Nothing -> traceM "No game by that name" 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) @@ -118,8 +118,8 @@ submitR r = do onePlayerOneGame sh <- access sh - submitRule (SubmitRule "" "" r) 1 sh - inputResult 1 3 (URadioData 0) + submitRule (SubmitRule "" "" r) 1 "test" sh + inputResult 1 3 (URadioData 0) "test" gameHelloWorld :: StateT Session IO () gameHelloWorld = submitR [cr|helloWorld|] @@ -131,9 +131,9 @@ gameHelloWorld2Players = do twoPlayersOneGame sh <- access sh - submitRule (SubmitRule "" "" [cr|helloWorld|]) 1 sh - inputResult 1 3 (URadioData 0) - inputResult 2 4 (URadioData 0) + submitRule (SubmitRule "" "" [cr|helloWorld|]) 1 "test" sh + inputResult 1 3 (URadioData 0) "test" + inputResult 2 4 (URadioData 0) "test" condHelloWorld2Players :: Multi -> Bool condHelloWorld2Players m = isOutput "hello, world!" m @@ -184,17 +184,17 @@ gameMoneyTransfer = do sh <- access sh twoPlayersOneGame - submitRule (SubmitRule "" "" [cr|createBankAccount|]) 1 sh - submitRule (SubmitRule "" "" [cr|winXEcuOnRuleAccepted 100|]) 1 sh - submitRule (SubmitRule "" "" [cr|moneyTransfer|]) 2 sh - 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 + submitRule (SubmitRule "" "" [cr|createBankAccount|]) 1 "test" sh + submitRule (SubmitRule "" "" [cr|winXEcuOnRuleAccepted 100|]) 1 "test" sh + submitRule (SubmitRule "" "" [cr|moneyTransfer|]) 2 "test" sh + inputResult 1 4 (URadioData 0) "test" + inputResult 2 3 (URadioData 0) "test" + inputResult 1 9 (URadioData 0) "test" + inputResult 2 8 (URadioData 0) "test" + inputResult 1 14 (URadioData 0) "test" + inputResult 2 13 (URadioData 0) "test" + inputResult 1 5 (URadioData 0) "test" + inputResult 1 0 (UTextData "50") "test"--TODO find event number condMoneyTransfer :: Multi -> Bool condMoneyTransfer m = (_vName $ head $ _variables $ G._game $ head $ _games m) == "Accounts" diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances, TypeFamilies, NamedFieldPuns, TemplateHaskell, FlexibleContexts, RecordWildCards, GeneralizedNewtypeDeriving #-} @@ -12,11 +11,10 @@ import Language.Haskell.Interpreter.Server (ServerHandle) import Data.Acid (makeAcidic, Update, Query, AcidState) import Happstack.Auth (ProfileState, AuthState) -import Data.Text (Text) import Data.Data (Data) -import Data.IxSet (toList, (@=), getOne, inferIxSet, noCalcs) +import Data.IxSet (toList, (@=), inferIxSet, noCalcs) import qualified Data.IxSet as IxSet -import Data.SafeCopy (SafeCopy, base, deriveSafeCopy) +import Data.SafeCopy (base, deriveSafeCopy) import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.State.Class (MonadState(..)) import Safe @@ -34,8 +32,6 @@ 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, @@ -51,7 +47,9 @@ data Settings = Settings { _logFilePath :: FilePath, _net :: Network, _sendMails :: Bool, - _adminPassword :: String} + _adminPassword :: String, + _dataDir :: FilePath, + _sourceDir :: FilePath} deriving (Eq, Show, Read, Typeable) --- | A structure to hold the active games and players @@ -60,12 +58,12 @@ deriving (Eq, Read, Show, Typeable) data Admin = Admin { _isAdmin :: Bool, - _pPlayAs :: PlayAs} + _pPlayAs :: Maybe PlayerNumber} deriving (Eq, Show, Read, Ord, Typeable, Data) $(deriveSafeCopy 1 'base ''Admin) defaultAdmin :: Admin -defaultAdmin = Admin False (PlayAs Nothing) +defaultAdmin = Admin False Nothing -- | 'ProfileData' contains application specific data ProfileData = diff --git a/src/Utils.hs b/src/Utils.hs --- a/src/Utils.hs +++ b/src/Utils.hs @@ -50,15 +50,15 @@ nomyxURL :: Network -> String nomyxURL (Network host port) = "http://" ++ host ++ ":" ++ (show port) -getPlayersName :: PlayerNumber -> Session -> IO PlayerName -getPlayersName pn s = do +getPlayerName :: PlayerNumber -> Session -> IO PlayerName +getPlayerName pn s = do pfd <- A.query' (acidProfileData $ _profiles s) (AskProfileData pn) return $ _pPlayerName $ _pPlayerSettings $ fromJustNote ("getPlayersName: no profile for pn=" ++ (show pn)) pfd -getPlayersName' :: Game -> PlayerNumber -> PlayerName -getPlayersName' g pn = do +getPlayerInGameName :: Game -> PlayerNumber -> PlayerName +getPlayerInGameName g pn = do case find ((==pn) . getL playerNumber) (_players g) of - Nothing -> error "getPlayersName: No player by that number in that game" + Nothing -> error "getPlayersName': No player by that number in that game" Just pm -> _playerName pm -- | returns the game the player is in @@ -98,8 +98,7 @@ modifyProfile pn mod = do s <- get pfd <- A.query' (acidProfileData $ _profiles s) (AskProfileData pn) - A.update' (acidProfileData $ _profiles s) (SetProfileData (mod $ fromJustNote "modifyProfile" pfd)) - return () + when (isJust pfd) $ void $ A.update' (acidProfileData $ _profiles s) (SetProfileData (mod $ fromJust pfd)) getProfile :: MonadIO m => Session -> PlayerNumber -> m (Maybe ProfileData) getProfile s pn = A.query' (acidProfileData $ _profiles s) (AskProfileData pn) diff --git a/src/Web/Common.hs b/src/Web/Common.hs --- a/src/Web/Common.hs +++ b/src/Web/Common.hs @@ -73,8 +73,8 @@ | JoinGame GameName | LeaveGame GameName | DelGame GameName - | DoInput EventNumber - | NewRule + | DoInput EventNumber GameName + | NewRule GameName | NewGame | SubmitNewGame | Upload @@ -224,7 +224,7 @@ -- | return the player number (user ID) based on the session cookie. getPlayerNumber :: (TVar Session) -> RoutedNomyxServer PlayerNumber getPlayerNumber ts = do - s@(T.Session _ _ (Profiles acidAuth acidProfile _)) <- liftIO $ readTVarIO ts + (T.Session _ _ (Profiles acidAuth acidProfile _)) <- liftIO $ readTVarIO ts uid <- getUserId acidAuth acidProfile case uid of Nothing -> error "not logged in." @@ -235,7 +235,7 @@ getPlayAs ts = do pn <- getPlayerNumber ts pf <- getProfile' ts pn - case pf >>= _playAs . _pPlayAs . _pAdmin of + case pf >>= _pPlayAs . _pAdmin of Just playAs -> return playAs Nothing -> return pn diff --git a/src/Web/Game.hs b/src/Web/Game.hs --- a/src/Web/Game.hs +++ b/src/Web/Game.hs @@ -38,13 +38,15 @@ import Data.Typeable import Data.Time import System.Locale +import Data.Lens +import Control.Category hiding ((.)) default (Integer, Double, Data.Text.Text) viewGame :: Game -> PlayerNumber -> (Maybe LastRule) -> Bool -> RoutedNomyxServer Html viewGame g pn mlr isAdmin = do let inGame = isJust $ Utils.getPlayer g pn - rf <- viewRuleForm mlr inGame isAdmin - vios <- viewIOs pn (_rules g) (_events g) (_outputs g) + rf <- viewRuleForm mlr inGame isAdmin (_gameName g) + vios <- viewIOs pn (_rules g) (_events g) (_outputs g) (_gameName g) ok $ table $ do tr $ td $ div ! A.id "gameDesc" $ viewGameDesc g pn tr $ td $ div ! A.id "rules" $ viewAllRules g @@ -156,24 +158,24 @@ 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) +viewIOs :: PlayerNumber -> [Rule] -> [EventHandler] -> [Output] -> GameName -> RoutedNomyxServer Html +viewIOs pn rs ehs os gn = do + vios <- mapM (viewIORule pn ehs os gn) (sort rs) ok $ do titleWithHelpIcon (h3 "Inputs/Ouputs") Help.inputsOutputs mconcat vios -viewIORule :: PlayerNumber -> [EventHandler] -> [Output] -> Rule -> RoutedNomyxServer Html -viewIORule pn ehs os r = do - vior <- viewIORuleM pn (_rNumber r) ehs os +viewIORule :: PlayerNumber -> [EventHandler] -> [Output] -> GameName -> Rule -> RoutedNomyxServer Html +viewIORule pn ehs os gn r = do + vior <- viewIORuleM pn (_rNumber r) ehs os gn ok $ when (isJust vior) $ div ! A.id "IORule" $ do div ! A.id "IORuleTitle" $ h4 $ string $ "IO for Rule \"" ++ (_rName r) ++ "\" (#" ++ (show $ _rNumber r) ++ "):" fromJust vior -viewIORuleM :: PlayerNumber -> RuleNumber -> [EventHandler] -> [Output] -> RoutedNomyxServer (Maybe Html) -viewIORuleM pn rn ehs os = do - vir <- viewInputsRule pn rn ehs +viewIORuleM :: PlayerNumber -> RuleNumber -> [EventHandler] -> [Output] -> GameName -> RoutedNomyxServer (Maybe Html) +viewIORuleM pn rn ehs os gn = do + vir <- viewInputsRule pn rn ehs gn let vor = viewOutputsRule pn rn os if (isJust vir || isJust vor) then do return $ Just $ do @@ -182,10 +184,10 @@ else return Nothing -viewInputsRule :: PlayerNumber -> RuleNumber -> [EventHandler] -> RoutedNomyxServer (Maybe Html) -viewInputsRule pn rn ehs = do +viewInputsRule :: PlayerNumber -> RuleNumber -> [EventHandler] -> GameName -> RoutedNomyxServer (Maybe Html) +viewInputsRule pn rn ehs gn = do let filtered = filter (\e -> _ruleNumber e == rn) ehs - mis <- mapM (viewInput pn) $ sort filtered + mis <- mapM (viewInput pn gn) $ sort filtered let is = catMaybes mis case is of [] -> return Nothing @@ -202,14 +204,14 @@ isPn pn (Output _ _ mypn _ SActive) = mypn == pn isPn _ _ = False -viewInput :: PlayerNumber -> EventHandler -> RoutedNomyxServer (Maybe Html) -viewInput me (EH eventNumber _ (InputEv (Input pn title iForm)) _ SActive) | me == pn = do - link <- showURL (DoInput eventNumber) +viewInput :: PlayerNumber -> GameName -> EventHandler -> RoutedNomyxServer (Maybe Html) +viewInput me gn (EH eventNumber _ (InputEv (Input pn title iForm)) _ SActive) | me == pn = do + link <- showURL (DoInput eventNumber gn) lf <- lift $ viewForm "user" $ inputForm iForm return $ Just $ tr $ td $ do string title blazeForm lf (link) ! A.id "InputForm" -viewInput _ _ = return Nothing +viewInput _ _ _ = return Nothing viewOutput :: String -> Html viewOutput s = pre $ string s >> br @@ -241,9 +243,9 @@ <*> if isAdmin then RB.inputSubmit "Admin submit" else pure Nothing -viewRuleForm :: Maybe LastRule -> Bool -> Bool -> RoutedNomyxServer Html -viewRuleForm msr inGame isAdmin = do - link <- showURL NewRule +viewRuleForm :: Maybe LastRule -> Bool -> Bool -> GameName -> RoutedNomyxServer Html +viewRuleForm msr inGame isAdmin gn = do + link <- showURL (NewRule gn) lf <- lift $ viewForm "user" (newRuleForm (fst <$> msr) isAdmin) ok $ do titleWithHelpIcon (h3 "Propose a new rule:") Help.code @@ -255,8 +257,8 @@ pre $ string $ fromJust error else lf ! A.disabled "" -newRule :: (TVar Session) -> RoutedNomyxServer Html -newRule ts = do +newRule :: (TVar Session) -> GameName -> RoutedNomyxServer Response +newRule ts gn = toResponse <$> do methodM POST s@(T.Session sh _ _) <- liftIO $ readTVarIO ts r <- liftRouteT $ eitherForm environment "user" (newRuleForm Nothing False) @@ -264,7 +266,7 @@ pn <- getPlayerNumber ts case r of Right (sr, Nothing) -> do - webCommand ts $ submitRule sr pn sh + webCommand ts $ submitRule sr pn gn sh liftIO $ do s' <- readTVarIO ts --TODO clean this gn <- getPlayersGame pn s @@ -272,7 +274,7 @@ let rs = _rules $ _game $ fromJust gn let rs' = _rules $ _game $ fromJust gn' when (length rs' > length rs) $ sendMailsNewRule s' sr pn - Right (sr, Just _) -> webCommand ts $ adminSubmitRule sr pn sh + Right (sr, Just _) -> webCommand ts $ adminSubmitRule sr pn gn sh (Left _) -> liftIO $ putStrLn $ "cannot retrieve form data" seeOther link $ string "Redirecting..." @@ -287,18 +289,18 @@ td $ string $ formatTime defaultTimeLocale "%Y/%m/%d_%H:%M" t td $ p $ string s -newInput :: EventNumber -> (TVar Session) -> RoutedNomyxServer Html -newInput en ts = do +newInput :: (TVar Session) -> EventNumber -> GameName -> RoutedNomyxServer Response +newInput ts en gn = toResponse <$> do pn <- getPlayerNumber ts s <- liftIO $ atomically $ readTVar ts - mgn <- liftIO $ getPlayersGame pn s - let eventHandler = fromJust $ findEvent en (_events $ _game $ fromJust mgn) + let g = find ((== gn) . getL (game >>> gameName)) (_games $ _multi s) + let eventHandler = fromJust $ findEvent en (_events $ _game $ fromJust g) methodM POST r <- liftRouteT $ eitherForm environment "user" (getNomyxForm eventHandler) link <- showURL MainPage case r of (Right c) -> do - webCommand ts $ M.inputResult pn en c + webCommand ts $ M.inputResult pn en c gn seeOther link $ string "Redirecting..." (Left _) -> do liftIO $ putStrLn $ "cannot retrieve form data" diff --git a/src/Web/Help.hs b/src/Web/Help.hs --- a/src/Web/Help.hs +++ b/src/Web/Help.hs @@ -16,7 +16,7 @@ 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" ++ + "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" diff --git a/src/Web/MainPage.hs b/src/Web/MainPage.hs --- a/src/Web/MainPage.hs +++ b/src/Web/MainPage.hs @@ -17,8 +17,6 @@ import Web.Routes.RouteT import Text.Blaze.Internal import Control.Monad -import Paths_Nomyx as PN -import Paths_Nomyx_Language as PNL import Control.Monad.State import Data.Monoid import Control.Concurrent.STM @@ -35,37 +33,36 @@ import Web.NewGame import Web.Login import Utils -import Data.Maybe import Data.Text(Text, pack) import qualified Language.Nomyx.Game as G import Happstack.Auth +import Safe default (Integer, Double, Data.Text.Text) -viewMulti :: PlayerNumber -> Session -> RoutedNomyxServer Html -viewMulti pn s = do +viewMulti :: PlayerNumber -> PlayerNumber -> FilePath -> Session -> RoutedNomyxServer Html +viewMulti pn playAs dataDir s = do pfd <- getProfile s pn - let isAdmin = _isAdmin $ _pAdmin $ fromJust pfd - gns <- viewGamesTab (map G._game $ _games $ _multi s) isAdmin + let isAdmin = _isAdmin $ _pAdmin $ fromJustNote "viewMulti" pfd + gns <- viewGamesTab (map G._game $ _games $ _multi s) isAdmin dataDir mgn <- liftRouteT $ lift $ getPlayersGame pn s - g <- case mgn of - Just g -> viewGame (G._game g) pn (_pLastRule $ fromJust pfd) isAdmin + vg <- case mgn of + Just g -> viewGame (G._game g) playAs (_pLastRule $ fromJustNote "viewMulti" pfd) isAdmin Nothing -> ok $ h3 "Not viewing any game" ok $ do div ! A.id "gameList" $ gns - div ! A.id "game" $ g + div ! A.id "game" $ vg -viewGamesTab :: [Game] -> Bool -> RoutedNomyxServer Html -viewGamesTab gs isAdmin = do +viewGamesTab :: [Game] -> Bool -> FilePath -> RoutedNomyxServer Html +viewGamesTab gs isAdmin dataDir = do gns <- mapM (viewGameName isAdmin) gs newGameLink <- showURL NewGame settingsLink <- showURL W.PlayerSettings advLink <- showURL Advanced logoutURL <- showURL (U_AuthProfile $ AuthURL A_Logout) - dd <- lift $ lift $ PN.getDataDir - mods <- lift $ lift $ getDirectoryContents $ dd modDir - fmods <- lift $ lift $ filterM (getFileStatus . (\f -> joinPath [dd, modDir, f]) >=> return . isRegularFile) $ mods + mods <- liftIO $ getDirectoryContents $ dataDir modDir + fmods <- liftIO $ filterM (getFileStatus . (\f -> joinPath [dataDir, modDir, f]) >=> return . isRegularFile) $ mods ok $ do h3 "Main menu" >> br "Active games:" >> br @@ -73,6 +70,7 @@ case gs of [] -> tr $ td "No Games" _ -> sequence_ gns + when isAdmin $ H.a "Create a new game" ! (href $ toValue newGameLink) >> br br >> "Nomyx language files:" >> br H.a "Rules examples" ! (href $ "/src/Language/Nomyx/Examples.hs") >> br H.a "Basic rules" ! (href $ "/src/Language/Nomyx/Rule.hs") >> br @@ -81,10 +79,9 @@ 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 >> "Settings:" >> br - when isAdmin $ H.a "Create a new game" ! (href $ toValue newGameLink) >> br H.a "Player settings" ! (href $ toValue settingsLink) >> br H.a "Advanced" ! (href $ toValue advLink) >> br - H.a "Logout " ! (href $ toValue logoutURL) >> br + H.a "Logout" ! (href $ toValue logoutURL) >> br viewGameName :: Bool -> Game -> RoutedNomyxServer Html @@ -112,13 +109,13 @@ nomyxPage ts = do pn <- getPlayerNumber ts s <- liftIO $ atomically $ readTVar ts - m <- viewMulti pn s - name <- liftIO $ getPlayersName pn s + let dataDir = _dataDir $ _mSettings $ _multi s + name <- liftIO $ Utils.getPlayerName pn s playAs <- getPlayAs ts - playAsName <- liftIO $ getPlayersName playAs s + m <- viewMulti pn playAs dataDir s let body = do string $ "Welcome to Nomyx, " ++ name ++ "! " - when (playAs /= pn) $ (b ! A.style "color:red;" $ string ("Playing as: " ++ playAsName ++ " (Player #" ++ (show playAs) ++ ")") ) + when (playAs /= pn) $ (b ! A.style "color:red;" $ string ("Playing as Player #" ++ (show playAs)) ) mainPage' "Welcome to Nomyx!" body (H.div ! A.id "multi" $ m) @@ -128,40 +125,42 @@ nomyxSite tm = setDefault HomePage $ mkSitePI (runRouteT $ routedNomyxCommands tm) routedNomyxCommands :: (TVar Session) -> PlayerCommand -> RoutedNomyxServer Response -routedNomyxCommands ts (U_AuthProfile auth) = authenticate ts auth -routedNomyxCommands ts PostAuth = postAuthenticate ts -routedNomyxCommands ts HomePage = homePage ts -routedNomyxCommands ts MainPage = nomyxPage ts -routedNomyxCommands ts (JoinGame game) = joinGame ts game -routedNomyxCommands ts (LeaveGame game) = leaveGame ts game -routedNomyxCommands ts (ViewGame game) = viewGamePlayer ts game -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 +routedNomyxCommands ts (U_AuthProfile auth) = authenticate ts auth +routedNomyxCommands ts PostAuth = postAuthenticate ts +routedNomyxCommands ts HomePage = homePage ts +routedNomyxCommands ts MainPage = nomyxPage ts +routedNomyxCommands ts (JoinGame game) = joinGame ts game +routedNomyxCommands ts (LeaveGame game) = leaveGame ts game +routedNomyxCommands ts (ViewGame game) = viewGamePlayer ts game +routedNomyxCommands ts (DelGame game) = delGame ts game +routedNomyxCommands ts (NewRule game) = newRule ts game +routedNomyxCommands _ NewGame = newGamePage +routedNomyxCommands ts SubmitNewGame = newGamePost ts +routedNomyxCommands ts (DoInput en game) = newInput ts en game +routedNomyxCommands ts Upload = newUpload ts +routedNomyxCommands ts W.PlayerSettings = playerSettings ts +routedNomyxCommands ts SubmitPlayerSettings = newPlayerSettings ts +routedNomyxCommands ts Advanced = advanced ts +routedNomyxCommands ts SubmitPlayAs = newPlayAsSettings ts +routedNomyxCommands ts SubmitAdminPass = newAdminPass ts +routedNomyxCommands ts SubmitSettings = newSettings ts launchWebServer :: (TVar Session) -> Network -> IO () launchWebServer tm net = do putStrLn $ "Starting web server...\nTo connect, drive your browser to \"" ++ nomyxURL net ++ "/Nomyx\"" - d <- PN.getDataDir - d' <- PNL.getDataDir - simpleHTTP nullConf {HS.port = T._port net} $ server d d' tm net + simpleHTTP nullConf {HS.port = T._port net} $ server tm net --serving Nomyx web page as well as data from this package and the language library package -server :: FilePath -> FilePath -> (TVar Session) -> Network -> ServerPartT IO Response -server d d' tm net = mconcat [ +server :: (TVar Session) -> Network -> ServerPartT IO Response +server ts net = do + s <- liftIO $ atomically $ readTVar ts + let d = _dataDir $ _mSettings $ _multi s + let d' = _sourceDir $ _mSettings $ _multi s + mconcat [ serveDirectory DisableBrowsing [] d, serveDirectory DisableBrowsing [] d', do decodeBody (defaultBodyPolicy "/tmp/" 102400 4096 4096) - html <- implSite (pack (nomyxURL net)) "/Nomyx" (nomyxSite tm) + html <- implSite (pack (nomyxURL net)) "/Nomyx" (nomyxSite ts) 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 @@ -3,7 +3,6 @@ module Web.NewGame where -import Text.Blaze.Html5 hiding (map, label, br, textarea) import Prelude hiding (div) import Text.Reform import Text.Blaze.Html5.Attributes hiding (label) @@ -38,8 +37,8 @@ gameNameRequired :: String -> Either NomyxError String gameNameRequired = fieldRequired GameNameRequired -newGamePage :: RoutedNomyxServer Html -newGamePage = do +newGamePage :: RoutedNomyxServer Response +newGamePage = toResponse <$> do newGameLink <- showURL SubmitNewGame mf <- lift $ viewForm "user" $ newGameForm mainPage "New game" @@ -48,8 +47,8 @@ False True -newGamePost :: (TVar Session) -> RoutedNomyxServer Html -newGamePost ts = do +newGamePost :: (TVar Session) -> RoutedNomyxServer Response +newGamePost ts = toResponse <$> do methodM POST r <- liftRouteT $ eitherForm environment "user" newGameForm link <- showURL MainPage diff --git a/src/Web/Settings.hs b/src/Web/Settings.hs --- a/src/Web/Settings.hs +++ b/src/Web/Settings.hs @@ -67,16 +67,16 @@ False True -playerSettings :: (TVar Session) -> RoutedNomyxServer Html -playerSettings ts = do +playerSettings :: (TVar Session) -> RoutedNomyxServer Response +playerSettings ts = toResponse <$> do pn <- getPlayerNumber ts pfd <- getProfile' ts pn names <- liftIO $ forbiddenNames ts pn emails <- liftIO $ forbiddenEmails ts pn settingsPage (_pPlayerSettings $ fromJust pfd) names emails -newPlayerSettings :: (TVar Session) -> RoutedNomyxServer Html -newPlayerSettings ts = do +newPlayerSettings :: (TVar Session) -> RoutedNomyxServer Response +newPlayerSettings ts = toResponse <$> do methodM POST pn <- getPlayerNumber ts names <- liftIO $ forbiddenNames ts pn @@ -106,17 +106,19 @@ return $ filter (not . null) $ (_mail . _pPlayerSettings) <$> filteredPfs -advanced :: (TVar Session) -> RoutedNomyxServer Html -advanced ts = do +advanced :: (TVar Session) -> RoutedNomyxServer Response +advanced ts = toResponse <$> do + session <- liftIO $ atomically $ readTVar ts pn <- getPlayerNumber ts - pfd <- getProfile' ts pn + pfd <- getProfile session pn + pfds <- liftIO $ getAllProfiles session session <- liftIO $ atomically $ readTVar ts - page <- advancedPage (_pLastUpload $ fromJust pfd) (_pAdmin $ fromJust pfd) (_mSettings $ _multi session) + page <- advancedPage (_pLastUpload $ fromJust pfd) (_pAdmin $ fromJust pfd) (_mSettings $ _multi session) pfds mainPage "Advanced" "Advanced" page False True -advancedPage :: LastUpload -> Admin -> Settings -> RoutedNomyxServer Html -advancedPage mlu (Admin admin (PlayAs mpn)) settings = do +advancedPage :: LastUpload -> Admin -> Settings -> [ProfileData] -> RoutedNomyxServer Html +advancedPage mlu (Admin admin mpn) settings pfds = do uploadLink <- showURL Upload submitAdminPass <- showURL SubmitAdminPass submitPlayAs <- showURL SubmitPlayAs @@ -153,21 +155,50 @@ h5 "Enter the number of the player you want to play for:" blazeForm paf submitPlayAs when (isJust mpn) $ h5 $ string $ "Playing as player " ++ (show $ fromJust mpn) + hr p $ do h5 "Send mails:" blazeForm set submitSettings h5 $ string $ if (_sendMails settings) then "mails will be sent " else "mails will NOT be sent " + hr + p $ do + h5 "Players:" + table ! A.class_ "table" $ do + thead $ do + td ! A.class_ "td" $ "#" + td ! A.class_ "td" $ "Name" + td ! A.class_ "td" $ "mail" + td ! A.class_ "td" $ "send mails" + td ! A.class_ "td" $ "viewing game" + td ! A.class_ "td" $ "last rule" + td ! A.class_ "td" $ "last upload" + td ! A.class_ "td" $ "is admin" + td ! A.class_ "td" $ "play as" + mapM_ viewProfile pfds +viewProfile :: ProfileData -> Html +viewProfile (ProfileData pn (Types.PlayerSettings playerName mail _ mailNewRule _ _) viewingGame lastRule lastUpload (Admin isAdmin playAs)) = + tr $ do + td ! A.class_ "td" $ string $ show pn + td ! A.class_ "td" $ string playerName + td ! A.class_ "td" $ string mail + td ! A.class_ "td" $ string $ show mailNewRule + td ! A.class_ "td" $ string $ show viewingGame + td ! A.class_ "td" $ string $ show lastRule + td ! A.class_ "td" $ string $ show lastUpload + td ! A.class_ "td" $ string $ show isAdmin + td ! A.class_ "td" $ string $ show playAs + adminPassForm :: NomyxForm String adminPassForm = RB.inputText "" playAsForm :: [PlayerNumber] -> NomyxForm (Maybe PlayerNumber) playAsForm _ = readPlayAs (label "Play as: " ++> RB.inputCheckbox False) (RB.inputText "") -newPlayAsSettings :: (TVar Session) -> RoutedNomyxServer Html -newPlayAsSettings ts = do +newPlayAsSettings :: (TVar Session) -> RoutedNomyxServer Response +newPlayAsSettings ts = toResponse <$> do methodM POST p <- liftRouteT $ eitherForm environment "user" $ playAsForm [] pn <- getPlayerNumber ts @@ -184,8 +215,8 @@ settingsForm :: Bool -> NomyxForm Bool settingsForm sendMails = label "Send mails: " ++> RB.inputCheckbox sendMails -newSettings :: (TVar Session) -> RoutedNomyxServer Html -newSettings ts = do +newSettings :: (TVar Session) -> RoutedNomyxServer Response +newSettings ts = toResponse <$> do methodM POST p <- liftRouteT $ eitherForm environment "user" $ settingsForm False case p of @@ -201,8 +232,8 @@ uploadForm :: NomyxForm (FilePath, FilePath, ContentType) uploadForm = RB.inputFile -newUpload :: (TVar Session) -> RoutedNomyxServer Html -newUpload ts = do +newUpload :: (TVar Session) -> RoutedNomyxServer Response +newUpload ts = toResponse <$> do methodM POST pn <- getPlayerNumber ts r <- liftRouteT $ eitherForm environment "user" uploadForm @@ -213,8 +244,8 @@ (Left _) -> liftIO $ putStrLn $ "cannot retrieve form data" seeOther link $ string "Redirecting..." -newAdminPass :: (TVar Session) -> RoutedNomyxServer Html -newAdminPass ts = do +newAdminPass :: (TVar Session) -> RoutedNomyxServer Response +newAdminPass ts = toResponse <$> do methodM POST p <- liftRouteT $ eitherForm environment "user" $ adminPassForm pn <- getPlayerNumber ts