nomyx-core (empty) → 1.0.0

raw patch · 30 files changed

+2978/−0 lines, 30 filesdep +Cabaldep +DebugTraceHelpersdep +HaskellNetsetup-changed

Dependencies added: Cabal, DebugTraceHelpers, HaskellNet, HaskellNet-SSL, MissingH, NoTrace, acid-state, aeson, base, blaze-html, blaze-markup, bytestring, deepseq, directory, either-unwrap, exceptions, filepath, hint, hint-server, hscolour, hslogger, imprevu, ixset, lens, mime-mail, mtl, network, nomyx-core, nomyx-language, nomyx-library, old-locale, random, safe, safecopy, shortcut, stm, tar, template-haskell, temporary, text, time, unix, yaml

Files

• AUTHORS +1/−0
• LICENSE +27/−0
• README.md +6/−0
• Setup.lhs +6/−0
• TODO +0/−0
• data/test/SimpleModule.hs +12/−0
• data/test/SimpleModule2.hs +9/−0
• data/test/TestTime.hs +13/−0
• data/test/UnsafeIO.hs +10/−0
• data/test/more/SimpleModule.hs +12/−0
• nomyx-core.cabal +99/−0
• src/Data/Todo.hs +43/−0
• src/Nomyx/Core/Engine.hs +58/−0
• src/Nomyx/Core/Engine/Context.hs +76/−0
• src/Nomyx/Core/Engine/Evaluation.hs +384/−0
• src/Nomyx/Core/Engine/GameEvents.hs +167/−0
• src/Nomyx/Core/Engine/Interpret.hs +147/−0
• src/Nomyx/Core/Engine/Test.hs +278/−0
• src/Nomyx/Core/Engine/Types.hs +218/−0
• src/Nomyx/Core/Engine/Utils.hs +85/−0
• src/Nomyx/Core/Mail.hs +100/−0
• src/Nomyx/Core/Multi.hs +61/−0
• src/Nomyx/Core/Profile.hs +142/−0
• src/Nomyx/Core/Quotes.hs +43/−0
• src/Nomyx/Core/Serialize.hs +83/−0
• src/Nomyx/Core/Session.hs +285/−0
• src/Nomyx/Core/Test.hs +284/−0
• src/Nomyx/Core/Types.hs +159/−0
• src/Nomyx/Core/Utils.hs +125/−0
• test/Test.hs +45/−0

@@ -0,0 +1,1 @@+Corentin Dupont <corentin.dupontDELAVEGAgmail.com> (remove DELAVEGA to obtain my email)

@@ -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.

@@ -0,0 +1,6 @@++Nomyx-Core+=========++Library holding the core processes of Nomyx.+

@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell 
+> module Main where
+> import Distribution.Simple
+> main :: IO ()
+> main = defaultMain
+

@@ -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"

@@ -0,0 +1,9 @@++module SimpleModule2 where++import Prelude+import Nomyx.Language+import Control.Monad++myRule :: Rule+myRule = void $ outputAll_ "Hello"

@@ -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"

@@ -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"

@@ -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"

@@ -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

@@ -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

@@ -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

@@ -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")]

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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'

@@ -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)

@@ -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+++

@@ -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+   

@@ -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)

@@ -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

@@ -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"+

@@ -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)

@@ -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+   }+