diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,1 @@ +Corentin Dupont (remove DELAVEGA to obtain my email) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ + +Nomyx-Core +========= + +Library holding the core processes of Nomyx. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO diff --git a/data/test/SimpleModule.hs b/data/test/SimpleModule.hs new file mode 100644 --- /dev/null +++ b/data/test/SimpleModule.hs @@ -0,0 +1,12 @@ + +module SimpleModule where + +import Prelude +import Nomyx.Language +import Control.Monad + +myRule :: Rule +myRule = void $ outputAll_ helperFunction + +helperFunction :: String +helperFunction = "Hello" diff --git a/data/test/SimpleModule2.hs b/data/test/SimpleModule2.hs new file mode 100644 --- /dev/null +++ b/data/test/SimpleModule2.hs @@ -0,0 +1,9 @@ + +module SimpleModule2 where + +import Prelude +import Nomyx.Language +import Control.Monad + +myRule :: Rule +myRule = void $ outputAll_ "Hello" diff --git a/data/test/TestTime.hs b/data/test/TestTime.hs new file mode 100644 --- /dev/null +++ b/data/test/TestTime.hs @@ -0,0 +1,13 @@ + +module TestTime where + +import Prelude +import Nomyx.Language +import Control.Monad +import Data.Time + +myRule :: Rule +myRule = void $ outputAll_ helperFunction + +helperFunction :: String +helperFunction = "Hello" diff --git a/data/test/UnsafeIO.hs b/data/test/UnsafeIO.hs new file mode 100644 --- /dev/null +++ b/data/test/UnsafeIO.hs @@ -0,0 +1,10 @@ + +module UnsafeIO where + +import Prelude +import Nomyx.Language +import System.IO.Unsafe +import Control.Monad + +myRule :: Rule +myRule = void $ outputAll_ $ unsafePerformIO $ readFile "/etc/passwd" diff --git a/data/test/more/SimpleModule.hs b/data/test/more/SimpleModule.hs new file mode 100644 --- /dev/null +++ b/data/test/more/SimpleModule.hs @@ -0,0 +1,12 @@ + +module SimpleModule where + +import Prelude +import Nomyx.Language +import Control.Monad + +myRule2 :: Rule +myRule2 = void $ outputAll_ helperFunction + +helperFunction :: String +helperFunction = "Hello" diff --git a/nomyx-core.cabal b/nomyx-core.cabal new file mode 100644 --- /dev/null +++ b/nomyx-core.cabal @@ -0,0 +1,99 @@ +name: nomyx-core +version: 1.0.0 +cabal-version: >=1.8 +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.md TODO +data-files: test/*.hs + test/more/*.hs +data-dir: data + +library + build-depends: nomyx-language == 1.0.*, + nomyx-library == 1.0.*, + imprevu == 0.1.*, + DebugTraceHelpers == 0.12.*, + MissingH >= 1.3 && < 1.5, + acid-state >= 0.12 && < 0.15, + aeson >= 0.7 && < 0.12, + base >= 4.6 && < 5, + blaze-html >= 0.5 && < 0.9, + blaze-markup == 0.7.*, + bytestring == 0.10.*, + lens >= 4.7 && < 4.15, + directory == 1.2.*, + either-unwrap == 1.1.*, + exceptions == 0.8.*, + filepath >= 1.3 && < 1.5, + hint >= 0.4 && < 0.7, + hscolour >= 1.22 && < 1.25, + ixset == 1.0.*, + mime-mail == 0.4.*, + mtl >= 2.1 && < 2.3, + deepseq >= 1.3 && < 1.5, + network == 2.6.*, + old-locale == 1.0.*, + random >= 1.0 && < 1.2, + safe == 0.3.*, + safecopy >= 0.8 && < 0.10, + shortcut == 0.1, + stm == 2.4.*, + tar >= 0.4 && < 0.6, + temporary == 1.2.*, + template-haskell >= 2.8 && < 2.12, + text == 1.2.*, + time >= 1.4 && < 1.7, + yaml -any, + NoTrace -any, + hslogger, + hint-server == 1.4.3, + HaskellNet, + HaskellNet-SSL + if os(windows) + Cpp-options: -DWINDOWS + else + build-depends: unix >= 2.6 && < 3 + + 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.Quotes + Nomyx.Core.Mail + Nomyx.Core.Utils + Nomyx.Core.Test + Nomyx.Core.Engine + Nomyx.Core.Engine.Types + Nomyx.Core.Engine.Evaluation + Nomyx.Core.Engine.GameEvents + Nomyx.Core.Engine.Interpret + Nomyx.Core.Engine.Context + Nomyx.Core.Engine.Utils + Nomyx.Core.Engine.Test + Paths_nomyx_core + Data.Todo + ghc-options: -W + cpp-options: -DNO_INTERPRET_QUOTES + +Test-Suite test + type: detailed-0.9 + test-module: Test + hs-source-dirs: test + build-depends: base, + nomyx-core == 1.0.0, + Cabal >= 0.22 + +source-repository head + type: git + location: https://github.com/cdupont/nomyx-core.git diff --git a/src/Data/Todo.hs b/src/Data/Todo.hs new file mode 100644 --- /dev/null +++ b/src/Data/Todo.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Data.Todo where + +import Control.Applicative +import Data.Typeable + +-- A todo list of things left to be done before obtaining a result. +data Todo a b = Todo [a] | Done b + deriving (Eq, Ord, Read, Show, Typeable) + +instance Alternative (Todo a) where + empty = Todo [] + Todo as <|> Todo bs = Todo $ as ++ bs + Todo _ <|> n = n + m <|> _ = m + +instance Applicative (Todo a) where + pure = Done + Todo as <*> Todo bs = Todo $ as ++ bs + Todo as <*> _ = Todo as + Done f <*> r = fmap f r + +instance Functor (Todo a) where + fmap _ (Todo x) = Todo x + fmap f (Done y) = Done $ f y + +instance Monad (Todo a) where + return = Done + Todo as >>= _ = Todo as + Done a >>= f = f a + +toEither :: Todo a b -> Either [a] b +toEither (Todo as) = Left as +toEither (Done a) = Right a + +fromEither :: Either [a] b -> Todo a b +fromEither (Left as) = Todo as +fromEither (Right a) = Done a + +toMaybe :: Todo a b -> Maybe b +toMaybe (Todo _) = Nothing +toMaybe (Done a) = Just a diff --git a/src/Nomyx/Core/Engine.hs b/src/Nomyx/Core/Engine.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Engine.hs @@ -0,0 +1,58 @@ + +-- | Warning: Nomyx internals (not required to compose rules and play the game) +-- This module implements game engine. +-- the module manages the effects of rules over each others. +module Nomyx.Core.Engine( + -- * Game management + GameEvent(..), + RuleEv(..), + LoggedGame(..), + GameName, + Game(..), + GameDesc(..), + RuleEventInfo(..), + execGameEvent, execGameEvent', + execWithGame, execWithGame', + game, + emptyGame, + getLoggedGame, + gameName, gameDesc, + players, + getVictorious, + + -- * Variables management + Var(..), + + -- * Rules management + activeRules, pendingRules, rejectedRules, + + -- * Events management + events, + getEventInfo, + EvalState(..), + defaultEvalConf, + + -- * Outputs management + Output(..), + Log(..), + evalOutput, + isOutput, + + -- * Time + currentTime, + getTimeEvents, + -- * Misc + tracePN, + getChoiceEvents, + runEvaluate, + withEvent', + saveModule, + defaultEvalEnv + ) where + +import Nomyx.Core.Engine.Evaluation +import Nomyx.Core.Engine.GameEvents +import Nomyx.Core.Engine.Test +import Nomyx.Core.Engine.Types +import Nomyx.Core.Engine.Utils +import Imprevu.Evaluation.Utils diff --git a/src/Nomyx/Core/Engine/Context.hs b/src/Nomyx/Core/Engine/Context.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Engine/Context.hs @@ -0,0 +1,76 @@ +module Nomyx.Core.Engine.Context ( + unQualImports, + qualImports, + defaultPackages +) where + + +unQualImports :: [String] +unQualImports = ["Nomyx.Language", + "Safe", + "Prelude", + "Control.Applicative", + "Control.Arrow", + "Control.Monad", + "Control.Monad.Cont", + "Control.Monad.Error", + "Control.Monad.Fix", + "Control.Monad.Identity", + "Control.Monad.RWS", + "Control.Monad.Reader", + "Control.Monad.State", + "Control.Monad.State", + "Control.Monad.Writer", + "Control.Monad.Loops", + "Control.Lens", + "Data.Function", + "Data.Typeable", + "Data.Array", + "Data.Bits", + "Data.Bool", + "Data.Char", + "Data.Complex", + "Data.Dynamic", + "Data.Either", + "Data.Eq", + "Data.Fixed", + "Data.Graph", + "Data.Int", + "Data.Ix", + "Data.List", + "Data.Maybe", + "Data.Monoid", + "Data.Ord", + "Data.Ratio", + "Data.Semigroup", + "Data.Tree", + "Data.Time", + "Data.Tuple", + "Data.Typeable", + "Data.Word", + "System.Random"] + +defaultPackages :: [String] +defaultPackages = ["nomyx-language", + "nomyx-library", + "array", + "base", + "bytestring", + "containers", + "text", + "time"] + +qualImports :: [(String, Maybe String)] +qualImports = [("Control.Category", Just "C"), + ("Data.ByteString", Just "BS"), + ("Data.ByteString.Char8", Just "BSC"), + ("Data.ByteString.Lazy", Just "BSL"), + ("Data.ByteString.Lazy.Char8", Just "BSLC"), + ("Data.Foldable", Just "Data.Foldable"), + ("Data.IntMap", Just "IM"), + ("Data.IntSet", Just "IS"), + ("Data.Map", Just "M"), + ("Data.Sequence", Just "Data.Sequence"), + ("Data.Set", Just "S"), + ("Data.Text", Just "T"), + ("Data.Traversable", Just "Data.Traversable")] diff --git a/src/Nomyx/Core/Engine/Evaluation.hs b/src/Nomyx/Core/Engine/Evaluation.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Engine/Evaluation.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | Evaluation of a Nomyx expression +module Nomyx.Core.Engine.Evaluation where + +import Control.Category hiding (id) +import Control.Lens +import Control.Monad +import Control.Monad.Except +import Control.Monad.State +import Data.List +import Data.Maybe +import Data.Time +import Data.Typeable +import qualified Imprevu.Evaluation as Imp +import Imprevu.Evaluation hiding (runEvalError, events) +import Imprevu +import Nomyx.Language +import Nomyx.Core.Engine.Utils +import Nomyx.Core.Engine.Types hiding (_vRuleNumber) +import Prelude hiding (log, (.)) +import System.Random + + +-- * Evaluation + +-- | evaluate an effecful expression. +evalNomex :: Nomex a -> Evaluate a +evalNomex (NewVar v a) = evNewVar v a +evalNomex (DelVar v) = evDelVar v +evalNomex (WriteVar v val) = evWriteVar v val +evalNomex (OnEvent ev h) = evOnEvent ev h +evalNomex (DelEvent en) = evDelEvent en +evalNomex (SendMessage m d) = evSendMessage m d +evalNomex (NewOutput pn s) = evNewOutput pn s +evalNomex (UpdateOutput on s) = evUpdateOutput on s +evalNomex (DelOutput on) = evDelOutput on +evalNomex (ProposeRule rule) = evProposeRule rule +evalNomex (ActivateRule rule) = evActivateRule rule +evalNomex (RejectRule rule) = evRejectRule rule +evalNomex (AddRule rule) = evAddRule rule +evalNomex (ModifyRule m rule) = evModifyRule m rule +evalNomex (SetPlayerName pn n) = evChangeName pn n +evalNomex (DelPlayer pn) = evDelPlayer pn +evalNomex (SetVictory ps) = evSetVictory ps +--evalNomex (LiftEffect e) = liftEval $ evalNomex e +evalNomex (ThrowError s) = throwError s +evalNomex (CatchError n h) = catchError (evalNomex n) (evalNomex . h) +evalNomex (Return a) = return a +evalNomex (Bind ex f) = evalNomex ex >>= \e -> evalNomex (f e) +evalNomex (GetRandomNumber r) = evGetRandomNumber r + +-- | evaluate an effectless expression. +evalNomex (ReadVar v) = evReadVar v +evalNomex (GetOutput on) = evGetOutput on +evalNomex GetRules = use (evalEnv . eGame . rules) +evalNomex GetPlayers = use (evalEnv . eGame . players) +evalNomex GetEvents = use (evalEnv . eGame . events) >>= return . (map _erEventInfo) +evalNomex SelfRuleNumber = use (evalEnv . eRuleNumber) +evalNomex (GetCurrentTime)= use (evalEnv . eGame . currentTime) +evalNomex (Simu sim ev) = evSimu sim ev + + +evNewVar :: (Typeable a, Show a) => VarName -> a -> Evaluate (Maybe (V a)) +evNewVar name def = do + (vars, rn) <- accessGame variables + case find ((== name) . view vName) vars of + Nothing -> do + modifyGame variables (Var rn name def : ) + return $ Just (V name) + Just _ -> return Nothing + +evDelVar :: V a -> Evaluate Bool +evDelVar (V name) = do + (vars, _) <- accessGame variables + case find ((== name) . view vName) vars of + Nothing -> return False + Just _ -> do + modifyGame variables $ filter ((/= name) . view vName) + return True + +evWriteVar :: (Typeable a, Show a) => V a -> a -> Evaluate Bool +evWriteVar (V name) val = do + (vars, _) <- accessGame variables + case find (\(Var _ myName _) -> myName == name) vars of + Nothing -> return False + Just (Var rn myName _) -> do + modifyGame variables $ replaceWith ((== name) . view vName) (Var rn myName val) + return True + +evOnEvent :: (Typeable e, Show e) => Event e -> ((EventNumber, e) -> Nomex ()) -> Evaluate EventNumber +evOnEvent ev h = do + (evs, rn) <- accessGame events + let en = head $ [1..] \\ (map (_eventNumber . _erEventInfo) evs) + modifyGame events (\eis -> (RuleEventInfo rn (EventInfo en ev h SActive [])) : eis) + return en + +evSendMessage :: (Typeable a, Show a) => Msg a -> a -> Evaluate () +evSendMessage m = triggerEvent (Signal m) + +evProposeRule :: RuleInfo -> Evaluate Bool +evProposeRule rule = do + (rs, _) <- accessGame rules + case find (\r -> (rule ^. rNumber) == (r ^. rNumber)) rs of + Nothing -> do + modifyGame rules (rule:) + triggerEvent (Signal Proposed) rule + return True + Just _ -> return False + +--Sets the rule status to Active and execute it if possible +evActivateRule :: RuleNumber -> Evaluate Bool +evActivateRule rn = do + (rs, by) <- accessGame rules --bug here + case find (\r -> _rNumber r == rn && _rStatus r /= Active) rs of + Nothing -> return False + Just r -> do + putGame rules $ replaceWith ((== rn) . view rNumber) r{_rStatus = Active, _rAssessedBy = Just by} rs + --execute the rule, using its own number: so events and outputs will have its number. + withRN (_rNumber r) $ evalNomex (_rRule r) + triggerEvent (Signal Activated) r + return True + +--replace temporarily the rule number used for evaluation +withEvent' :: EventInfo -> Evaluate a -> Evaluate a +withEvent' (EventInfo en _ _ _ _) eval = do + (evs, _) <- accessGame events + let rn = _erRuleNumber $ fromJust $ find (\(RuleEventInfo _ (EventInfo en2 _ _ evst _)) -> en == en2) evs + oldRn <- use (evalEnv . eRuleNumber) + evalEnv . eRuleNumber .= rn + a <- eval + evalEnv . eRuleNumber .= oldRn + return a + +evRejectRule :: RuleNumber -> Evaluate Bool +evRejectRule rn = do + (rs, by) <- accessGame rules + case find (\r -> _rNumber r == rn && _rStatus r /= Reject) rs of + Nothing -> return False + Just r -> do + delVarsRule rn + delEventsRule rn + delOutputsRule rn + delVictoryRule rn + putGame rules $ replaceWith ((== rn) . view rNumber) r{_rStatus = Reject, _rAssessedBy = Just by} rs + triggerEvent (Signal Rejected) r + return True + +evAddRule :: RuleInfo -> Evaluate Bool +evAddRule rule = do + (rs, _) <- accessGame rules + case find (\a -> (rule ^. rNumber) == (a ^. rNumber)) rs of + Nothing -> do + modifyGame rules (rule:) + triggerEvent (Signal Added) rule + return True + Just _ -> return False + + +evModifyRule :: RuleNumber -> RuleInfo -> Evaluate Bool +evModifyRule rn rule = do + (rs, _) <- accessGame rules + let newRules = replaceWith ((== rn) . view rNumber) rule rs + case find ((== rn) . view rNumber) rs of + Nothing -> return False + Just r -> do + putGame rules newRules + triggerEvent (Signal Modified) r + return True + +evDelPlayer :: PlayerNumber -> Evaluate Bool +evDelPlayer pn = do + g <- use (evalEnv . eGame) + case find ((== pn) . view playerNumber) (_players g) of + Nothing -> do + return False + Just pid -> do + modifyGame players $ filter (\a -> a ^. playerNumber /= pn) + triggerEvent (Signal Leave) pid + return True + +evChangeName :: PlayerNumber -> PlayerName -> Evaluate Bool +evChangeName pn name = do + pls <- use (evalEnv . eGame . players) + case find ((== pn) . view playerNumber) pls of + Nothing -> return False + Just pid -> do + putGame players $ replaceWith ((== pn) . view playerNumber) (pid {_playerName = name}) pls + return True + +evDelEvent :: EventNumber -> Evaluate Bool +evDelEvent en = do + evs <- use (evalEnv . eGame . events) + case find ((== en) . view (erEventInfo . eventNumber)) evs of + Nothing -> return False + Just eh -> case (_evStatus $ _erEventInfo eh) of + SActive -> do + let evs' = replaceWith ((== en) . view (erEventInfo . eventNumber)) (erEventInfo . evStatus .~ SDeleted $ eh) evs + putGame events evs' + return True + SDeleted -> return False + +evTriggerTime :: UTCTime -> Evaluate () +evTriggerTime t = triggerEvent (Signal t) t + +evNewOutput :: Maybe PlayerNumber -> Nomex String -> Evaluate OutputNumber +evNewOutput pn s = do + (ops, rn) <- accessGame outputs + let on = head $ [1..] \\ (map _outputNumber ops) + modifyGame outputs (Output on rn pn s SActive : ) + return on + +evGetOutput :: OutputNumber -> Evaluate (Maybe String) +evGetOutput on = do + ops <- use (evalEnv . eGame . outputs) + case find (\(Output myOn _ _ _ s) -> myOn == on && s == SActive) ops of + Nothing -> return Nothing + Just (Output _ _ _ o _) -> do + out <- evalNomex o + return $ Just out + +evUpdateOutput :: OutputNumber -> Nomex String -> Evaluate Bool +evUpdateOutput on s = do + (ops, _) <- accessGame outputs + case find (\(Output myOn _ _ _ st) -> myOn == on && st == SActive) ops of + Nothing -> return False + Just (Output _ rn pn _ _) -> do + modifyGame outputs $ replaceWith ((== on) . view outputNumber) (Output on rn pn s SActive) + return True + +evDelOutput :: OutputNumber -> Evaluate Bool +evDelOutput on = do + ops <- use (evalEnv . eGame . outputs) + case find ((== on) . view outputNumber) ops of + Nothing -> return False + Just o -> case _oStatus o of + SActive -> do + putGame outputs $ replaceWith ((== on) . view outputNumber) o{_oStatus = SDeleted} ops + return True + SDeleted -> return False + +evSetVictory :: Nomex [PlayerNumber] -> Evaluate () +evSetVictory ps = do + rn <- use (evalEnv . eRuleNumber) + putGame victory (Just $ VictoryInfo rn ps) + triggerEvent (Signal Victory) (VictoryInfo rn ps) + +evReadVar :: (Typeable a, Show a) => V a -> Evaluate (Maybe a) +evReadVar (V name) = do + vars <- use (evalEnv . eGame . variables) + let var = find ((== name) . view vName) vars + case var of + Nothing -> return Nothing + Just (Var _ _ val) -> case cast val of + Just v -> return $ Just v + Nothing -> return Nothing + +evGetRandomNumber :: Random a => (a, a) -> Evaluate a +evGetRandomNumber r = do + g <- use (evalEnv . eGame . randomGen) + let (a, g') = randomR r g + putGame randomGen g' + return a + +--TODO should we also give a rule number to simulate the Nomex with? +-- currently we use the simulating rule number +evSimu :: Nomex a -> Nomex Bool -> Evaluate Bool +evSimu sim ev = undefined--do + --rn <- use (evalEnv . eRuleNumber) + --let s = runEvalError rn Nothing (evalNomex sim) + --g <- use (evalEnv . eGame) + --let g' = execState s g + --return $ runEvaluate' g' rn (evalNomex ev) + +-- * misc + +getVictorious :: Game -> [PlayerNumber] +getVictorious g = case _victory g of + Nothing -> [] + Just (VictoryInfo rn v) -> runEvaluate' g rn (evalNomex v) + +evalOutput :: Game -> Output -> String +evalOutput g (Output _ rn _ o _) = runEvaluate' g rn (evalNomex o) + +allOutputs :: Game -> [String] +allOutputs g = map (evalOutput g) (_outputs g) + +getTimeEvents :: UTCTime -> Game -> [UTCTime] +getTimeEvents t g = join $ maybeToList $ Imp.runEvaluate (Imp.getTimeEvents t) (defaultEvalEnv 0 g) + + +--delete all variables of a rule +delVarsRule :: RuleNumber -> Evaluate () +delVarsRule rn = void $ (evalEnv . eGame . variables) %= filter ((/= rn) . view vRuleNumber) + +--delete all events of a rule +delEventsRule :: RuleNumber -> Evaluate () +delEventsRule rn = do + evs <- use (evalEnv . eGame . events) + let toDelete = filter ((== rn) . view (erRuleNumber)) evs + mapM_ (evDelEvent . _eventNumber . _erEventInfo) toDelete + +--delete all outputs of a rule +delOutputsRule :: RuleNumber -> Evaluate () +delOutputsRule rn = do + os <- use (evalEnv . eGame . outputs) + let toDelete = filter ((== rn) . view oRuleNumber) os + mapM_ (evDelOutput . _outputNumber) toDelete + +--delete victory of a rule +delVictoryRule :: RuleNumber -> Evaluate () +delVictoryRule rn = do + vic <- use (evalEnv . eGame . victory) + when (isJust vic && _vRuleNumber (fromJust vic) == rn) $ (evalEnv . eGame . victory) .= Nothing + +--extract the game state from an Evaluate +--knowing the rule number performing the evaluation (0 if by the system) +--and the player number to whom display errors (set to Nothing for all players) +runEvalError :: RuleNumber -> Maybe PlayerNumber -> Evaluate a -> State Game (Maybe a) +runEvalError rn mpn eva = do + g <- get + let (a, (EvalEnv (EvalState g' _) _)) = runState (Imp.runEvalError eva) (defaultEvalEnv rn g) + put g' + return a + +defaultEvalEnv :: RuleNumber -> Game -> EvalEnvN Nomex EvalState +defaultEvalEnv rn g = EvalEnv (EvalState g rn) defaultEvalConf + +--TODO: to check. how to map the events correctly? +defaultEvalConf :: EvalConfN Nomex EvalState +defaultEvalConf = EvalConf getEventsNomex setEventsNomex evalNomex errorNomex withEvent' where + getEventsNomex s = map _erEventInfo (_events $ _eGame s) + setEventsNomex eis s = (eGame . events) .~ (getreis (_events $ _eGame s) eis) $ s where + getreis reis eis = if (length reis /= length eis) then error "setEvents" else zipWith (\rei ei -> rei {_erEventInfo = ei}) reis eis + +runSystemEval :: PlayerNumber -> Evaluate a -> State Game (Maybe a) +runSystemEval pn = runEvalError 0 (Just pn) + +runSystemEval' :: Evaluate a -> State Game (Maybe a) +runSystemEval' = runEvalError 0 Nothing + +errorNomex :: EventNumber -> String -> Evaluate () +errorNomex en s = do + tracePN 0 $ "Error: " ++ s + log Nothing $ "Error: " ++ s ++ ", from event: " ++ (show en) + +runEvaluate :: Game -> RuleNumber -> State EvalEnv a -> a +runEvaluate g rn ev = error "runEvaluate" --evalState ev (EvalEnv rn g evalNomex) + +runEvaluate' :: Game -> RuleNumber -> Evaluate a -> a +runEvaluate' g rn ev = fromJust $ Imp.runEvaluate ev (defaultEvalEnv rn g) --TODO check this fromJust + +-- | Show instance for Game +-- showing a game involves evaluating some parts (such as victory and outputs) +instance Show Game where + show g@(Game gn _ rs ps vs es os _ l t _) = + "Game Name = " ++ show gn ++ + "\n\n Rules = " ++ (intercalate "\n " $ map show rs) ++ + "\n\n Players = " ++ show ps ++ + "\n\n Variables = " ++ show vs ++ + "\n\n Events = " ++ (intercalate "\n " $ map (displayEvent g) es) ++ "\n" ++ + "\n\n Outputs = " ++ (intercalate "\n " $ map (displayOutput g) os) ++ "\n" ++ + "\n\n Victory = " ++ show (getVictorious g) ++ + "\n\n currentTime = " ++ show t ++ "\n" ++ + "\n\n logs = " ++ show l ++ "\n" + +displayEvent :: Game -> RuleEventInfo -> String +displayEvent g (RuleEventInfo rn ei@(EventInfo en _ _ s envi)) = + "event num: " ++ (show en) ++ + ", rule num: " ++ (show rn) ++ + ", remaining signals: " ++ (show $ getRemainingSignals ei (EvalEnv (EvalState g 0) defaultEvalConf)) ++ --TODO: display also event result? + ", envs: " ++ (show envi) ++ + ", status: " ++ (show s) + +deriving instance Show LoggedGame + +displayOutput :: Game -> Output -> String +displayOutput g o@(Output on rn mpn _ s) = + "output num: " ++ (show on) ++ + ", rule num: " ++ (show rn) ++ + ", by pn: " ++ (show mpn) ++ + ", output: " ++ (show $ evalOutput g o) ++ + ", status: " ++ (show s) diff --git a/src/Nomyx/Core/Engine/GameEvents.hs b/src/Nomyx/Core/Engine/GameEvents.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Engine/GameEvents.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | This module implements the events that can affect a game. +module Nomyx.Core.Engine.GameEvents where + +import Prelude hiding (log) +import Data.List +import Data.Time +import Data.Maybe +import Control.Monad.State +import Control.Lens +import Control.Category ((>>>)) +import Control.Exception as E +import System.Log.Logger +import Nomyx.Language.Types +import Nomyx.Core.Engine.Evaluation +import Nomyx.Core.Engine.Utils +import Nomyx.Core.Engine.Types +import Nomyx.Core.Engine.Interpret +import Imprevu.Evaluation hiding (runEvalError) + +-- | perform a game event +enactEvent :: GameEvent -> Maybe Rule -> StateT Game IO () +enactEvent (JoinGame pn name) _ = joinGame name pn +enactEvent (LeaveGame pn) _ = leaveGame pn +enactEvent (ProposeRuleEv Propose pn rt ms) mr = proposeRule rt ms pn mr +enactEvent (ProposeRuleEv SystemAdd _ rt ms) mr = systemAddRule rt ms mr +enactEvent (ProposeRuleEv Check _ _ _) _ = return () +enactEvent (ProposeRuleEv _ _ _ _) Nothing = error "ProposeRuleEv: interpreter function needed" +enactEvent (InputResult pn en is id) _ = inputResult pn en is id +enactEvent (GLog mpn s) _ = logGame s mpn +enactEvent (TimeEvent t) _ = timeEvent t + +enactTimedEvent :: Maybe Rule -> TimedEvent -> StateT Game IO () +enactTimedEvent mr (TimedEvent t ge) = flip stateCatch updateError $ do + currentTime .= t + enactEvent ge mr + lg <- get + lift $ evaluate lg + return () + +updateError :: SomeException -> StateT Game IO () +updateError e = do + warn 0 $ "IO error: " ++ show e + logGame ("IO error: " ++ show e) Nothing + +execGameEvent :: GameEvent -> StateT LoggedGame IO () +execGameEvent = execGameEvent' Nothing + +execGameEvent' :: Maybe Rule -> GameEvent -> StateT LoggedGame IO () +execGameEvent' inter ge = do + t <- use (game . currentTime) + let te = TimedEvent t ge + gameLog %= \gl -> gl ++ [te] + zoom game $ enactTimedEvent inter te + +getLoggedGame :: Game -> [TimedEvent] -> IO LoggedGame +getLoggedGame g tes = do + let a = mapM_ (enactTimedEvent Nothing) tes + g' <- execStateT a g + return $ LoggedGame g' tes + +-- | join the game. +joinGame :: PlayerName -> PlayerNumber -> StateT Game IO () +joinGame name pn = do + g <- get + case find ((== pn) . view playerNumber) (_players g) of + Just _ -> return () + Nothing -> do + let player = PlayerInfo { _playerNumber = pn, _playerName = name, _playingAs = Nothing} + players %= (player : ) + void $ mapStateIO $ runSystemEval pn $ triggerEvent (Signal Arrive) player + + +-- | leave the game. +leaveGame :: PlayerNumber -> StateT Game IO () +leaveGame pn = void $ mapStateIO $ runSystemEval pn $ void $ evDelPlayer pn + +-- | insert a rule in pending rules. +proposeRule :: RuleTemplate -> [ModuleInfo] -> PlayerNumber -> Maybe Rule -> StateT Game IO () +proposeRule rt ms pn mr = do + rule <- createRule rt ms pn mr + r <- mapStateIO $ runEvalError (_rNumber rule) (Just pn) (evProposeRule rule) --do --bug here + case r of + Just _ -> info pn "Your rule has been added to pending rules." + Nothing -> warn pn "Error: Rule could not be proposed" + +-- | add a rule forcefully (no votes etc.) +systemAddRule :: RuleTemplate -> [ModuleInfo] -> Maybe Rule -> StateT Game IO () +systemAddRule rt ms mr = do + rule <- createRule rt ms 0 mr + let sysRule = (rStatus .~ Active) >>> (rAssessedBy .~ Just 0) + rules %= (sysRule rule : ) + void $ mapStateIO $ runEvalError (_rNumber rule) Nothing $ evalNomex (_rRule rule) + +-- | insert a log message. +logGame :: String -> Maybe PlayerNumber -> StateT Game IO () +logGame s mpn = do + time <- use currentTime + void $ logs %= (Log mpn time s : ) + +-- | the user has provided an input result +inputResult :: PlayerNumber -> EventNumber -> Input -> InputData -> StateT Game IO () +inputResult pn en is id = do + debug pn $ "input result: input " ++ (show is) ++ " input data " ++ (show id) + evs <- gets _events + let rn = _erRuleNumber $ fromJust $ find (\(RuleEventInfo rn (EventInfo en' _ _ _ _)) -> en' == en) evs + void $ mapStateIO $ runEvalError rn (Just pn) $ triggerInput is id + + +timeEvent :: UTCTime -> StateT Game IO () +timeEvent t = void $ mapStateIO $ runSystemEval' $ evTriggerTime t + +-- | A helper function to run the game state. +-- It additionally sets the current time +execWithGame :: UTCTime -> State LoggedGame () -> LoggedGame -> LoggedGame +execWithGame t gs g = execState gs $ set (game . currentTime) t g + +execWithGame' :: UTCTime -> StateT LoggedGame IO () -> LoggedGame -> IO LoggedGame +execWithGame' t gs g = execStateT gs $ set (game . currentTime) t g + +activeRules :: Game -> [RuleInfo] +activeRules = sort . filter ((==Active) . view rStatus) . _rules + +pendingRules :: Game -> [RuleInfo] +pendingRules = sort . filter ((==Pending) . view rStatus) . _rules + +rejectedRules :: Game -> [RuleInfo] +rejectedRules = sort . filter ((==Reject) . view rStatus) . _rules + +createRule :: RuleTemplate -> [ModuleInfo] -> PlayerNumber -> Maybe Rule -> StateT Game IO RuleInfo +createRule (RuleTemplate name des code author _ _ decls) ms pn mr = do + rs <- use rules + let rn = head $ [1..] \\ (map _rNumber rs) + g <- get + r <- case mr of + -- If the rule has already been interpreted, use it + Just r -> return r + -- re-interpret the rule (in the case of loading game from logs) + Nothing -> lift $ interpretRule' code ms + info pn $ "Creating rule n=" ++ show rn ++ " code=" ++ code + let ruleTemplate = RuleTemplate {_rName = name, + _rDescription = des, + _rRuleCode = code, + _rAuthor = author, + _rPicture = Nothing, + _rCategory = [], + _rDeclarations = []} --Declarations are transfered in the RuleInfo + return RuleInfo {_rNumber = rn, + _rProposedBy = pn, + _rRule = r, + _rStatus = Pending, + _rAssessedBy = Nothing, + _rRuleTemplate = ruleTemplate, + _rModules = ms} + +stateCatch :: Exception e => StateT Game IO a -> (e -> StateT Game IO a) -> StateT Game IO a +stateCatch m h = StateT $ \s -> runStateT m s `E.catch` \e -> runStateT (h e) s + +getEventInfo :: EventNumber -> LoggedGame -> EventInfo +getEventInfo en g = _erEventInfo $ fromJust $ find ((== en) . view (erEventInfo . eventNumber)) (_events $ _game g) + +warn, info :: (MonadIO m) => Int -> String -> m () +info pn s = liftIO $ infoM "Nomyx.Core.GameEvent" ("Player " ++ (show pn) ++ " " ++ s) +warn pn s = liftIO $ warningM "Nomyx.Core.GameEvent" ("Player " ++ (show pn) ++ " " ++ s) +debug pn s = liftIO $ debugM "Nomyx.Core.GameEvent" ("Player " ++ (show pn) ++ " " ++ s) diff --git a/src/Nomyx/Core/Engine/Interpret.hs b/src/Nomyx/Core/Engine/Interpret.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Engine/Interpret.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + +-- | This module interprets strings representing rules to convert them to plain Rules. +module Nomyx.Core.Engine.Interpret ( + interpretRule, + interpretRule', + showInterpreterError + ) + where + +import Control.Exception as CE +import Control.Monad +import Control.Monad.Catch as MC +import Data.List +import Language.Haskell.Interpreter +import Language.Haskell.Interpreter.Server +import Language.Haskell.Interpreter.Unsafe (unsafeSetGhcOption) +import Nomyx.Language +import Nomyx.Core.Engine.Context +import Nomyx.Core.Engine.Utils +import System.FilePath (dropExtension, joinPath, + takeFileName, dropFileName, + splitDirectories, takeBaseName, ()) +import System.IO.Temp +import System.IO.Unsafe +import System.Directory +import System.Log.Logger +#ifndef WINDOWS +import qualified System.Posix.Signals as S +#endif + + +#ifndef NOINTER + +serverHandle :: ServerHandle +serverHandle = unsafePerformIO $ start + +exts :: [String] +exts = ["Safe", "GADTs"] ++ map show namedExts + +namedExts :: [Extension] +namedExts = [GADTs, + ScopedTypeVariables, + TypeFamilies, + DeriveDataTypeable] + +-- | initializes the interpreter by loading some modules. +initializeInterpreter :: [ModuleInfo] -> Interpreter () +initializeInterpreter mods = do + reset + -- Interpreter options + set [installedModulesInScope := False, + languageExtensions := map readExt exts] + -- GHC options + unsafeSetGhcOption "-w" + unsafeSetGhcOption "-fpackage-trust" + forM_ (defaultPackages >>= words) $ \pkg -> unsafeSetGhcOption ("-trust " ++ pkg) + -- Modules + when (not $ null mods) $ do + dir <- liftIO $ createTempDirectory "/tmp" "Nomyx" + modPaths <- liftIO $ mapM (saveModule dir) mods + let modNames = map (getModName . _modPath) mods + info $ "Loading modules: " ++ (intercalate ", " modPaths) + info $ "module names: " ++ (intercalate ", " modNames) + loadModules modPaths + setTopLevelModules modNames + -- Imports + let importMods = qualImports ++ zip (unQualImports) (repeat Nothing) + setImportsQ importMods + +getModName :: FilePath -> String +getModName fp = intercalate "." $ (filter (/= ".") $ splitDirectories $ dropFileName fp) ++ [takeBaseName fp] + +---- | reads a Rule out of a string. +interpretRule :: RuleCode -> [ModuleInfo] -> IO (Either InterpreterError Rule) +interpretRule rc ms = runRule `catchIOError` handler where + runRule = protectHandlers $ runIn serverHandle $ do + initializeInterpreter ms + interpret rc (as :: Rule) + handler (e::IOException) = return $ Left $ NotAllowed $ "Caught exception: " ++ (show e) + +interpretRule' :: RuleCode -> [ModuleInfo] -> IO Rule +interpretRule' rc ms = do + res <- interpretRule rc ms + case res of + Right rf -> return rf + Left e -> error $ show 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 + +readExt :: String -> Extension +readExt s = case reads s of + [(e,[])] -> e + _ -> UnknownExtension s + +#else + +interpretRule :: RuleCode -> [ModuleInfo] -> IO (Either InterpreterError Rule) +interpretRule rc ms = return $ Left $ NotAllowed "Interpreter not included" + +interpretRule' :: RuleCode -> [ModuleInfo] -> IO Rule +interpretRule' rc ms = error "Interpreter not included" + +showInterpreterError :: InterpreterError -> String +showInterpreterError (NotAllowed s) = s + +#endif + + +#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 + +warn, info :: (MonadIO m) => String -> m () +info s = liftIO $ infoM "Nomyx.Core.Engine.Interpret" s +warn s = liftIO $ warningM "Nomyx.Core.Engine.Interpret" s diff --git a/src/Nomyx/Core/Engine/Test.hs b/src/Nomyx/Core/Engine/Test.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Engine/Test.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} + +module Nomyx.Core.Engine.Test where + +import Nomyx.Language.Types +import Nomyx.Language.Variables +import Nomyx.Language.Rules +import Nomyx.Language.Events +import Nomyx.Language.Outputs +import Nomyx.Language.Messages +import Nomyx.Core.Engine.Evaluation +import Nomyx.Core.Engine.Types +import Nomyx.Library.Examples +import Nomyx.Library.Vote +import Nomyx.Library.Victory +import Control.Monad.State +import Data.Typeable +import Data.Function hiding ((.)) +import Data.Maybe +import Control.Lens +import System.Random +import Imprevu.Test.TestMgt +import Imprevu.Evaluation hiding (events) +import Debug.NoTrace -- .Helpers (traceM) + + +testGame :: Game +testGame = Game { _gameName = "test", + _gameDesc = GameDesc "test" "test", + _rules = [], + _players = [PlayerInfo 1 "coco" Nothing], + _variables = [], + _events = [], + _outputs = [], + _victory = Nothing, + _logs = [], + _currentTime = date1, + _randomGen = mkStdGen 0} + +testRule :: RuleInfo +testRule = RuleInfo { _rNumber = 0, + _rProposedBy = 0, + _rRule = return (), + _rStatus = Pending, + _rAssessedBy = Nothing, + _rModules = [], + _rRuleTemplate = RuleTemplate {_rName = "test", + _rDescription = "test", + _rRuleCode = "", + _rAuthor = "", + _rPicture = Nothing, + _rCategory = [], + _rDeclarations = []}} + +execRuleGame :: Nomex a -> Game -> Game +execRuleGame r g = execState (runSystemEval' $ void $ evalNomex r) g + +execRuleEventGame :: (Show e, Typeable e, Eq e, Eq s, Show s, Typeable s) => Nomex a -> Signal s e -> e -> Game -> Game +execRuleEventGame r f d g = execState (runSystemEval' $ evalNomex r >> (triggerEvent f d)) g + +execRule :: Nomex a -> Game +execRule r = execRuleGame r testGame + +addActivateRule :: Rule -> RuleNumber -> Evaluate () +addActivateRule rf rn = do + let rule = testRule & (rRuleTemplate . rName) .~ "testRule" + & rRule .~ rf + & rNumber .~ rn + & rStatus .~ Pending + evAddRule rule + evActivateRule (_rNumber rule) + return () + +--Test variable creation +testVar1 :: Rule +testVar1 = do + NewVar "toto" (1::Integer) + return () + +testVarEx1 :: Bool +testVarEx1 = True --(variables ^$ execRuleFunc testVar1) == [(Var 0 "toto" (1::Integer))] + +--Test variable deleting +testVar2 :: Rule +testVar2 = do + var <- newVar_ "toto" (1::Int) + delVar var + return () + +testVarEx2 :: Bool +testVarEx2 = True --_variables (execRuleFunc testVar2) == [] + +--Test variable reading +testVar3 :: Rule +testVar3 = do + var <- newVar_ "toto" (1::Int) + a <- readVar var + case a of + Just (1::Int) -> void $ newOutput (Just 1) (return "ok") + _ -> void $ newOutput (Just 1) (return "nok") + +testVarEx3 :: Bool +testVarEx3 = isOutput "ok" (execRule testVar3) + +--Test variable writing +testVar4 :: Rule +testVar4 = do + var <- newVar_ "toto" (1::Int) + writeVar var (2::Int) + a <- readVar var + case a of + Just (2::Int) -> void $ newOutput (Just 1) (return "ok") + _ -> void $ newOutput (Just 1) (return "nok") + +testVarEx4 :: Bool +testVarEx4 = isOutput "ok" (execRule testVar4) + +--Test variable writing +testVar5 :: Rule +testVar5 = do + var <- newVar_ "toto" ([]::[Int]) + writeVar var ([1]::[Int]) + a <- readVar var + case a of + Just (a::[Int]) -> void $ writeVar var (2:a) + Nothing -> void $ newOutput (Just 1) (return "nok") + +testVarEx5 :: Bool +testVarEx5 = (show $ head $ _variables $ execRule testVar5) == "Rule number = 0, Name = \"toto\", Value = [2,1]\n" + +-- Test rule activation +testActivateRule :: Rule +testActivateRule = do + a <- GetRules + when (_rStatus (head a) == Pending) $ void $ ActivateRule $ _rNumber (head a) + + +testActivateRuleEx :: Bool +testActivateRuleEx = _rStatus (head $ _rules (execRuleGame testActivateRule testGame {_rules=[testRule]})) == Active + +testAutoActivateEx :: Bool +testAutoActivateEx = _rStatus (head $ _rules (execRuleEventGame autoActivate (Signal Proposed) testRule (testGame {_rules=[testRule]}))) == Active + +--testAutoDelete :: Rule +--testAutoDelete = do +-- outputAll_ "before" +-- autoDelete +-- outputAll_ "after" +-- +--testAutoDeleteEx = isOutput "ok" (execRuleGame testAutoDelete testGame {_rules=[testRule {_rNumber = 1}]}) + +-- Test deletes +testDeleteRule :: Rule +testDeleteRule = do + newVar_ "toto" (1::Int) + onMessage (Signal "msg" :: Msg ()) (const $ return ()) + void $ newOutput (Just 1) (return "toto") + +testDeleteGame :: Game +testDeleteGame = flip execState testGame {_players = []} $ runSystemEval 1 $ do + addActivateRule testDeleteRule 1 + addActivateRule (void $ suppressRule 1) 2 + +testDeleteRuleEx1 :: Bool +testDeleteRuleEx1 = (_rStatus $ head $ drop 1 $ _rules testDeleteGame) == Reject && + --(_variables testDeleteGame == []) && + (_oStatus $ head $ _outputs testDeleteGame) == SDeleted && + (_evStatus $ _erEventInfo $ head $ _events testDeleteGame) == SDeleted + +-- Test victory +testVictoryGame :: Game +testVictoryGame = flip execState testGame $ runSystemEval' $ do + addActivateRule (victoryXRules 1) 1 + addActivateRule (nothing) 2 + +testVictoryEx1 :: Bool +testVictoryEx1 = (length $ getVictorious testVictoryGame) == 1 + +-- Test votes + +voteGameActions :: Int -> Int -> Int -> Bool -> Evaluate () -> Game +voteGameActions positives negatives total timeEvent actions = flip execState testGame {_players = []} $ runSystemEval' $ do + mapM_ (\x -> addPlayer (PlayerInfo x ("coco " ++ show x) Nothing)) [1..total] + actions + evProposeRule testRule + evs <- lift getChoiceEvents + traceM $ "choice events =" ++ (show evs) + mapM_ (triggerVote 1) (take positives evs) --issuing positive votes + mapM_ (triggerVote 0) (take negatives $ drop positives evs) --issuing negative votes + when timeEvent $ evTriggerTime date2 + +--Trigger a vote event (0 for positive, 1 for negative), using event details +triggerVote :: Int -> Input -> Evaluate () +triggerVote res is = triggerInput is (RadioData res) + +voteGame' :: Int -> Int -> Int -> Bool -> Rule -> Game +voteGame' positives negatives notVoted timeEvent rf = voteGameActions positives negatives notVoted timeEvent $ addActivateRule rf 1 + +voteGame :: Int -> Int -> Int -> Rule -> Game +voteGame positives negatives notVoted = voteGame' positives negatives notVoted False + +voteGameTimed :: Int -> Int -> Int -> Rule -> Game +voteGameTimed positives negatives notVoted = voteGame' positives negatives notVoted True + +testVoteAssessOnVoteComplete1, testVoteAssessOnVoteComplete2, testVoteAssessOnEveryVote1, testVoteAssessOnEveryVote2, testVoteAssessOnEveryVote3, testVoteAssessOnEveryVote4, testVoteMajorityWith, testVoteNumberPositiveVotes, testVoteWithQuorum1, testVoteAssessOnTimeLimit1, testVoteAssessOnTimeLimit2, testVoteAssessOnTimeLimit3, testVoteAssessOnTimeLimit4, testVoteAssessOnTimeLimit5 :: Bool +-- vote rules |Expected result |pos |neg |total |description of voting system +testVoteAssessOnVoteComplete1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ (callVoteRule majority oneDay) +testVoteAssessOnVoteComplete2 = testVoteRule Pending $ voteGame 9 0 10 $ onRuleProposed $ (callVoteRule unanimity oneDay) +testVoteAssessOnEveryVote1 = testVoteRule Active $ voteGame 10 0 10 $ onRuleProposed $ (callVoteRule unanimity oneDay) +testVoteAssessOnEveryVote2 = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ (callVoteRule majority oneDay) +testVoteAssessOnEveryVote3 = testVoteRule Pending $ voteGame 5 0 10 $ onRuleProposed $ (callVoteRule majority oneDay) +testVoteAssessOnEveryVote4 = testVoteRule Reject $ voteGame 0 5 10 $ onRuleProposed $ (callVoteRule majority oneDay) +testVoteMajorityWith = testVoteRule Active $ voteGame 6 0 10 $ onRuleProposed $ (callVoteRule (majorityWith 50) oneDay) +testVoteNumberPositiveVotes = testVoteRule Active $ voteGame 3 7 10 $ onRuleProposed $ (callVoteRule (numberVotes 3) oneDay) +testVoteWithQuorum1 = testVoteRule Active $ voteGame 7 3 10 $ onRuleProposed $ (callVoteRule (majority `withQuorum` 7) oneDay) +testVoteAssessOnTimeLimit1 = testVoteRule Active $ voteGameTimed 10 0 10 $ onRuleProposed $ (callVoteRule' unanimity date2) +testVoteAssessOnTimeLimit2 = testVoteRule Active $ voteGameTimed 1 0 10 $ onRuleProposed $ (callVoteRule' unanimity date2) +testVoteAssessOnTimeLimit3 = testVoteRule Reject $ voteGameTimed 1 0 10 $ onRuleProposed $ (callVoteRule' (unanimity `withQuorum` 5) date2) +testVoteAssessOnTimeLimit4 = testVoteRule Reject $ voteGameTimed 0 0 10 $ onRuleProposed $ (callVoteRule' (unanimity `withQuorum` 1) date2) +testVoteAssessOnTimeLimit5 = testVoteRule Active $ voteGameTimed 1 0 10 $ onRuleProposed $ (callVoteRule' (unanimity `withQuorum` 1) date2) + +testVoteRule s g = (_rStatus $ head $ _rules g) == s + +--Test with a player arriving in the middle of a vote (he should be able to vote) +testVotePlayerArrive :: Game +testVotePlayerArrive = flip execState testGame {_players = []} $ runSystemEval' $ do + addPlayer (PlayerInfo 1 "coco 1" Nothing) + addActivateRule (onRuleProposed $ callVoteRule (unanimity `withQuorum` 2) oneDay) 1 + evProposeRule testRule + evs <- lift getChoiceEvents + mapM_ (triggerVote 1) evs --issuing positive vote player 1 + addPlayer (PlayerInfo 2 "coco 2" Nothing) --new player + evs <- lift getChoiceEvents + mapM_ (triggerVote 1) evs --issuing positive vote player 2 + +testVotePlayerArriveEx = testVoteRule Active testVotePlayerArrive + +--Test with a player leaving in the middle of a vote +--in some cases a player leaving can trigger the end of the vote (i.e when everybody voted except him) +testVotePlayerLeave :: Game +testVotePlayerLeave = flip execState testGame {_players = []} $ runSystemEval' $ do + addPlayer (PlayerInfo 1 "coco 1" Nothing) + addPlayer (PlayerInfo 2 "coco 2" Nothing) + addActivateRule (onRuleProposed $ callVoteRule unanimity oneDay) 1 + evProposeRule testRule + evs <- lift getChoiceEvents + triggerVote 1 (last evs) -- issuing positive vote player 1 + evDelPlayer 2 -- player 2 leaving + +testVotePlayerLeaveEx :: Bool +testVotePlayerLeaveEx = testVoteRule Active testVotePlayerLeave + + +--Get all event numbers of type choice (radio button) +getChoiceEvents :: State EvalEnv [Input] +getChoiceEvents = do + evs <- use (evalEnv . eGame . events) + ee <- get + return $ concatMap (getInputChoices ee) evs + +getInputChoices :: EvalEnv -> RuleEventInfo -> [Input] +getInputChoices ee (RuleEventInfo _ ei) = mapMaybe isInput (getRemainingSignals ei ee) where + isInput :: SomeSignal -> Maybe Input + isInput (SomeSignal (Signal s)) = cast s + +addPlayer :: PlayerInfo -> Evaluate Bool +addPlayer pi = do + pls <- use (evalEnv . eGame . players) + let exists = any (((==) `on` _playerNumber) pi) pls + unless exists $ do + (evalEnv . eGame . players) %= (pi:) + triggerEvent (Signal Arrive) pi + return $ not exists + +isOutput :: String -> Game -> Bool +isOutput s g = s `elem` allOutputs g diff --git a/src/Nomyx/Core/Engine/Types.hs b/src/Nomyx/Core/Engine/Types.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Engine/Types.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | Types for the engine +module Nomyx.Core.Engine.Types where + +import Prelude hiding (log) +import Nomyx.Language.Types +import Data.Time +import Data.Typeable +import Data.Aeson.TH (deriveJSON, defaultOptions) +import Data.Aeson +import Data.Time.Clock.POSIX +import Control.Lens hiding ((.=)) +import Control.Monad.State +import Control.Monad.Reader +import System.Random +import Imprevu.Evaluation hiding (events) + +-- * Evaluation + +-- | Environment necessary for the evaluation of any nomyx expressions or events +data EvalState = EvalState { _eGame :: Game, -- game to be read/modified + _eRuleNumber :: RuleNumber} -- number of the rule requesting the evaluation + +type EvalEnv = EvalEnvN Nomex EvalState + +-- | Environment necessary for the evaluation of Nomex +type Evaluate a = EvaluateN Nomex EvalState a + +-- * Game + +type GameName = String + + +-- | The state of the game: +data Game = Game { _gameName :: GameName, + _gameDesc :: GameDesc, + _rules :: [RuleInfo], + _players :: [PlayerInfo], + _variables :: [Var], + _events :: [RuleEventInfo], + _outputs :: [Output], + _victory :: Maybe VictoryInfo, + _logs :: [Log], + _currentTime :: UTCTime, + _randomGen :: StdGen} + deriving (Typeable) + +data GameDesc = GameDesc { _desc :: String, _forumURL :: String} deriving (Eq, Show, Read, Ord) + +instance Eq Game where + (Game {_gameName=gn1}) == (Game {_gameName=gn2}) = gn1 == gn2 + +instance Ord Game where + compare (Game {_gameName=gn1}) (Game {_gameName=gn2}) = compare gn1 gn2 + +emptyGame :: GameName -> GameDesc -> UTCTime -> StdGen -> Game +emptyGame name desc date gen = Game { + _gameName = name, + _gameDesc = desc, + _rules = [], + _players = [], + _variables = [], + _events = [], + _outputs = [], + _victory = Nothing, + _logs = [], + _randomGen = gen, + _currentTime = date} + + +-- | a list of possible events affecting a game +data GameEvent = JoinGame PlayerNumber PlayerName + | LeaveGame PlayerNumber + | ProposeRuleEv RuleEv PlayerNumber RuleTemplate [ModuleInfo] + | InputResult PlayerNumber EventNumber Input InputData + | GLog (Maybe PlayerNumber) String + | TimeEvent UTCTime + deriving (Show, Read, Eq, Ord) + +data RuleEv = Propose | Check | SystemAdd + deriving (Show, Read, Eq, Ord) + +data TimedEvent = TimedEvent UTCTime GameEvent deriving (Show, Read, Eq, Ord) + +-- | A game being non serializable, we have to store events in parralel in order to rebuild the state latter. +data LoggedGame = LoggedGame { _game :: Game, + _gameLog :: [TimedEvent]} + +instance Eq LoggedGame where + (LoggedGame {_game=g1}) == (LoggedGame {_game=g2}) = g1 == g2 + +instance Ord LoggedGame where + compare (LoggedGame {_game=g1}) (LoggedGame {_game=g2}) = compare g1 g2 + + +-- * Variables + +-- | stores the variable's data +data Var = forall a . (Typeable a, Show a) => + Var { _vRuleNumber :: RuleNumber, + _vName :: String, + vData :: a} + +vRuleNumber :: Lens' Var RuleNumber +vRuleNumber f (Var vr vn vd) = fmap (\vr' -> (Var vr' vn vd)) (f vr) + +vName :: Lens' Var String +vName f (Var vr vn vd) = fmap (\vn' -> (Var vr vn' vd)) (f vn) + +instance Show Var where + show (Var a b c) = "Rule number = " ++ (show a) ++ ", Name = " ++ (show b) ++ ", Value = " ++ (show c) ++ "\n" + + + +-- * Events + +data RuleEventInfo = RuleEventInfo { _erRuleNumber :: RuleNumber, -- the rule that created the event + _erEventInfo :: EventInfo} -- event informations + deriving (Eq) + +instance Ord RuleEventInfo where + (RuleEventInfo rn1 _) <= (RuleEventInfo rn2 _) = rn1 <= rn2 + +-- * Outputs + +data Output = Output { _outputNumber :: OutputNumber, -- number of the output + _oRuleNumber :: RuleNumber, -- rule that triggered the output + _oPlayerNumber :: (Maybe PlayerNumber), -- player to display the output to (Nothing means display to all players) + _output :: Nomex String, -- output string + _oStatus :: Status} -- status of the output + deriving (Show) + +instance Eq Output where + (Output {_outputNumber=on1}) == (Output {_outputNumber=on2}) = on1 == on2 + +instance Ord Output where + (Output {_outputNumber=r1}) <= (Output {_outputNumber=r2}) = r1 <= r2 + +-- * Logs + +data Log = Log { _lPlayerNumber :: Maybe PlayerNumber, + _lTime :: UTCTime, + _lMsg :: String} + deriving (Show) + +makeLenses ''Game +makeLenses ''GameDesc +makeLenses ''Var +makeLenses ''Output +makeLenses ''EvalState +makeLenses ''LoggedGame +makeLenses ''RuleEventInfo + +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 <*> + pure (mkStdGen 0) + parseJSON _ = mzero + +instance ToJSON RuleTemplate where + toJSON (RuleTemplate n d rc a p cs ds) = + object ["name" .= n, + "desc" .= d, + "rule" .= rc, + "author" .= a, + "picture" .= p, + "category" .= cs, + "decls" .= ds] + +instance FromJSON RuleTemplate where + parseJSON (Object v) = RuleTemplate <$> + v .: "name" <*> + v .: "desc" <*> + v .: "rule" <*> + v .: "author" <*> + v .: "picture" <*> + v .: "category" <*> + v .: "decls" + parseJSON _ = mzero + + +$(deriveJSON defaultOptions ''TimedEvent) +$(deriveJSON defaultOptions ''GameEvent) +$(deriveJSON defaultOptions ''InputField) +$(deriveJSON defaultOptions ''Input) +$(deriveJSON defaultOptions ''InputData) +$(deriveJSON defaultOptions ''RuleEv) +$(deriveJSON defaultOptions ''GameDesc) +$(deriveJSON defaultOptions ''StdGen) +$(deriveJSON defaultOptions ''SignalAddressElem) +$(deriveJSON defaultOptions ''LoggedGame) +$(deriveJSON defaultOptions ''ModuleInfo) diff --git a/src/Nomyx/Core/Engine/Utils.hs b/src/Nomyx/Core/Engine/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Engine/Utils.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | additional tools for evaluation +module Nomyx.Core.Engine.Utils where + +import Control.Applicative +import Control.Category +import Control.Lens +import Control.Monad +import Control.Monad.Reader +import Control.Monad.State +import Data.List +import qualified Data.Text.IO as DT +import Data.Maybe +import Data.Typeable +import Imprevu.Evaluation as Imp +import Nomyx.Language.Types +import Nomyx.Core.Engine.Types +import Prelude hiding (log, (.)) +import Safe +import Debug.Trace.Helpers (traceM) +import System.FilePath (dropFileName, ()) +import System.Directory (createDirectoryIfMissing) + + +log :: Maybe PlayerNumber -> String -> Evaluate () +log mpn s = focusGame $ do + time <- use currentTime + void $ logs %= (Log mpn time s : ) + +focusGame :: State Game a -> Evaluate a +focusGame = lift . zoom (evalEnv . eGame) + +accessGame :: Lens' Game a -> Evaluate (a, RuleNumber) +accessGame l = do + a <- use (evalEnv . eGame . l) + rn <- use (evalEnv . eRuleNumber) + return (a, rn) + +putGame :: Lens' Game a -> a -> Evaluate () +putGame l a = do + ruleActive <- evalRuleActive + void $ (evalEnv . eGame . l) .= a --when ruleActive $ + +modifyGame :: Lens' Game a -> (a -> a) -> Evaluate () +modifyGame l f = do + ruleActive <- evalRuleActive + void $ (evalEnv . eGame . l) %= f --when ruleActive $ + +evalRuleActive :: Evaluate Bool +evalRuleActive = do + rn <- use (evalEnv . eRuleNumber) + rs <- use (evalEnv . eGame . rules) + return $ (rn == 0) || + case find (\r -> _rNumber r == rn) rs of + Just r -> _rStatus r == Active + Nothing -> True --TODO why should there be an evaluating rule not in the list? + + +--replace temporarily the rule number used for evaluation +withRN :: RuleNumber -> Evaluate a -> Evaluate a +withRN rn eval = do + oldRn <- use (evalEnv . eRuleNumber) + evalEnv . eRuleNumber .= rn + a <- eval + evalEnv . eRuleNumber .= oldRn + return a + +tracePN :: (Monad m) => Int -> String -> m () +tracePN pn s = traceM $ "Player " ++ (show pn) ++ " " ++ s + +mapStateIO :: Show s => State s a -> StateT s IO a +mapStateIO = mapStateT $ return . runIdentity + +--TODO handle error cases +saveModule :: FilePath -> ModuleInfo -> IO (FilePath) +saveModule saveDir (ModuleInfo path content) = do + let dest = saveDir path + createDirectoryIfMissing True $ dropFileName dest + DT.writeFile dest content + return dest diff --git a/src/Nomyx/Core/Mail.hs b/src/Nomyx/Core/Mail.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Mail.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + + +module Nomyx.Core.Mail ( + sendMailsSubmitRule + ) where + +import Prelude hiding (div, (.), error) +import Control.Category +import Control.Concurrent +import Control.Monad +import Control.Monad.State +import Data.Maybe +import Data.Text (Text, pack) +import qualified Data.Text.Lazy as B +import Language.Haskell.HsColour.Colourise hiding (string) +import qualified Language.Haskell.HsColour.HTML as HSC +import Network.Mail.Mime hiding (mailTo) +import Network.HaskellNet.Auth +import Network.HaskellNet.SMTP +import Network.HaskellNet.SMTP.SSL +import Nomyx.Language +import Nomyx.Core.Engine +import Nomyx.Core.Profile +import Nomyx.Core.Types +import Nomyx.Core.Utils +import Text.Blaze.Html.Renderer.String +import Text.Blaze.Html5 hiding (br, label, map) +import qualified Text.Blaze.Html5 as H +import System.Log.Logger + +default (Integer, Double, Data.Text.Text) + + +sendMail' :: String -> String -> String -> String -> MailSettings -> IO () +sendMail' to obj textBody htmlBody (MailSettings _ host login pass) = do + info $ "Sending a mail to " ++ to ++ " login: " ++ login ++ " pass: " ++ pass + let authSend connection = do + succeeded <- authenticate LOGIN login pass connection + if succeeded + then sendMimeMail to "game@nomyx.net" obj (B.pack textBody) (B.pack htmlBody) [] connection + else error "Mail authentication error" + void $ forkIO $ doSMTPSSL host authSend + + +newRuleHtmlBody :: PlayerName -> RuleTemplate -> PlayerName -> Network -> Html +newRuleHtmlBody playerName (RuleTemplate 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 >> (preEscapedToHtml $ HSC.hscolour defaultColourPrefs False 0 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 -> RuleTemplate -> PlayerName -> Network -> String +newRuleTextBody playerName (RuleTemplate 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 ++ "!" + +sendMailsSubmitRule :: Session -> RuleTemplate -> PlayerNumber -> GameName -> IO () +sendMailsSubmitRule s rt pn gn = do + let mailSet = _mailSettings $ _mSettings $ _multi s + when (_sendMails mailSet) $ do + let (Just gi) = getGameByName gn s + guard (_isPublic gi) + putStrLn "Sending mails" + let sendMailsTo = map _playerNumber (_players $ _game $ _loggedGame gi) + proposer <- Nomyx.Core.Profile.getPlayerName pn s + profiles <- mapM (getProfile s) sendMailsTo + mapM_ (send proposer (_net $ _mSettings $ _multi s) rt mailSet) (_pPlayerSettings <$> catMaybes profiles) + + +send :: PlayerName -> Network -> RuleTemplate -> MailSettings -> PlayerSettings -> IO() +send prop net sr ms set = when (_mailSubmitRule set && (isJust $ _mail set)) + $ sendMail' (fromJust $ _mail set) + (newRuleObject prop) + (newRuleTextBody (_pPlayerName set) sr prop net) + (renderHtml $ newRuleHtmlBody (_pPlayerName set) sr prop net) + ms + +mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM f = liftM catMaybes . mapM f + +error, info :: (MonadIO m) => String -> m () +info s = liftIO $ infoM "Nomyx.Core.Mail" s +error s = liftIO $ errorM "Nomyx.Core.Mail" s diff --git a/src/Nomyx/Core/Multi.hs b/src/Nomyx/Core/Multi.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Multi.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module manages multi-player games. +module Nomyx.Core.Multi where + +import Control.Exception +import Control.Lens +import Control.Monad.State +import Data.List +import Data.Time as T +import Nomyx.Language +import Nomyx.Core.Engine as G +import Nomyx.Core.Engine.Interpret +import Nomyx.Core.Quotes (cr) +import Nomyx.Core.Types +import Nomyx.Core.Utils +import System.Random + + +rAutoActivate :: RuleTemplate +rAutoActivate = RuleTemplate "AutoActivate" + "Any proposed rule will be automatically activated, without any vote" + [cr|autoActivate|] + "Kau" + Nothing + [] + [] + +initialGame :: StateT GameInfo IO () +initialGame = zoom loggedGame $ mapM_ addR [rAutoActivate] + where addR rt = execGameEvent' Nothing (ProposeRuleEv SystemAdd 0 rt []) + +initialGameInfo :: GameName -> GameDesc -> Bool -> Maybe PlayerNumber -> UTCTime -> IO GameInfo +initialGameInfo name desc isPub mpn date = do + let gen = mkStdGen 0 + let lg = GameInfo { _loggedGame = LoggedGame (emptyGame name desc date gen) [], + _ownedBy = mpn, + _forkedFromGame = Nothing, + _isPublic = isPub, + _startedAt = date} + execStateT initialGame lg + +defaultMulti :: Settings -> Library -> Multi +defaultMulti s lib = Multi [] s lib + +-- | finds the corresponding game in the multistate and replaces it. +modifyGame :: GameInfo -> StateT Multi IO () +modifyGame gi = do + gs <- use 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 + +execWithMulti :: UTCTime -> StateT Multi IO () -> Multi -> IO Multi +execWithMulti t ms m = do + let setTime g = (loggedGame . game . currentTime) .~ t $ g + let m' = over gameInfos (map setTime) m + execStateT ms m' diff --git a/src/Nomyx/Core/Profile.hs b/src/Nomyx/Core/Profile.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Profile.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Nomyx.Core.Profile where + +import Control.Monad +import Control.Monad.Catch (bracket) +import Control.Monad.Reader.Class (MonadReader (..)) +import Control.Monad.State +import Control.Lens +import Data.Acid (Query, Update, makeAcidic, + openLocalStateFrom) +import Data.Acid (AcidState (..)) +import Data.Acid.Advanced (query', update') +import Data.Acid.Local (createCheckpointAndClose) +import Data.IxSet (toList, (@=)) +import qualified Data.IxSet as IxSet +import Data.List +import Data.Maybe +import Safe +import Nomyx.Language +import Nomyx.Core.Engine +import Nomyx.Core.Quotes +import Nomyx.Core.Types +import System.FilePath (()) + +-- | 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 + +initialProfileData :: PlayerNumber -> PlayerSettings -> Library -> ProfileData +initialProfileData uid ps lib = ProfileData uid ps (Just (exampleRule, "")) NoUpload False lib + +exampleRule :: RuleTemplate +exampleRule = RuleTemplate "" "" [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 +|] + "" + Nothing + [] + [] + + +-- | create the profile data, but only if it is missing +newProfileData :: PlayerNumber -> PlayerSettings -> Library -> Update ProfileDataState ProfileData +newProfileData uid ps lib = + do pds@(ProfileDataState {..}) <- get + case IxSet.getOne (profilesData @= uid) of + Nothing -> do + let pd = initialProfileData uid ps lib + 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 + 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 "" Nothing False False False False + + +modifyProfile :: PlayerNumber -> (ProfileData -> ProfileData) -> StateT Session IO () +modifyProfile pn mod = do + s <- get + pfd <- query' (_acidProfiles s) (AskProfileData pn) + when (isJust pfd) $ void $ update' (_acidProfiles s) (SetProfileData (mod $ fromJust pfd)) + +getProfile :: MonadIO m => Session -> PlayerNumber -> m (Maybe ProfileData) +getProfile s pn = query' (_acidProfiles s) (AskProfileData pn) + +getPlayerName :: PlayerNumber -> Session -> IO PlayerName +getPlayerName pn s = do + pfd <- query' (_acidProfiles s) (AskProfileData pn) + return $ _pPlayerName $ _pPlayerSettings $ fromJustNote ("getPlayersName: no profile for pn=" ++ show pn) pfd + +getPlayerNumber' :: PlayerName -> Session -> IO (Maybe PlayerNumber) +getPlayerNumber' pname s = do + pds <- query' (_acidProfiles s) AskProfilesData + return $ headMay $ [ _pPlayerNumber pd | pd <- pds, _pPlayerName (_pPlayerSettings pd) == pname] + +getPlayerInGameName :: Game -> PlayerNumber -> PlayerName +getPlayerInGameName g pn = case find ((==pn) . view playerNumber) (_players g) of + Nothing -> error "getPlayersName': No player by that number in that game" + Just pm -> _playerName pm + +getAllProfiles :: Session -> IO [ProfileData] +getAllProfiles s = query' (_acidProfiles s) AskProfilesData + +getPlayerInfo :: Game -> PlayerNumber -> Maybe PlayerInfo +getPlayerInfo g pn = find ((==pn) . view playerNumber) (_players g) + +withAcid :: Maybe FilePath -- ^ state directory + -> (AcidState ProfileDataState -> IO a) -- ^ action + -> IO a +withAcid mBasePath action = do + let basePath = fromMaybe "_state" mBasePath + bracket (openLocalStateFrom (basePath "profileData") initialProfileDataState) createCheckpointAndClose updateProfile where + updateProfile profileData = action (profileData) diff --git a/src/Nomyx/Core/Quotes.hs b/src/Nomyx/Core/Quotes.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Quotes.hs @@ -0,0 +1,43 @@ + +{-# 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.Engine.Context + + +-- This quasi quoter allows to type check a string as a Nomyx rule. +-- 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 "Nomex ()" -> [| s |] + Right "Exp 'Effect ()" -> [| s |] + Right "Rule" -> [| s |] + Right a -> fail $ "Rule doesn't typecheck: " ++ show a + Left e -> fail $ show e + + + diff --git a/src/Nomyx/Core/Serialize.hs b/src/Nomyx/Core/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Serialize.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Nomyx.Core.Serialize where + +import Prelude hiding (log, (.)) +import Control.Category +import Control.Lens hiding ((.=)) +import Control.Monad.State +import Data.Yaml as Yaml (decodeEither, encode) +import qualified Data.Aeson as Json (eitherDecode, encode) +import Data.List +import qualified Data.Text.IO as DT +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as BL +import Nomyx.Core.Engine +import Nomyx.Core.Engine.Interpret +import Nomyx.Core.Types +import Nomyx.Core.Utils +import Nomyx.Language +import System.FilePath + +save :: Multi -> IO () +save m = BL.writeFile (getSaveFile $ _mSettings m) (Json.encode m) + +save' :: StateT Multi IO () +save' = get >>= lift . save + +load :: FilePath -> IO Multi +load fp = do + s <- BL.readFile fp + case Json.eitherDecode s of + Left e -> error $ "error decoding save file: " ++ e + Right a -> return a + +loadMulti :: Settings -> IO Multi +loadMulti s = do + let sd = getSaveFile s + m <- load sd + gs' <- mapM updateGameInfo (_gameInfos m) + let m' = set gameInfos gs' m + let m'' = set mSettings s m' + return m'' + +updateGameInfo :: GameInfo -> IO GameInfo +updateGameInfo gi = do + gi' <- updateLoggedGame (_loggedGame gi) + return $ gi {_loggedGame = gi'} + +updateLoggedGame :: LoggedGame -> IO LoggedGame +updateLoggedGame (LoggedGame g log) = getLoggedGame g log + +-- read a library file +readLibrary :: FilePath -> IO Library +readLibrary yamlFile = do + let dir = takeDirectory yamlFile + ts <- readTemplates yamlFile + let mods = nub $ join [ms | (RuleTemplate _ _ _ _ _ _ ms) <- ts] + ms <- mapM (readModule dir) mods + return $ Library ts ms + +readTemplates :: FilePath -> IO [RuleTemplate] +readTemplates yamlFile = do + s <- BC.readFile yamlFile + case Yaml.decodeEither s of + Left e -> error $ "error decoding library: " ++ e + Right ts -> return ts + +readModule :: FilePath -> FilePath -> IO ModuleInfo +readModule basePath mod = do + let absPath = basePath mod + content <- DT.readFile absPath + return $ ModuleInfo mod content + +-- write a library file +writeLibrary :: FilePath -> Library -> IO () +writeLibrary yamlFile (Library ts ms) = do + let dir = takeDirectory yamlFile + putStrLn $ "saving templates: " ++ yamlFile + BC.writeFile yamlFile (Yaml.encode ts) + mapM_ (saveModule dir) ms + diff --git a/src/Nomyx/Core/Session.hs b/src/Nomyx/Core/Session.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Session.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module manages multi-player commands. +module Nomyx.Core.Session ( + -- * Player managament + newPlayer, + -- * Game management + newGame, newGame', + forkGame, + joinGame, + delGame, + leaveGame, + -- * Rule management + submitRule, + adminSubmitRule, + checkRule, + -- * Library management + newRuleTemplate, + addRuleTemplate, + delRuleTemplate, + updateLibrary, + -- * Modules + newModule, + -- * IO + inputResult, + applyTimeEvent, + -- * settings + playerSettings, + adminPass, + globalSettings, + playAs, + -- * Session + updateSession, + evalSession, + ) +where + +import Control.Concurrent.STM +import Control.Lens +import Control.Monad.State +import qualified Data.Acid.Advanced as A (query', update') +import Data.List +import Data.Maybe +import Data.Time as T +import Debug.Trace.Helpers +import Nomyx.Language +import Nomyx.Core.Engine as G +import Nomyx.Core.Engine.Interpret +import Nomyx.Core.Multi +import Nomyx.Core.Profile +import Nomyx.Core.Serialize +import Nomyx.Core.Types +import Nomyx.Core.Utils +import Nomyx.Core.Mail +import System.IO.PlafCompat +import System.Log.Logger +import Imprevu.Evaluation + +-- | add a new player +newPlayer :: PlayerNumber -> PlayerSettings -> StateT Session IO () +newPlayer uid ps = do + info uid $ "New player: " ++ (_pPlayerName ps) + s <- get + --void $ A.update' (acidAuth $ _profiles s) (SetDefaultSessionTimeout $ 3600 * 24 * 7 *25) + void $ A.update' (_acidProfiles s) (NewProfileData uid ps (_mLibrary $ _multi s)) + +-- | starts a new game +newGame :: GameName -> GameDesc -> PlayerNumber -> Bool -> StateT Session IO () +newGame name desc pn isPublic = zoom multi $ newGame' name desc pn isPublic + +newGame' :: GameName -> GameDesc -> PlayerNumber -> Bool -> StateT Multi IO () +newGame' name desc pn isPublic = do + gs <- use gameInfos + if not $ any ((== name) . view gameNameLens) gs then do + info pn $ " creating a new game with name: " ++ name + t <- lift T.getCurrentTime + -- create a game with zero players + lg <- lift $ initialGameInfo name desc isPublic (Just pn) t + void $ gameInfos %= (lg : ) + else warn pn $ "this name is already used" + +forkGame :: GameName -> GameName -> GameDesc -> Bool -> PlayerNumber -> StateT Session IO () +forkGame fromgn newgn desc isPublic pn = zoom multi $ do + gms <- use gameInfos + case filter ((== fromgn) . view gameNameLens) gms of + [gi] -> do + info pn $ "Forking game: " ++ fromgn + time <- liftIO T.getCurrentTime + let lg = ((game . gameName) .~ newgn) . + ((game . gameDesc) .~ desc) $ _loggedGame gi + let gi' = GameInfo { + _loggedGame = lg, + _ownedBy = Just pn, + _forkedFromGame = Just fromgn, + _isPublic = isPublic, + _startedAt = time} + void $ gameInfos %= (gi' : ) + _ -> warn pn $ "Forking game: no game by that name: " ++ fromgn + +-- | join a game (also view it for conveniency) +joinGame :: GameName -> PlayerNumber -> StateT Session IO () +joinGame gn pn = do + info pn $ "joining game: " ++ gn + s <- get + name <- lift $ Nomyx.Core.Profile.getPlayerName pn s + inGameDo gn $ G.execGameEvent $ JoinGame pn name + +-- | delete a game. +delGame :: GameName -> StateT Session IO () +delGame gn = do + info 0 $ "deleting game: " ++ gn + zoom multi $ void $ gameInfos %= filter ((/= gn) . view gameNameLens) + +-- | leave a game. +leaveGame :: GameName -> PlayerNumber -> StateT Session IO () +leaveGame game pn = do + info pn $ "left game " ++ game + inGameDo game $ G.execGameEvent $ LeaveGame pn + +-- | insert a rule in pending rules. +submitRule :: RuleTemplate -> PlayerNumber -> GameName -> StateT Session IO () +submitRule rt pn gn = do + info pn $ "proposed " ++ show rt + compileOK <- compileRule rt pn gn Propose "Rule submitted OK! See \"Constitution\" or \"Actions\" tabs for actions." + when compileOK $ do + s <- get + liftIO $ sendMailsSubmitRule s rt pn gn + +adminSubmitRule :: RuleTemplate -> PlayerNumber -> GameName -> StateT Session IO () +adminSubmitRule rt pn gn = do + info pn $ "admin proposed " ++ show rt + void $ compileRule rt pn gn SystemAdd "Admin rule submitted OK!" + +checkRule :: RuleTemplate -> PlayerNumber -> GameName -> StateT Session IO () +checkRule rt pn gn = do + info pn $ "check rule " ++ show rt + void $ compileRule rt pn gn Check "Rule compiled OK. Now you can submit it!" + +compileRule :: RuleTemplate -> PlayerNumber -> GameName -> RuleEv -> String -> StateT Session IO Bool +compileRule rt pn gn re msg = do + mods <- getModules pn rt + mrr <- liftIO $ interpretRule (_rRuleCode rt) mods + case mrr of + Right r -> do + info pn "proposed rule compiled OK " + inGameDo gn $ G.execGameEvent' (Just r) (ProposeRuleEv re pn rt mods) + modifyProfile pn (pLastRule .~ Just (rt, msg)) + return True + Left e -> do + let errorMsg = showInterpreterError e + submitRuleError rt pn gn errorMsg + return False + +getModules :: PlayerNumber -> RuleTemplate -> StateT Session IO [ModuleInfo] +getModules pn rt = do + s <- get + prof <- fromJust <$> getProfile s pn + let mods = _mModules $ _pLibrary prof + return $ catMaybes $ map (getModule mods) (_rDeclarations rt) + +getModule :: [ModuleInfo] -> FilePath -> Maybe ModuleInfo +getModule ms fp = listToMaybe $ filter (\(ModuleInfo fp' _) -> (fp==fp')) ms + +newModule :: PlayerNumber -> ModuleInfo -> StateT Session IO () +newModule pn modi = do + info pn " inserted new module" + modifyProfile pn $ (pLibrary . mModules) %~ (addModule modi) + +addModule :: ModuleInfo -> [ModuleInfo] -> [ModuleInfo] +addModule mi mis = case (find (\mi' -> (_modPath mi) == (_modPath mi'))) mis of + (Just mi') -> replace mi' mi mis + Nothing -> mi:mis + +submitRuleError :: RuleTemplate -> PlayerNumber -> GameName -> String -> StateT Session IO () +submitRuleError sr pn gn errorMsg = do + inGameDo gn $ execGameEvent $ GLog (Just pn) ("Error in submitted rule: " ++ errorMsg) + warn pn ("Error in submitted rule: " ++ errorMsg) + modifyProfile pn (pLastRule .~ Just (sr, errorMsg)) + +newRuleTemplate :: PlayerNumber -> RuleTemplate -> StateT Session IO () +newRuleTemplate pn rt = do + info pn " inserted new template" + modifyProfile pn $ (pLibrary . mTemplates) %~ (addRuleTemplate rt) + +updateLibrary :: PlayerNumber -> Library -> StateT Session IO () +updateLibrary pn lib = do + info pn " updated library" + modifyProfile pn $ pLibrary .~ lib + +addRuleTemplate :: RuleTemplate -> [RuleTemplate] -> [RuleTemplate] +addRuleTemplate rt rts = case (find (\rt' -> (_rName rt) == (_rName rt'))) rts of + (Just rt') -> replace rt' rt rts + Nothing -> rt:rts + +delRuleTemplate :: RuleName -> PlayerNumber -> StateT Session IO () +delRuleTemplate rn pn = do + info pn $ "del template " ++ show rn + modifyProfile pn $ (pLibrary . mTemplates) %~ filter (\rt -> _rName rt /= rn) + +inputResult :: PlayerNumber -> EventNumber -> Input -> InputData -> GameName -> StateT Session IO () +inputResult pn en is id gn = inGameDo gn $ execGameEvent $ InputResult pn en is id + +applyTimeEvent :: UTCTime -> Game -> StateT Session IO () +applyTimeEvent t g = do + let ts = G.getTimeEvents t g + when (not $ null ts) $ debug 0 "Time event found" + mapM_ (\t -> inGameDo (_gameName g) $ execGameEvent $ TimeEvent t) ts + + +-- | 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 + info pn $ unwords ["playing as ", show playAs, "in game" ++ g] + pls <- use (game . players) + case find ((== pn) . view playerNumber) pls of + Nothing -> warn pn "player not in game" + Just pi -> (game . players) .= replaceWith ((== pn) . view playerNumber) (pi {_playingAs = playAs}) pls + +adminPass :: String -> PlayerNumber -> StateT Session IO () +adminPass pass pn = do + s <- get + if pass == (_adminPassword $ _mSettings $ _multi s) then do + info pn "getting admin rights" + modifyProfile pn $ pIsAdmin .~ True + else do + warn pn "submitted wrong admin password" + modifyProfile pn $ pIsAdmin .~ False + +globalSettings :: Bool -> StateT Session IO () +globalSettings mails = (multi . mSettings . mailSettings . sendMails) .= mails + +-- | Utility functions + +getNewPlayerNumber :: StateT Session IO PlayerNumber +getNewPlayerNumber = do + s <- get + pfd <- A.query' (_acidProfiles s) AskProfileDataNumber + return $ pfd + 1 + +-- | this function apply the given game actions to the game the player is in. +inAllGamesDo :: StateT LoggedGame IO a -> StateT Session IO () +inAllGamesDo action = do + t <- lift T.getCurrentTime + gis <- use (multi . gameInfos) + forM_ gis $ \gi -> do + (_, mylg) <- lift $ runStateT action (set (game . currentTime) t (_loggedGame gi)) + zoom multi $ modifyGame (gi {_loggedGame = mylg}) + +inGameDo :: GameName -> StateT LoggedGame IO () -> StateT Session IO () +inGameDo gn action = zoom multi $ do + (gs :: [GameInfo]) <- use gameInfos + case find ((==gn) . view gameNameLens) gs of + Nothing -> warn 0 "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 + let delay = _watchdog $ _mSettings $ _multi s + ms <- evalWithWatchdog delay s (evalSession sm) + case ms of + Just s' -> do + atomically $ writeTVar ts s' + save $ _multi s + Nothing -> warn 0 "thread timed out, session 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' + +warn, info :: (MonadIO m) => Int -> String -> m () +info pn s = liftIO $ infoM "Nomyx.Core.Session" ("Player " ++ (show pn) ++ " " ++ s) +warn pn s = liftIO $ warningM "Nomyx.Core.Session" ("Player " ++ (show pn) ++ " " ++ s) +debug pn s = liftIO $ debugM "Nomyx.Core.Session" ("Player " ++ (show pn) ++ " " ++ s) diff --git a/src/Nomyx/Core/Test.hs b/src/Nomyx/Core/Test.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Test.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} + +-- | Test module +module Nomyx.Core.Test where + +import Control.Monad.State +import Control.Exception as E +import Control.Lens +import Language.Haskell.TH hiding (ModuleInfo) +import Language.Haskell.TH.Syntax as THS hiding (lift, Module, ModuleInfo) +import System.IO.Unsafe +import Data.List +import Data.Maybe +import qualified Data.Text.IO as DT +import Data.Acid +import Data.Acid.Memory +import Data.Time hiding (getCurrentTime) +import Paths_nomyx_core as PNC +import System.IO.Temp +import System.FilePath (()) +import System.Directory (createDirectoryIfMissing) +import Nomyx.Language hiding (getCurrentTime) +import Nomyx.Core.Types +import Nomyx.Core.Multi +import Nomyx.Core.Session +import Nomyx.Core.Utils +import Nomyx.Core.Profile +import Nomyx.Core.Quotes +import Nomyx.Core.Engine +import qualified Nomyx.Core.Engine as G +import Imprevu.Evaluation + + +playTests :: Maybe String -> Int -> IO [(String, Bool)] +playTests mTestName delay = do + tests <- case mTestName of + Just testName -> do + let tsts = fatalTests ++ regularTests + return $ maybeToList $ find (\(name, _, _) -> name == testName) tsts + Nothing -> return regularTests + tp <- testProfiles + let session = Session (defaultMulti Settings {_net = defaultNetwork, _mailSettings = (MailSettings False "" "" ""), _adminPassword = "", _saveDir = "", _webDir = "", _sourceDir = "", _watchdog = delay} + (Library [rAutoActivate] + [])) tp + mapM (\(title, t, cond) -> (title,) <$> test title session t cond) tests + +defaultNetwork :: Network +defaultNetwork = Network "" 0 + +-- | 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), + ("Partial Function 1", gamePartialFunction1, condPartialFunction), + ("Partial Function 2", gamePartialFunction2, condPartialFunction), + ("Partial Function 3", gamePartialFunction3, condPartialFunction3), + ("Test file 1", testFile1, condNRules 2), + ("Test file 2", testFile2, condNRules 2), + ("Test import Data.Time", testFileTime, condNRules 2), + ("load file twice 2", testFileTwice', condNRules 3), + ("load file unsafe", testFileUnsafeIO, condNRules 1)] ++ + map (\i -> ("Loop" ++ show i, loops !! (i-1), condNoGame)) [1..(length loops)] ++ + map (\i -> ("Forbidden" ++ show i, forbiddens !! (i-1), condNRules 1)) [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 + let delay = _watchdog $ _mSettings $ _multi s + ms <- evalWithWatchdog delay 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, session discarded" + return $ _multi s + +testException :: Multi -> SomeException -> IO Multi +testException m e = do + putStrLn $ "Test Exception: " ++ show e + return m + +testProfiles :: IO (AcidState ProfileDataState) +testProfiles = openMemoryState initialProfileDataState + +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 = Nothing, _mailNewInput = False, _mailSubmitRule = False, _mailNewOutput = False, _mailConfirmed = False} + newGame "test" (GameDesc "" "") 1 True + joinGame "test" 1 + +twoPlayersOneGame :: StateT Session IO () +twoPlayersOneGame = do + onePlayerOneGame + newPlayer 2 PlayerSettings {_pPlayerName = "Player 2", _mail = Nothing, _mailNewInput = False, _mailSubmitRule = False, _mailNewOutput = False, _mailConfirmed = False} + joinGame "test" 2 + +submitR :: String -> StateT Session IO () +submitR r = do + onePlayerOneGame + submitRule (RuleTemplate "" "" r "" Nothing [] []) 1 "test" + +testFile' :: FilePath -> FilePath -> String -> StateT Session IO () +testFile' path name func = do + dataDir <- lift PNC.getDataDir + cont <- liftIO $ DT.readFile (dataDir testDir path) + updateLibrary 1 (Library [] [ModuleInfo name cont]) + submitRule (RuleTemplate "" "" func "" Nothing [] [name]) 1 "test" + +testFile :: FilePath -> String -> StateT Session IO () +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 + submitRule (RuleTemplate "" "" [cr|helloWorld|] "" Nothing [] []) 1 "test" + +condHelloWorld2Players :: Multi -> Bool +condHelloWorld2Players = isOutput' "hello, world!" + +condMoneyTransfer :: Multi -> Bool +condMoneyTransfer m = (_vName $ head $ _variables $ firstGame m) == "Accounts" + +-- ** Partial functions + +partialFunction1 :: String +partialFunction1 = [cr|void $ readVar_ (V "toto1" :: V String)|] + +partialFunction2 :: String +partialFunction2 = [cr|void $ do + t <- getCurrentTime + onEventOnce (timeEvent $ addUTCTime 5 t) $ const $ readVar_ (V "toto2")|] + +gamePartialFunction1 :: StateT Session IO () +gamePartialFunction1 = submitR partialFunction1 + +gamePartialFunction2 :: StateT Session IO () +gamePartialFunction2 = do + onePlayerOneGame + submitR partialFunction2 + gs <- (use $ multi . gameInfos) + let now = _currentTime $ G._game $ _loggedGame $ head gs + return () +-- zoom multi $ Nomyx.Core.Multi.triggerTimeEvent (5 `addUTCTime` now) +-- triggerTimeEvent defaultEvalConf) (EvalState g 0) ts + +-- 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_ (ruleEvent Proposed) $ const $ readVar_ (V "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) == 3 + +-- * 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 + 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 + testFile "SimpleModule.hs" "SimpleModule.myRule" + + +--module that imports Data.Time (should be Safe in recent versions) +testFileTime :: StateT Session IO () +testFileTime = do + onePlayerOneGame + testFile "TestTime.hs" "TestTime.myRule" + +--loading two modules with the same name is forbidden +testFileTwice :: StateT Session IO () +testFileTwice = do + onePlayerOneGame + testFile "SimpleModule.hs" "SimpleModule.myRule" + 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 + testFile "SimpleModule.hs" "SimpleModule.myRule" + testFile "SimpleModule2.hs" "SimpleModule2.myRule" + +--security: no unsafe module imports +testFileUnsafeIO :: StateT Session IO () +testFileUnsafeIO = do + onePlayerOneGame + 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) + +firstGame :: Multi -> Game +firstGame = G._game . _loggedGame . head . _gameInfos diff --git a/src/Nomyx/Core/Types.hs b/src/Nomyx/Core/Types.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Types.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Nomyx.Core.Types ( + module Nomyx.Core.Types, + module Nomyx.Core.Engine.Types) + where + +import Control.Lens hiding (Indexable) +import Data.Acid (AcidState) +import Data.Aeson.TH (defaultOptions, deriveJSON) +import Data.Data (Data) +import Data.IxSet (ixFun, ixSet, Indexable(..), IxSet) +import Data.SafeCopy (base, deriveSafeCopy) +import Data.Time +import Data.List +import Data.Typeable +import Data.Aeson +import GHC.Generics (Generic) +import Network.BSD +import Nomyx.Language +import Nomyx.Core.Engine +import Nomyx.Core.Engine.Types + +type PlayerPassword = String +type Port = Int +type CompileError = String +type LastRule = (RuleTemplate, String) + +-- * Game structures + +-- | Session contains all the game informations. +data Session = Session { _multi :: Multi, + _acidProfiles :: AcidState ProfileDataState} + +instance Show Session where + show (Session m _) = show m + +-- | A structure to hold the active games and players +data Multi = Multi { _gameInfos :: [GameInfo], + _mSettings :: Settings, + _mLibrary :: Library} + deriving (Eq, Show, Typeable) + +-- | Informations on a particular game +data GameInfo = GameInfo { _loggedGame :: LoggedGame, + _ownedBy :: Maybe PlayerNumber, + _forkedFromGame :: Maybe GameName, + _isPublic :: Bool, + _startedAt :: UTCTime} + deriving (Typeable, Show, Eq) + +-- | Global settings +data Settings = Settings { _net :: Network, -- URL where the server is launched + _mailSettings :: MailSettings, -- 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) + _watchdog :: Int} -- time in seconds before killing the compilation thread + deriving (Eq, Show, Read, Typeable) + +-- | Network infos +data Network = Network {_host :: HostName, + _port :: Port} + deriving (Eq, Show, Read, Typeable) + +data MailSettings = MailSettings {_sendMails :: Bool, + _mailHost :: String, + _mailLogin :: String, + _mailPass :: String} + deriving (Eq, Show, Read, Typeable) + +-- | The Library contains a list of rule templates together with their declarations +data Library = Library { _mTemplates :: [RuleTemplate], + _mModules :: [ModuleInfo]} + deriving (Eq, Ord, Typeable) + +instance Show Library where + show (Library ts ms) = "\n\n Library Templates = " ++ (intercalate "\n " $ map show ts) ++ + "\n\n Library Modules = " ++ (intercalate "\n " $ map show ms) + + +-- * Player settings + +data ProfileDataState = ProfileDataState { profilesData :: IxSet ProfileData } + deriving (Eq, Ord, Show, Typeable) + +-- | 'ProfileData' contains player settings +data ProfileData = + ProfileData { _pPlayerNumber :: PlayerNumber, -- same as UserId + _pPlayerSettings :: PlayerSettings, + _pLastRule :: Maybe LastRule, + _pLastUpload :: LastUpload, + _pIsAdmin :: Bool, + _pLibrary :: Library} + deriving (Eq, Ord, Show, Typeable, Generic) + +instance Indexable ProfileData where + empty = ixSet [ ixFun (\(ProfileData pn _ _ _ _ _) -> [pn])] + +-- Settings of a single player +data PlayerSettings = + PlayerSettings { _pPlayerName :: PlayerName, + _mail :: Maybe String, + _mailNewInput :: Bool, + _mailSubmitRule :: Bool, + _mailNewOutput :: Bool, + _mailConfirmed :: Bool} + deriving (Eq, Show, Read, Data, Ord, Typeable, Generic) + +data LastUpload = NoUpload + | UploadSuccess + | UploadFailure (FilePath, CompileError) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + + +$(deriveSafeCopy 1 'base ''LastUpload) +$(deriveSafeCopy 1 'base ''PlayerSettings) +$(deriveSafeCopy 1 'base ''ProfileData) +$(deriveSafeCopy 1 'base ''RuleTemplate) +$(deriveSafeCopy 1 'base ''ModuleInfo) +$(deriveSafeCopy 1 'base ''ProfileDataState) +$(deriveSafeCopy 1 'base ''Library) + +makeLenses ''Multi +makeLenses ''Library +makeLenses ''ModuleInfo +makeLenses ''GameInfo +makeLenses ''Settings +makeLenses ''Network +makeLenses ''PlayerSettings +makeLenses ''Session +makeLenses ''ProfileData +makeLenses ''MailSettings + +$(deriveJSON defaultOptions ''Library) +$(deriveJSON defaultOptions ''GameInfo) +$(deriveJSON defaultOptions ''Multi) +$(deriveJSON defaultOptions ''Settings) +$(deriveJSON defaultOptions ''Network) +$(deriveJSON defaultOptions ''LastUpload) +$(deriveJSON defaultOptions ''PlayerSettings) +$(deriveJSON defaultOptions ''ProfileData) +$(deriveJSON defaultOptions ''RuleInfo) +$(deriveJSON defaultOptions ''RuleStatus) +$(deriveJSON defaultOptions ''MailSettings) + + +instance ToJSON Rule where + toJSON _ = object [] + +instance FromJSON Rule where + parseJSON (Object _) = error "FromJSON" + diff --git a/src/Nomyx/Core/Utils.hs b/src/Nomyx/Core/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Core/Utils.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE CPP #-} + +module Nomyx.Core.Utils where + +import Codec.Archive.Tar as Tar +import System.FilePath +import System.IO.Temp +import Control.Concurrent +import Control.DeepSeq +import Control.Exception +import Control.Lens +import Control.Monad.State +import Data.Maybe +import Nomyx.Core.Engine +import Nomyx.Core.Types +import System.IO +import System.IO.PlafCompat +import Data.List + +saveFile, profilesDir, uploadDir, testDir, authDir, tarFile :: FilePath +saveFile = "Nomyx.save" +profilesDir = "profiles" +uploadDir = "uploads" +testDir = "test" +authDir = "authenticate" +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 h p) = "http://" ++ h ++ ":" ++ show p + +getSaveFile :: Settings -> FilePath +getSaveFile s = _saveDir s 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 + +getRegularFiles :: FilePath -> [FilePath] -> IO [FilePath] +getRegularFiles dir fps = filterM (getFileStatus . (\f -> dir f) >=> return . isRegularFile) fps + +-- The setMode function is only used during module loading. In Windows, +-- a copied file automatically inherits permissions based on the containing +-- folder's ACLs an the user account being used. +#ifdef WINDOWS + +setMode :: FilePath -> IO() +setMode _ = return () + +#else + +setMode :: FilePath -> IO() +setMode file = setFileMode file (ownerModes + groupModes) + +#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 => Int -> a -> (a -> IO b) -> IO (Maybe b) +evalWithWatchdog delay s f = do + mvar <- newEmptyMVar + hSetBuffering stdout NoBuffering + --start evaluation thread + id <- forkIO $ do + s' <- f s + s'' <- evaluate s' + writeFile nullFileName $ show s'' + putMVar mvar (Just s'') + --start watchdog thread + forkIO $ watchDog delay id mvar + takeMVar mvar + +evalWithWatchdog' :: NFData a => IO a -> IO (Maybe a) +evalWithWatchdog' s = do + mvar <- newEmptyMVar + hSetBuffering stdout NoBuffering + --start evaluation thread + id <- forkIO $ do + s' <- s + let s'' = force s' + putMVar mvar (Just s'') + --start watchdog thread + forkIO $ watchDog 5 id mvar + takeMVar mvar + + +-- | Fork off a thread which will sleep n seconds and then kill off the specified thread. +watchDog :: Int -> ThreadId -> MVar (Maybe a) -> IO () +watchDog n tid mvar = do + threadDelay (n * 1000000) + killThread tid + threadDelay 1000000 --give some time to kill the thread + putMVar mvar Nothing + +gameNameLens :: Lens' GameInfo GameName +gameNameLens = loggedGame . game . gameName + +getGameByName :: GameName -> Session -> Maybe GameInfo +getGameByName gn s = find ((==gn) . view (loggedGame . game . gameName)) (_gameInfos $ _multi s) diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,45 @@ +module Test where + +import Nomyx.Core.Engine.Test +import Distribution.TestSuite + +tests :: IO [Test] +tests = return [ + test testVarEx1 "test var 1", + test testVarEx2 "test var 2", + test testVarEx3 "test var 3", + test testVarEx4 "test var 4", + test testVarEx5 "test var 5", + test testActivateRuleEx "test activate rule", + test testAutoActivateEx "test auto activate", + test testDeleteRuleEx1 "test delete rule", + test testVictoryEx1 "test victory rule", + test testVoteAssessOnVoteComplete1 "test assess on vote complete 1", + test testVoteAssessOnVoteComplete2 "test assess on vote complete 2", + test testVoteAssessOnEveryVote1 "test assess on every vote 1", + test testVoteAssessOnEveryVote2 "test assess on every vote 2", + test testVoteAssessOnEveryVote3 "test assess on every vote 3", + test testVoteAssessOnEveryVote4 "test assess on every vote 4", + test testVoteMajorityWith "test majority with", + test testVoteNumberPositiveVotes "test number positive votes", + test testVoteWithQuorum1 "test vote with quorum 1", + test testVoteAssessOnTimeLimit1 "test assess on time limit 1", + test testVoteAssessOnTimeLimit2 "test assess on time limit 2", + test testVoteAssessOnTimeLimit3 "test assess on time limit 3", + test testVoteAssessOnTimeLimit4 "test assess on time limit 4", + test testVoteAssessOnTimeLimit5 "test assess on time limit 5", + test testVotePlayerArriveEx "test vote player arrives", + test testVotePlayerLeaveEx "test vote player leaves"] + +test :: Bool -> String -> Test +test p t = Test $ test' p t + +test' :: Bool -> String -> TestInstance +test' p t = TestInstance + { run = return $ Finished $ if p then Pass else Fail "" + , name = t + , tags = [] + , options = [] + , setOption = \_ _ -> Right $ test' p t + } +