Nomyx-Core (empty) → 0.5.0
raw patch · 20 files changed
+1589/−0 lines, 20 filesdep +DebugTraceHelpersdep +MissingHdep +Nomyx-Languagesetup-changed
Dependencies added: DebugTraceHelpers, MissingH, Nomyx-Language, acid-state, aeson, base, blaze-html, blaze-markup, bytestring, data-lens, data-lens-fd, data-lens-template, directory, either-unwrap, exceptions, filepath, happstack-authenticate, hint, hint-server, hscolour, ixset, mime-mail, mtl, mueval, network, safe, safecopy, stm, tar, template-haskell, temporary, text, time, unix
Files
- AUTHORS +1/−0
- LICENSE +27/−0
- Nomyx-Core.cabal +75/−0
- README +8/−0
- Setup.lhs +6/−0
- TODO +0/−0
- data/test/SimpleModule.hs +12/−0
- data/test/SimpleModule2.hs +9/−0
- data/test/UnsafeIO.hs +10/−0
- data/test/more/SimpleModule.hs +12/−0
- src/Nomyx/Core/Interpret.hs +138/−0
- src/Nomyx/Core/Mail.hs +93/−0
- src/Nomyx/Core/Multi.hs +94/−0
- src/Nomyx/Core/Profile.hs +155/−0
- src/Nomyx/Core/Quotes.hs +54/−0
- src/Nomyx/Core/Serialize.hs +85/−0
- src/Nomyx/Core/Session.hs +232/−0
- src/Nomyx/Core/Test.hs +330/−0
- src/Nomyx/Core/Types.hs +101/−0
- src/Nomyx/Core/Utils.hs +147/−0
+ AUTHORS view
@@ -0,0 +1,1 @@+corentin.dupont@gmail.com
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright 2012, Corentin Dupont. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of its contributors may be+ used to endorse or promote products derived from this software without+ specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Nomyx-Core.cabal view
@@ -0,0 +1,75 @@+name: Nomyx-Core+version: 0.5.0+cabal-version: >=1.6+build-type: Simple+license: BSD3+license-file: LICENSE+maintainer: corentin.dupont@gmail.com+synopsis: A Nomic game in haskell+category: game+Homepage: http://www.nomyx.net+author: Corentin Dupont+extra-source-files: AUTHORS README TODO+data-files: test/*.hs+ test/more/*.hs+data-dir: data+ +library + build-depends: Nomyx-Language == 0.5.0,+ DebugTraceHelpers == 0.12.*,+ MissingH == 1.2.*,+ acid-state == 0.12.*,+ aeson == 0.7.*,+ base == 4.6.*,+ blaze-html == 0.7.*,+ blaze-markup == 0.6.*,+ bytestring == 0.10.*,+ data-lens == 2.10.*,+ data-lens-template == 2.1.*,+ data-lens-fd == 2.0.*,+ directory == 1.2.*,+ either-unwrap == 1.1.*,+ exceptions == 0.3.*,+ filepath == 1.3.*,+ happstack-authenticate == 0.10.*,+ hint == 0.4.*,+ hint-server == 1.3.*,+ hscolour == 1.20.*,+ ixset == 1.0.*,+ mime-mail == 0.4.*,+ mtl == 2.1.*,+ mueval == 0.9.*,+ network == 2.4.*,+ safe == 0.3.*,+ safecopy == 0.8.*,+ stm == 2.4.*,+ tar == 0.4.*,+ temporary == 1.1.*,+ template-haskell == 2.8.*,+ text == 1.1.*,+ time == 1.4.*+ if os(windows)+ Cpp-options: -DWINDOWS+ else+ build-depends: unix == 2.6.*++ extensions: CPP+ exposed: True+ buildable: True+ hs-source-dirs: src+ exposed-modules: Nomyx.Core.Types+ Nomyx.Core.Profile+ Nomyx.Core.Session+ Nomyx.Core.Multi+ Nomyx.Core.Serialize+ Nomyx.Core.Interpret+ Nomyx.Core.Quotes+ Nomyx.Core.Mail+ Nomyx.Core.Utils+ Nomyx.Core.Test+ Paths_Nomyx_Core+ ghc-options: -W -threaded+ +source-repository head+ type: git+ location: git://github.com/cdupont/Nomyx-Core.git
+ README view
@@ -0,0 +1,8 @@+[](https://travis-ci.org/cdupont/Nomyx-Core)+[](https://hackage.haskell.org/package/Nomyx-Core)++Nomyx-Core+=========++Library holding the core processes of Nomyx.+
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain +
+ TODO view
+ data/test/SimpleModule.hs view
@@ -0,0 +1,12 @@++module SimpleModule where++import Prelude+import Language.Nomyx+import Control.Monad++myRule :: Rule+myRule = void $ outputAll_ helperFunction++helperFunction :: String+helperFunction = "Hello"
+ data/test/SimpleModule2.hs view
@@ -0,0 +1,9 @@++module SimpleModule2 where++import Prelude+import Language.Nomyx+import Control.Monad++myRule :: Rule+myRule = void $ outputAll_ "Hello"
+ data/test/UnsafeIO.hs view
@@ -0,0 +1,10 @@++module UnsafeIO where++import Prelude+import Language.Nomyx+import System.IO.Unsafe+import Control.Monad++myRule :: Rule+myRule = void $ outputAll_ $ unsafePerformIO $ readFile "/etc/passwd"
+ data/test/more/SimpleModule.hs view
@@ -0,0 +1,12 @@++module SimpleModule where++import Prelude+import Language.Nomyx+import Control.Monad++myRule2 :: Rule+myRule2 = void $ outputAll_ helperFunction++helperFunction :: String+helperFunction = "Hello"
+ src/Nomyx/Core/Interpret.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | This module starts a Interpreter server that will read our strings representing rules to convert them to plain Rules. +module Nomyx.Core.Interpret where + +import Language.Haskell.Interpreter +import Language.Haskell.Interpreter.Server +import Language.Nomyx +import System.Directory (createDirectoryIfMissing, copyFile, removeFile, doesFileExist)+import System.FilePath ((</>), joinPath, dropExtension, takeFileName)+import Control.Exception as CE+import Data.Either.Unwrap+import Nomyx.Core.Utils+import Data.List+import Control.Monad+import Language.Haskell.Interpreter.Unsafe (unsafeSetGhcOption)+import qualified Mueval.Resources as MR (limitResources)+import qualified Mueval.Context as MC+import qualified Mueval.Interpreter as MI+import System.IO.Error++++unQualImports :: [String]+unQualImports = "Language.Nomyx" :+ "Language.Nomyx.Examples" :+ "Safe" :+ "Data.Typeable" :+ "Data.Lens" :+ MC.defaultModules++qualImports :: [(String, Maybe String)]+qualImports = ("Control.Category", Just "C") : MC.qualifiedModules++defaultPackages :: [String]+defaultPackages = "Nomyx-Language" : MC.defaultPackages+++exts :: [String]+exts = ["Safe", "GADTs"] ++ map show namedExts++namedExts :: [Extension]+namedExts = [GADTs,+ ScopedTypeVariables,+ TypeFamilies,+ DeriveDataTypeable]+ +-- | the server handle +startInterpreter :: FilePath -> IO ServerHandle +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 sh ++-- get all uploaded modules from the directory (may be empty)+getUploadModules :: FilePath -> IO [FilePath]+getUploadModules saveDir = do+ files <- getUploadedModules saveDir `catch` (\(_::SomeException) -> return [])+ return $ map (\f -> joinPath [saveDir, uploadDir, f]) files++ +-- | initializes the interpreter by loading some modules. +initializeInterpreter :: FilePath -> Interpreter () +initializeInterpreter saveDir = do+ reset -- Make sure nothing is available+ set [installedModulesInScope := False,+ languageExtensions := map MI.readExt exts]+ unsafeSetGhcOption "-fpackage-trust"+ forM_ (defaultPackages >>= words) $ \pkg -> unsafeSetGhcOption ("-trust " ++ pkg) + uploadedMods <- liftIO $ getUploadModules saveDir+ liftIO $ putStrLn $ "Loading modules: " ++ (intercalate ", " uploadedMods)+ loadModules uploadedMods+ setTopLevelModules $ map (dropExtension . takeFileName) uploadedMods+ liftIO $ MR.limitResources False+ let importMods = qualImports ++ zip (unQualImports) (repeat Nothing)+ setImportsQ importMods++--initializeInterpreter :: FilePath -> Interpreter ()+--initializeInterpreter saveDir = do+-- uploadedMods <- liftIO $ getUploadModules saveDir+-- liftIO $ putStrLn $ "Loading modules: " ++ (concat $ intersperse ", " uploadedMods)+-- let o = Options { extensions = True,+-- namedExtensions = exts,+-- typeOnly = True,+-- rLimits = True,+-- loadFile = "",+-- packageTrust = True,+-- modules = Just unQualImports}+-- MI.initializeInterpreter o+-- uploadedMods <- liftIO $ getUploadModules saveDir+-- liftIO $ putStrLn $ "Loading modules: " ++ (concat $ intersperse ", " uploadedMods)+-- loadModules uploadedMods++---- | reads maybe a Rule out of a string. +interpretRule :: String -> ServerHandle -> IO (Either InterpreterError Rule) +interpretRule s sh = (liftIO $ runIn sh $ interpret s (as :: Rule))+ `catchIOError` (\(e::IOException) -> return $ Left $ NotAllowed $ "Caught exception: " ++ (show e))++getRuleFunc :: ServerHandle -> RuleCode -> IO Rule+getRuleFunc sh rc = do+ res <- interpretRule rc sh+ case res of+ Right rf -> return rf+ Left e -> error $ show e++-- | check an uploaded file and reload +loadModule :: FilePath -> FilePath -> ServerHandle -> FilePath -> IO (Maybe InterpreterError) +loadModule tempModName name sh saveDir = do+ --copy the new module in the upload directory+ let dest = saveDir </> uploadDir </> name+ exist <- doesFileExist dest+ if exist then return $ Just $ NotAllowed "Module already uploaded"+ else do+ copyFile tempModName dest+ setMode dest+ inter <- runIn sh $ initializeInterpreter saveDir+ case inter of+ Right _ -> return Nothing + Left e -> do+ --suppress the faulty module+ removeFile dest+ final <- runIn sh $ initializeInterpreter saveDir+ when (isLeft final) $ putStrLn "Error: reinitialize interpreter failed"+ return $ Just e+++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 (Probable cause: bad module or file name)\n" ++ s+showInterpreterError (GhcException s) = "Ghc Exception\n" ++ s
+ src/Nomyx/Core/Mail.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE NamedFieldPuns #-}+++module Nomyx.Core.Mail where++import Text.Blaze.Html5 hiding (map, label, br)+import qualified Text.Blaze.Html5 as H+import Text.Blaze.Html.Renderer.String+import Network.Mail.Mime hiding (mailTo)+import Prelude hiding (div, (.))+import Control.Monad+import Language.Nomyx+import Language.Nomyx.Engine+import Data.Text(Text, pack)+import Control.Concurrent+import Data.Maybe+import qualified Data.Text.Lazy as B+import qualified Language.Haskell.HsColour.HTML as HSC+import Language.Haskell.HsColour.Colourise hiding (string)+import Text.Blaze.Internal+import Control.Category+import Control.Applicative ((<$>))+import Safe+import Data.List+import Nomyx.Core.Profile+import Nomyx.Core.Types+import Nomyx.Core.Utils+++default (Integer, Double, Data.Text.Text)+++sendMail :: String -> String -> String -> String-> IO()+sendMail to object htmlBody textBody = do+ putStrLn $ "sending a mail to " ++ to+ forkIO $ simpleMail (Address Nothing (pack to))+ (Address (Just "Nomyx Game") "kau@nomyx.net")+ (pack object)+ (B.pack htmlBody)+ (B.pack textBody)+ [] >>= renderSendMail+ putStrLn "done"+++newRuleHtmlBody :: PlayerName -> SubmitRule -> PlayerName -> Network -> Html+newRuleHtmlBody playerName (SubmitRule name desc code) prop net = docTypeHtml $ do+ (toHtml $ "Dear " ++ playerName ++ ",") >> H.br+ (toHtml $ "a new rule has been proposed by player " ++ prop ++ ".") >> H.br+ (toHtml $ "Name: " ++ name) >> H.br+ (toHtml $ "Description: " ++ desc) >> H.br+ (toHtml $ "Code: ") >> H.br >> (preEscapedString $ HSC.hscolour defaultColourPrefs False code) >> H.br >> H.br+ (toHtml $ "Please login into Nomyx for actions on this rule:") >> H.br+ (toHtml $ nomyxURL net ++ "/Nomyx") >> H.br >> H.br+ (toHtml $ "You received this mail because you subscribed to Nomyx. To stop receiving mails, login to Nomyx with the above address, go to Settings and uncheck the corresponding box.") >> H.br++newRuleTextBody :: PlayerName -> SubmitRule -> PlayerName -> Network -> String+newRuleTextBody playerName (SubmitRule name desc code) prop net =+ "Dear " ++ playerName ++ ",\n" +++ "a new rule has been proposed by player " ++ prop ++ ".\n" +++ "Name: " ++ name ++ "\n" +++ "Description: " ++ desc ++ "\n" +++ "Code: \n" ++ code ++ "\n\n" +++ "Please login into Nomyx for actions on this rule:\n" +++ nomyxURL net ++ "/Nomyx\n\n" +++ "You received this mail because you subscribed to Nomyx. To stop receiving mails, login to Nomyx with the above address, go to Settings and uncheck the corresponding box.\n"+++newRuleObject :: PlayerName -> String+newRuleObject name = "[Nomyx] New rule posted by player " ++ name ++ "!"++sendMailsNewRule :: Session -> SubmitRule -> PlayerNumber -> IO ()+sendMailsNewRule s sr pn = when (_sendMails $ _mSettings $ _multi s) $ do+ putStrLn "Sending mails"+ gn <- fromJustNote "sendMailsNewRule" <$> getPlayersGame pn s+ let sendMailsTo = delete pn (map _playerNumber (_players $ _game $ _loggedGame gn))+ proposer <- Nomyx.Core.Profile.getPlayerName pn s+ profiles <- mapM (getProfile s) sendMailsTo+ mapM_ (send proposer (_net $ _mSettings $ _multi s) sr) (_pPlayerSettings <$> catMaybes profiles)+++send :: PlayerName -> Network -> SubmitRule -> PlayerSettings -> IO()+send prop net sr set = when (_mailNewRule set)+ $ sendMail (_mail set)+ (newRuleObject prop)+ (newRuleTextBody (_pPlayerName set) sr prop net)+ (renderHtml $ newRuleHtmlBody (_pPlayerName set) sr prop net)+ +mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM f = liftM catMaybes . mapM f++
+ src/Nomyx/Core/Multi.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE QuasiQuotes #-}++-- | This module manages multi-player games.+module Nomyx.Core.Multi where++import Prelude+import Control.Monad.State+import Data.Time as T+import Language.Haskell.Interpreter.Server (ServerHandle)+import Data.Maybe+import Control.Exception+import Data.Lens+import Language.Nomyx.Engine as G+import Control.Category hiding ((.))+import Nomyx.Core.Quotes (cr)+import Control.Applicative+import Data.List+import Language.Nomyx+import Nomyx.Core.Utils+import Nomyx.Core.Types+import Nomyx.Core.Interpret++triggerTimeEvent :: UTCTime -> StateT Multi IO ()+triggerTimeEvent t = do+ gs <- access gameInfos+ gs' <- lift $ mapM (trig' t) gs+ void $ gameInfos ~= gs'++trig' :: UTCTime -> GameInfo -> IO GameInfo+trig' t gi = do+ lg <- trig t (_loggedGame gi)+ return $ gi {_loggedGame = lg}++trig :: UTCTime -> LoggedGame -> IO LoggedGame+trig t g = do+ g' <- execWithGame' t (execGameEvent $ TimeEvent t) g+ evaluate g'++-- | get all events that has not been triggered yet+getTimeEvents :: UTCTime -> Multi -> IO [UTCTime]+getTimeEvents now m = do+ let times = mapMaybe getTimes $ concatMap (getL $ loggedGame >>> game >>> events) $ _gameInfos m+ return $ filter (\t -> t <= now && t > (-2) `addUTCTime` now) times++-- | the initial rule set for a game.+rVoteUnanimity = SubmitRule "Unanimity Vote"+ "A proposed rule will be activated if all players vote for it"+ [cr|onRuleProposed $ voteWith_ unanimity $ assessOnEveryVote |]++rVictory5Rules = SubmitRule "Victory 5 accepted rules"+ "Victory is achieved if you have 5 active rules"+ [cr|victoryXRules 5|]++rVoteMajority = SubmitRule "Majority Vote"+ "A proposed rule will be activated if a majority of players is reached, with a minimum of 2 players, and within oone day"+ [cr|onRuleProposed $ voteWith_ (majority `withQuorum` 2) $ assessOnEveryVote >> assessOnTimeDelay oneMinute |]+++initialGame :: ServerHandle -> StateT GameInfo IO ()+initialGame sh = focus loggedGame $ mapM_ addR [rVoteUnanimity, rVictory5Rules]+ where addR r = execGameEvent' (Just $ getRuleFunc sh) (SystemAddRule r)++initialGameInfo :: GameName -> GameDesc -> Bool -> Maybe PlayerNumber -> UTCTime -> ServerHandle -> IO GameInfo+initialGameInfo name desc isPublic mpn date sh = do+ let lg = GameInfo { _loggedGame = LoggedGame (emptyGame name desc date) [],+ _ownedBy = mpn,+ _forkedFromGame = Nothing,+ _isPublic = isPublic,+ _startedAt = date}++ execStateT (initialGame sh) lg++getGameByName :: GameName -> StateT Multi IO (Maybe GameInfo)+getGameByName gn = find ((==gn) . getL gameNameLens) <$> access gameInfos++defaultMulti :: Settings -> Multi+defaultMulti = Multi []++-- | finds the corresponding game in the multistate and replaces it.+modifyGame :: GameInfo -> StateT Multi IO ()+modifyGame gi = do+ gs <- access gameInfos+ case find (== gi) gs of+ Nothing -> error "modifyGame: No game by that name"+ Just oldg -> do+ let newgs = replace oldg gi gs+ gameInfos ~= newgs+ return ()++execWithMulti :: UTCTime -> StateT Multi IO () -> Multi -> IO Multi+execWithMulti t ms m = do+ let setTime g = (loggedGame >>> game >>> currentTime) ^= t $ g+ let m' = gameInfos `modL` (map setTime) $ m+ execStateT ms m'
+ src/Nomyx/Core/Profile.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE QuasiQuotes #-}++module Nomyx.Core.Profile where++import Language.Nomyx+import Language.Nomyx.Engine+import Data.IxSet (toList, (@=))+import qualified Data.IxSet as IxSet+import Control.Monad.Reader.Class (MonadReader(..))+import Control.Monad.Catch (bracket)+import Control.Concurrent.STM+import Safe+import Data.Lens+import Data.List+import Data.Maybe+import Control.Monad+import Control.Monad.State+import qualified Data.Acid.Advanced as A (update', query')+import Data.Acid.Local (createCheckpointAndClose)+import Data.Acid (openLocalStateFrom, makeAcidic, Update, Query)+import Happstack.Auth.Core.Auth (initialAuthState)+import Happstack.Auth.Core.Profile (initialProfileState)+import System.FilePath ((</>))+import Nomyx.Core.Quotes+import Nomyx.Core.Types+import Nomyx.Core.Utils++-- | set 'ProfileData' for UserId+setProfileData :: ProfileData -> Update ProfileDataState ProfileData+setProfileData profileData =+ do pds@(ProfileDataState {..}) <- get+ put $ pds { profilesData = IxSet.updateIx (_pPlayerNumber profileData) profileData profilesData }+ return profileData++-- | get 'ProfileData' associated with 'UserId'+askProfileData :: PlayerNumber -> Query ProfileDataState (Maybe ProfileData)+askProfileData uid = do+ ProfileDataState{..} <- ask+ let pfs = toList profilesData+ let filtered = filter (\a -> _pPlayerNumber a == uid) pfs+ return $ headMay filtered+ --return $ getOne $ profilesData @= uid++initialProfileData :: PlayerNumber -> PlayerSettings -> ProfileData+initialProfileData uid ps = ProfileData uid ps Nothing (Just (exampleRule, "")) NoUpload False++exampleRule :: SubmitRule+exampleRule = SubmitRule "" "" [cr|+--This is an example new rule that you can enter.+--If you submit this rule it will have to be voted on by other players (as described by rule 1).+--A lot of other examples can be found in the left menu bar.+do+ --get your own player number+ me <- getProposerNumber_+ --create an output for me only+ let displayMsg _ = void $ newOutput_ (Just me) "Bravo!"+ --create a button for me, which will display the output when clicked+ void $ onInputButton_ "Click here:" displayMsg me+|]+++-- | create the profile data, but only if it is missing+newProfileData :: PlayerNumber -> PlayerSettings -> Update ProfileDataState ProfileData+newProfileData uid ps =+ do pds@(ProfileDataState {..}) <- get+ case IxSet.getOne (profilesData @= uid) of+ Nothing -> do+ let pd = initialProfileData uid ps+ put $ pds { profilesData = IxSet.updateIx uid pd profilesData }+ return pd+ (Just profileData) -> return profileData++-- | get number of+askProfileDataNumber :: Query ProfileDataState Int+askProfileDataNumber =+ do pds <- ask+ tracePN 1 (show $ profilesData pds)+ return $ IxSet.size $ profilesData pds++-- | get all profiles+askProfilesData :: Query ProfileDataState [ProfileData]+askProfilesData =+ do pds <- ask+ return $ toList $ profilesData pds++$(makeAcidic ''ProfileDataState+ [ 'setProfileData+ , 'askProfileData+ , 'newProfileData+ , 'askProfileDataNumber+ , 'askProfilesData+ ]+ )++initialProfileDataState :: ProfileDataState+initialProfileDataState = ProfileDataState { profilesData = IxSet.empty }++defaultPlayerSettings :: PlayerSettings+defaultPlayerSettings = PlayerSettings "" "" False False False False+++modifyProfile :: PlayerNumber -> (ProfileData -> ProfileData) -> StateT Session IO ()+modifyProfile pn mod = do+ s <- get+ pfd <- A.query' (acidProfileData $ _profiles s) (AskProfileData pn)+ 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)++getProfile' :: MonadIO m => TVar Session -> PlayerNumber -> m (Maybe ProfileData)+getProfile' ts pn = do+ s <- liftIO $ atomically $ readTVar ts+ getProfile s pn++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++getPlayerInGameName :: Game -> PlayerNumber -> PlayerName+getPlayerInGameName g pn = case find ((==pn) . getL playerNumber) (_players g) of+ Nothing -> error "getPlayersName': No player by that number in that game"+ Just pm -> _playerName pm++-- | returns the game the player is in+getPlayersGame :: PlayerNumber -> Session -> IO (Maybe GameInfo)+getPlayersGame pn s = do+ pfd <- A.query' (acidProfileData $ _profiles s) (AskProfileData pn)+ let mgn = _pViewingGame $ fromJustNote "getPlayersGame" pfd+ return $ do+ gn <- mgn+ find ((== gn) . getL gameNameLens) (_gameInfos $ _multi s) --checks if any game by that name exists++getAllProfiles :: Session -> IO [ProfileData]+getAllProfiles s = A.query' (acidProfileData $ _profiles s) AskProfilesData++getPlayerInfo :: Game -> PlayerNumber -> Maybe PlayerInfo+getPlayerInfo g pn = find ((==pn) . getL playerNumber) (_players g)++withAcid :: Maybe FilePath -- ^ state directory+ -> (Profiles -> IO a) -- ^ action+ -> IO a+withAcid mBasePath f =+ let basePath = fromMaybe "_state" mBasePath in+ bracket (openLocalStateFrom (basePath </> "auth") initialAuthState) createCheckpointAndClose $ \auth ->+ bracket (openLocalStateFrom (basePath </> "profile") initialProfileState) createCheckpointAndClose $ \profile ->+ bracket (openLocalStateFrom (basePath </> "profileData") initialProfileDataState) createCheckpointAndClose $ \profileData ->+ f (Profiles auth profile profileData)++
+ src/Nomyx/Core/Quotes.hs view
@@ -0,0 +1,54 @@+-----------------------------------------------------------------------------+--+-- Module : Quotes+-- Copyright :+-- License : BSD3+--+-- Maintainer : corentin.dupont@gmail.com+-- Stability :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}++module Nomyx.Core.Quotes where++import Language.Haskell.TH as TH+import Language.Haskell.TH.Quote+import Language.Haskell.Interpreter hiding (get)+import Nomyx.Core.Interpret+++-- This quasi quoter allows to type check a string as a Nomyx rule (a RuleFunc).+-- this gives additionnal safety at compile time.+#ifdef NO_INTERPRET_QUOTES+cr :: QuasiQuoter+cr = QuasiQuoter { quoteExp = \s -> [| s |],+ quotePat = undefined,+ quoteType = undefined,+ quoteDec = undefined}+#else+cr :: QuasiQuoter+cr = QuasiQuoter { quoteExp = quoteRuleFunc,+ quotePat = undefined,+ quoteType = undefined,+ quoteDec = undefined}+#endif++quoteRuleFunc :: String -> Q TH.Exp+quoteRuleFunc s = do+ res <- runIO $ runInterpreter $ do+ setImports unQualImports+ typeOf s+ case res of+ Right "Exp Effect ()" -> [| s |]+ Right "Exp 'Effect ()" -> [| s |]+ Right "Rule" -> [| s |]+ Right a -> fail $ "Rule doesn't typecheck: " ++ show a+ Left e -> fail $ show e+++
+ src/Nomyx/Core/Serialize.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module Nomyx.Core.Serialize where++import Prelude hiding (log, (.))+import Language.Nomyx hiding (getCurrentTime)+import Language.Nomyx.Engine+import Language.Nomyx.Engine.GameEvents+import Control.Monad.State+import Data.Lens+import Language.Haskell.Interpreter.Server+import Data.Aeson.TH+import Data.Aeson+import Control.Applicative+import Control.Category+import Data.Time.Clock.POSIX+import qualified Data.ByteString.Lazy.Char8 as BL+import Nomyx.Core.Types+import Nomyx.Core.Utils+import Nomyx.Core.Interpret++save :: Multi -> IO ()+save m = BL.writeFile (getSaveFile $ _mSettings m) (encode m)++save' :: StateT Multi IO ()+save' = get >>= lift . save++load :: FilePath -> IO Multi+load fp = do+ s <- BL.readFile fp+ case eitherDecode s of+ Left e -> error $ "error decoding save file: " ++ e+ Right a -> return a++loadMulti :: Settings -> ServerHandle -> IO Multi+loadMulti set sh = do+ m <- load (getSaveFile set)+ gs' <- mapM (updateGameInfo $ getRuleFunc sh) $ _gameInfos m+ let m' = gameInfos `setL` gs' $ m+ let m'' = mSettings `setL` set $ m'+ return m''++updateGameInfo :: (RuleCode -> IO Rule) -> GameInfo -> IO GameInfo+updateGameInfo f gi = do+ gi' <- updateLoggedGame f (_loggedGame gi)+ return $ gi {_loggedGame = gi'}++updateLoggedGame :: (RuleCode -> IO Rule) -> LoggedGame -> IO LoggedGame+updateLoggedGame f (LoggedGame g log) = getLoggedGame g f log++time0 = posixSecondsToUTCTime 0++instance ToJSON Game where+ toJSON (Game name desc _ _ _ _ _ _ _ _) =+ object ["gameName" .= name,+ "gameDesc" .= desc]++instance FromJSON Game where+ parseJSON (Object v) = Game <$>+ v .: "gameName" <*>+ v .: "gameDesc" <*>+ pure [] <*>+ pure [] <*>+ pure [] <*>+ pure [] <*>+ pure [] <*>+ pure Nothing <*>+ pure [] <*>+ pure time0+ -- A non-Object value is of the wrong type, so fail.+ parseJSON _ = mzero+++$(deriveJSON defaultOptions ''Multi)+$(deriveJSON defaultOptions ''Settings)+$(deriveJSON defaultOptions ''Network)+$(deriveJSON defaultOptions ''LoggedGame)+$(deriveJSON defaultOptions ''GameInfo)+$(deriveJSON defaultOptions ''TimedEvent)+$(deriveJSON defaultOptions ''GameEvent)+$(deriveJSON defaultOptions ''UInputData)+$(deriveJSON defaultOptions ''SubmitRule)+$(deriveJSON defaultOptions ''GameDesc)+
+ src/Nomyx/Core/Session.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DoAndIfThenElse #-}++-- | This module manages multi-player commands.+module Nomyx.Core.Session where++import Prelude+import Data.List+import Control.Monad.State+import Data.Time as T+import Language.Haskell.Interpreter.Server (ServerHandle)+import Language.Haskell.Interpreter (InterpreterError)+import Nomyx.Core.Types+import Debug.Trace.Helpers+import Data.Lens+import Language.Nomyx+import Language.Nomyx.Engine as G+import Control.Category hiding ((.))+import qualified Data.Acid.Advanced as A (update', query')+import Control.Concurrent.STM+import System.IO.PlafCompat+import Nomyx.Core.Utils+import Nomyx.Core.Multi+import Nomyx.Core.Profile+import Nomyx.Core.Interpret++-- | add a new player+newPlayer :: PlayerNumber -> PlayerSettings -> StateT Session IO ()+newPlayer uid ms = do+ s <- get+ void $ A.update' (acidProfileData $ _profiles s) (NewProfileData uid ms)++-- | starts a new game+newGame :: GameName -> GameDesc -> PlayerNumber -> Bool -> StateT Session IO ()+newGame name desc pn isPublic = do+ sh <- access sh+ focus multi $ newGame' name desc pn isPublic sh++newGame' :: GameName -> GameDesc -> PlayerNumber -> Bool -> ServerHandle -> StateT Multi IO ()+newGame' name desc pn isPublic sh = do+ gs <- access gameInfos+ if not $ any ((== name) . getL gameNameLens) gs then do+ tracePN pn $ "Creating a new game of name: " ++ name+ t <- lift T.getCurrentTime+ -- create a game with zero players+ lg <- lift $ initialGameInfo name desc isPublic (Just pn) t sh+ void $ gameInfos %= (lg : )+ else tracePN pn "this name is already used"++-- | view a game.+viewGamePlayer :: GameName -> PlayerNumber -> StateT Session IO ()+viewGamePlayer gn pn = do+ mg <- focus multi $ getGameByName gn+ case mg of+ Nothing -> tracePN pn "No game by that name"+ Just _ -> modifyProfile pn (pViewingGame ^= Just gn)++-- | unview a game.+unviewGamePlayer :: PlayerNumber -> StateT Session IO ()+unviewGamePlayer pn = modifyProfile pn (pViewingGame ^= Nothing)++-- | join a game (also view it for conveniency)+joinGame :: GameName -> PlayerNumber -> StateT Session IO ()+joinGame gn pn = do+ s <- get+ name <- lift $ Nomyx.Core.Profile.getPlayerName pn s+ inGameDo gn $ G.execGameEvent $ JoinGame pn name+ viewGamePlayer gn pn++-- | delete a game.+delGame :: GameName -> StateT Session IO ()+delGame name = focus multi $ void $ gameInfos %= filter ((/= name) . getL gameNameLens)+++-- | leave a game.+leaveGame :: GameName -> PlayerNumber -> StateT Session IO ()+leaveGame game pn = inGameDo game $ G.execGameEvent $ LeaveGame pn++-- | insert a rule in pending rules.+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 "+ inGameDo gn $ G.execGameEvent' (Just $ getRuleFunc sh) (ProposeRuleEv pn sr)+ modifyProfile pn (pLastRule ^= Just (sr, "Rule submitted OK!"))+ Left e -> submitRuleError sr pn gn e++adminSubmitRule :: SubmitRule -> PlayerNumber -> GameName -> ServerHandle -> StateT Session IO ()+adminSubmitRule sr@(SubmitRule _ _ code) pn gn sh = do+ tracePN pn $ "admin proposed " ++ show sr+ mrr <- liftIO $ interpretRule code sh+ case mrr of+ Right _ -> do+ tracePN pn "proposed rule compiled OK "+ inGameDo gn $ execGameEvent' (Just $ getRuleFunc sh) (SystemAddRule sr)+ modifyProfile pn (pLastRule ^= Just (sr, "Admin rule submitted OK!"))+ Left e -> submitRuleError sr pn gn e++submitRuleError :: SubmitRule -> PlayerNumber -> GameName -> InterpreterError -> StateT Session IO ()+submitRuleError sr pn gn e = do+ let errorMsg = showInterpreterError e+ inGameDo gn $ execGameEvent $ GLog (Just pn) ("Error in submitted rule: " ++ errorMsg)+ tracePN pn ("Error in submitted rule: " ++ errorMsg)+ modifyProfile pn (pLastRule ^= Just (sr, errorMsg))++checkRule :: SubmitRule -> PlayerNumber -> ServerHandle -> StateT Session IO ()+checkRule sr@(SubmitRule _ _ code) pn sh = do+ tracePN pn $ "check rule " ++ show sr+ mrr <- liftIO $ interpretRule code sh+ case mrr of+ Right _ -> do+ tracePN pn "proposed rule compiled OK"+ modifyProfile pn (pLastRule ^= Just (sr, "Rule compiled OK. Now you can submit it!"))+ Left e -> do+ let errorMsg = showInterpreterError e+ 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 $ execGameEvent $ InputResult pn en ir++-- | upload a rule file, given a player number, the full path of the file, the file name and the server handle+inputUpload :: PlayerNumber -> FilePath -> FilePath -> ServerHandle -> StateT Session IO Bool+inputUpload pn temp mod sh = do+ saveDir <- access (multi >>> mSettings >>> saveDir)+ m <- liftIO $ loadModule temp mod sh saveDir+ tracePN pn $ " uploaded " ++ show mod+ case m of+ Nothing -> do+ inPlayersGameDo pn $ execGameEvent $ GLog (Just pn) ("File loaded: " ++ show temp ++ ", as " ++ show mod ++"\n")+ tracePN pn "upload success"+ modifyProfile pn (pLastUpload ^= UploadSuccess)+ return True+ Just e -> do+ let errorMsg = showInterpreterError e+ inPlayersGameDo pn $ execGameEvent $ GLog (Just pn) ("Error in file: " ++ show e ++ "\n")+ tracePN pn $ "upload failed: \n" ++ show e+ modifyProfile pn (pLastUpload ^= UploadFailure (temp, errorMsg))+ return False++-- | update player settings+playerSettings :: PlayerSettings -> PlayerNumber -> StateT Session IO ()+playerSettings playerSettings pn = modifyProfile pn (pPlayerSettings ^= playerSettings)++playAs :: Maybe PlayerNumber -> PlayerNumber -> GameName -> StateT Session IO ()+playAs playAs pn g = inGameDo g $ do+ pls <- access (game >>> players)+ case find ((== pn) . getL playerNumber) pls of+ Nothing -> tracePN pn "player not in game"+ Just pi -> void $ (game >>> players) ~= replaceWith ((== pn) . getL playerNumber) (pi {_playAs = playAs}) pls++adminPass :: String -> PlayerNumber -> StateT Session IO ()+adminPass pass pn = do+ s <- get+ if pass == (_adminPassword $ _mSettings $ _multi s) then do+ tracePN pn "getting admin rights"+ modifyProfile pn $ pIsAdmin ^= True+ else do+ tracePN pn "submitted wrong admin password"+ modifyProfile pn $ pIsAdmin ^= False++globalSettings :: Bool -> StateT Session IO ()+globalSettings mails = void $ (multi >>> mSettings >>> sendMails) ~= mails++-- | Utility functions++getNewPlayerNumber :: StateT Session IO PlayerNumber+getNewPlayerNumber = do+ s <- get+ pfd <- A.query' (acidProfileData $ _profiles s) AskProfileDataNumber+ return $ pfd + 1++forkGame :: GameName -> PlayerNumber -> StateT Session IO ()+forkGame gn pn = focus multi $ do+ gms <- access gameInfos+ case filter ((== gn) . getL gameNameLens) gms of+ gi:[] -> do+ tracePN pn $ "Forking game: " ++ gn+ time <- liftIO T.getCurrentTime+ let gi' = GameInfo {+ _loggedGame = (game >>> gameName) `setL` ("Forked " ++ gn) $ _loggedGame gi,+ _ownedBy = Just pn,+ _forkedFromGame = Just gn,+ _isPublic = False,+ _startedAt = time}+ void $ gameInfos %= (gi' : )+ _ -> tracePN pn $ "Creating a simulation game: no game by that name: " ++ gn+++-- | this function apply the given game actions to the game the player is in.+inPlayersGameDo :: PlayerNumber -> StateT LoggedGame IO a -> StateT Session IO (Maybe a)+inPlayersGameDo pn action = do+ s <- get+ t <- lift T.getCurrentTime+ mg <- lift $ getPlayersGame pn s+ case mg of+ Nothing -> tracePN pn "You must be in a game" >> return Nothing+ Just gi -> do+ (a, mylg) <- lift $ runStateT action (setL (game >>> currentTime) t (_loggedGame gi))+ focus multi $ modifyGame (gi {_loggedGame = mylg})+ return (Just a)++inGameDo :: GameName -> StateT LoggedGame IO () -> StateT Session IO ()+inGameDo gn action = focus multi $ do+ (gs :: [GameInfo]) <- access gameInfos+ case find ((==gn) . getL gameNameLens) gs of+ Nothing -> traceM "No game by that name"+ Just (gi::GameInfo) -> do+ t <- lift $ T.getCurrentTime+ mylg <- lift $ execWithGame' t action (_loggedGame gi)+ modifyGame (gi {_loggedGame = mylg})++-- update a session by executing a command.+-- we set a watchdog in case the evaluation would not finish+updateSession :: TVar Session -> StateT Session IO () -> IO ()+updateSession ts sm = do+ s <- atomically $ readTVar ts+ ms <- evalWithWatchdog s (evalSession sm)+ case ms of+ Just s -> atomically $ writeTVar ts s+ Nothing -> putStrLn "thread timed out, updateSession discarded"+++evalSession :: StateT Session IO () -> Session -> IO Session+evalSession sm s = do+ s' <- execStateT sm s+ writeFile nullFileName $ show $ _multi s' --dirty hack to force deep evaluation --deepseq (_multi s') (return ())+ return s'+
+ src/Nomyx/Core/Test.hs view
@@ -0,0 +1,330 @@+-----------------------------------------------------------------------------+--+-- Module : Test+-- Copyright :+-- License : BSD3+--+-- Maintainer : corentin.dupont@gmail.com+-- Stability :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE QuasiQuotes #-}++-- | Test module+module Nomyx.Core.Test where++import Prelude+import Control.Monad.State+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+import Language.Haskell.TH.Syntax as THS hiding (lift)+import System.IO.Unsafe+import Data.Lens+import Data.List+import Data.Maybe+import Data.Acid.Memory+import Happstack.Auth.Core.Auth (initialAuthState)+import Happstack.Auth.Core.Profile (initialProfileState)+import qualified Language.Nomyx.Engine as G+import Control.Arrow ((>>>))+import Data.Time hiding (getCurrentTime)+import System.IO.Temp+import Paths_Nomyx_Core as PNC+import System.FilePath ((</>))+import System.Directory (createDirectoryIfMissing)+import Nomyx.Core.Types+import Nomyx.Core.Multi+import Nomyx.Core.Session+import Nomyx.Core.Utils+import Nomyx.Core.Profile+import Nomyx.Core.Quotes++playTests :: FilePath -> ServerHandle -> Maybe String -> IO [(String, Bool)]+playTests saveDir sh mTestName = do+ tests <- case mTestName of+ Just testName -> do+ let tsts = fatalTests ++ regularTests+ return $ maybeToList $ find (\(name, _, _) -> name == testName) tsts+ Nothing -> return regularTests+ tp <- testProfiles+ dir <- createTempDirectory "/tmp" "Nomyx"+ createDirectoryIfMissing True $ dir </> uploadDir+ let session = Session sh (defaultMulti Settings {_net = defaultNetwork, _sendMails = False, _adminPassword = "", _saveDir = saveDir, _webDir = "", _sourceDir = ""}) tp+ mapM (\(title, t, cond) -> (title,) <$> test title session t cond) tests++-- | test list.+-- each test can be loaded individually in Nomyx with the command line:+-- Nomyx -l <"test name">+regularTests :: [(String, StateT Session IO (), Multi -> Bool)]+regularTests = [("hello World", gameHelloWorld, condHelloWorld),+ ("hello World 2 players", gameHelloWorld2Players, condHelloWorld2Players),+ ("Money transfer", gameMoneyTransfer, condMoneyTransfer),+ ("Partial Function 1", gamePartialFunction1, condPartialFunction),+ ("Partial Function 2", gamePartialFunction2, condPartialFunction),+ ("Partial Function 3", gamePartialFunction3, condPartialFunction3),+ ("Test file 1", testFile1, condNRules 3),+ ("Test file 2", testFile2, condNRules 3),+ ("load file twice", testFileTwice, condNRules 3),+ ("load file twice 2", testFileTwice', condNRules 4),+ ("load file unsafe", testFileUnsafeIO, condNRules 2)] +++ map (\i -> ("Loop" ++ show i, loops !! (i-1), condNoGame)) [1..(length loops)] +++ map (\i -> ("Forbidden" ++ show i, forbiddens !! (i-1), condNRules 2)) [1..(length forbiddens)]++-- Those tests should make the game die immediately because of security problem (it will be re-launched)+fatalTests :: [(String, StateT Session IO (), Multi -> Bool)]+fatalTests = [("Timeout type check", gameBadTypeCheck, const True)]+++test :: String -> Session -> StateT Session IO () -> (Multi -> Bool) -> IO Bool+test title session tes cond = do+ putStrLn $ "\nPlaying test: " ++ title+ m' <- loadTest tes session+ (evaluate $ cond m') `E.catch` (\(e::SomeException) -> (putStrLn $ "Exception in test: " ++ show e) >> return False)++--Loads a test+loadTest :: StateT Session IO () -> Session -> IO Multi+loadTest tes s = do+ ms <- evalWithWatchdog s (evalSession tes) --version with no watchdog: ms <- Just <$> execStateT tes s+ case ms of+ Just s' -> return $ _multi s'+ Nothing -> do+ putStrLn "thread timed out, updateSession discarded"+ return $ _multi s++testException :: Multi -> SomeException -> IO Multi+testException m e = do+ putStrLn $ "Test Exception: " ++ show e+ return m++testProfiles :: IO Profiles+testProfiles = do+ ias <- openMemoryState initialAuthState+ ips <- openMemoryState initialProfileState+ ipds <- openMemoryState initialProfileDataState+ return $ Profiles ias ips ipds++printRule :: Q THS.Exp -> String+printRule r = unsafePerformIO $ do+ expr <- runQ r+ return $ pprint expr++onePlayerOneGame :: StateT Session IO ()+onePlayerOneGame = do+ newPlayer 1 PlayerSettings {_pPlayerName = "Player 1", _mail = "", _mailNewInput = False, _mailNewRule = False, _mailNewOutput = False, _mailConfirmed = False}+ newGame "test" (GameDesc "" "") 1 True+ joinGame "test" 1+ viewGamePlayer "test" 1++twoPlayersOneGame :: StateT Session IO ()+twoPlayersOneGame = do+ onePlayerOneGame+ newPlayer 2 PlayerSettings {_pPlayerName = "Player 2", _mail = "", _mailNewInput = False, _mailNewRule = False, _mailNewOutput = False, _mailConfirmed = False}+ joinGame "test" 2+ viewGamePlayer "test" 2++submitR :: String -> StateT Session IO ()+submitR r = do+ onePlayerOneGame+ sh <- access sh+ submitRule (SubmitRule "" "" r) 1 "test" sh+ inputAllRadios 0 1++testFile' :: FilePath -> FilePath -> String -> StateT Session IO Bool+testFile' path name func = do+ sh <- access sh+ dataDir <- lift PNC.getDataDir+ res <- inputUpload 1 (dataDir </> testDir </> path) name sh+ submitRule (SubmitRule "" "" func) 1 "test" sh+ inputAllRadios 0 1+ return res++testFile :: FilePath -> String -> StateT Session IO Bool+testFile name = testFile' name name++-- * Tests++-- ** Standard tests++gameHelloWorld :: StateT Session IO ()+gameHelloWorld = submitR [cr|helloWorld|]++condHelloWorld :: Multi -> Bool+condHelloWorld = isOutput' "hello, world!"++gameHelloWorld2Players :: StateT Session IO ()+gameHelloWorld2Players = do+ twoPlayersOneGame+ sh <- access sh+ submitRule (SubmitRule "" "" [cr|helloWorld|]) 1 "test" sh+ inputAllRadios 0 1+ inputAllRadios 0 2++condHelloWorld2Players :: Multi -> Bool+condHelloWorld2Players = isOutput' "hello, world!"++--Create bank accounts, win 100 Ecu on rule accepted (so 100 Ecu is won for each player), transfer 50 Ecu+--TODO fix the text input+gameMoneyTransfer :: StateT Session IO ()+gameMoneyTransfer = do+ sh <- access sh+ twoPlayersOneGame+ submitRule (SubmitRule "" "" [cr|createBankAccount|]) 1 "test" sh+ submitRule (SubmitRule "" "" [cr|winXEcuOnRuleAccepted 100|]) 1 "test" sh+ submitRule (SubmitRule "" "" [cr|moneyTransfer|]) 2 "test" sh+ inputAllRadios 0 1+ inputAllRadios 0 2+ inputAllTexts "50" 1++condMoneyTransfer :: Multi -> Bool+condMoneyTransfer m = (_vName $ head $ _variables $ firstGame m) == "Accounts"++-- ** Partial functions++partialFunction1 :: String+partialFunction1 = [cr|void $ readMsgVar_ (msgVar "toto1" :: MsgVar String)|]++partialFunction2 :: String+partialFunction2 = [cr|void $ do+ t <- liftEffect getCurrentTime+ onEventOnce (Time $ addUTCTime 5 t) $ const $ readMsgVar_ (msgVar "toto2")|]++gamePartialFunction1 :: StateT Session IO ()+gamePartialFunction1 = submitR partialFunction1++gamePartialFunction2 :: StateT Session IO ()+gamePartialFunction2 = do+ onePlayerOneGame+ submitR partialFunction2+ gs <- (access $ multi >>> gameInfos)+ let now = _currentTime $ G._game $ _loggedGame $ head gs+ focus multi $ triggerTimeEvent (5 `addUTCTime` now)+++-- rule has not been accepted due to exception+condPartialFunction :: Multi -> Bool+condPartialFunction m = (_rStatus $ head $ _rules $ firstGame m) == Active &&+ (take 5 $ _lMsg $ head $ _logs $ firstGame m) == "Error"+++partialFunction3 :: String+partialFunction3 = [cr|void $ onEvent_ (RuleEv Proposed) $ const $ readMsgVar_ (msgVar "toto3")|]++gamePartialFunction3 :: StateT Session IO ()+gamePartialFunction3 = do+ submitR partialFunction3+ submitR [cr|nothing|]++-- rule has been accepted and also next one+condPartialFunction3 :: Multi -> Bool+condPartialFunction3 m = (length $ _rules $ firstGame m) == 4++-- * Malicious codes++++--infinite loops: they should be interrupted by the watchdog & resource limits+loops, forbiddens :: [StateT Session IO ()]+loops = [loop1, loop2, loop3, loop4, loop5, loop6, stackOverflow, outputLimit]+forbiddens = [forbid1, forbid2, forbid3, forbid4, forbid5, forbid6]++loop1 = submitR [cr| let x :: Int; x = x in showRule x |]+loop2 = submitR [cr| let f :: Int -> Int; f y = f 1 in showRule (f 1) |]+loop3 = submitR [cr| let x = x + 1 in showRule x |]+loop4 = submitR [cr| let f :: Int -> Int; f x = f $! (x+1) in showRule (f 0) |]+--test stack overflow limits+loop5 = submitR [cr| let x = 1 + x in showRule x |]+loop6 = submitR [cr| let x = array (0::Int, maxBound) [(1000000,'x')] in showRule x |]+++-- forbidden codes+forbid1 = submitR "void $ runST (unsafeIOToST (readFile \"/etc/passwd\")) >>= outputAll_"+forbid2 = submitR "void $ unsafeCoerce (readFile \"/etc/passwd\") >>= outputAll_"+forbid3 = submitR "void $ Unsafe.unsafeCoerce (readFile \"/etc/passwd\") >>= outputAll_"+forbid4 = submitR "void $ Foreign.unsafePerformIO $ readFile \"/etc/passwd\" >>= outputAll_"+forbid5 = submitR "void $ Data.ByteString.Internal.inlinePerformIO (readFile \"/etc/passwd\") >>= outputAll_"+forbid6 = submitR "void $ unsafePerformIO (readFile \"/etc/passwd\") >>= outputAll_"++--an expression very long to type check+gameBadTypeCheck :: StateT Session IO ()+gameBadTypeCheck = submitR+ "void $ let {p x y f = f x y; f x = p x x} in f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f f)))))))))))))))))) f"++stackOverflow = submitR [cr| let fix f = let x = f x in x in showRule $ foldr (.) id (repeat read) $ fix show |]+outputLimit = submitR [cr| showRule $ repeat 1|]++--the game created should be withdrawn+condNoGame :: Multi -> Bool+condNoGame m = null $ _gameInfos m+++-- ** File loading++--standard module+testFile1 :: StateT Session IO ()+testFile1 = do+ onePlayerOneGame+ void $ testFile "SimpleModule.hs" "myRule"++condNRules :: Int -> Multi -> Bool+condNRules n m = (length $ _rules $ firstGame m) == n++--standard module, call with namespace+testFile2 :: StateT Session IO ()+testFile2 = do+ onePlayerOneGame+ void $ testFile "SimpleModule.hs" "SimpleModule.myRule"+++--loading two modules with the same name is forbidden+testFileTwice :: StateT Session IO ()+testFileTwice = do+ onePlayerOneGame+ void $ testFile "SimpleModule.hs" "SimpleModule.myRule"+ void $ testFile' "more/SimpleModule.hs" "SimpleModule.hs" "SimpleModule.myRule2"+++--but having the same function name in different modules is OK+testFileTwice' :: StateT Session IO ()+testFileTwice' = do+ onePlayerOneGame+ void $ testFile "SimpleModule.hs" "SimpleModule.myRule"+ void $ testFile "SimpleModule2.hs" "SimpleModule2.myRule"++--security: no unsafe module imports+testFileUnsafeIO :: StateT Session IO ()+testFileUnsafeIO = do+ onePlayerOneGame+ void $ testFile "UnsafeIO.hs" "UnsafeIO.myRule"+++-- * Helpers++--True if the string in parameter is among the outputs+isOutput' :: String -> Multi -> Bool+isOutput' s m = any (isOutput s . _game . _loggedGame) (_gameInfos m)++-- select first choice for all radio buttons+inputAllRadios :: Int -> PlayerNumber -> StateT Session IO ()+inputAllRadios choice pn = do+ s <- get+ let evs = evalState getChoiceEvents (firstGame $ _multi s)+ mapM_ (\en -> inputResult pn en (URadioData choice) "test") evs++-- input text for all text fields+inputAllTexts :: String -> PlayerNumber -> StateT Session IO ()+inputAllTexts a pn = do+ s <- get+ let evs = evalState getTextEvents (firstGame $ _multi s)+ mapM_ (\en -> inputResult pn en (UTextData a) "test") evs++firstGame :: Multi -> Game+firstGame = G._game . _loggedGame . head . _gameInfos
+ src/Nomyx/Core/Types.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Nomyx.Core.Types where+import Language.Nomyx+import Language.Nomyx.Engine+import Data.Typeable+import Network.BSD+import Data.Lens.Template+import Language.Haskell.Interpreter.Server (ServerHandle)+import Data.Acid (AcidState)+import Happstack.Auth (ProfileState, AuthState)+import Data.Data (Data)+import Data.IxSet (inferIxSet, noCalcs)+import Data.SafeCopy (base, deriveSafeCopy)+import Data.Time++type PlayerPassword = String+type Port = Int+type CompileError = String+type LastRule = (SubmitRule, String)+++data LastUpload = NoUpload+ | UploadSuccess+ | UploadFailure (FilePath, CompileError)+ deriving (Eq, Ord, Read, Show, Typeable, Data)+$(deriveSafeCopy 1 'base ''LastUpload)++data Network = Network {_host :: HostName, _port :: Port}+ deriving (Eq, Show, Read, Typeable)+defaultNetwork = Network "" 0++data PlayerSettings =+ PlayerSettings { _pPlayerName :: PlayerName,+ _mail :: String,+ _mailNewInput :: Bool,+ _mailNewRule :: Bool,+ _mailNewOutput :: Bool,+ _mailConfirmed :: Bool}+ deriving (Eq, Show, Read, Data, Ord, Typeable)+$(deriveSafeCopy 1 'base ''PlayerSettings)+++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, profiles and uploaded files+ _webDir :: FilePath, -- location of the website files+ _sourceDir :: FilePath} -- location of the language files, for display on the web gui (from Nomyx-Language)+ deriving (Eq, Show, Read, Typeable)++--- | A structure to hold the active games and players+data Multi = Multi { _gameInfos :: [GameInfo],+ _mSettings :: Settings}+ deriving (Eq, Show, Typeable)++data GameInfo = GameInfo { _loggedGame :: LoggedGame,+ _ownedBy :: Maybe PlayerNumber,+ _forkedFromGame :: Maybe GameName,+ _isPublic :: Bool,+ _startedAt :: UTCTime}+ deriving (Typeable, Show, Eq)+++-- | 'ProfileData' contains application specific+data ProfileData =+ ProfileData { _pPlayerNumber :: PlayerNumber, -- ^ same as UserId+ _pPlayerSettings :: PlayerSettings,+ _pViewingGame :: Maybe GameName,+ _pLastRule :: Maybe LastRule,+ _pLastUpload :: LastUpload,+ _pIsAdmin :: Bool+ }+ deriving (Eq, Ord, Read, Show, Typeable, Data)+$(deriveSafeCopy 1 'base ''ProfileData)+$(deriveSafeCopy 1 'base ''SubmitRule)++$(inferIxSet "ProfilesData" ''ProfileData 'noCalcs [''PlayerNumber]) -- , ''Text++data ProfileDataState =+ ProfileDataState { profilesData :: ProfilesData }+ deriving (Eq, Ord, Read, Show, Typeable, Data)+$(deriveSafeCopy 1 'base ''ProfileDataState)+++-- | 'Acid' holds all the 'AcidState' handles for this site.+data Profiles = Profiles+ { acidAuth :: AcidState AuthState,+ acidProfile :: AcidState ProfileState,+ acidProfileData :: AcidState ProfileDataState}++data Session = Session { _sh :: ServerHandle,+ _multi :: Multi,+ _profiles :: Profiles}++instance Show Session where+ show (Session _ m _) = show m++$( makeLenses [''Multi, ''GameInfo, ''Settings, ''Network, ''PlayerSettings, ''Session, ''ProfileData] )+
+ src/Nomyx/Core/Utils.hs view
@@ -0,0 +1,147 @@+----------------------------------------------------------------------------- +-- +-- Module : Utils +-- Copyright : +-- License : AllRightsReserved +-- +-- Maintainer : +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- ++{-# LANGUAGE CPP #-}++module Nomyx.Core.Utils where++import Data.Maybe+import Control.Monad.State+import Nomyx.Core.Types+import System.IO.Temp+import Codec.Archive.Tar as Tar+import System.Directory+import System.FilePath+import Control.Monad.Catch as MC+#ifndef WINDOWS+import qualified System.Posix.Signals as S+#endif+import Control.Concurrent+import System.IO+import System.IO.PlafCompat+import Data.Lens+import Control.Exception+import Control.Category ((>>>))+import Language.Nomyx.Engine++saveFile, profilesDir, uploadDir, tarFile :: FilePath+saveFile = "Nomyx.save"+profilesDir = "profiles"+uploadDir = "uploads"+testDir = "test"+tarFile = "Nomyx.tar"+ +-- | this function will return just a if it can cast it to an a. +maybeRead :: Read a => String -> Maybe a +maybeRead = fmap fst . listToMaybe . reads + +-- | Replaces all instances of a value in a list by another value. +replace :: Eq a => a -- ^ Value to search + -> a -- ^ Value to replace it with + -> [a] -- ^ Input list + -> [a] -- ^ Output list +replace x y = map (\z -> if z == x then y else z) ++-- | generic function to say things on transformers like GameState, ServerState etc.+say :: String -> StateT a IO () +say = lift . putStrLn++nomyxURL :: Network -> String+nomyxURL (Network host port) = "http://" ++ host ++ ":" ++ show port++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 :: IO a -> IO a+protectHandlers = id++#else++installHandler' :: S.Handler -> S.Signal -> IO S.Handler+installHandler' handler signal = S.installHandler signal handler Nothing++signals :: [S.Signal]+signals = [ S.sigQUIT+ , S.sigINT+ , S.sigHUP+ , S.sigTERM+ ]++saveHandlers :: IO [S.Handler]+saveHandlers = liftIO $ mapM (installHandler' S.Ignore) signals++restoreHandlers :: [S.Handler] -> IO [S.Handler]+restoreHandlers h = liftIO . sequence $ zipWith installHandler' h signals++protectHandlers :: IO a -> IO a+protectHandlers a = MC.bracket saveHandlers restoreHandlers $ const a++#endif++--Sets a watchdog to kill the evaluation thread if it doesn't finishes.+-- The function starts both the evaluation thread and the watchdog thread, and blocks awaiting the result.+-- Option 1: the evaluation thread finishes before the watchdog. The MVar is filled with the result,+-- which unblocks the main thread. The watchdog then finishes latter, and fills the MVar with Nothing.+-- Option 2: the watchdog finishes before the evaluation thread. The eval thread is killed, and the+-- MVar is filled with Nothing, which unblocks the main thread. The watchdog finishes.+evalWithWatchdog :: Show b => a -> (a -> IO b) -> IO (Maybe b)+evalWithWatchdog s f = do+ mvar <- newEmptyMVar+ hSetBuffering stdout NoBuffering+ --start evaluation thread+ id <- forkOS $ do+ s' <- f s+ s'' <- evaluate s'+ writeFile nullFileName $ show s''+ putMVar mvar (Just s'')+ --start watchdog thread+ forkIO $ watchDog 3 id mvar+ takeMVar mvar++-- | Fork off a thread which will sleep and then kill off the specified thread.+watchDog :: Int -> ThreadId -> MVar (Maybe a) -> IO ()+watchDog tout tid mvar = do+ threadDelay (tout * 1000000)+ killThread tid+ putMVar mvar Nothing++gameNameLens :: Lens GameInfo GameName+gameNameLens = loggedGame >>> game >>> gameName++