Nomyx 0.3.0 → 0.3.1
raw patch · 15 files changed
+236/−190 lines, 15 filesdep ~Nomyx-Language
Dependency ranges changed: Nomyx-Language
Files
- Nomyx.cabal +3/−2
- TODO +6/−0
- src/Interpret.hs +16/−21
- src/Mail.hs +1/−1
- src/Main.hs +25/−7
- src/Multi.hs +20/−22
- src/Test.hs +17/−17
- src/Types.hs +7/−9
- src/Utils.hs +6/−7
- src/Web/Common.hs +4/−4
- src/Web/Game.hs +32/−30
- src/Web/Help.hs +1/−1
- src/Web/MainPage.hs +45/−46
- src/Web/NewGame.hs +4/−5
- src/Web/Settings.hs +49/−18
Nomyx.cabal view
@@ -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,
TODO view
@@ -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
src/Interpret.hs view
@@ -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)
src/Mail.hs view
@@ -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)
src/Main.hs view
@@ -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
src/Multi.hs view
@@ -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"
src/Test.hs view
@@ -60,7 +60,7 @@ test :: ServerHandle -> StateT Session IO () -> (Multi -> Bool) -> IO Bool test sh tes cond = do tp <- testProfiles- let s = Session sh (defaultMulti (Settings "" defaultNetwork False "")) tp+ let s = Session sh (defaultMulti (Settings "" defaultNetwork False "" "" "")) tp m' <- loadTest tes s (evaluate $ cond m') `E.catch` (\(e::SomeException) -> (putStrLn $ "Exception in test: " ++ show e) >> return False) @@ -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"
src/Types.hs view
@@ -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 =
src/Utils.hs view
@@ -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)
src/Web/Common.hs view
@@ -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
src/Web/Game.hs view
@@ -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"
src/Web/Help.hs view
@@ -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"
src/Web/MainPage.hs view
@@ -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]
src/Web/NewGame.hs view
@@ -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
src/Web/Settings.hs view
@@ -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