Nomyx 0.3.2 → 0.4.0
raw patch · 18 files changed
+369/−319 lines, 18 filesdep +either-unwrapdep +tardep +temporarydep −Cabaldep −QuickCheckdep −Unixutilsdep ~DebugTraceHelpersdep ~MissingHdep ~MonadCatchIO-mtl
Dependencies added: either-unwrap, tar, temporary, unix-compat
Dependencies removed: Cabal, QuickCheck, Unixutils, binary, data-accessor-transformers, eprocess, extensible-exceptions, hdaemonize, hslogger, lenses, monad-loops, mueval, process, regular, syb, utf8-string
Dependency ranges changed: DebugTraceHelpers, MissingH, MonadCatchIO-mtl, Nomyx-Language, acid-state, base, blaze-markup, bytestring, containers, data-lens, data-lens-fd, data-lens-template, directory, fb, filepath, happstack-authenticate, happstack-server, hint, hint-server, hscolour, ixset, mime-mail, mtl, network, old-locale, reform, reform-blaze, reform-happstack, safe, safecopy, split, stm, template-haskell, text, time, unix, web-routes-th
Files
- Nomyx.cabal +53/−59
- TODO +20/−4
- data/static/css/nomyx.css +9/−1
- src/Interpret.hs +38/−46
- src/Mail.hs +5/−3
- src/Main.hs +48/−61
- src/Multi.hs +18/−15
- src/Quotes.hs +0/−43
- src/Serialize.hs +10/−12
- src/Test.hs +7/−5
- src/Types.hs +9/−7
- src/Utils.hs +74/−8
- src/Web/Common.hs +3/−5
- src/Web/Game.hs +13/−11
- src/Web/Help.hs +3/−2
- src/Web/MainPage.hs +41/−32
- src/Web/NewGame.hs +1/−1
- src/Web/Settings.hs +17/−4
Nomyx.cabal view
@@ -1,5 +1,5 @@ name: Nomyx-version: 0.3.2+version: 0.4.0 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -11,7 +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+Homepage: http://www.nomyx.net author: Corentin Dupont data-files: static/css/nomyx.css static/nomyx.js@@ -20,63 +20,57 @@ extra-source-files: AUTHORS README TODO executable Nomyx- build-depends: Nomyx-Language ==0.3.2,- 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+ build-depends: Nomyx-Language == 0.4.0,+ DebugTraceHelpers == 0.12.*,+ MissingH == 1.2.*,+ MonadCatchIO-mtl == 0.3.*,+ acid-state == 0.10.*,+ base == 4.6.*,+ blaze-html == 0.5.*,+ blaze-markup == 0.5.*,+ bytestring == 0.10.*,+ containers == 0.5.*,+ data-lens == 2.10.*,+ data-lens-template == 2.1.*,+ data-lens-fd == 2.0.*,+ directory == 1.2.*,+ either-unwrap == 1.1.*,+ fb == 0.14.*,+ filepath == 1.3.*,+ happstack-authenticate == 0.10.*,+ happstack-server == 7.1.*,+ hint == 0.3.*,+ hint-server == 1.2.*,+ hscolour == 1.20.*,+ ixset == 1.0.*,+ mime-mail == 0.4.*,+ mtl == 2.1.*,+ network == 2.4.*,+ old-locale == 1.0.*,+ reform == 0.1.*,+ reform-blaze == 0.1.*,+ reform-happstack == 0.1.*,+ safe == 0.3.*,+ safecopy == 0.8.*,+ split == 0.2.*,+ stm == 2.4.*,+ tar == 0.4.*,+ temporary == 1.1.*,+ template-haskell == 2.8.*,+ text == 0.11.*,+ time == 1.4.*,+ -- cross-platform file handling+ unix-compat == 0.4.*,+ web-routes == 0.27.*,+ web-routes-happstack == 0.23.*,+ web-routes-regular == 0.19.*,+ web-routes-th == 0.22.*+ + if os(windows)+ Cpp-options: -DWINDOWS+ else+ build-depends: unix == 2.6.*+ main-is: Main.hs buildable: True extensions: CPP
TODO view
@@ -2,9 +2,12 @@ TODO list Bugs: -- command line arguments are ignored if there is a save file - recurring event are making increasing memory size +- forbid void names +- import qualified Data.Map and Control.Category (or hide conflicting functions) +- display bugs on MacOS (tabs, vertical size) + Improvements: - make code instructions in the active rules table clickable to access haddock documentation - option to read step by step the save file for analysis? @@ -18,13 +21,26 @@ - add examples with a game master, a castle.. - fix facebook - vote: include new players, delete leaving players -- make settings file with start up rules +- make 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 - +- rules should communicate by message passing instead of shared variable +- HCI improvements: space player names, bold games +- display viewer list +- import qualified uploads (?) +- 15 characters max for names +- add a space before buttons (in HTML) +- some files are accepted when uploaded but cause the game to crash when restarting. Check with GATDs for example. +- display vote infos (modalities, date etc.) +- parameterize the mail sender +- Short description field is too small +- variable creation: use the definition (V...) ? +- put a scroll on long IOs +- put settings at session level, not multi level +- a way to overwrite uploads (automatically or with admin intervention) +- tag the save file with the version Futur Nomic: - ability to analyse rules, proof system
data/static/css/nomyx.css view
@@ -226,7 +226,7 @@ pointer-events: none; } -.view, .join {+.modalButton { background: #606061; color: #FFFFFF; line-height: 25px;@@ -272,4 +272,12 @@ #modalCode { overflow: auto; height: 60%;+}++pre {+ -moz-tab-size: 16;+ -o-tab-size: 16;+ -webkit-tab-size: 16;+ -ms-tab-size: 16;+ tab-size: 16; }
src/Interpret.hs view
@@ -6,52 +6,56 @@ import Language.Nomyx import System.Directory import System.FilePath-import System.Posix.Files-import System.Posix.Resource import Control.Exception as CE+import Data.Either.Unwrap+import Utils+import Data.List+import Control.Monad -modDir = "modules" importList = ["Prelude", "Language.Nomyx",+ "Language.Nomyx.Examples", "GHC.Base", "Data.Maybe", "Data.List", "Control.Monad.State", "Control.Applicative", "Control.Monad.Error",- "Data.Map",+ --"Data.Map", "Safe", "Data.Typeable",- "Control.Category",+ --"Control.Category", "Data.Lens", "Control.Arrow"] -- | the server handle startInterpreter :: FilePath -> IO ServerHandle -startInterpreter dataDir = do - h <- start- liftIO $ createDirectoryIfMissing True $ dataDir </> modDir - ir <- runIn h $ initializeInterpreter dataDir +startInterpreter saveDir = do + sh <- start+ liftIO $ createDirectoryIfMissing True $ saveDir </> uploadDir + ir <- runIn sh $ initializeInterpreter saveDir case ir of Right r -> do putStrLn "Interpreter Loaded" return $ Just r Left e -> error $ "sHandle: initialization error:\n" ++ show e - return h + return sh +-- get all uploaded modules from the directory (may be empty) 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- +getUploadModules saveDir = do+ files <- getUploadedModules saveDir+ return $ map (\f -> joinPath [saveDir, uploadDir, f]) files++ -- | initializes the interpreter by loading some modules. initializeInterpreter :: FilePath -> Interpreter () -initializeInterpreter dataDir = do - fmods <- liftIO $ getUploadModules dataDir+initializeInterpreter saveDir = do + fmods <- liftIO $ getUploadModules saveDir+ liftIO $ putStrLn $ "Loading modules: " ++ (concat $ intersperse ", " fmods) loadModules fmods setTopLevelModules $ map (dropExtension . takeFileName) fmods- set [searchPath := [dataDir], languageExtensions := [GADTs, ScopedTypeVariables]] --, installedModulesInScope := False+ set [searchPath := [saveDir], languageExtensions := [GADTs, ScopedTypeVariables]] --, installedModulesInScope := False setImports importList return () @@ -67,41 +71,29 @@ Right ruleFunc -> return ruleFunc Left e -> error $ show e ---liftIO $ mapM_ (uncurry setResourceLimit) limits -cpuTimeLimitSoft = ResourceLimit 4-cpuTimeLimitHard = ResourceLimit 5- --limits :: [(Resource, ResourceLimits)]-limits = [ (ResourceCPUTime, ResourceLimits cpuTimeLimitSoft cpuTimeLimitHard)]- - -- | check an uploaded file and reload 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 dataDir- return $ Right () - Left e -> do- runIn sh $ initializeInterpreter dataDir- return $ Left e+loadModule tempModName name sh saveDir = do+ --copy the new module in the upload directory+ let dest = (saveDir </> uploadDir </> name)+ copyFile tempModName dest+ setMode dest+ inter <- runIn sh $ initializeInterpreter saveDir+ res <- case inter of+ Right _ -> return $ Right () + Left e -> do+ --suppress the faulty module+ removeFile dest+ final <- runIn sh $ initializeInterpreter saveDir+ when (isLeft final) $ putStrLn "Error: reinitialize interpreter failed"+ return $ Left e+ return res ----- | check if a module is valid. Context will be reset.-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) 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 (NotAllowed s) = "Not Allowed (Probable cause: bad module or file name)\n" ++ s showInterpreterError (GhcException s) = "Ghc Exception\n" ++ s
src/Mail.hs view
@@ -12,7 +12,7 @@ import Control.Monad import Types import Language.Nomyx-import Language.Nomyx.Game+import Language.Nomyx.Engine import Data.Text(Text, pack) import Control.Concurrent import Data.Maybe@@ -23,6 +23,8 @@ import Text.Blaze.Internal import Control.Category import Control.Applicative ((<$>))+import Safe+import Data.List default (Integer, Double, Data.Text.Text) @@ -30,7 +32,7 @@ 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")+ (Address (Just "Nomyx Game") "kau@nomyx.net") (pack object) (B.pack htmlBody) (B.pack textBody)@@ -67,7 +69,7 @@ sendMailsNewRule :: Session -> SubmitRule -> PlayerNumber -> IO () sendMailsNewRule s sr pn = when (_sendMails $ _mSettings $ _multi s) $ do putStrLn "Sending mails"- gn <- fromJust <$> getPlayersGame pn s+ gn <- fromJustNote "sendMailsNewRule" <$> getPlayersGame pn s let sendMailsTo = delete pn (map _playerNumber (_players $ _game gn)) proposer <- Utils.getPlayerName pn s profiles <- mapM (getProfile s) sendMailsTo
src/Main.hs view
@@ -22,39 +22,31 @@ import Control.Concurrent import Interpret import Control.Concurrent.STM-import qualified System.Posix.Signals as S-import Control.Monad.CatchIO hiding (catch)-import Control.Monad.Trans-import Language.Nomyx.Test as LT+import Control.Monad.CatchIO (bracket)+import Language.Nomyx.Engine.Test as LT import Data.Maybe import Safe import Network.BSD-import System.Posix.Daemonize import Types import Serialize import Paths_Nomyx as PN import Paths_Nomyx_Language as PNL-import System.Directory+import System.Directory (removeDirectoryRecursive, canonicalizePath, removeFile, doesFileExist) import Data.Time.Clock-import Language.Nomyx hiding (getCurrentTime)+import Language.Nomyx.Engine import Control.Exception as E hiding (bracket) import Test import Utils import Data.Version (showVersion)-import Control.Category 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+import Control.Monad.State -defaultLogFile, profilesDir, modulesDir :: FilePath-defaultLogFile = "Nomyx.save"-profilesDir = "profiles"-modulesDir = "modules" -- | Entry point of the program. main :: IO Bool @@ -70,39 +62,45 @@ else do 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+ start flags+ return True start :: [Flag] -> IO () start flags = do- serverCommandUsage defDataDir <- PN.getDataDir defSourceDir <- PNL.getDataDir hostName <- getHostName- logFilePath <- case (findSaveFile flags) of- Just f -> canonicalizePath f- 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+ -- save directory: Nomyx.save and uploaded files+ saveDir <- case (findTarFile flags) of+ Just tarFile -> untar tarFile+ Nothing -> case (findSaveDir flags) of+ Just f -> canonicalizePath f+ Nothing -> PN.getDataDir+ -- data directory: web ressources and profiles let dataDir = fromMaybe defDataDir (findDataDir flags)+ -- source directory: Nomyx-Language files (used only for display in GUI, since this library is statically linked otherwise) let sourceDir = fromMaybe defSourceDir (findSourceDir flags)- let settings = Settings logFilePath (Network host port) sendMail adminPass dataDir sourceDir- --start the haskell interpreter- sh <- protectHandlers $ startInterpreter dataDir+ let settings = Settings (Network host port) sendMail adminPass saveDir dataDir sourceDir if Test `elem` flags then do+ sh <- protectHandlers $ startInterpreter saveDir putStrLn $ "\nNomyx Language Tests results:\n" ++ (concatMap (\(a,b) -> a ++ ": " ++ (show b) ++ "\n") LT.tests) ts <- playTests sh putStrLn $ "\nNomyx Game Tests results:\n" ++ (concatMap (\(a,b) -> a ++ ": " ++ (show b) ++ "\n") ts) putStrLn $ "All Tests Pass: " ++ (show $ allTests && (all snd ts)) else if (DeleteSaveFile `elem` flags) then do putStrLn "Deleting save files"- (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)+ let catchExp io = io `catch` (\(e::SomeException)-> putStrLn $ show e)+ catchExp $ removeDirectoryRecursive $ dataDir </> profilesDir+ catchExp $ removeDirectoryRecursive $ saveDir </> uploadDir+ catchExp $ removeFile $ saveDir </> saveFile else do+ serverCommandUsage+ --start the haskell interpreter+ sh <- protectHandlers $ startInterpreter saveDir --creating game structures multi <- case (findLoadTest flags) of Just testName -> loadTestName settings testName sh@@ -117,13 +115,15 @@ loadMulti :: Settings -> ServerHandle -> IO Multi loadMulti set sh = do- fileExists <- doesFileExist $ _logFilePath $ set+ fileExists <- doesFileExist $ getSaveFile set multi <- case fileExists of True -> do- putStrLn $ "Loading game: " ++ (_logFilePath $ set)+ putStrLn $ "Loading game: " ++ (getSaveFile set) Serialize.loadMulti set sh `E.catch` (\e -> (putStrLn $ "Error while loading logged events, log file discarded\n" ++ (show (e::ErrorCall))) >> (return $ defaultMulti set))- False -> return $ defaultMulti set+ False -> do+ let defMulti = defaultMulti set+ execStateT (newGame' "Default game" (GameDesc "This is the default game." "") 0 sh) defMulti return multi @@ -152,15 +152,15 @@ | Test | HostName String | Port String- | LogFile FilePath- | Daemon | LoadTest String | DeleteSaveFile | AdminPass String | Mails | Help+ | SaveDir FilePath | DataDir FilePath- | SourceDir FilePath + | SourceDir FilePath+ | TarFile FilePath deriving (Show, Eq) -- | launch options description @@ -171,15 +171,15 @@ , 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 ['a'] ["adminPass"] (ReqArg AdminPass "AdminPass") "specify the admin password (default is NXPSD)" , Option ['m'] ["mails"] (NoArg Mails) "send mails (default is no)" , Option ['?'] ["help"] (NoArg Help) "display usage options (this screen)"- , Option ['f'] ["dataDir"] (ReqArg DataDir "DataDir") "set data directory"- , Option ['s'] ["sourceDir"] (ReqArg SourceDir "SourceDir") "set source directory"+ , Option ['r'] ["saveDir"] (ReqArg SaveDir "SaveDir") "specify save directory (for Nomyx.save and uploads)"+ , Option ['f'] ["dataDir"] (ReqArg DataDir "DataDir") "specify data directory (for profiles and website files)"+ , Option ['s'] ["sourceDir"] (ReqArg SourceDir "SourceDir") "specify source directory (for Nomyx-Language files)"+ , Option ['T'] ["tar"] (ReqArg TarFile "TarFile") "specify tar file (containing Nomyx.save and uploads)" ] nomyxOpts :: [String] -> IO ([Flag], [String]) @@ -206,10 +206,10 @@ isLoadTest (LoadTest a) = Just a isLoadTest _ = Nothing -findSaveFile :: [Flag] -> Maybe FilePath-findSaveFile fs = headMay $ catMaybes $ map isSaveFile fs where- isSaveFile (LogFile a) = Just a- isSaveFile _ = Nothing+findSaveDir :: [Flag] -> Maybe FilePath+findSaveDir fs = headMay $ catMaybes $ map isSaveDir fs where+ isSaveDir (SaveDir a) = Just a+ isSaveDir _ = Nothing findAdminPass :: [Flag] -> Maybe String findAdminPass fs = headMay $ catMaybes $ map isAdminPass fs where@@ -226,32 +226,18 @@ 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--signals :: [S.Signal]-signals = [ S.sigQUIT- , S.sigINT- , S.sigHUP- , S.sigTERM- ]--saveHandlers :: MonadCatchIO m => m [S.Handler]-saveHandlers = liftIO $ mapM (helper S.Ignore) signals--restoreHandlers :: MonadCatchIO m => [S.Handler] -> m [S.Handler]-restoreHandlers h = liftIO . sequence $ zipWith helper h signals+findTarFile :: [Flag] -> Maybe String+findTarFile fs = headMay $ catMaybes $ map isTarFile fs where+ isTarFile (TarFile a) = Just a+ isTarFile _ = Nothing -protectHandlers :: MonadCatchIO m => m a -> m a-protectHandlers a = bracket saveHandlers restoreHandlers $ const a- triggerTimeEvent :: TVar Session -> UTCTime -> IO() triggerTimeEvent tm t = do (Session sh m a) <- atomically $ readTVar tm m' <- execWithMulti t (Multi.triggerTimeEvent t) m atomically $ writeTVar tm (Session sh m' a)- save (_mSettings >>>_logFilePath $ m') m'+ save m' launchTimeEvents :: TVar Session -> IO()@@ -275,3 +261,4 @@ bracket (openLocalStateFrom (basePath </> "profile") initialProfileState) (createCheckpointAndClose) $ \profile -> bracket (openLocalStateFrom (basePath </> "profileData") initialProfileDataState) (createCheckpointAndClose) $ \profileData -> f (Profiles auth profile profileData)+
src/Multi.hs view
@@ -19,7 +19,7 @@ import Debug.Trace.Helpers import Data.Lens import Language.Nomyx-import Language.Nomyx.Game as G+import Language.Nomyx.Engine as G import Control.Category hiding ((.)) import qualified Data.Acid.Advanced as A (update', query') import Quotes (cr)@@ -35,7 +35,10 @@ newGame :: GameName -> GameDesc -> PlayerNumber -> StateT Session IO () newGame name desc pn = do sh <- access sh- focus multi $ do+ focus multi $ newGame' name desc pn sh++newGame' :: GameName -> GameDesc -> PlayerNumber -> ServerHandle -> StateT Multi IO ()+newGame' name desc pn sh = do gs <- access games case null $ filter ((== name) . getL (game >>> gameName)) gs of True -> do@@ -63,7 +66,7 @@ joinGame game pn = do s <- get name <- lift $ Utils.getPlayerName pn s- inGameDo game $ G.update $ JoinGame pn name+ inGameDo game $ G.execGameEvent $ JoinGame pn name viewGamePlayer game pn -- | del a game.delGame :: GameName -> StateT Session IO ()@@ -72,7 +75,7 @@ -- | leave a game. leaveGame :: GameName -> PlayerNumber -> StateT Session IO ()-leaveGame game pn = inGameDo game $ G.update $ LeaveGame pn+leaveGame game pn = inGameDo game $ G.execGameEvent $ LeaveGame pn -- | insert a rule in pending rules. submitRule :: SubmitRule -> PlayerNumber -> GameName -> ServerHandle -> StateT Session IO ()@@ -82,11 +85,11 @@ case mrr of Right _ -> do tracePN pn $ "proposed rule compiled OK "- inGameDo gn $ G.update' (Just $ getRuleFunc sh) (ProposeRuleEv pn sr)+ inGameDo gn $ G.execGameEvent' (Just $ getRuleFunc sh) (ProposeRuleEv pn sr) modifyProfile pn (pLastRule ^= Nothing) Left e -> do let errorMsg = showInterpreterError e- inGameDo gn $ update $ GLog (Just pn) ("Error in submitted rule: " ++ errorMsg)+ inGameDo gn $ execGameEvent $ GLog (Just pn) ("Error in submitted rule: " ++ errorMsg) tracePN pn ("Error in submitted rule: " ++ errorMsg) modifyProfile pn (pLastRule ^= Just (sr, errorMsg)) -- keep in memory the last rule proposed by the player to display it in case of error @@ -97,32 +100,32 @@ case mrr of Right _ -> do tracePN pn $ "proposed rule compiled OK "- inGameDo gn $ update' (Just $ getRuleFunc sh) (SystemAddRule sr)+ inGameDo gn $ execGameEvent' (Just $ getRuleFunc sh) (SystemAddRule sr) modifyProfile pn (pLastRule ^= Nothing) Left e -> do let errorMsg = showInterpreterError e- inGameDo gn $ update $ GLog (Just pn) ("Error in submitted rule: " ++ errorMsg)+ inGameDo gn $ execGameEvent $ GLog (Just pn) ("Error in submitted rule: " ++ errorMsg) tracePN pn ("Error in submitted rule: " ++ errorMsg) modifyProfile pn (pLastRule ^= Just (sr, errorMsg)) inputResult :: PlayerNumber -> EventNumber -> UInputData -> GameName -> StateT Session IO ()-inputResult pn en ir gn = inGameDo gn $ update $ InputResult pn en ir+inputResult pn en ir gn = inGameDo gn $ execGameEvent $ InputResult pn en ir -- | upload a rule file inputUpload :: PlayerNumber -> FilePath -> String -> ServerHandle -> StateT Session IO () inputUpload pn temp mod sh = do- dataDir <- access (multi >>> mSettings >>> dataDir)- m <- liftIO $ loadModule temp mod sh dataDir+ saveDir <- access (multi >>> mSettings >>> saveDir)+ m <- liftIO $ loadModule temp mod sh saveDir 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 $ execGameEvent $ GLog (Just pn) ("File loaded: " ++ show temp ++ ", as " ++ show mod ++"\n") tracePN pn "upload success" modifyProfile pn (pLastUpload ^= UploadSuccess) Left e -> do let errorMsg = showInterpreterError e- inPlayersGameDo pn $ update $ GLog (Just pn) ("Error in file: " ++ show e ++ "\n")+ inPlayersGameDo pn $ execGameEvent $ GLog (Just pn) ("Error in file: " ++ show e ++ "\n") tracePN pn "upload failed" modifyProfile pn (pLastUpload ^= UploadFailure (temp, errorMsg)) @@ -191,7 +194,7 @@ trig :: UTCTime -> LoggedGame -> IO LoggedGame trig t g = do- g' <- execWithGame' t (update $ TimeEvent t) g+ g' <- execWithGame' t (execGameEvent $ TimeEvent t) g evaluate g' -- | get all events that has not been triggered yet@@ -216,7 +219,7 @@ initialGame :: ServerHandle -> StateT LoggedGame IO () initialGame sh = mapM_ addR [rVoteUnanimity, rVictory5Rules]- where addR r = update' (Just $ getRuleFunc sh) (SystemAddRule r)+ where addR r = execGameEvent' (Just $ getRuleFunc sh) (SystemAddRule r) initialLoggedGame :: GameName -> GameDesc -> UTCTime -> ServerHandle -> IO LoggedGame initialLoggedGame name desc date sh = do
src/Quotes.hs view
@@ -40,46 +40,3 @@ ----cr2 :: QuasiQuoter---cr2 = QuasiQuoter { quoteExp = quoteRuleFunc2,--- quotePat = undefined,--- quoteType = undefined,--- quoteDec = undefined}------quoteRuleFunc2 :: String -> Q TH.Exp---quoteRuleFunc2 s = do--- res <- runIO $ runInterpreter $ do--- setImports importList--- interpret s (as::RuleFunc)--- case res of--- Right f -> [| (s,f) |]--- Left e -> fail $ show e--- --do --[| putParens s |]--- s_0 <- newName "s"--- return $ LamE [VarP s_0] (InfixE (Just (LitE (StringL "(")))--- (VarE GHC.Base.++)--- (Just (InfixE (Just (VarE s_0))---------putParens :: String -> String---putParens s = "(" ++ s ++ ",\"" ++ s ++ "\")"------putParens' :: Q TH.Exp -> Q TH.Exp---putParens' (LitE (StringL s)) = (LitE (StringL s))----t :: (Int, String)---t = $( [| 1 |] )---RuleName -> RuleFunc -> RuleCode -> RuleNumber -> String -> Nomex ()------ $( quoteRuleFunc2 "voidRule $ return ()")---putParens :: String -> IO (String, RuleFunc)---putParens s = do--- res <- runIO $ runInterpreter $ do--- setImports importList--- interpret s (as::RuleFunc)--- case res of--- Right f -> return (s, f)--- Left e -> fail $ show e
src/Serialize.hs view
@@ -3,36 +3,34 @@ module Serialize where -import Prelude hiding (log, (.))+import Prelude hiding (log) import Language.Nomyx hiding (getCurrentTime)-import Language.Nomyx.Game+import Language.Nomyx.Engine import Control.Monad.State import Types-import Control.Category import Data.Lens import Language.Haskell.Interpreter.Server import Interpret+import Utils -save :: FilePath -> Multi -> IO()-save fp m = writeFile fp (show m)+save :: Multi -> IO ()+save m = writeFile (getSaveFile $ _mSettings m) (show m) save' :: StateT Multi IO ()-save' = do- lfp <- access (mSettings >>> logFilePath)- m <- get- lift $ save lfp m+save' = get >>= lift . save -load :: FilePath -> IO(Multi)+load :: FilePath -> IO Multi load fp = do s <- readFile fp return $ read s loadMulti :: Settings -> ServerHandle -> IO Multi loadMulti set sh = do- m <- load $ _logFilePath set+ m <- load (getSaveFile set) gs' <- mapM (updateLoggedGame $ getRuleFunc sh) $ _games m let m' = games `setL` gs' $ m- return m'+ let m'' = mSettings `setL` set $ m'+ return m'' updateLoggedGame :: (RuleCode -> IO RuleFunc) -> LoggedGame -> IO LoggedGame updateLoggedGame f (LoggedGame g log) = getLoggedGame g f log
src/Test.hs view
@@ -22,6 +22,7 @@ import Multi import Language.Haskell.Interpreter.Server (ServerHandle) import Language.Nomyx hiding (getCurrentTime)+import Language.Nomyx.Engine import Control.Applicative import Control.Exception as E import Language.Haskell.TH@@ -29,11 +30,12 @@ import System.IO.Unsafe import Quotes import Data.Lens+import Data.List import Safe import Data.Acid.Memory import Happstack.Auth.Core.Auth (initialAuthState) import Happstack.Auth.Core.Profile (initialProfileState)-import qualified Language.Nomyx.Game as G+import qualified Language.Nomyx.Engine as G import Control.Arrow ((>>>)) import Data.Time hiding (getCurrentTime) @@ -60,7 +62,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) @@ -139,7 +141,7 @@ condHelloWorld2Players m = isOutput "hello, world!" m partialFunction1 :: String-partialFunction1 = [cr|voidRule $ readVar_ (V "toto1" :: V String)|]+partialFunction1 = [cr|voidRule $ readMsgVar_ (msgVar "toto1" :: MsgVar String)|] gamePartialFunction1 :: StateT Session IO () gamePartialFunction1 = submitR partialFunction1@@ -152,7 +154,7 @@ partialFunction2 :: String partialFunction2 = [cr|voidRule $ do t <- getCurrentTime- onEventOnce_ (Time $ addUTCTime 5 t) $ const $ readVar_ (V "toto2")|]+ onEventOnce_ (Time $ addUTCTime 5 t) $ const $ readMsgVar_ (msgVar "toto2")|] gamePartialFunction2 :: StateT Session IO () gamePartialFunction2 = do@@ -168,7 +170,7 @@ (take 5 $ _lMsg $ headNote "cond3 failed" $ _logs $ G._game $ headNote "cond4 failed" $ _games m) == "Error" partialFunction3 :: String-partialFunction3 = [cr|voidRule $ onEvent_ (RuleEv Proposed) $ const $ readVar_ (V "toto3")|]+partialFunction3 = [cr|voidRule $ onEvent_ (RuleEv Proposed) $ const $ readMsgVar_ (msgVar "toto3")|] gamePartialFunction3 :: StateT Session IO () gamePartialFunction3 = do
src/Types.hs view
@@ -3,11 +3,11 @@ module Types where import Language.Nomyx+import Language.Nomyx.Engine import Data.Typeable import Text.Reform.Happstack() import Network.BSD import Data.Lens.Template-import Language.Nomyx.Game import Language.Haskell.Interpreter.Server (ServerHandle) import Data.Acid (makeAcidic, Update, Query, AcidState) import Happstack.Auth (ProfileState, AuthState)@@ -23,6 +23,8 @@ type Port = Int type CompileError = String type LastRule = (SubmitRule, CompileError)++ data LastUpload = NoUpload | UploadSuccess | UploadFailure (FilePath, CompileError)@@ -44,12 +46,12 @@ $(deriveSafeCopy 1 'base ''PlayerSettings) -data Settings = Settings { _logFilePath :: FilePath,- _net :: Network,- _sendMails :: Bool,- _adminPassword :: String,- _dataDir :: FilePath,- _sourceDir :: FilePath}+data Settings = Settings { _net :: Network, -- URL where the server is launched+ _sendMails :: Bool, -- send mails or not+ _adminPassword :: String, -- admin password+ _saveDir :: FilePath, -- location of the save file and uploaded files+ _dataDir :: FilePath, -- location of the static files (profiles + website)+ _sourceDir :: FilePath} -- location of the language files (from Nomyx-Language) deriving (Eq, Show, Read, Typeable) --- | A structure to hold the active games and players
src/Utils.hs view
@@ -13,20 +13,36 @@ ----------------------------------------------------------------------------- {-# LANGUAGE NamedFieldPuns #-}- +{-# OPTIONS -cpp #-} module Utils where import Data.Maybe -import Data.Char import Control.Monad.State import Types import Language.Nomyx-import Language.Nomyx.Game+import Language.Nomyx.Engine import Data.Lens-import Control.Category hiding ((.))+import Control.Category hiding ((.), id) import Safe import Control.Concurrent.STM import qualified Data.Acid.Advanced as A (query', update')+import System.IO.Temp+import Codec.Archive.Tar as Tar+import System.Directory+import System.FilePath+import Control.Monad.CatchIO+import Data.Time+import Data.List+import System.PosixCompat.Files (getFileStatus, isRegularFile, setFileMode, ownerModes, groupModes)+#ifndef WINDOWS+import qualified System.Posix.Signals as S+#endif++saveFile, profilesDir, uploadDir, tarFile :: FilePath+saveFile = "Nomyx.save"+profilesDir = "profiles"+uploadDir = "uploads"+tarFile = "Nomyx.tar" -- | this function will return just a if it can cast it to an a. maybeRead :: Read a => String -> Maybe a @@ -38,10 +54,6 @@ -> [a] -- ^ Input list -> [a] -- ^ Output list replace x y = map (\z -> if z == x then y else z) - -yes = ["o", "oui", "y", "yes", "v", "vrai", "true"] -toLowerS = map toLower -isYes a = toLowerS a `elem` yes -- | generic function to say things on transformers like GameState, ServerState etc. say :: String -> StateT a IO () @@ -108,3 +120,57 @@ s <- liftIO $ atomically $ readTVar ts getProfile s pn +getSaveFile :: Settings -> FilePath+getSaveFile set = (_saveDir set) </> saveFile++makeTar :: FilePath -> IO ()+makeTar saveDir = do+ putStrLn $ "creating tar in " ++ (show saveDir)+ Tar.create (saveDir </> tarFile) saveDir [saveFile, uploadDir]++untar :: FilePath -> IO (FilePath)+untar fp = do+ dir <- createTempDirectory "/tmp" "Nomyx"+ extract dir fp+ return dir++getUploadedModules :: FilePath -> IO [FilePath]+getUploadedModules saveDir = do+ mods <- getDirectoryContents $ saveDir </> uploadDir+ getRegularFiles (saveDir </> uploadDir) mods++getRegularFiles :: FilePath -> [FilePath] -> IO [FilePath]+getRegularFiles dir fps = filterM (getFileStatus . (\f -> dir </> f) >=> return . isRegularFile) $ fps++setMode :: FilePath -> IO()+setMode file = setFileMode file (ownerModes + groupModes)++#ifdef WINDOWS++--no signals under windows+protectHandlers :: MonadCatchIO m => m a -> m a+protectHandlers = id++#else++helper :: MonadCatchIO m => S.Handler -> S.Signal -> m S.Handler+helper handler signal = liftIO $ S.installHandler signal handler Nothing++signals :: [S.Signal]+signals = [ S.sigQUIT+ , S.sigINT+ , S.sigHUP+ , S.sigTERM+ ]++saveHandlers :: MonadCatchIO m => m [S.Handler]+saveHandlers = liftIO $ mapM (helper S.Ignore) signals++restoreHandlers :: MonadCatchIO m => [S.Handler] -> m [S.Handler]+restoreHandlers h = liftIO . sequence $ zipWith helper h signals+++protectHandlers :: MonadCatchIO m => m a -> m a+protectHandlers a = bracket saveHandlers restoreHandlers $ const a++#endif
src/Web/Common.hs view
@@ -15,6 +15,7 @@ import Control.Monad.State import Control.Concurrent.STM import Language.Nomyx+import Language.Nomyx.Engine import Happstack.Server as HS import Types as T import qualified Data.ByteString.Char8 as C@@ -100,9 +101,6 @@ [(n,[])] -> Just n _ -> Nothing -modDir :: FilePath-modDir = "modules"- evalCommand :: (TVar Session) -> StateT Session IO a -> RoutedNomyxServer a evalCommand ts sm = liftIO $ do s <- atomically $ readTVar ts@@ -113,7 +111,7 @@ s <- atomically $ readTVar ts s' <- execStateT sm s atomically $ writeTVar ts s'- save (_logFilePath $ _mSettings $ _multi $ s') (_multi s') --TODO not really nice to put that here+ save (_multi s') --TODO not really nice to put that here webCommand' :: (TVar Session) -> StateT Session IO () -> RoutedNomyxServer ()@@ -121,7 +119,7 @@ s <- atomically $ readTVar ts s' <- execStateT sm s atomically $ writeTVar ts s'- save (_logFilePath $ _mSettings $ _multi $ s') (_multi s') --TODO not really nice to put that here+ save (_multi s') --TODO not really nice to put that here protectedExecCommand :: (TVar Session) -> StateT Session IO a -> IO ()
src/Web/Game.hs view
@@ -14,7 +14,7 @@ import Data.Monoid import Control.Concurrent.STM import Language.Nomyx-import Language.Nomyx.Game+import Language.Nomyx.Engine import Data.Maybe import Text.Reform.Happstack import Text.Reform@@ -29,6 +29,7 @@ import Mail import Text.Printf import Data.String+import Data.List import Data.Text(Text) import qualified Text.Reform.Blaze.Common as RBC import qualified Language.Haskell.HsColour.HTML as HSC@@ -40,6 +41,7 @@ import System.Locale import Data.Lens import Control.Category hiding ((.))+import Safe default (Integer, Double, Data.Text.Text) viewGame :: Game -> PlayerNumber -> (Maybe LastRule) -> Bool -> RoutedNomyxServer Html@@ -57,8 +59,10 @@ 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 $ do+ h4 $ "Description:"+ string (_desc $ _gameDesc g)+ p $ h4 $ "This game is discussed in the " >> a "Agora" ! (A.href $ toValue (_agora $ _gameDesc g)) >> "." p $ h4 $ "Players in game:" viewPlayers (_players g) pn p $ viewVictory g@@ -106,7 +110,7 @@ viewRule :: Game -> Rule -> Html viewRule g nr = tr $ do- let pl = fromMaybe (show $ _rProposedBy nr) (_playerName <$> (Utils.getPlayer g $ _rProposedBy nr))+ let pl = fromMaybe ("Player " ++ (show $ _rProposedBy nr)) (_playerName <$> (Utils.getPlayer g $ _rProposedBy nr)) td ! A.class_ "td" $ string . show $ _rNumber nr td ! A.class_ "td" $ string $ _rName nr td ! A.class_ "td" $ string $ _rDescription nr@@ -129,9 +133,6 @@ a ! A.href "#close" ! A.title "Close" ! A.class_ "close" $ "X" 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@@ -201,7 +202,8 @@ [] -> Nothing os -> Just $ mapM_ viewOutput os -isPn pn (Output _ _ mypn _ SActive) = mypn == pn+isPn pn (Output _ _ (Just mypn) _ SActive) = mypn == pn+isPn _ (Output _ _ Nothing _ SActive) = True isPn _ _ = False viewInput :: PlayerNumber -> GameName -> EventHandler -> RoutedNomyxServer (Maybe Html)@@ -272,8 +274,8 @@ s' <- readTVarIO ts --TODO clean this gn <- getPlayersGame pn s gn' <- getPlayersGame pn s'- let rs = _rules $ _game $ fromJust gn- let rs' = _rules $ _game $ fromJust gn'+ let rs = _rules $ _game $ fromJustNote "newRule" gn+ let rs' = _rules $ _game $ fromJustNote "newRule" gn' when (length rs' > length rs) $ sendMailsNewRule s' sr pn Right (sr, Just _) -> webCommand ts $ adminSubmitRule sr pn gn sh (Left _) -> liftIO $ putStrLn $ "cannot retrieve form data"@@ -295,7 +297,7 @@ pn <- getPlayerNumber ts s <- liftIO $ atomically $ readTVar ts let g = find ((== gn) . getL (game >>> gameName)) (_games $ _multi s)- let eventHandler = fromJust $ findEvent en (_events $ _game $ fromJust g)+ let eventHandler = getEventHandler en (fromJust g) methodM POST r <- liftRouteT $ eitherForm environment "user" (getNomyxForm eventHandler) link <- showURL MainPage
src/Web/Help.hs view
@@ -42,5 +42,6 @@ getSaveFile = "With the following link, you can download the save file of the game. This allows you to load it in a local instance of the game.\n" ++ "This way, you will be able to compose and test the effects of your new rules locally, without affecting the online game. \n" ++ "The procedure is: \n" ++- "$> cabal install Nomyx \n" ++- "$> Nomyx -r <save file name>\n"+ "$> cabal install Nomyx-<version> \n" +++ "$> Nomyx -r <save file name>\n" +++ "Warning: Nomyx and Nomyx-Language should have the same exact version as the online instance.\n"
src/Web/MainPage.hs view
@@ -21,10 +21,9 @@ import Data.Monoid import Control.Concurrent.STM import Language.Nomyx+import Language.Nomyx.Engine import Happstack.Server as HS-import System.Directory import System.FilePath-import System.Posix.Files import qualified Web.Help as Help import Types as T import Web.Game@@ -32,20 +31,20 @@ import Web.Settings import Web.NewGame import Web.Login+import Data.List import Utils import Data.Text(Text, pack)-import qualified Language.Nomyx.Game as G+import qualified Language.Nomyx.Engine as G import Happstack.Auth import Safe-+import Paths_Nomyx_Language default (Integer, Double, Data.Text.Text) - viewMulti :: PlayerNumber -> PlayerNumber -> FilePath -> Session -> RoutedNomyxServer Html-viewMulti pn playAs dataDir s = do+viewMulti pn playAs saveDir s = do pfd <- getProfile s pn let isAdmin = _isAdmin $ _pAdmin $ fromJustNote "viewMulti" pfd- gns <- viewGamesTab (map G._game $ _games $ _multi s) isAdmin dataDir+ gns <- viewGamesTab (map G._game $ _games $ _multi s) isAdmin saveDir mgn <- liftRouteT $ lift $ getPlayersGame pn s vg <- case mgn of Just g -> viewGame (G._game g) playAs (_pLastRule $ fromJustNote "viewMulti" pfd) isAdmin@@ -55,14 +54,13 @@ div ! A.id "game" $ vg viewGamesTab :: [Game] -> Bool -> FilePath -> RoutedNomyxServer Html-viewGamesTab gs isAdmin dataDir = do+viewGamesTab gs isAdmin saveDir = do gns <- mapM (viewGameName isAdmin) gs newGameLink <- showURL NewGame settingsLink <- showURL W.PlayerSettings advLink <- showURL Advanced logoutURL <- showURL (U_AuthProfile $ AuthURL A_Logout)- mods <- liftIO $ getDirectoryContents $ dataDir </> modDir- fmods <- liftIO $ filterM (getFileStatus . (\f -> joinPath [dataDir, modDir, f]) >=> return . isRegularFile) $ mods+ fmods <- liftIO $ getUploadedModules saveDir ok $ do h3 "Main menu" >> br "Active games:" >> br@@ -71,13 +69,12 @@ [] -> 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- H.a "Rules definitions" ! (href $ "/src/Language/Nomyx/Definition.hs") >> br- 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 >> "Help files:" >> br+ H.a "Rules examples" ! (href $ "/html/Language-Nomyx-Examples.html") >> br+ H.a "Nomyx language" ! (href $ "/html/Language-Nomyx.html") >> br+ when (fmods /= []) $ do+ br >> "Uploaded files:" >> br+ mapM_ (\f -> (H.a $ toHtml f ) ! (href $ toValue (pathSeparator : uploadDir </> f)) >> br) (sort fmods) br >> "Settings:" >> br H.a "Player settings" ! (href $ toValue settingsLink) >> br H.a "Advanced" ! (href $ toValue advLink) >> br@@ -87,32 +84,37 @@ viewGameName :: Bool -> Game -> RoutedNomyxServer Html viewGameName isAdmin g = do let gn = _gameName g- join <- showURL (JoinGame gn)- leave <- showURL (LeaveGame gn)- view <- showURL (ViewGame gn)- del <- showURL (DelGame gn)+ join <- showURL (W.JoinGame gn)+ leave <- showURL (W.LeaveGame gn)+ view <- showURL (W.ViewGame gn)+ del <- showURL (W.DelGame gn) ok $ tr $ do td ! A.id "gameName" $ string $ (gn ++ " ") td $ H.a "View" ! (href $ toValue view) ! (A.title $ toValue Help.view) td $ H.a "Join" ! (href $ toValue $ "#openModalJoin" ++ gn) ! (A.title $ toValue Help.join)- td $ H.a "Leave" ! (href $ toValue leave)+ td $ H.a "Leave" ! (href $ toValue $ "#openModalLeave" ++ gn) when isAdmin $ td $ H.a "Del" ! (href $ toValue del) div ! A.id (toValue $ "openModalJoin" ++ gn) ! A.class_ "modalWindow" $ do div $ do h2 "Joining the game. Please register in the Agora (see the link) and introduce yourself to the other players! \n \ If you do not wich to play, you can just view the game."- H.a "Join" ! (href $ toValue join) ! A.class_ "join" ! (A.title $ toValue Help.join)- H.a "View" ! (href $ toValue view) ! A.class_ "view" ! (A.title $ toValue Help.view)+ H.a "Join" ! (href $ toValue join) ! A.class_ "modalButton" ! (A.title $ toValue Help.join)+ H.a "View" ! (href $ toValue view) ! A.class_ "modalButton" ! (A.title $ toValue Help.view)+ div ! A.id (toValue $ "openModalLeave" ++ gn) ! A.class_ "modalWindow" $ do+ div $ do+ h2 "Do you really want to leave? You will loose your assets in the game (for example, your bank account)."+ H.a "Leave" ! (href $ toValue leave) ! A.class_ "modalButton"+ H.a "Stay" ! (href $ toValue view) ! A.class_ "modalButton" nomyxPage :: (TVar Session) -> RoutedNomyxServer Response nomyxPage ts = do pn <- getPlayerNumber ts s <- liftIO $ atomically $ readTVar ts- let dataDir = _dataDir $ _mSettings $ _multi s+ let saveDir = _saveDir $ _mSettings $ _multi s name <- liftIO $ Utils.getPlayerName pn s playAs <- getPlayAs ts- m <- viewMulti pn playAs dataDir s+ m <- viewMulti pn playAs saveDir s let body = do string $ "Welcome to Nomyx, " ++ name ++ "! " when (playAs /= pn) $ (b ! A.style "color:red;" $ string ("Playing as Player #" ++ (show playAs)) )@@ -129,8 +131,8 @@ 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 (W.JoinGame game) = joinGame ts game+routedNomyxCommands ts (W.LeaveGame game) = leaveGame ts game routedNomyxCommands ts (ViewGame game) = viewGamePlayer ts game routedNomyxCommands ts (DelGame game) = delGame ts game routedNomyxCommands ts (NewRule game) = newRule ts game@@ -154,13 +156,20 @@ 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+ let set = _mSettings $ _multi s+ docdir <- liftIO $ getDocDir mconcat [- serveDirectory DisableBrowsing [] d,- serveDirectory DisableBrowsing [] d',+ serveDirectory DisableBrowsing [] (_saveDir set),+ serveDirectory DisableBrowsing [] docdir,+ serveDirectory DisableBrowsing [] (_dataDir set),+ serveDirectory DisableBrowsing [] (_sourceDir set), do decodeBody (defaultBodyPolicy "/tmp/" 102400 4096 4096) html <- implSite (pack (nomyxURL net)) "/Nomyx" (nomyxSite ts) return $ toResponse html] +getDocDir :: IO FilePath+getDocDir = do+ datadir <- getDataDir+ let (x:xs) = reverse $ splitDirectories datadir+ return $ joinPath $ reverse $ (x:"doc":xs)
src/Web/NewGame.hs view
@@ -15,7 +15,7 @@ import Text.Reform.Happstack import Web.Common import Control.Monad.State-import Language.Nomyx+import Language.Nomyx.Engine import Web.Routes.RouteT import Control.Concurrent.STM import Data.Text(Text)
src/Web/Settings.hs view
@@ -28,6 +28,11 @@ import qualified Language.Haskell.HsColour.HTML as HSC import Language.Haskell.HsColour.Colourise hiding (string) import Text.Blaze.Internal hiding (Text)+import Safe+import Paths_Nomyx as PN+import Paths_Nomyx_Language as PNL+import Data.Version (showVersion)+import System.FilePath default (Integer, Double, Data.Text.Text) playerSettingsForm :: (Maybe PlayerSettings) -> [PlayerName] -> [String] -> NomyxForm PlayerSettings@@ -73,7 +78,7 @@ pfd <- getProfile' ts pn names <- liftIO $ forbiddenNames ts pn emails <- liftIO $ forbiddenEmails ts pn- settingsPage (_pPlayerSettings $ fromJust pfd) names emails+ settingsPage (_pPlayerSettings $ fromJustNote "playerSettings" pfd) names emails newPlayerSettings :: (TVar Session) -> RoutedNomyxServer Response newPlayerSettings ts = toResponse <$> do@@ -113,7 +118,7 @@ pfd <- getProfile session pn pfds <- liftIO $ getAllProfiles session session <- liftIO $ atomically $ readTVar ts- page <- advancedPage (_pLastUpload $ fromJust pfd) (_pAdmin $ fromJust pfd) (_mSettings $ _multi session) pfds+ page <- advancedPage (_pLastUpload $ fromJustNote "advanced" pfd) (_pAdmin $ fromJustNote "advanced" pfd) (_mSettings $ _multi session) pfds mainPage "Advanced" "Advanced" page False True @@ -127,10 +132,16 @@ ap <- lift $ viewForm "user" $ adminPassForm paf <- lift $ viewForm "user" $ playAsForm [] set <- lift $ viewForm "user" $ settingsForm (_sendMails settings)+ liftIO $ makeTar (_saveDir settings) ok $ do p $ do+ string $ "Versions:"+ pre $ string $ "Nomyx " ++ showVersion PN.version ++ "\n" +++ "Nomyx-Language " ++ showVersion PNL.version+ hr+ p $ do pre $ string Help.getSaveFile- H.a "get save file" ! (href $ "/Nomyx.save")+ H.a "get save file" ! (href $ toValue (pathSeparator : tarFile)) H.br hr p $ do@@ -146,7 +157,7 @@ NoUpload -> p "" hr p $ do- h5 "Enter admin password to get admin rights:"+ h5 "Enter admin password to get admin rights (necessary to create a new game):" blazeForm ap (submitAdminPass) when admin $ h5 "You are admin" when admin $ do@@ -257,3 +268,5 @@ (Left errorForm) -> do settingsLink <- showURL SubmitAdminPass mainPage "Admin settings" "Admin settings" (blazeForm errorForm settingsLink) False True++