Nomyx 0.0.3 → 0.1.0

raw patch · 24 files changed

+1767/−937 lines, 24 filesdep +acid-statedep +data-accessor-transformersdep +mime-maildep ~Nomyx-Rules

Dependencies added: acid-state, data-accessor-transformers, mime-mail, template-haskell

Dependency ranges changed: Nomyx-Rules

Files

• Nomyx.cabal +19/−17
• TODO +12/−10
• data/static/css/nomyx.css +2/−4
• src/Commands.hs +3/−3
• src/Forms.hs +0/−83
• src/Game.hs +31/−43
• src/Help.hs +0/−23
• src/Interpret.hs +20/−21
• src/Mail.hs +65/−0
• src/Main.hs +126/−39
• src/Multi.hs +149/−183
• src/Quotes.hs +40/−0
• src/Serialize.hs +83/−0
• src/Test.hs +174/−0
• src/Types.hs +91/−0
• src/Utils.hs +80/−9
• src/Web.hs +0/−502
• src/Web/Common.hs +133/−0
• src/Web/Game.hs +259/−0
• src/Web/Help.hs +23/−0
• src/Web/Login.hs +133/−0
• src/Web/MainPage.hs +208/−0
• src/Web/NewGame.hs +52/−0
• src/Web/Settings.hs +64/−0

@@ -1,5 +1,5 @@ name: Nomyx-version: 0.0.3+version: 0.1.0 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -18,22 +18,24 @@   executable Nomyx     build-depends: DebugTraceHelpers -any, MonadCatchIO-mtl -any,-                   Nomyx-Rules ==0.0.3, QuickCheck -any, base <5, binary -any,-                   blaze-html ==0.5.*, blaze-markup -any, bytestring -any,-                   containers -any, directory -any, eprocess -any,-                   extensible-exceptions -any, filepath -any, happstack-server ==7.*,-                   hdaemonize -any, hint -any, hint-server -any, hslogger -any,-                   monad-loops -any, mtl ==2.*, mueval -any, network -any,-                   process -any, reform -any, reform-blaze -any,-                   reform-happstack -any, regular -any, safe -any, stm -any,-                   text -any, time -any, unix -any, utf8-string -any,-                   web-routes ==0.27.*, web-routes-happstack ==0.23.*,-                   web-routes-regular ==0.19.*, web-routes-th -any+                   Nomyx-Rules ==0.1.0, QuickCheck -any, acid-state -any, base <5,+                   binary -any, blaze-html ==0.5.*, blaze-markup -any,+                   bytestring -any, containers -any, data-accessor-transformers -any,+                   directory -any, eprocess -any, extensible-exceptions -any,+                   filepath -any, happstack-server ==7.*, hdaemonize -any, hint -any,+                   hint-server -any, hslogger -any, mime-mail -any, monad-loops -any,+                   mtl ==2.*, mueval -any, network -any, process -any, reform -any,+                   reform-blaze -any, reform-happstack -any, regular -any, safe -any,+                   stm -any, template-haskell -any, text -any, time -any, unix -any,+                   utf8-string -any, web-routes ==0.27.*,+                   web-routes-happstack ==0.23.*, web-routes-regular ==0.19.*,+                   web-routes-th -any     main-is: Main.hs     buildable: True     extensions: CPP-    hs-source-dirs: src -    other-modules: Help Game Forms Multi Server Utils Interpret Web-                   Commands-    ghc-options: -W- +    hs-source-dirs: src+    other-modules: Quotes Types Mail Game Test Multi Server Serialize+                   Utils Interpret Commands Web.Common Web.Help Web.Game Web.Login+                   Web.Settings Web.MainPage Web.NewGame+    ghc-options: -W +    -- no-omit-yield

@@ -4,28 +4,30 @@ Features to add:
 
 - interpreter (like tryhaskell.org) on the web page to debug rules
-- store state in DB
 - make a command line client
-- make a clear login/session system
+- make a session system with cookie
 - colorize code
 - make code instructions in the active rules table clickable to access haddock documentation
-- mail server to send notices/events when other players played.
 
+
 Improves:
 
 - refresh web page when new event (currently, player needs to hit F5)
-- keep the rule in the field if compile error
 - input sanitization and error reporting
-- avoid unrecoverable "error" in variables
-- add tests in main Nomyx
 - secure interpreter with mueval: time limits, no unsafe instructions, memory limits...
+- add a name to events to be able to delete categories of them
+- add "back to main page" links
+- recognize array vars to display them properly on HCI
+- add command to rm save file
 
 Futur Nomic:
 - ability to analyse rules, proof system
 
 BUGS
-- fix moneyTransfer: accept new players, check balance is positive
 - fix rule number for variables
-- schedule: drop 1 is wrong, protect head
-- time events: some events are triggered 2 times
-- self proposed victory not working
+- check when error on parameters (for victory for example)
+- concurrent access to log file
+- sendmail is blocking the game
+- delete invalid events
+- events may be triggered twice if not deleted (in case of exception)
+

@@ -121,11 +121,9 @@ }  -#code {+.code {    width:100%;-   height:150px;-   rows:20;-   cols:80;+  /* height:150px;*/ }  input[type="file"]{

@@ -1,8 +1,8 @@ - -- | This module handles intrepreting players' commands.+-- DEPRECATED module Commands where-{-+ import Text.ParserCombinators.Parsec import Data.List import Utils@@ -13,7 +13,7 @@ -- | All commands issuable.
 data Command = ListGame
 --             | Name
-			    | NewGame
+             | NewGame
              | JoinGame              | LeaveGame              | SubscribeGame

@@ -1,83 +0,0 @@--{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, TemplateHaskell,-   EmptyDataDecls, TypeFamilies, MultiParamTypeClasses, DeriveDataTypeable, PackageImports, GADTs,-   ScopedTypeVariables, NamedFieldPuns, Rank2Types, DoAndIfThenElse, ExtendedDefaultRules#-}----module Forms where--import Prelude hiding (div)-import Text.Blaze.Html5 hiding (map, label)-import qualified Text.Blaze.Html5.Attributes as A-import Text.Reform-import Text.Reform.Blaze.String hiding (form)-import Happstack.Server-import Multi-import Language.Nomyx.Expression-import qualified Data.ByteString.Char8 as C-import Text.Blaze.Html.Renderer.Utf8 (renderHtml)-import Control.Applicative-import Data.Text hiding (map, zip, concatMap)-import Data.List-import Data.Maybe-import Text.Reform.Happstack()-import qualified Text.Reform.Generalized as G-import qualified Text.Blaze.Html5  as H-default (Integer, Double, Data.Text.Text)--data LoginPass = LoginPass { login :: PlayerName,-                             password :: PlayerPassword}-                             deriving (Show, Eq)--data NewRuleForm = NewRuleForm { ruleName :: String,-                         ruleText :: String,-                         ruleCode :: String,-                         pn :: PlayerNumber }--data NewGameForm = NewGameForm { newGameName :: String,-                                 gamePn :: PlayerNumber }--type NomyxForm a = Form (ServerPartT IO) [Input] String Html () a--instance FormError String where-    type ErrorInputType String = [Input]-    commonFormError _ = "common error"---loginForm :: NomyxForm LoginPass-loginForm = pure LoginPass <*> label "Login: " ++> (inputText "") <*> label "    Password: " ++> (inputText "") <++ label " "--inputChoiceForm :: String -> [String] -> String -> NomyxForm Int-inputChoiceForm title choices def = label (title ++ " ") ++> inputRadio' (zip [0..] choices) ((==) $ fromJust $ elemIndex def choices)--inputStringForm :: String -> NomyxForm String-inputStringForm title = label (title ++ " ") ++> inputText ""--uploadForm :: NomyxForm (FilePath, FilePath, ContentType)-uploadForm = inputFile--blazeResponse :: Html -> Response-blazeResponse html = toResponseBS (C.pack "text/html;charset=UTF-8") $ renderHtml html--blazeForm :: Html -> Text -> Html-blazeForm html link =-    form ! A.action (toValue link)-         ! A.method "POST"-         ! A.enctype "multipart/form-data" $-            do html-               input ! A.type_ "submit" ! A.value "Submit"---- | Create a group of radio elements without BR between elements-inputRadio' :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, ToMarkup lbl) =>-              [(a, lbl)]  -- ^ value, label, initially checked-           -> (a -> Bool) -- ^ isDefault-           -> Form m input error Html () a-inputRadio' choices isDefault =-    G.inputChoice isDefault choices mkRadios-    where-      mkRadios nm choices' = mconcat $ concatMap (mkRadio nm) choices'-      mkRadio nm (i, val, lbl, checked) =-          [ ((if checked then (! A.checked "checked") else id) $-             input ! A.type_ "radio" ! A.id (toValue i) ! A.name (toValue nm) ! A.value (toValue val))-          ,  H.label ! A.for (toValue i) $ toHtml lbl]

@@ -14,33 +14,21 @@ import Data.List import Language.Nomyx.Expression import Language.Nomyx.Evaluation-import Examples-import Data.Time.Clock as T-+import Language.Nomyx.Examples  -- | the initial rule set for a game.-rApplicationMetaRule = Rule  {-    rNumber       = 1,-    rName         = "Evaluate rule using meta-rules",-    rDescription  = "a proposed rule will be activated if all active metarules return true",-    rProposedBy   = 0,-    rRuleCode     = "applicationMetaRule",-    rRuleFunc     = applicationMetaRule,-    rStatus       = Active,-    rAssessedBy   = Nothing}- rVoteUnanimity = Rule  {-    rNumber       = 2,-    rName         = "Vote Unanimity",-    rDescription  = "meta-rule: return true if all players vote positively for a rule",+    rNumber       = 1,+    rName         = "Unanimity Vote",+    rDescription  = "A proposed rule will be activated if all players vote for it",     rProposedBy   = 0,-    rRuleCode     = "vote unanimity",-    rRuleFunc     = vote unanimity,+    rRuleCode     = "onRuleProposed $ voteWith unanimity",+    rRuleFunc     = onRuleProposed $ voteWith unanimity,     rStatus       = Active,     rAssessedBy   = Nothing}  rVictory5Rules = Rule  {-    rNumber       = 3,+    rNumber       = 2,     rName         = "Victory 5 accepted rules",     rDescription  = "Victory is achieved if you have 5 active rules",     rProposedBy   = 0,@@ -49,31 +37,38 @@     rStatus       = Active,     rAssessedBy   = Nothing} -emptyGame name date = Game { gameName      = name,-                          rules         = [],-                          players       = [],-                          variables     = [],-                          events        = [],-                          outputs       = [],-                          victory       = [],-                          currentTime   = date}+emptyGame name desc date = Game { gameName      = name,+                             gameDesc      = desc,+                             rules         = [],+                             players       = [],+                             variables     = [],+                             events        = [],+                             outputs       = [],+                             victory       = [],+                             currentTime   = date} ---initialGame :: Game-initialGame name date = flip execState (emptyGame name date) $ do+initialGame :: GameName -> String -> UTCTime -> Game+initialGame name desc date = flip execState (emptyGame name desc date) $ do     evAddRule rVoteUnanimity     evActivateRule (rNumber rVoteUnanimity) 0-    evAddRule rApplicationMetaRule-    evActivateRule (rNumber rApplicationMetaRule) 0     evAddRule rVictory5Rules     evActivateRule (rNumber rVictory5Rules) 0 +-- | the initial rule set for a game.+rApplicationMetaRule = Rule  {+    rNumber       = 0,+    rName         = "Evaluate rule using meta-rules",+    rDescription  = "a proposed rule will be activated if all active metarules return true",+    rProposedBy   = 0,+    rRuleCode     = "applicationMetaRule",+    rRuleFunc     = onRuleProposed checkWithMetarules,+    rStatus       = Active,+    rAssessedBy   = Nothing}  -- | An helper function to use the state transformer GameState.-execWithGame :: StateT Game IO () -> Game -> IO Game-execWithGame gs g = do-    t <- T.getCurrentTime-    let g' = g {currentTime = t}-    execStateT gs g'+-- It additionally sets the current time.+execWithGame :: UTCTime -> State Game () -> Game -> Game+execWithGame t gs g = execState gs g {currentTime = t}   --accessors@@ -86,13 +81,6 @@  rejectedRules :: Game -> [Rule] rejectedRules = sort . filter (\(Rule {rStatus=rs}) -> rs==Reject) . rules--instance Eq Game where-   (Game name1 _ _ _ _ _ _ _) == (Game name2 _ _ _ _ _ _ _) = name1 == name2--instance Ord Game where-   compare (Game name1 _ _ _ _ _ _ _) (Game name2 _ _ _ _ _ _ _) = compare name1 name2-  instance Ord PlayerInfo where    h <= g = (playerNumber h) <= (playerNumber g)

@@ -1,23 +0,0 @@------------------------------------------------------------------------------------ Module      :  Help--- Copyright   :--- License     :  OtherLicense------ Maintainer  :  corentin.dupont@gmail.com--- Stability   :--- Portability :------ |-----------------------------------------------------------------------------------module Help where-upload = "You can upload your file containing custom rules here. File must be a haskell .hs file containing a module. Once correctly loaded, you will be able to propose the functions in the file as new rules."-code = "This is where you type in your new rule. Its type must be \"RuleFunc\". As a first rule, you can try to type \"nothing\", which is a rule that does nothing. Other examples can be found in the file Examples.hs accessible on the left tab."-actives = "Those rules are active and control the game. Usually, initial rules define how to propose and activate new rules (for example, a democratic vote) and how to win. Of course, this can be changed!"-pendings = "Rules are pending after being proposed by a player. Only another, active rule can activate those rules with instruction \"activateRule\"."-inputs = "Rules can trigger an input to gather data from the player, for example with the instruction \"onInputChoice\"."-events = "Rules can register on events, in order to be triggered when the event happens, for example with the instruction \"onEvent\"."-variables = "Rules can create variables to store data. For example, a rule creating a bank account with instruction \"newVar\" will make a new variable appear here."-outputs = "Rules can display text on players screen, with instruction \"output\"."

@@ -1,5 +1,5 @@ -- | This module starts a Interpreter server that will read our strings representing rules to convert them to plain Rules.
-module Interpret(startInterpreter, readNamedRule, interpretRule, loadModule) where
+module Interpret where
 
 import Language.Haskell.Interpreter
 import Language.Haskell.Interpreter.Server
@@ -10,10 +10,12 @@ import System.FilePath import System.Posix.Files import Control.Monad-+import System.Posix.Resource  modDir = "modules"-
+importList = ["Prelude", "Language.Nomyx.Rule", "Language.Nomyx.Expression", "Language.Nomyx.Test",+              "Language.Nomyx.Examples", "GHC.Base", "Data.Maybe"]+              
 -- | the server handle
 startInterpreter :: IO ServerHandle
 startInterpreter = do
@@ -42,28 +44,25 @@    loadModules fmods    setTopLevelModules $ map (dropExtension . takeFileName) fmods    dataDir <- liftIO getDataDir-   set [searchPath := [dataDir]]
-   setImports ["Prelude", "Language.Nomyx.Rule", "Language.Nomyx.Expression", "Test", "Examples", "GHC.Base", "Data.Maybe"]+   set [searchPath := [dataDir], languageExtensions := [GADTs, ScopedTypeVariables]] --, languageExtensions := [], installedModulesInScope := False+   --TODO: get all exported modules of Nomyx library+   setImports importList    return ()
 
--- | reads maybe a Rule out of a string.
+---- | reads maybe a Rule out of a string.
 interpretRule :: String -> ServerHandle -> IO (Either InterpreterError RuleFunc)
-interpretRule s sh = do
-   liftIO $ runIn sh (interpret s (as :: RuleFunc))
-
-
--- | reads a Rule. May produce an error if badly formed.
-readRule :: String -> ServerHandle -> IO RuleFunc
-readRule sr sh = do
-   ir <- interpretRule sr sh
-   case ir of
-      Right r -> return r
-      Left e -> error $ "errReadRule: Rule is ill-formed. Shouldn't have happened.\n" ++ show e
+interpretRule s sh = liftIO $ runIn sh $ do+      liftIO $ mapM_ (uncurry setResourceLimit) limits+      interpret s (as :: RuleFunc)+      
+cpuTimeLimitSoft = ResourceLimit 4+cpuTimeLimitHard = ResourceLimit 5 
--- | reads a NamedRule. May produce an error if badly formed.
-readNamedRule :: Rule -> ServerHandle -> IO RuleFunc
-readNamedRule r sh = readRule (rRuleCode r) sh
 +limits :: [(Resource, ResourceLimits)]+limits = [ (ResourceCPUTime,      ResourceLimits cpuTimeLimitSoft cpuTimeLimitHard)]+         
+ -- | check an uploaded file and reload
 loadModule :: FilePath -> FilePath -> ServerHandle -> IO (Either InterpreterError ())
 loadModule dir name sh = do@@ -78,7 +77,7 @@             runIn sh $ initializeInterpreter             return $ Left e --- | check if a module is valid. Context will be reset.+---- | check if a module is valid. Context will be reset. checkModule :: FilePath -> ServerHandle -> IO (Either InterpreterError ()) checkModule dir sh = runIn sh $ do    fmods <- liftIO getUploadModules

@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules, OverloadedStrings, NamedFieldPuns#-}+++module Mail where++import Text.Blaze.Html5 hiding (map, label, br)+import qualified Text.Blaze.Html5 as H+import Text.Blaze.Html.Renderer.String+import Network.Mail.Mime hiding (mailTo)+import Prelude hiding (div)+import Text.Reform.Happstack()+import Control.Monad+import Types+import Language.Nomyx.Expression+import Data.Text(Text, pack)+import Control.Concurrent+import Data.Maybe+import Utils+import Control.Exception+import qualified Data.Text.Lazy as B+default (Integer, Double, Data.Text.Text)+++sendMail :: String -> String -> String -> IO()+sendMail to object body = do+   putStrLn $ "sending a mail to " ++ to+   forkIO $ simpleMail (Address Nothing (pack to)) (Address (Just "Nomyx Game") "corentin.dupont@gmail.com") (pack object) "" (B.pack body) [] >>= renderSendMail+   putStrLn $ "done"+   return ()++newRuleBody :: PlayerName -> SubmitRule -> PlayerName -> Network -> Html+newRuleBody playerName (SubmitRule name desc code) prop net = docTypeHtml $ do+   (toHtml $ "Dear " ++ playerName ++ ",") >> H.br+   (toHtml $ "a new rule has been proposed by player " ++ prop ++ ".") >> H.br+   (toHtml $ "Name: " ++ name) >> H.br+   (toHtml $ "Description: " ++ desc) >> H.br+   (toHtml $ "Code: " ++ 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++newRuleObject :: PlayerName -> String+newRuleObject name = "[Nomyx] New rule posted by player " ++ name ++ "!"++sendMailsNewRule :: Multi -> SubmitRule -> PlayerNumber -> IO()+sendMailsNewRule m sr pn = do+   evaluate m+   let gn = gameName $ fromJust $ getPlayersGame pn m+   let proposer = getPlayersName pn m+   forM_ (mPlayers m) $ send proposer gn+   where send prop gn pm = when ((Just gn == inGame pm) && (mailNewRule $ mMail pm)) $ \+      sendMail (mailTo $ mMail pm) (newRuleObject prop) (renderHtml $ newRuleBody (mPlayerName pm) sr prop (net m))++   
+mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]
+mapMaybeM f = liftM catMaybes . mapM f++getOutputs :: Multi -> [Output]+getOutputs m = concatMap outputs $ games m++newRulebody :: Rule -> String+newRulebody (Rule {rNumber, rProposedBy}) = "Rule number " ++ (show rNumber) ++ " has been proposed by player " ++ (show rProposedBy)+++

@@ -11,24 +11,39 @@ -- |
 --
 -----------------------------------------------------------------------------
-
+{-# LANGUAGE GADTs, DoAndIfThenElse #-}+    
 module Main (main) where
-
++import Prelude hiding (catch)
 import System.Console.GetOpt 
 import System.Environment 
-import Web-import Multi+import Web.MainPage import Control.Concurrent import Interpret import Control.Concurrent.STM import qualified System.Posix.Signals as S-import Control.Monad.CatchIO+import Control.Monad.CatchIO hiding (catch) import Control.Monad.Trans-import Test+import Language.Nomyx.Test as LT import Data.Maybe import Safe import Network.BSD+import System.Posix.Daemonize+import Types+import Serialize+import Paths_Nomyx as PN+import Language.Haskell.Interpreter.Server hiding (start)+import System.Directory+import Data.Time.Clock+import Language.Nomyx.Expression+import Control.Monad+import Control.Exception hiding (bracket)+import Test+import Utils +defaultLogFile :: FilePath+defaultLogFile = "Nomyx.save"  -- | Entry point of the program. main :: IO Bool
@@ -38,45 +53,73 @@    (flags, _) <- nomyxOpts args
    --parseActions flags    --let verbose = Verbose `elem` flags
-   if Test `elem` flags-      then do-         putStrLn $ "Tests result: " ++ show allTests-         return allTests-      else do-         serverCommandUsage-         multi <- newTVarIO defaultMulti-         --start the haskell interpreter-         sh <- protectHandlers startInterpreter-         --start the web server-         port <- case (findPort flags) of-            Just p -> return $ read p-            Nothing -> return $ read "8000"-         host <- case (findHost flags) of-            Just h -> return h-            Nothing -> getHostName >>= return-         forkIO $ launchWebServer sh multi host port-         forkIO $ launchTimeEvents multi-         --loop-         serverLoop multi-         return True+   case (Daemon `elem` flags) of+       True -> (daemonize $ start flags) >> return True+       False -> start flags >> return True +start :: [Flag] -> IO ()+start flags = do+   serverCommandUsage+   --start the haskell interpreter+   sh <- protectHandlers startInterpreter+   if Test `elem` flags then do+      putStrLn $ "\nNomyx Language Tests results:\n" ++ (concatMap (\(a,b) -> a ++ ": " ++ (show b) ++ "\n") LT.tests)+      ts <- playTests sh+      putStrLn $ "\nNomyx Game Tests results:\n" ++ (concatMap (\(a,b) -> a ++ ": " ++ (show b) ++ "\n") ts)+   else do+      --creating game structures+      logFile <- case (findSaveFile flags) of+         Just f -> return f+         Nothing -> return defaultLogFile+      port <- case (findPort flags) of+         Just p -> return $ read p+         Nothing -> return $ 8000+      host <- case (findHost flags) of+         Just h -> return h+         Nothing -> getHostName >>= return+      logFilePath <- getDataFileName logFile+      multi <- case (findLoadTest flags) of+         Just testName -> loadTestName logFilePath sh (Network host port) testName+         Nothing -> loadMulti logFilePath sh (Network host port)+      tvMulti <- atomically $ newTVar multi+      --start the web server+      forkIO $ launchWebServer tvMulti (Network host port)+      forkIO $ launchTimeEvents tvMulti+      --main loop+      serverLoop tvMulti logFile++loadMulti :: FilePath -> ServerHandle -> Network -> IO Multi+loadMulti fp sh net = do+   fileExists <- doesFileExist fp+   t <- getCurrentTime+   multi <- case fileExists of+      True -> do+         putStrLn "Loading previous game"+         (loadEvents fp sh net) `catch`+            (\e -> (putStrLn $ "Error while loading logged events, log file discarded\n" ++ (show (e::ErrorCall))) >> (return $ defaultMulti sh fp net t))+      False -> return $ defaultMulti sh fp net t+   return multi++ -- | a loop that will handle server commands
-serverLoop :: TVar Multi -> IO ()
-serverLoop tm = do+serverLoop :: TVar Multi -> FilePath -> IO ()
+serverLoop tm f = do    s <- getLine    case s of       "d" -> do          m <- atomically $ readTVar tm          putStrLn $ show m-         serverLoop tm+         serverLoop tm f       "s" -> do          putStrLn "saving state..."-         --createCheckpoint c-         serverLoop tm+         m <- atomically $ readTVar tm+         fp <- getDataFileName f+         save fp $ logEvents $ logs m+         serverLoop tm f       "q" -> return ()       _ -> do          putStrLn "command not recognized"-         serverLoop tm+         serverLoop tm f  serverCommandUsage :: IO () serverCommandUsage = do@@ -87,17 +130,20 @@ 
 -- | Launch mode 
 data Flag 
-     = Verbose | Version | Test | HostName String | Port String
+     = Verbose | Version | Test | HostName String | Port String | LogFile FilePath | Daemon | LoadTest String
        deriving (Show, Eq)
  -- | launch options description
 options :: [OptDescr Flag]
 options =
-     [ Option ['v']     ["verbose"] (NoArg Verbose)       "chatty output on stderr"
-     , Option ['V','?'] ["version"] (NoArg Version)       "show version number"
-     , Option ['t']     ["tests"]   (NoArg Test)          "perform routine check"-     , Option ['h']     ["host"]    (ReqArg HostName "Hostname")      "specify host name"-     , Option ['p']     ["port"]    (ReqArg Port "Port")           "specify port"
+     [ Option ['v']     ["verbose"]  (NoArg Verbose)              "chatty output on stderr"
+     , Option ['V','?'] ["version"]  (NoArg Version)              "show version number"
+     , Option ['t']     ["tests"]    (NoArg Test)                 "perform routine check"+     , Option ['h']     ["host"]     (ReqArg HostName "Hostname") "specify host name"+     , Option ['p']     ["port"]     (ReqArg Port "Port")         "specify port"+     , Option ['r']     ["read"]     (ReqArg LogFile "SaveFile")  "specify save file"+     , Option ['d']     ["daemon"]   (NoArg Daemon)               "run in daemon mode"+     , Option ['l']     ["loadtest"] (ReqArg LoadTest "TestName") "specify name of test to load"      ]
     
 nomyxOpts :: [String] -> IO ([Flag], [String])
@@ -117,6 +163,16 @@     isHost (HostName a) = Just a     isHost _ = Nothing +findLoadTest :: [Flag] -> Maybe String+findLoadTest fs = headMay $ catMaybes $ map isLoadTest fs where+    isLoadTest (LoadTest a) = Just a+    isLoadTest _ = Nothing++findSaveFile :: [Flag] -> Maybe FilePath+findSaveFile fs = headMay $ catMaybes $ map isSaveFile fs where+    isSaveFile (LogFile a) = Just a+    isSaveFile _ = Nothing+ helper :: MonadCatchIO m => S.Handler -> S.Signal -> m S.Handler helper handler signal = liftIO $ S.installHandler signal handler Nothing @@ -136,3 +192,34 @@  protectHandlers :: MonadCatchIO m => m a -> m a protectHandlers a = bracket saveHandlers restoreHandlers $ const a++triggerTimeEvent :: TVar Multi -> UTCTime -> IO()+triggerTimeEvent tm t = do+    m <- atomically $ readTVar tm+    m' <- execWithMulti t (update (TE t (MultiTimeEvent t)) Nothing) m+    atomically $ writeTVar tm m'+++-- | get all events that has not been triggered yet+getTimeEvents :: UTCTime -> TVar Multi -> IO([UTCTime])+getTimeEvents now tm = do+    m <- atomically $ readTVar tm+    let times = catMaybes $ map getTimes $ concatMap events $ games m+    return $ filter (\t -> t <= now && t > (-2) `addUTCTime` now) times+++launchTimeEvents :: TVar Multi -> IO()+launchTimeEvents tm = do+    now <- getCurrentTime+    --putStrLn $ "tick " ++ (show now)+    timeEvents <- getTimeEvents now tm+    when (length timeEvents /= 0) $ putStrLn "found time event(s)"+    mapM_ (triggerTimeEvent tm) timeEvents+    --sleep 1 second roughly+    threadDelay 1000000+    launchTimeEvents tm+++getTimes :: EventHandler -> Maybe UTCTime+getTimes (EH _ _ (Time t) _) = Just t+getTimes _ = Nothing

@@ -1,6 +1,6 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, GeneralizedNewtypeDeriving,+{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, ScopedTypeVariables,     MultiParamTypeClasses, TemplateHaskell, TypeFamilies, TypeOperators,-    TypeSynonymInstances, FlexibleInstances, GADTs #-}+    TypeSynonymInstances, FlexibleInstances, GADTs, NamedFieldPuns, DoAndIfThenElse #-}  -- | This module manages multi-player games and commands. module Multi where@@ -17,320 +17,286 @@ import Game import Utils import Interpret-import Data.Typeable-import Data.Function (on) import Debug.Trace.Helpers() import Language.Nomyx.Expression import Data.Time-import Language.Haskell.Interpreter.Server+import Language.Haskell.Interpreter.Server (ServerHandle) import Language.Nomyx.Evaluation-import Control.Concurrent.STM import Data.Maybe-import Control.Concurrent---type PlayerPassword = String--data PlayerMulti = PlayerMulti   { mPlayerNumber :: PlayerNumber,-                                   mPlayerName :: PlayerName,-                                   mPassword :: PlayerPassword,-                                   inGame :: Maybe GameName}-                                   deriving (Eq, Show, Typeable)----- | A structure to hold the active games and players-data Multi = Multi { games   :: [Game],-                     mPlayers :: [PlayerMulti]}-                     deriving (Eq, Typeable)--instance Show Multi where-   show Multi{games=gs, mPlayers=mps} = show (sort gs) ++ "\n" ++ show (sort mps)--defaultMulti :: Multi-defaultMulti = Multi [] []+import Types+import Control.Applicative+import Control.Exception+import Debug.Trace.Helpers  -- | helper function to change a player's ingame status. mayJoinGame :: Maybe GameName -> PlayerNumber -> [PlayerMulti] -> [PlayerMulti]-mayJoinGame maybename pn pl = case find (\(PlayerMulti mypn _ _ _) -> mypn == pn) pl of+mayJoinGame maybename pn pl = case find (\(PlayerMulti mypn _ _ _ _ _) -> mypn == pn) pl of                      Just o -> replace o o{ inGame = maybename} pl                      Nothing -> pl -newPlayerU :: PlayerMulti -> StateT Multi IO ()+newPlayerU :: PlayerMulti -> State Multi () newPlayerU pm = do    pms <- gets mPlayers    modify (\multi -> multi { mPlayers = pm : pms}) -findPlayer :: PlayerName -> StateT Multi IO (Maybe PlayerMulti)-findPlayer name =  fmap (find (\PlayerMulti {mPlayerName = pn} -> pn==name)) (gets mPlayers) -getNewPlayerNumber :: StateT Multi IO PlayerNumber+getNewPlayerNumber :: State Multi PlayerNumber getNewPlayerNumber = do    ps <- gets mPlayers    return $ length ps + 1  -addNewGame :: Game -> StateT Multi IO ()+addNewGame :: Game -> State Multi () addNewGame new = modify (\multi@Multi {games=gs} -> multi {games =  new:gs}) -getGameByName :: GameName -> StateT Multi IO (Maybe Game)+getGameByName :: GameName -> State Multi (Maybe Game) getGameByName gn =  fmap (find (\(Game {gameName = n}) -> n==gn)) (gets games) -joinGamePlayer :: PlayerNumber -> GameName -> StateT Multi IO ()+joinGamePlayer :: PlayerNumber -> GameName -> State Multi () joinGamePlayer pn game = modify (\multi -> multi {mPlayers = mayJoinGame (Just game) pn (mPlayers multi)})  -leaveGameU :: PlayerNumber -> StateT Multi IO ()+leaveGameU :: PlayerNumber -> State Multi () leaveGameU pn = modify (\multi -> multi {mPlayers = mayJoinGame Nothing pn (mPlayers multi)})  -- | list the active games-listGame :: PlayerNumber -> StateT Multi IO ()+listGame :: PlayerNumber -> State Multi () listGame _ = do    gs <- gets games    case length gs of-      0 -> say "No active games"+      0 -> traceM "No active games"       _ -> do-         say "Active games:"-         say $ concatMap (\g -> gameName g ++ "\n") gs+         traceM "Active games:"+         traceM $ concatMap (\g -> gameName g ++ "\n") gs  -- | starts a new game-newGame :: String -> PlayerNumber -> StateT Multi IO ()-newGame name _ = do+newGame :: GameName -> String -> PlayerNumber -> State Multi ()+newGame name desc _ = do    gs <- gets games    case null $ filter (\p -> gameName p == name) gs of       True -> do-         say $ "Creating a new game of name: " ++ name-         t <- liftIO getCurrentTime+         traceM $ "Creating a new game of name: " ++ name+         t <- gets mCurrentTime          -- create a game with zero players-         modify (\m -> m {games = (initialGame name t):gs})-      False -> say $ "this name is already used"+         modify (\m -> m {games = (initialGame name desc t):gs})+      False -> traceM $ "this name is already used"  uniqueGame :: String -> [Game] -> Bool uniqueGame s gs = null $ filter (\p -> gameName p == s) gs  -- | join a game.-joinGame :: GameName -> PlayerNumber -> StateT Multi IO ()+joinGame :: GameName -> PlayerNumber -> State Multi () joinGame game pn = do    mg <- getGameByName game    case mg of-      Nothing -> say $ "No game by that name"+      Nothing -> traceM $ "No game by that name"       Just g -> do-         say "subscribing first."+         traceM "subscribing first."          subscribeGame (gameName g) pn-         say $ "Joining game: " ++ game+         traceM $ "Joining game: " ++ game          joinGamePlayer pn game   -- | leave a game (you remain subscribed).-leaveGame :: PlayerNumber -> StateT Multi IO  ()+leaveGame :: PlayerNumber -> State Multi () leaveGame pn = do    leaveGameU pn-   say "You left the game (you remain subscribed)."+   traceM "You left the game (you remain subscribed)."   -- | subcribe to a game.-subscribeGame :: GameName -> PlayerNumber -> StateT Multi IO ()+subscribeGame :: GameName -> PlayerNumber -> State Multi () subscribeGame game pn = do    m <- get    inGameDo game $ do       g <- get       case find (\(PlayerInfo  { playerNumber=mypn}) -> mypn == pn ) (players g) of-         Just _ -> say "Already subscribed!"+         Just _ -> traceM "Already subscribed!"          Nothing -> do-            say $ "Subscribing to game: " ++ game+            traceM $ "Subscribing to game: " ++ game             let player = PlayerInfo { playerNumber = pn, playerName = getPlayersName pn m}             put g {players = player : (players g)}-            liftT $ triggerEvent (Player Arrive) (PlayerData player)+            triggerEvent (Player Arrive) (PlayerData player)   -- | subcribe to a game.-unsubscribeGame :: GameName -> PlayerNumber -> StateT Multi IO ()+unsubscribeGame :: GameName -> PlayerNumber -> State Multi () unsubscribeGame game pn = inGameDo game $ do    g <- get    case find (\(PlayerInfo  { playerNumber=mypn}) -> mypn == pn ) (players g) of-      Nothing -> say "Not subscribed!"+      Nothing -> traceM "Not subscribed!"       Just _ -> do-         say $ "Unsubscribing to game: " ++ game+         traceM $ "Unsubscribing to game: " ++ game          let player = PlayerInfo { playerNumber = pn, playerName = getPlayersName' g pn}          put g {players = filter (\PlayerInfo { playerNumber = mypn} -> mypn /= pn) (players g)}-         liftT $ triggerEvent (Player Leave) (PlayerData player)+         triggerEvent (Player Leave) (PlayerData player)  -showSubGame :: GameName -> PlayerNumber -> StateT Multi IO  ()+showSubGame :: GameName -> PlayerNumber -> State Multi () showSubGame g _ = inGameDo g $ do    ps <- gets players-   say $ concatMap show ps+   traceM $ concatMap show ps -showSubscribtion :: PlayerNumber -> StateT Multi IO  ()-showSubscribtion pn = inPlayersGameDo pn $ do+showSubscribtion :: PlayerNumber -> State Multi ()+showSubscribtion pn = inPlayersGameDo_ pn $ do    ps <- gets players-   say $ concatMap show ps+   traceM $ concatMap show ps  ++ -- | insert a rule in pending rules.-submitRule :: String -> String -> String -> PlayerNumber -> ServerHandle -> StateT Multi IO  ()-submitRule name text rule pn sh = inPlayersGameDo pn $ do-   --input the new rule (may fail if ill-formed)-   rs <- gets rules-   let rn = getFreeNumber $ map rNumber rs-   mnr <- enterRule rn name text rule pn sh+submitRule :: SubmitRule -> PlayerNumber -> ServerHandle -> StateT Multi IO ()+submitRule sr pn sh = do+   mnr <- enterRule sr pn sh    case mnr of       Just nr -> do-         r <- liftT $ evProposeRule nr-         if r == True then say $ "Your rule has been added to pending rules."-             else say $ "Error: Rule could not be proposed"-         return ()-      Nothing -> say $ "Please try again."+         inPlayersGameDo' pn $ do+            r <- evProposeRule nr+            if r == True then traceM $ "Your rule has been added to pending rules."+            else traceM $ "Error: Rule could not be proposed"+         liftT $ updateLastRule Nothing pn+      Nothing -> liftT $ updateLastRule (Just sr) pn -inputChoiceResult :: EventNumber -> Int -> PlayerNumber -> StateT Multi IO  ()-inputChoiceResult eventNumber choiceIndex pn = inPlayersGameDo pn $ liftT $ triggerChoice eventNumber choiceIndex -inputStringResult :: Event InputString -> String -> PlayerNumber -> StateT Multi IO  ()-inputStringResult event input pn = inPlayersGameDo pn $ liftT $ triggerEvent event (InputStringData input)+-- | reads a rule.+enterRule :: SubmitRule -> PlayerNumber -> ServerHandle -> StateT Multi IO (Maybe Rule)+enterRule (SubmitRule name desc code) pn sh = do+   mrr <- lift $ interpretRule code sh+   join <$> (inPlayersGameDo' pn $ do+      rs <- gets rules+      let rn = getFreeNumber $ map rNumber rs -inputUpload :: PlayerNumber -> FilePath -> String -> ServerHandle -> StateT Multi IO  ()-inputUpload pn dir mod sh = inPlayersGameDo pn $ do+      case mrr of+         Right ruleFunc -> return $ Just Rule {rNumber = rn,+                      rName = name,+                      rDescription = desc,+                      rProposedBy = pn,+                      rRuleCode = code,+                      rRuleFunc = ruleFunc,+                      rStatus = Pending,+                      rAssessedBy = Nothing}+         Left e -> do+            output ("Compiler error: " ++ show e ++ "\n") pn+            return Nothing)++updateLastRule :: Maybe SubmitRule -> PlayerNumber -> State Multi ()+updateLastRule msr pn = do+   pm <- fromJust <$> findPlayer' pn+   pls <- gets mPlayers+   let pls' = replace pm (pm {lastRule = msr}) pls+   modify (\m -> m{mPlayers = pls'})++--cpuTimeLimitSoft = ResourceLimit 4+--cpuTimeLimitHard = ResourceLimit 5+--limits :: [(Resource, ResourceLimits)]+--limits = [ (ResourceCPUTime,      ResourceLimits cpuTimeLimitSoft cpuTimeLimitHard)]++inputChoiceResult :: EventNumber -> Int -> PlayerNumber -> State Multi ()+inputChoiceResult eventNumber choiceIndex pn = inPlayersGameDo_ pn $ triggerChoice eventNumber choiceIndex++-- TODO maybe homogeneise both inputs event+inputStringResult :: Event InputString -> String -> PlayerNumber -> State Multi ()+inputStringResult event input pn = inPlayersGameDo_ pn $ triggerEvent event (InputStringData input)++inputUpload :: PlayerNumber -> FilePath -> String -> ServerHandle -> StateT Multi IO ()+inputUpload pn dir mod sh = do     m <- lift $ loadModule dir mod sh     case m of       Right _ -> do-         output pn $ "File loaded: " ++ show dir ++ " Module " ++ show mod ++"\n"+         inPlayersGameDo'_ pn $ output ("File loaded: " ++ show dir ++ " Module " ++ show mod ++"\n") pn          return ()       Left e -> do-         output pn $ "Compiler error: " ++ show e ++ "\n"+         inPlayersGameDo'_ pn $ output ("Compiler error: " ++ show e ++ "\n") pn          return () -output :: PlayerNumber -> String -> StateT Game IO ()-output pn s = modify (\game -> game { outputs = (pn, s) : (outputs game)}) --- | finds the corresponding game in the multistate and replaces it.-modifyGame :: Game -> StateT Multi IO  ()-modifyGame g = do-   Multi gs ps <- get-   case find (\myg -> gameName g == gameName myg) gs of-      Nothing -> error "modifyGame: No game by that name"-      Just oldg -> do-         let newgs = replace oldg g gs-         put $ Multi newgs ps---- | reads a rule.-enterRule :: RuleNumber -> String -> String -> String -> PlayerNumber -> ServerHandle -> StateT Game IO (Maybe Rule)-enterRule num name text ruleText pn sh = do-   mrr <- lift $ interpretRule ruleText sh-   case mrr of-      Right ruleFunc -> return $ Just Rule {rNumber = num,-                      rName = name,-                      rDescription = text,-                      rProposedBy = pn,-                      rRuleCode = ruleText,-                      rRuleFunc = ruleFunc,-                      rStatus = Pending,-                      rAssessedBy = Nothing}-      Left e -> do-         output pn $ "Compiler error: " ++ show e ++ "\n"-         return Nothing-+mailSettings :: MailSettings -> PlayerNumber -> State Multi ()+mailSettings mailSettings pn = do+   mps <- gets mPlayers+   case find (\(PlayerMulti {mPlayerNumber}) -> pn==mPlayerNumber) mps of+      Nothing -> traceM "settings not modified!"+      Just pm -> do+         let newmps = replace pm pm{mMail=mailSettings} mps+         modify (\m -> m{mPlayers = newmps})  -- | show the constitution.-showConstitution :: PlayerNumber -> StateT Multi IO ()-showConstitution pn = inPlayersGameDo pn $ get >>= (say  .  show  .  activeRules)+showConstitution :: PlayerNumber -> State Multi ()+showConstitution pn = inPlayersGameDo_ pn $ get >>= (traceM  .  show  .  activeRules)   -- | show every rules (including pendings and deleted)-showAllRules :: PlayerNumber -> StateT Multi IO ()	-showAllRules pn = inPlayersGameDo pn $ get >>= (say . show . rules)+showAllRules :: PlayerNumber -> State Multi ()	+showAllRules pn = inPlayersGameDo_ pn $ get >>= (traceM . show . rules)  displayPlayer :: PlayerMulti -> String-displayPlayer (PlayerMulti pn name _ (Just game)) = show pn ++ ": " ++ name ++ " in game: " ++ game ++ "\n"-displayPlayer (PlayerMulti pn name _ Nothing)     = show pn ++ ": " ++ name ++ "\n"+displayPlayer (PlayerMulti pn name _ _ (Just game) _) = show pn ++ ": " ++ name ++ " in game: " ++ game ++ "\n"+displayPlayer (PlayerMulti pn name _ _ Nothing _)     = show pn ++ ": " ++ name ++ "\n"  --- | quit the game-quit :: PlayerNumber -> IO ()-quit _ = putStrLn "quit"- -- | Utility functions  -- | replace the player's name in the list setName :: String -> PlayerNumber -> [PlayerMulti] -> [PlayerMulti]-setName name pn pl = case find (\(PlayerMulti h _ _ _) -> h == pn) pl of+setName name pn pl = case find (\(PlayerMulti h _ _ _ _ _) -> h == pn) pl of                         Just o -> replace o o{ mPlayerName = name} pl                         Nothing -> pl  --- | returns the game the player is in						-getPlayersGame :: PlayerNumber -> Multi -> Maybe Game-getPlayersGame pn multi = do-        pi <- find (\(PlayerMulti n _ _ _) -> n==pn) (mPlayers multi)-        gn <- inGame pi-        find (\(Game {gameName=name}) -> name==gn) (games multi) -getPlayersName :: PlayerNumber -> Multi -> PlayerName-getPlayersName pn multi = do-   case find (\(PlayerMulti n _ _ _) -> n==pn) (mPlayers multi) of-      Nothing -> error "getPlayersName: No player by that number"-      Just pm -> mPlayerName pm--getPlayersName' :: Game -> PlayerNumber -> PlayerName-getPlayersName' g pn = do-   case find (\(PlayerInfo n _) -> n==pn) (players g) of-      Nothing -> error "getPlayersName: No player by that number in that game"-      Just pm -> playerName pm- -- | this function apply the given game actions to the game the player is in.-inPlayersGameDo :: PlayerNumber -> StateT Game IO () -> StateT Multi IO ()+inPlayersGameDo :: PlayerNumber -> State Game a -> State Multi (Maybe a) inPlayersGameDo pn action = do    multi <- get+   t <- gets mCurrentTime    let mg = getPlayersGame pn multi    case mg of-      Nothing -> say "You must be in a game"+      Nothing -> traceM "You must be in a game" >> return Nothing       Just g -> do-         myg <- lift $ execWithGame action g+         (a, myg) <- lift $ runStateT action (g { currentTime = t})          modifyGame myg+         return (Just a) -inGameDo :: GameName -> StateT Game IO () -> StateT Multi IO ()+inPlayersGameDo_ :: PlayerNumber -> State Game a -> State Multi ()+inPlayersGameDo_ pn action = inPlayersGameDo pn action >> return ()++inPlayersGameDo' :: PlayerNumber -> State Game a -> StateT Multi IO (Maybe a)+inPlayersGameDo' pn gs = do+    m <- get+    let (a, m') = runState (inPlayersGameDo pn gs) m+    put m'+    return a++inPlayersGameDo'_ :: PlayerNumber -> State Game a -> StateT Multi IO ()+inPlayersGameDo'_ pn action = inPlayersGameDo' pn action >> return ()++inGameDo :: GameName -> State Game () -> State Multi () inGameDo game action = do    gs <- gets games    case find (\(Game {gameName =n}) -> n==game) gs of-      Nothing -> say "No game by that name"+      Nothing -> traceM "No game by that name"       Just g -> do-         myg <- lift $ execWithGame action g+         t <- gets mCurrentTime+         let myg = execWithGame t action g          modifyGame myg -instance Ord PlayerMulti where-  (<=) = (<=) `on` mPlayerNumber +triggerTimeEvent :: UTCTime -> StateT Multi IO ()+triggerTimeEvent t = do+   gs <- gets games+   gs' <- lift $ mapM (\g -> trig t g `catch` timeExceptionHandler t g) gs+   modify(\m -> m{games = gs'}) -triggerTimeEvent :: TVar Multi -> UTCTime -> IO()-triggerTimeEvent tm t = do-    m <- atomically $ readTVar tm-    gs' <- mapM (trig t) (games m)-    let m' = m {games = gs'}-    atomically $ writeTVar tm m'-       where trig t g =  execWithGame (liftT $ evTriggerTime t) g -execGame :: State Game () -> Game -> Game-execGame s g = execState s g---- | get all events within time and time + 2 second-getTimeEvents :: UTCTime -> TVar Multi -> IO([UTCTime])-getTimeEvents time tm = do-    m <- atomically $ readTVar tm-    let times = catMaybes $ map getTimes $ concatMap events $ games m-    return $ filter (\t-> t >= time && t < addUTCTime 2 time) times----TODO: fix this-launchTimeEvents :: TVar Multi -> IO()-launchTimeEvents tm = do-    now <- getCurrentTime-    --putStrLn $ "tick " ++ (show now)-    schedule <- getTimeEvents now tm-    when (length schedule /= 0) $ putStrLn "found time event"-    mapM_ (triggerTimeEvent tm) schedule-    after <- getCurrentTime-    --sleep 1 second minus rough delay of execution-    threadDelay $ truncate(1000000 - 1000000*(diffUTCTime after now))-    launchTimeEvents tm-+trig :: UTCTime -> Game -> IO Game+trig t g =  do+   let g' = execWithGame t (evTriggerTime t) g+   evaluate g'+   return g' -getTimes :: EventHandler -> Maybe UTCTime-getTimes (EH _ _ (Time t) _) = Just t-getTimes _ = Nothing+timeExceptionHandler :: UTCTime -> Game -> ErrorCall -> IO Game+timeExceptionHandler t g e = do+   putStrLn $ "Error in triggerTimeEvent: " ++ (show e)+   return $ execWithGame t (outputAll $ "Error while triggering a time event: " ++ (show e) +++                           "\nThe event have been canceled. Please remove/fix the faulty rule.") g 

@@ -0,0 +1,40 @@+-----------------------------------------------------------------------------+--+-- Module      :  Quotes+-- Copyright   :+-- License     :  BSD3+--+-- Maintainer  :  corentin.dupont@gmail.com+-- Stability   :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------+{-# LANGUAGE NamedFieldPuns, TemplateHaskell, QuasiQuotes #-}++module Quotes where++import Language.Haskell.TH as TH+import Language.Haskell.TH.Quote+import Language.Haskell.Interpreter hiding (get)+import Interpret++cr :: QuasiQuoter+cr = QuasiQuoter { quoteExp = quoteRuleFunc,+                   quotePat = undefined,+                   quoteType = undefined,+                   quoteDec = undefined}++quoteRuleFunc :: String -> Q TH.Exp+quoteRuleFunc s = do+   res <- runIO $ runInterpreter $ do+      setImports importList+      typeOf s+   case res of+      Right "RuleFunc" -> [| s |]+      Right _ -> fail $ "Rule doesn't typecheck"+      Left e -> fail $ show e+++

@@ -0,0 +1,83 @@++{-# LANGUAGE NamedFieldPuns, FlexibleInstances #-}++module Serialize where++import Prelude hiding (log, catch)+import Language.Nomyx.Expression+import Control.Monad.State+import Types+import Multi+import Language.Haskell.Interpreter.Server+import Control.Applicative+import Data.Time.Clock+import Utils+import Control.Exception++save :: FilePath -> [TimedEvent] -> IO()+save fp ges = writeFile fp $ concatMap (\a -> show a ++ "\n") ges++save' :: StateT Multi IO ()+save' = do+   lgs <- gets logs+   lift $ save (logFilePath lgs) (logEvents lgs)++load :: FilePath -> IO([TimedEvent])+load fp = (map read . lines) <$> readFile fp++logEvent :: TimedEvent -> StateT Multi IO ()+logEvent le = do+    m <- get+    ls <- gets logs+    put m { logs = ls { logEvents = (logEvents $ logs m) ++ [le]}}++putTime :: UTCTime -> StateT Multi IO ()+putTime t = modify (\m -> m{mCurrentTime = t})++enactTimedEvent :: TimedEvent -> StateT Multi IO ()+enactTimedEvent (TE t e) = do+   putTime t+   enactEvent e++enactEvent :: MultiEvent -> StateT Multi IO ()+enactEvent (MultiNewPlayer pm)                = liftT $ newPlayerU pm+enactEvent (MultiNewGame s d pn)              = liftT $ newGame s d pn+enactEvent (MultiJoinGame gn pn)              = liftT $ joinGame gn pn+enactEvent (MultiLeaveGame pn)                = liftT $ leaveGame pn+enactEvent (MultiSubscribeGame gn pn)         = liftT $ subscribeGame gn pn+enactEvent (MultiUnsubscribeGame gn pn)       = liftT $ unsubscribeGame gn pn+enactEvent (MultiSubmitRule sr pn)            = gets sh >>= submitRule sr pn+enactEvent (MultiInputChoiceResult en ci pn)  = liftT $ inputChoiceResult en ci pn+enactEvent (MultiInputStringResult ti res pn) = liftT $ inputStringResult (InputString pn ti) res pn+enactEvent (MultiInputUpload pn dir mod)      = gets sh >>= inputUpload pn dir mod+enactEvent (MultiTimeEvent t)                 = triggerTimeEvent t+enactEvent (MultiMailSettings mms pn)         = liftT $ mailSettings mms pn++update :: TimedEvent -> (Maybe PlayerNumber) -> StateT Multi IO ()+update te mpn = logEvent te >> update' te mpn >> save'++update' :: TimedEvent -> (Maybe PlayerNumber) -> StateT Multi IO ()+update' te mpn = do+   m <- get+   m' <- lift $ (enactTimedEvent' te m) `catch` commandExceptionHandler mpn m+   put m'++enactTimedEvent' te m = do+   m' <- (execStateT (enactTimedEvent te) m)+   evaluate m'+   return m'++loadEvents :: FilePath -> ServerHandle -> Network -> IO Multi+loadEvents fp sh net = do+   t <- getCurrentTime+   execStateT (loadEvents' fp) (defaultMulti sh fp net t)++loadEvents' :: FilePath -> StateT Multi IO ()+loadEvents' fp = do+   les <- liftIO $ load fp+   loadTimedEvents les++loadTimedEvents :: [TimedEvent] -> StateT Multi IO ()+loadTimedEvents les = do+   modify(\m -> m { logs = (logs m) { logEvents = les}})+   mapM_ (\a -> update' a (Just 1)) les --(lift $ putStrLn $ "loading " ++ (show a)) >>

@@ -0,0 +1,174 @@+-----------------------------------------------------------------------------+--+-- Module      :  Test+-- Copyright   :+-- License     :  BSD3+--+-- Maintainer  :  corentin.dupont@gmail.com+-- Stability   :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------+{-# LANGUAGE TupleSections, ScopedTypeVariables, TemplateHaskell, GADTs, QuasiQuotes #-}++module Test where++import Prelude hiding (catch)+import Types+import Data.Time hiding (getCurrentTime)+import Control.Monad.State+import Serialize+import Language.Haskell.Interpreter.Server (ServerHandle)+import Language.Nomyx.Expression+import Control.Applicative+import Control.Exception+import Language.Haskell.TH+import Language.Haskell.TH.Syntax as THS+import System.IO.Unsafe+import Quotes+import Data.List+import Data.Time.Clock++playTests :: ServerHandle -> IO [(String, Bool)]+playTests sh = mapM (\(title, t, cond) -> (title,) <$> test sh t cond) tests++tests :: [(String, [TimedEvent], Multi -> Bool)]+tests = [("hello World",           noTime gameHelloWorld,         condHelloWorld),+         ("hello World 2 players", noTime gameHelloWorld2Players, condHelloWorld2Players),+         ("Partial Function 1",    noTime gamePartialFunction1,   condPartialFunction1),+         ("Partial Function 2",    gamePartialFunction2,          condPartialFunction2),+         ("Partial Function 3",    noTime gamePartialFunction3,   condPartialFunction3),+         ("Money transfer",        noTime gameMoneyTransfer,      condMoneyTransfer)]++dayZero :: UTCTime+dayZero = UTCTime (ModifiedJulianDay 0) 0++noTime :: [MultiEvent] -> [TimedEvent]+noTime mes = map (TE dayZero) mes++test :: ServerHandle -> [TimedEvent] -> (Multi -> Bool) -> IO Bool+test sh tes cond = do+   --putStrLn $ "\n\n\nTEST"+   let m = defaultMulti sh "" defaultNetwork dayZero+   m' <- (loadTest tes m)+   --putStrLn $ show m'+   (return $ cond m') `catch` (\(e::IOError) -> (putStrLn $ show e) >> return False)++loadTest ::  [TimedEvent] -> Multi -> IO Multi+loadTest tes m = do+   m' <- execStateT (loadTimedEvents tes) m+   evaluate m'+   return m'++testException :: Multi -> SomeException -> IO Multi+testException m e = do+   putStrLn $ "Test Exception: " ++ show e+   return m++loadTestName :: FilePath -> ServerHandle -> Network -> String -> IO Multi+loadTestName fp sh net testName = do+   let mt = find (\(name, _, _) -> name == testName) tests+   t <- getCurrentTime+   let m = defaultMulti sh fp net t+   case mt of+      Just (n, t, _) -> putStrLn ("Loading test game: " ++ n)  >> loadTest t m+      Nothing -> putStrLn "Test name not found" >> return m++printRule :: Q THS.Exp -> String+printRule r = unsafePerformIO $ do+   expr <- runQ r+   return $ pprint expr+++onePlayerOneGame :: [MultiEvent]+onePlayerOneGame =+   [MultiNewPlayer (PlayerMulti {mPlayerNumber = 1, mPlayerName = "coco", mPassword = "coco", mMail = MailSettings {mailTo = "", mailNewInput = False, mailNewRule = False, mailNewOutput = False, mailConfirmed = False}, inGame = Nothing, lastRule = Nothing}),+    MultiMailSettings (MailSettings {mailTo = "c", mailNewInput = True, mailNewRule = True, mailNewOutput = True, mailConfirmed = True}) 1,+    MultiNewGame "test" "" 1,+    MultiJoinGame "test" 1]++twoPlayersOneGame :: [MultiEvent]+twoPlayersOneGame = onePlayerOneGame +++   [MultiNewPlayer (PlayerMulti {mPlayerNumber = 2, mPlayerName = "bat", mPassword = "bat", mMail = MailSettings {mailTo = "", mailNewInput = False, mailNewRule = False, mailNewOutput = False, mailConfirmed = False}, inGame = Nothing, lastRule = Nothing}),+    MultiMailSettings (MailSettings {mailTo = "c", mailNewInput = True, mailNewRule = True, mailNewOutput = True, mailConfirmed = True}) 2,+    MultiJoinGame "test" 2]++submitRule ::  String -> [MultiEvent]+submitRule r = onePlayerOneGame +++   [MultiSubmitRule (SubmitRule "" "" r) 1,+    MultiInputChoiceResult 4 0 1]++++gameHelloWorld :: [MultiEvent]+gameHelloWorld = onePlayerOneGame ++ submitRule [cr|helloWorld|]++condHelloWorld :: Multi -> Bool+condHelloWorld m = (head $ outputs $ head $ games m) == (1, "hello, world!")++gameHelloWorld2Players :: [MultiEvent]+gameHelloWorld2Players = twoPlayersOneGame +++   [MultiSubmitRule (SubmitRule "" "" [cr|helloWorld|]) 1,+   MultiInputChoiceResult 5 0 1,+   MultiInputChoiceResult 4 0 2]++condHelloWorld2Players :: Multi -> Bool+condHelloWorld2Players m = (head $ outputs $ head $ games m) == (1, "hello, world!")++partialFunction1 :: String+partialFunction1 = [cr|VoidRule $ readVar_ (V "toto1")|]++gamePartialFunction1 :: [MultiEvent]+gamePartialFunction1 = onePlayerOneGame ++ (submitRule partialFunction1)++-- rule has not been accepted due to exception+condPartialFunction1 :: Multi -> Bool+condPartialFunction1 m = (rStatus $ head $ rules $ head $ games m) == Pending &&+                         (take 5 $ snd $ head $ outputs $ head $ games m) == "Error"++partialFunction2 :: String+partialFunction2 = [cr|VoidRule $ do+   t <- getCurrentTime+   onEventOnce_ (Time $ addUTCTime 5 t) $ const $ readVar_ (V "toto2")|]++gamePartialFunction2 :: [TimedEvent]+gamePartialFunction2 = noTime onePlayerOneGame ++ (noTime $ submitRule partialFunction2) +++    [TE (5 `addUTCTime` dayZero) $  (MultiTimeEvent $ 5 `addUTCTime` dayZero)]++-- rule has been accepted but exception happened later+condPartialFunction2 :: Multi -> Bool+condPartialFunction2 m = (rStatus $ head $ rules $ head $ games m) == Active &&+                         (take 5 $ snd $ head $ outputs $ head $ games m) == "Error"++--This rule blocks the game: the exception (variable not existing) is triggered during a "rule proposed" event,+--thus preventing to propose any new rule to the game.+partialFunction3 :: String+partialFunction3 = [cr|VoidRule $ do+   onEvent_ (RuleEv Proposed) $ const $ readVar_ (V "toto3")|]++gamePartialFunction3 :: [MultiEvent]+gamePartialFunction3 = onePlayerOneGame ++ (submitRule partialFunction3) ++ (submitRule [cr|nothing|])++-- rule has been accepted but no more rule can be proposed+condPartialFunction3 :: Multi -> Bool+condPartialFunction3 m = (length $ rules $ head $ games m) == 3++--Create bank accounts, win 100 Ecu on rule accepted (so 100 Ecu is won for each player), transfer 50 Ecu+gameMoneyTransfer :: [MultiEvent]+gameMoneyTransfer = twoPlayersOneGame +++   [MultiSubmitRule (SubmitRule "" "" [cr|createBankAccount|]) 1,+   (MultiInputChoiceResult 5 0 1),+   (MultiInputChoiceResult 4 0 2),+   (MultiSubmitRule (SubmitRule "" "" [cr|winXEcuOnRuleAccepted 100|]) 1),+   (MultiInputChoiceResult 7 0 1),+   (MultiInputChoiceResult 6 0 2),+   (MultiSubmitRule (SubmitRule "" "" [cr|moneyTransfer|]) 2),+   (MultiInputChoiceResult 8 0 1),+   (MultiInputChoiceResult 7 0 2),+   (MultiInputChoiceResult 7 0 1),+   (MultiInputStringResult "Select Amount to transfert to player: 2" "50" 1)]++condMoneyTransfer :: Multi -> Bool+condMoneyTransfer m = (vName $ head $ variables $ head $ games m) == "Accounts"

@@ -0,0 +1,91 @@++{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances, TypeFamilies,+             NamedFieldPuns #-}++module Types where+import Language.Nomyx.Expression+import Data.Typeable+import Data.List+import Data.Function+import Language.Haskell.Interpreter.Server (ServerHandle)+import Text.Blaze.Html5 hiding (map, label)+import Text.Reform+import Happstack.Server+import Text.Reform.Happstack()+import Network.BSD+import Data.Time+++type PlayerPassword = String+type Port = Int+data Network = Network {host :: HostName, port :: Port}+defaultNetwork = Network "" 0++data PlayerMulti = PlayerMulti   { mPlayerNumber :: PlayerNumber,+                                   mPlayerName :: PlayerName,+                                   mPassword :: PlayerPassword,+                                   mMail :: MailSettings,+                                   inGame :: Maybe GameName,+                                   lastRule :: Maybe SubmitRule}+                                   deriving (Eq, Show, Read, Typeable)++--- | A structure to hold the active games and players+data Multi = Multi { games   :: [Game],+                     mPlayers :: [PlayerMulti],+                     logs ::  Log,+                     sh :: ServerHandle,+                     net :: Network,+                     mCurrentTime :: UTCTime}+                     deriving (Typeable)++instance Show Multi where+   show Multi{games, mPlayers} = "Games: " ++ show (sort games) ++ "\n" +++                                 "Players: " ++ show (sort mPlayers) ++ "\n"++defaultMulti :: ServerHandle -> FilePath -> Network -> UTCTime -> Multi+defaultMulti sh fp net t = Multi [] [] (defaultLog fp) sh net t++data Log = Log { logEvents :: [TimedEvent],+                 logFilePath :: FilePath } deriving (Eq)++defaultLog :: FilePath ->Log+defaultLog fp = Log [] fp++data SubmitRule = SubmitRule RuleName String RuleCode deriving (Show, Read, Eq)++data TimedEvent = TE UTCTime MultiEvent deriving (Show, Read, Eq)++data MultiEvent =  MultiNewPlayer         PlayerMulti+                 | MultiNewGame           GameName String PlayerNumber+                 | MultiJoinGame          GameName PlayerNumber+                 | MultiLeaveGame         PlayerNumber+                 | MultiSubscribeGame     GameName PlayerNumber+                 | MultiUnsubscribeGame   GameName PlayerNumber+                 | MultiSubmitRule        SubmitRule PlayerNumber+                 | MultiInputChoiceResult EventNumber Int PlayerNumber+                 | MultiInputStringResult String String PlayerNumber+                 | MultiInputUpload       PlayerNumber FilePath String+                 | MultiTimeEvent         UTCTime+                 | MultiMailSettings      MailSettings PlayerNumber+                   deriving (Show, Read, Eq)+++instance Ord PlayerMulti where+  (<=) = (<=) `on` mPlayerNumber++type NomyxForm a = Form (ServerPartT IO) [Input] String Html () a+++data MailSettings = MailSettings { mailTo :: String,+                   mailNewInput :: Bool,+                   mailNewRule :: Bool,+                   mailNewOutput :: Bool,+                   mailConfirmed :: Bool } deriving (Eq, Show, Read)++defaultMailSettings :: MailSettings+defaultMailSettings = MailSettings "" False False False False++instance FormError String where+    type ErrorInputType String = [Input]+    commonFormError _ = "common error"+

@@ -11,12 +11,22 @@ -- |
 --
 -----------------------------------------------------------------------------
-
++{-# LANGUAGE NamedFieldPuns #-}+    
 module Utils where
 
 import Data.Maybe
 import Data.Char
-import Control.Monad.State
+import Control.Monad.State+import Types+import Language.Nomyx.Expression+import Data.List+import Control.Applicative
+import Control.Exception+import Data.Time++          
 -- | this function will return just a if it can cast it to an a.
 maybeRead :: Read a => String -> Maybe a
@@ -31,12 +41,6 @@         -> [a] -- ^ Output list
 replace x y = map (\z -> if z == x then y else z)
 --- | Replaces all instances of a value in a list by another value.
-replaceWith :: (a -> Bool)   -- ^ Value to search
-        -> a   -- ^ Value to replace it with
-        -> [a] -- ^ Input list
-        -> [a] -- ^ Output list
-replaceWith f y = map (\z -> if f z then y else z) 
 
 yes = ["o", "oui", "y", "yes", "v", "vrai", "true"]
@@ -51,8 +55,75 @@ liftT st = do     s1 <- get     let (a, s) = runState st s1-    --lift $ putStrLn $ "putting " ++ show s     put s     return a+++findPlayer :: PlayerName -> State Multi (Maybe PlayerMulti)+findPlayer name = find (\PlayerMulti {mPlayerName = pname} -> pname==name) <$> gets mPlayers++findPlayer' :: PlayerNumber -> State Multi (Maybe PlayerMulti)+findPlayer' pn = find (\PlayerMulti {mPlayerNumber} -> pn==mPlayerNumber) <$> gets mPlayers++nomyxURL :: Network -> String+nomyxURL (Network host port) = "http://" ++ host ++ ":" ++ (show port)++getPlayersName :: PlayerNumber -> Multi -> PlayerName+getPlayersName pn multi = do+   case find (\(PlayerMulti n _ _ _ _ _) -> n==pn) (mPlayers multi) of+      Nothing -> error "getPlayersName: No player by that number"+      Just pm -> mPlayerName pm++getPlayersName' :: Game -> PlayerNumber -> PlayerName+getPlayersName' g pn = do+   case find (\(PlayerInfo n _) -> n==pn) (players g) of+      Nothing -> error "getPlayersName: No player by that number in that game"+      Just pm -> playerName pm++-- | returns the game the player is in+getPlayersGame :: PlayerNumber -> Multi -> Maybe Game+getPlayersGame pn multi = do+        pi <- find (\(PlayerMulti n _ _ _ _ _) -> n==pn) (mPlayers multi)+        gn <- inGame pi+        find (\(Game {gameName=name}) -> name==gn) (games multi)++getPlayersNameMay :: Game -> PlayerNumber -> Maybe PlayerName+getPlayersNameMay g pn = do+   case find (\(PlayerInfo n _) -> n==pn) (players g) of+      Nothing -> Nothing+      Just pm -> Just $ playerName pm++commandExceptionHandler :: Maybe PlayerNumber -> Multi -> ErrorCall -> IO Multi+commandExceptionHandler mpn m e = do+   putStrLn $ "Exception in rule: " ++ (show e)+   case mpn of+      Just pn -> do+         let g = fromJust $ getPlayersGame pn m+         let g' = execState (output ("Error in command: " ++ (show e)) pn) g+         return $ execState (modifyGame g') m+      Nothing -> return m+++-- | finds the corresponding game in the multistate and replaces it.+modifyGame :: Game -> State Multi ()+modifyGame g = do+   m@(Multi {games=gs}) <- get+   case find (\myg -> gameName g == gameName myg) gs of+      Nothing -> error "modifyGame: No game by that name"+      Just oldg -> do+         let newgs = replace oldg g gs+         put (m {games=newgs})++output :: String -> PlayerNumber -> State Game ()+output s pn = modify (\game -> game { outputs = (pn, s) : (outputs game)})++outputAll :: String -> State Game ()
+outputAll s = gets players >>= mapM_ ((output s) . playerNumber)+++execWithMulti :: UTCTime -> StateT Multi IO () -> Multi -> IO Multi+execWithMulti t ms m = do+   let m' = m { games = map (\g -> g {currentTime = t}) (games m)}+   execStateT ms m'  

@@ -1,502 +0,0 @@--{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, TemplateHaskell,-   EmptyDataDecls, TypeFamilies, MultiParamTypeClasses, DeriveDataTypeable, PackageImports, GADTs,-   ScopedTypeVariables, NamedFieldPuns, Rank2Types, DoAndIfThenElse, StandaloneDeriving, OverloadedStrings#-}--module Web (launchWebServer) where--import Prelude hiding (div)-import Text.Blaze.Html5 hiding (map)-import Text.Blaze.Html5.Attributes hiding (dir)-import qualified Text.Blaze.Html5 as H-import qualified Text.Blaze.Html5.Attributes as A-import Web.Routes.Site-import Web.Routes.PathInfo-import Web.Routes.Happstack-import Web.Routes.RouteT-import Web.Routes.TH (derivePathInfo)-import Text.Blaze.Internal-import Game-import Multi-import Control.Monad-import Paths_Nomyx as PN-import Paths_Nomyx_Rules as PNR-import Control.Monad.State-import Data.Monoid-import Data.String-import Control.Concurrent.STM-import Language.Haskell.Interpreter.Server-import Language.Nomyx.Expression-import Language.Nomyx.Evaluation-import Utils-import Data.Maybe-import Text.Reform.Happstack-import Text.Reform-import Forms-import Data.Text hiding (concat, map, filter, concatMap, length, intersperse)-import Happstack.Server-import Data.List-import System.Directory-import System.FilePath-import System.Posix.Files-import qualified Help-import Network.BSD---- | associate a player number with a handle-data PlayerClient = PlayerClient PlayerNumber deriving (Eq, Show)---- | A structure to hold the active games and players-data Server = Server [PlayerClient] deriving (Eq, Show)-type Port = Int--data PlayerCommand = Login-                   | PostLogin-                   | Noop            PlayerNumber-                   | JoinGame        PlayerNumber GameName-                   | LeaveGame       PlayerNumber-                   | SubscribeGame   PlayerNumber GameName-                   | UnsubscribeGame PlayerNumber GameName-                   | DoInputChoice   PlayerNumber EventNumber-                   | DoInputString   PlayerNumber String-                   | NewRule-                   | NewGame-                   | Upload PlayerNumber-                   deriving (Show)--$(derivePathInfo ''PlayerCommand)--instance PathInfo Bool where-  toPathSegments i = [pack $ show i]-  fromPathSegments = pToken (const "bool") (checkBool . show)-   where checkBool str =-           case reads str of-             [(n,[])] -> Just n-             _ ->        Nothing--modDir = "modules"--type NomyxServer       = ServerPartT IO-type RoutedNomyxServer = RouteT PlayerCommand NomyxServer---nomyxSite :: ServerHandle -> (TVar Multi) -> Site PlayerCommand (ServerPartT IO Html)-nomyxSite sh tm = setDefault Login $ mkSitePI (runRouteT $ routedNomyxCommands sh tm)--viewGame :: Game -> PlayerNumber -> RoutedNomyxServer Html-viewGame g pn = do-   rf <- ruleForm pn-   vi <- viewInputs pn $ events g-   ok $ table $ do-      td ! A.id "gameCol" $ do-         table $ do-            tr $ td $ h3 $ string $ "Viewing game: " ++ gameName g  --div ! A.id "gameName"-            tr $ td $ viewPlayers $ players g -- div ! A.id "citizens"-            tr $ td $ viewVictory g --  div ! A.id "victory"-      td ! A.id "gameElem" $ do-         table $ do-         tr $ td $ div ! A.id "rules" $ viewAllRules g-         tr $ td $ div ! A.id "inputs" ! A.title (toValue Help.inputs) $ vi-         tr $ td $ div ! A.id "events" ! A.title (toValue Help.events) $ viewEvents $ events g-         tr $ td $ div ! A.id "variables" ! A.title (toValue Help.variables)$ viewVars $ variables g-         tr $ td $ div ! A.id "newRule" $ rf-         tr $ td $ div ! A.id "outputs" ! A.title (toValue Help.outputs)$ viewOutput (outputs g) pn--viewPlayers :: [PlayerInfo] -> Html-viewPlayers pis = do-   h5 "Players in game:"-   table $ mapM_ viewPlayer (sort pis)---viewPlayer :: PlayerInfo -> Html-viewPlayer pi = tr $ do-    td $ string $ show $ playerNumber pi-    td $ string $ playerName pi--viewVictory :: Game -> Html-viewVictory g = do-    let vs = map (getPlayersName' g) (victory g)-    case length vs of-        0 -> br-        _ -> h3 $ string $ "Player(s) " ++ (concat $ intersperse " " $ vs) ++ " won the game!"--viewAllRules :: Game -> Html-viewAllRules g = do-   h3 "Rules"-   viewRules "Active rules:" (activeRules g) ! (A.title $ toValue Help.actives)-   viewRules "Pending rules:" (pendingRules g) ! (A.title $ toValue Help.pendings)-   viewRules "Suppressed rules:" $ rejectedRules g--viewRules :: Html -> [Rule] -> Html-viewRules _ [] = return ()-viewRules title nrs = do-   table ! A.class_ "table" $ do-      caption $ h4 title-      thead $ do-         td ! A.class_ "td" $ text "Number"-         td ! A.class_ "td" $ text "Name"-         td ! A.class_ "td" $ text "Description"-         td ! A.class_ "td" $ text "Proposed by"-         td ! A.class_ "td" $ text "Code of the rule"-         td ! A.class_ "td" $ text "Assessed by"-      forM_ nrs viewRule--viewRule :: Rule -> Html-viewRule nr = tr $ do-   td ! A.class_ "td" $ string . show $ rNumber nr-   td ! A.class_ "td" $ string $ rName nr-   td ! A.class_ "td" $ string $ rDescription nr-   td ! A.class_ "td" $ string $ if rProposedBy nr == 0 then "System" else "Player " ++ (show $ rProposedBy nr)-   td ! A.class_ "td" $ string $ rRuleCode nr-   td ! A.class_ "td" $ string $ case rAssessedBy nr of-      Nothing -> "Not assessed"-      Just 0  -> "System"-      Just a  -> "Rule " ++ (show $ a)--viewEvents :: [EventHandler] -> Html-viewEvents [] = h3 "Events" >> h5 "No Events"-viewEvents ehs = do-   h3 "Events"-   table ! A.class_ "table" $ do-      thead $ do-         td ! A.class_ "td" $ text "Event Number"-         td ! A.class_ "td" $ text "By Rule"-         td ! A.class_ "td" $ text "Event"-      mapM_ viewEvent $ sort ehs--viewEvent :: EventHandler -> Html-viewEvent (EH eventNumber ruleNumber event _) = tr $ do-   td ! A.class_ "td" $ string . show $ eventNumber-   td ! A.class_ "td" $ string . show $ ruleNumber-   td ! A.class_ "td" $ string . show $ event--viewInputs :: PlayerNumber -> [EventHandler] -> RoutedNomyxServer Html-viewInputs pn ehs = do-   mis <- mapM (viewInput pn) $ sort ehs-   let is = catMaybes mis-   case length is of-      0 -> ok $ h3 "Inputs" >> h5 "No Inputs"-      _ -> ok $ do-         h3 "Inputs"-         table $ do-            mconcat is--viewInput :: PlayerNumber -> EventHandler -> RoutedNomyxServer (Maybe Html)-viewInput me (EH eventNumber _ (InputChoice pn title choices def) _) | me == pn = do-    link <- showURL (DoInputChoice pn eventNumber)-    lf  <- lift $ viewForm "user" $ inputChoiceForm title (map show choices) (show def)-    return $ Just $ tr $ td $ blazeForm lf (link)-viewInput me (EH _ _ (InputString pn title) _) | me == pn = do-    link <- showURL (DoInputString pn title)-    lf  <- lift $ viewForm "user" $ inputStringForm title-    return $ Just $ tr $ td $ blazeForm lf (link)-viewInput _ _ = return Nothing--viewVars :: [Var] -> Html-viewVars [] = h3 "Variables" >> h5 "No Variables"-viewVars vs = do-   h3 "Variables"-   table ! A.class_ "table" $ do-      thead $ do-         td ! A.class_ "td" $ text "Rule number"-         td ! A.class_ "td" $ text "Name"-         td ! A.class_ "td" $ text "Value"-      mapM_ viewVar vs--viewVar :: Var -> Html-viewVar (Var vRuleNumber vName vData) = tr $ do-   td ! A.class_ "td" $ string . show $ vRuleNumber-   td ! A.class_ "td" $ string . show $ vName-   td ! A.class_ "td" $ string . show $ vData---ruleForm :: PlayerNumber -> RoutedNomyxServer Html-ruleForm pn = do-   link <- showURL NewRule-   ok $ do-      h3 "Propose a new rule:"-      H.form ! A.method "POST" ! A.action (toValue link) ! enctype "multipart/form-data;charset=UTF-8"  $ do-      H.label ! A.for "name" $ "Name: "-      input ! type_ "text" ! name "name" ! A.id "name" ! tabindex "1" ! accesskey "N"-      H.label ! A.for "text" $ "      Short description: "-      input ! type_ "text" ! name "description" ! A.id "description" ! tabindex "2" ! accesskey "T"-      H.br-      H.label ! A.for "text" $ "Code: "-      textarea ! name "code" ! A.id "code" ! tabindex "3" ! accesskey "C" ! A.placeholder "Enter here your rule" !-       A.title (toValue Help.code) $ ""-      input ! type_ "hidden" ! name "pn" ! value (fromString $ show pn)-      input ! type_  "submit" ! tabindex "4" ! accesskey "S" ! value "Submit rule!"--viewOutput :: [Output] -> PlayerNumber -> Html-viewOutput [] _ = h3 "Output" >> h5 "No Output"-viewOutput os pn = do-   h3 "Output"-   let myos = map snd $ filter (\o -> fst o == pn) os-   mapM_ viewMessages [myos]--viewMessages :: [String] -> Html-viewMessages = mapM_ (\s -> string s >> br)---viewMulti :: PlayerNumber -> Multi -> RoutedNomyxServer Html-viewMulti pn m = do-   gns <- viewGamesTab pn (games m)-   g <- case getPlayersGame pn m of-            Just g -> viewGame g pn-            Nothing -> ok $ h3 "Not in game"-   ok $ do-      div ! A.id "gameList" $ gns-      div ! A.id "game" $ g--viewGamesTab :: PlayerNumber -> [Game] -> RoutedNomyxServer Html-viewGamesTab pn gs = do-   gns <- mapM (viewGameName pn) gs-   ng <- newGameForm pn-   link <- showURL (Upload pn)-   up  <- lift $ viewForm "user" uploadForm-   dd <- lift $ lift $ PN.getDataDir-   mods <- lift $ lift $ getDirectoryContents $ dd </> modDir-   fmods <- lift $ lift $ filterM (getFileStatus . (\f -> joinPath [dd, modDir, f]) >=> return . isRegularFile) $ mods-   ok $ do-      h3 "Games:"-      table $ do-         case gs of-            [] -> tr $ td "No Games"-            _ ->  sequence_ gns-      br >> "Create a new game:"-      ng-      br >> "Rule language files:" >> br-      H.a "Rules examples" ! (href $ "/examples/Examples.hs") >> br-      H.a "Rules definitions" ! (href $ "/src/Language/Nomyx/Rule.hs") >> br-      H.a "Rules types" ! (href $ "/src/Language/Nomyx/Expression.hs") >> br-      mapM_ (\f -> (H.a $ toHtml f ) ! (href $ toValue (pathSeparator : modDir </> f)) >> br) fmods-      br >> "Upload new rules file:" >> br-      blazeForm up (link) ! (A.title $ toValue Help.upload)--viewGameName :: PlayerNumber -> Game -> RoutedNomyxServer Html-viewGameName pn g = do-   let gn = gameName g-   join <- showURL (JoinGame pn gn)-   leave <- showURL (LeaveGame pn)-   --subscribe <- showURL (SubscribeGame pn gn)-   unsubscribe <- showURL (UnsubscribeGame pn gn)-   ok $ do-      tr $ do-         td $ string $ gn-         td $ H.a "Join" ! (href $ toValue join)-         td $ H.a "Leave" ! (href $ toValue leave)-         --td $ H.a "Subscribe" ! (href $ toValue subscribe)-         td $ H.a "Unsubscribe" ! (href $ toValue unsubscribe)--newGameForm :: PlayerNumber -> RoutedNomyxServer Html-newGameForm pn = do-   link <- showURL NewGame-   ok $ H.form ! A.method "POST" ! A.action (toValue link) ! enctype "multipart/form-data;charset=UTF-8"  $ do-      input ! type_ "text" ! name "name" ! A.id "name" ! tabindex "1" ! accesskey "G" ! A.title "Game name"-      input ! type_ "hidden" ! name "pn" ! value (fromString $ show pn)-      input ! type_  "submit" ! tabindex "2" ! accesskey "S" ! value "Create New Game!"---nomyxPage :: Multi -> PlayerNumber -> RoutedNomyxServer Html-nomyxPage multi pn = do-   m <- viewMulti pn multi-   ok $ do-      H.html $ do-        H.head $ do-          H.title "Welcome to Nomyx!"-          H.link ! rel "stylesheet" ! type_ "text/css" ! href "/static/css/nomyx.css"-          H.meta ! A.httpEquiv "Content-Type" ! content "text/html;charset=utf-8"-          H.meta ! A.name "keywords" ! A.content "Nomyx, game, rules, Haskell, auto-reference"-          --H.meta ! A.httpEquiv "refresh" ! A.content "3"-        H.body $ do-          H.div ! A.id "container" $ do-             H.div ! A.id "header" $ string $ "Welcome to Nomyx, " ++ (getPlayersName pn multi) ++ "!"-             H.div ! A.id "multi" $ m---loginPage :: RoutedNomyxServer Html-loginPage = do-   link <- showURL PostLogin-   lf  <- lift $ viewForm "user" loginForm-   ok $ H.html $ do-      H.head $ do-        H.title "Login to Nomyx"-        H.link ! rel "stylesheet" ! type_ "text/css" ! href "/static/css/nomyx.css"-        H.meta ! A.httpEquiv "Content-Type" ! content "text/html;charset=utf-8"-        H.meta ! A.name "keywords" ! A.content "Nomyx, game, rules, Haskell, auto-reference"-      H.body $ do-        H.div ! A.id "container" $ do-           H.div ! A.id "header" $ "Login to Nomyx"-           H.div ! A.id "login" $ blazeForm lf (link)-           H.div ! A.id "footer" $ string "Copyright Corentin Dupont 2012"---routedNomyxCommands :: ServerHandle -> (TVar Multi) -> PlayerCommand -> RoutedNomyxServer Html-routedNomyxCommands _ _  (Login)                     = loginPage-routedNomyxCommands _ tm (PostLogin)                 = postLogin tm-routedNomyxCommands _ tm (Noop pn)                   = nomyxPageComm pn tm (return ())-routedNomyxCommands _ tm (JoinGame pn game)          = nomyxPageComm pn tm (joinGame game pn)-routedNomyxCommands _ tm (LeaveGame pn)              = nomyxPageComm pn tm (leaveGame pn)-routedNomyxCommands _ tm (SubscribeGame pn game)     = nomyxPageComm pn tm (subscribeGame game pn)-routedNomyxCommands _ tm (UnsubscribeGame pn game)   = nomyxPageComm pn tm (unsubscribeGame game pn)-routedNomyxCommands sh tm (NewRule)                  = newRule sh tm-routedNomyxCommands _ tm (NewGame)                   = newGameWeb tm-routedNomyxCommands _ tm (DoInputChoice pn en)       = newInputChoice pn en tm-routedNomyxCommands _ tm (DoInputString pn en)       = newInputString pn en tm-routedNomyxCommands sh tm (Upload pn)                = newUpload pn sh tm----execute the given instructions (Comm) and embed the result in a web page-nomyxPageComm :: PlayerNumber -> (TVar Multi) -> StateT Multi IO () -> RoutedNomyxServer Html-nomyxPageComm pn tm comm = execCommand tm comm >> nomyxPageServer pn tm--execCommand :: (TVar Multi) -> StateT Multi IO a -> RoutedNomyxServer a-execCommand tm sm = do-    m <- liftRouteT $ lift $ atomically $ readTVar tm-    (a, m') <- liftRouteT $ lift $ runStateT sm m-    liftRouteT $ lift $ atomically $ writeTVar tm m'-    return a---newRule :: ServerHandle -> (TVar Multi) -> RoutedNomyxServer Html-newRule sh tm = do-   methodM POST -- only accept a post method-   mbEntry <- getData -- get the data-   case mbEntry of-      Left a -> error $ "error: newRule " ++ (concat a)-      Right (NewRuleForm name text code pn) -> do-         --debugM ("Rule submitted: name =" ++ name ++ "\ntext=" ++ text ++ "\ncode=" ++ code ++ "\npn=" ++ (show pn))-         nomyxPageComm pn tm (submitRule name text code pn sh)---newGameWeb :: (TVar Multi) -> RoutedNomyxServer Html-newGameWeb tm = do-   methodM POST-   mbEntry <- getData-   case mbEntry of-      Left a                      -> error $ "error: newGame" ++ (concat a)-      Right (NewGameForm name pn) -> nomyxPageComm pn tm (newGame name pn)--newInputChoice :: PlayerNumber -> EventNumber -> (TVar Multi) -> RoutedNomyxServer Html-newInputChoice pn en tm = do-    multi <- liftRouteT $ lift $ atomically $ readTVar tm-    let mg = fromJust $ getPlayersGame pn multi-    let eventHandler = fromJust $ findEvent en (events mg)-    methodM POST-    let (title, choices, def) = getChoices eventHandler-    r <- liftRouteT $ eitherForm environment "user" (inputChoiceForm title choices def)-    link <- showURL $ Noop pn-    case r of-       (Right c) -> do-          liftRouteT $ lift $ putStrLn $ "choice:" ++ (show c)-          execCommand tm $ inputChoiceResult en c pn-          seeOther link $ string "Redirecting..."-       (Left _) -> do-          liftRouteT $ lift $ putStrLn $ "cannot retrieve form data"-          seeOther link $ string "Redirecting..."--getChoices :: EventHandler -> (String, [String], String)-getChoices (EH _ _ (InputChoice _ title choices def) _) = (title, map show choices, show def)-getChoices _ = error "InputChoice event expected"--newInputString :: PlayerNumber -> String -> (TVar Multi) -> RoutedNomyxServer Html-newInputString pn title tm = do-    methodM POST-    r <- liftRouteT $ eitherForm environment "user" (inputStringForm title)-    link <- showURL $ Noop pn-    case r of-       (Right c) -> do-          liftRouteT $ lift $ putStrLn $ "entered:" ++ (show c)-          execCommand tm $ inputStringResult (InputString pn title) c pn-          seeOther link $ string "Redirecting..."-       (Left _) -> do-          liftRouteT $ lift $ putStrLn $ "cannot retrieve form data"-          seeOther link $ string "Redirecting..."--newUpload :: PlayerNumber -> ServerHandle -> (TVar Multi) -> RoutedNomyxServer Html-newUpload pn sh tm = do-    methodM POST-    r <- liftRouteT $ eitherForm environment "user" uploadForm-    link <- showURL $ Noop pn-    case r of-       (Right (path,name,content)) -> do-          lift $ lift $ putStrLn $ "Upload entered:" ++ (show path) ++ " " ++ (show name) ++ " " ++ (show content)-          execCommand tm $ inputUpload pn path name sh-          seeOther link $ string "Redirecting..."-       (Left _) -> do-          liftRouteT $ lift $ putStrLn $ "cannot retrieve form data"-          seeOther link $ string "Redirecting..."--nomyxPageServer :: PlayerNumber -> (TVar Multi) -> RoutedNomyxServer Html-nomyxPageServer pn tm = do-   multi <- liftRouteT $ lift $ atomically $ readTVar tm-   nomyxPage multi pn---postLogin :: (TVar Multi) -> RoutedNomyxServer Html-postLogin tm = do-    methodM POST-    r <- liftRouteT $ eitherForm environment "user" loginForm-    case r of-       (Right (LoginPass login password)) -> do-          liftRouteT $ lift $ putStrLn $ "login:" ++ login-          liftRouteT $ lift $ putStrLn $ "password:" ++ password-          mpn <- execCommand tm $ newPlayerWeb login password-          case mpn of-             Just pn -> do-                link <- showURL $ Noop pn-                seeOther link $ string "Redirecting..."-             Nothing -> error "cannot login"-       (Left _) -> seeOther ("/Login?status=fail" :: String) $ string "Redirecting..."---newPlayerWeb :: PlayerName -> PlayerPassword -> StateT Multi IO (Maybe PlayerNumber)-newPlayerWeb name pwd = do-   --find that name among the list-   mpn <- findPlayer name-   case mpn of-      Just pl -> do-         say $ "Trying name:" ++ mPlayerName pl-         case pwd == mPassword pl of-            True -> do-               say "password OK"-               return $ Just $ mPlayerNumber pl-            False -> do-               say "password false"-               return Nothing-      Nothing -> do-         say "New player"-         --add the new player to the list-         pn <- getNewPlayerNumber-         newPlayerU PlayerMulti { mPlayerNumber = pn, mPlayerName = name, mPassword = pwd, inGame = Nothing}-         return (Just pn)---launchWebServer :: ServerHandle -> (TVar Multi) -> HostName -> Port -> IO ()-launchWebServer sh tm host portNumber = do-   putStrLn $ "Starting web server...\nTo connect, drive your browser to \"http://" ++ host ++ ":" ++ (show portNumber) ++ "/Login\""-   d <- PN.getDataDir-   d' <- PNR.getDataDir-   simpleHTTP nullConf {port=portNumber} $ server d d' sh tm host portNumber----serving Nomyx web page as well as data from this package and the language library package-server :: FilePath -> FilePath -> ServerHandle -> (TVar Multi) -> HostName -> Port -> NomyxServer Response-server d d' sh tm host port = mconcat [-    serveDirectory EnableBrowsing [] d,-    serveDirectory EnableBrowsing [] d', do-       decodeBody (defaultBodyPolicy "/tmp/" 102400 4096 4096)-       html <- implSite (pack ("http://" ++ host ++ ":" ++ (show port))) "/Login" (nomyxSite sh tm)-       return $ toResponse html]--instance FromData NewRuleForm where-  fromData = do-    name  <- look "name" `mplus` (error "need rule name")-    text <-  look "description" `mplus` (error "need rule text")-    code <-  look "code" `mplus` (error "need rule code")-    pn <- lookRead "pn" `mplus` (error "need player number")-    return $ NewRuleForm name text code pn--instance FromData NewGameForm where-  fromData = do-    name  <- look "name" `mplus` (error "need rule name")-    pn <- lookRead "pn" `mplus` (error "need player number")-    return $ NewGameForm name pn-

@@ -0,0 +1,133 @@+{-# LANGUAGE TemplateHaskell, OverloadedStrings, GADTs, ScopedTypeVariables#-}++module Web.Common where+++import Prelude hiding (div, catch)+import Text.Blaze.Html5 hiding (map, output)+import Text.Blaze.Html5.Attributes hiding (dir, id)+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A+import Web.Routes.PathInfo+import Web.Routes.RouteT+import Web.Routes.TH (derivePathInfo)+import Control.Monad.State+import Control.Concurrent.STM+import Language.Nomyx.Expression+import Happstack.Server+import Types+import qualified Data.ByteString.Char8 as C+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)+import Text.Reform.Happstack()+import Text.Reform+import Text.Reform.Blaze.String()+import Text.Reform.Happstack()+import qualified Text.Reform.Generalized as G+import Data.Text(Text, pack)+import Web.Routes.Happstack()+import Data.Time+import Serialize+default (Integer, Double, Data.Text.Text)+++data LoginPass = LoginPass { login :: PlayerName,+                             password :: PlayerPassword}+                             deriving (Show, Eq)+++-- | associate a player number with a handle+data PlayerClient = PlayerClient PlayerNumber deriving (Eq, Show)++-- | A structure to hold the active games and players+data Server = Server [PlayerClient] deriving (Eq, Show)+++data PlayerCommand = Login+                   | PostLogin+                   | NewPlayer       LoginPass+                   | NewPlayerLogin  LoginPass+                   | Noop            PlayerNumber+                   | JoinGame        PlayerNumber GameName+                   | LeaveGame       PlayerNumber+                   | SubscribeGame   PlayerNumber GameName+                   | UnsubscribeGame PlayerNumber GameName+                   | DoInputChoice   PlayerNumber EventNumber+                   | DoInputString   PlayerNumber String+                   | NewRule         PlayerNumber+                   | NewGame         PlayerNumber+                   | SubmitNewGame   PlayerNumber+                   | Upload          PlayerNumber+                   | Settings        PlayerNumber+                   | SubmitSettings  PlayerNumber+                   deriving (Show)++$(derivePathInfo ''PlayerCommand)+$(derivePathInfo ''LoginPass)++instance PathInfo Bool where+  toPathSegments i = [pack $ show i]+  fromPathSegments = pToken (const "bool") (checkBool . show)+   where checkBool str =+           case reads str of+             [(n,[])] -> Just n+             _ ->        Nothing++modDir :: FilePath+modDir = "modules"++type NomyxServer       = ServerPartT IO+type RoutedNomyxServer = RouteT PlayerCommand NomyxServer+++evalCommand :: (TVar Multi) -> State Multi a -> RoutedNomyxServer a+evalCommand tm sm = do+    m <- liftRouteT $ lift $ atomically $ readTVar tm+    return $ evalState sm m+++webCommand :: (TVar Multi) -> PlayerNumber -> MultiEvent -> RoutedNomyxServer ()+webCommand tm pn me = liftRouteT $ lift $ do+   t <- getCurrentTime+   m <- atomically $ readTVar tm+   m' <- execStateT (update (TE t me) (Just pn)) m+   atomically $ writeTVar tm m'+++blazeResponse :: Html -> Response+blazeResponse html = toResponseBS (C.pack "text/html;charset=UTF-8") $ renderHtml html++blazeForm :: Html -> Text -> Html+blazeForm html link =+    H.form ! A.action (toValue link)+         ! A.method "POST"+         ! A.enctype "multipart/form-data" $+            do html+               input ! A.type_ "submit" ! A.value "Submit"++-- | Create a group of radio elements without BR between elements+inputRadio' :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, ToMarkup lbl) =>+              [(a, lbl)]  -- ^ value, label, initially checked+           -> (a -> Bool) -- ^ isDefault+           -> Form m input error Html () a+inputRadio' choices isDefault =+    G.inputChoice isDefault choices mkRadios+    where+      mkRadios nm choices' = mconcat $ concatMap (mkRadio nm) choices'+      mkRadio nm (i, val, lbl, checked) =+          [ ((if checked then (! A.checked "checked") else id) $+             input ! A.type_ "radio" ! A.id (toValue i) ! A.name (toValue nm) ! A.value (toValue val))+          , " ", H.label ! A.for (toValue i) $ toHtml lbl]++mainPage :: Html -> Html -> Html -> Bool -> RoutedNomyxServer Html+mainPage body title header footer = do+   ok $ H.html $ do+      H.head $ do+        H.title title+        H.link ! rel "stylesheet" ! type_ "text/css" ! href "/static/css/nomyx.css"+        H.meta ! A.httpEquiv "Content-Type" ! content "text/html;charset=utf-8"+        H.meta ! A.name "keywords" ! A.content "Nomyx, game, rules, Haskell, auto-reference"+      H.body $ do+        H.div ! A.id "container" $ do+           H.div ! A.id "header" $ header+           body+           when footer $ H.div ! A.id "footer" $ "Copyright Corentin Dupont 2012-2013"

@@ -0,0 +1,259 @@++{-# LANGUAGE GADTs, OverloadedStrings, ExtendedDefaultRules#-}++module Web.Game where++import Prelude hiding (div)+import Text.Blaze.Html5 hiding (map)+import qualified Text.Blaze.Html5.Attributes as A+import Web.Routes.RouteT+import Text.Blaze.Internal+import Game+import Control.Monad+import Control.Monad.State+import Data.Monoid+import Control.Concurrent.STM+import Language.Nomyx.Expression+import Language.Nomyx.Evaluation+import Data.Maybe+import Text.Reform.Happstack+import Text.Reform+import Happstack.Server+import Data.List+import qualified Web.Help as Help+import Web.Common+import Types+import Web.Routes.Happstack()+import qualified Text.Reform.Blaze.String as RB hiding (form)+import Control.Applicative+import Utils+import Mail+import Data.Text(Text)+import qualified Text.Reform.Blaze.Common as RBC+default (Integer, Double, Data.Text.Text)+++viewGame :: Game -> PlayerNumber -> (Maybe SubmitRule) -> RoutedNomyxServer Html+viewGame g pn sr = do+   rf <- viewRuleForm pn sr+   vi <- viewInputs pn $ events g+   ok $ table $ do+      td ! A.id "gameCol" $ do+         table $ do+            tr $ td $ h3 $ string $ "Viewing game: " ++ gameName g+            tr $ td $ (string $ "Description: " ++ gameDesc g ++ "\n\n") >> br >> br+            tr $ td $ viewPlayers $ players g+            tr $ td $ viewVictory g+      td ! A.id "gameElem" $ do+         table $ do+         tr $ td $ div ! A.id "rules" $ viewAllRules g+         tr $ td $ div ! A.id "inputs" ! A.title (toValue Help.inputs) $ vi+         tr $ td $ div ! A.id "events" ! A.title (toValue Help.events) $ viewEvents $ events g+         tr $ td $ div ! A.id "variables" ! A.title (toValue Help.variables)$ viewVars $ variables g+         tr $ td $ div ! A.id "newRule" $ rf+         tr $ td $ div ! A.id "outputs" ! A.title (toValue Help.outputs)$ viewOutput (outputs g) pn++viewPlayers :: [PlayerInfo] -> Html+viewPlayers pis = do+   h5 "Players in game:"+   table $ mapM_ viewPlayer (sort pis)+++viewPlayer :: PlayerInfo -> Html+viewPlayer pi = tr $ do+    td $ string $ show $ playerNumber pi+    td $ string $ playerName pi++viewVictory :: Game -> Html+viewVictory g = do+    let vs = mapMaybe (getPlayersNameMay g) (victory g)+    case vs of+        []   -> br+        a:[] -> h3 $ string $ "Player " ++ (show a) ++ " won the game!"+        a:bs -> h3 $ string $ "Players " ++ (concat $ intersperse ", " $ bs) ++ " and " ++ a ++ " won the game!"++viewAllRules :: Game -> Html+viewAllRules g = do+   h3 "Rules"+   viewRules "Active rules:" (activeRules g) ! (A.title $ toValue Help.actives)+   viewRules "Pending rules:" (pendingRules g) ! (A.title $ toValue Help.pendings)+   viewRules "Suppressed rules:" $ rejectedRules g++viewRules :: Html -> [Rule] -> Html+viewRules _ [] = return ()+viewRules title nrs = do+   table ! A.class_ "table" $ do+      caption $ h4 title+      thead $ do+         td ! A.class_ "td" $ text "Number"+         td ! A.class_ "td" $ text "Name"+         td ! A.class_ "td" $ text "Description"+         td ! A.class_ "td" $ text "Proposed by"+         td ! A.class_ "td" $ text "Code of the rule"+         td ! A.class_ "td" $ text "Assessed by"+      forM_ nrs viewRule++viewRule :: Rule -> Html+viewRule nr = tr $ do+   td ! A.class_ "td" $ string . show $ rNumber nr+   td ! A.class_ "td" $ string $ rName nr+   td ! A.class_ "td" $ string $ rDescription nr+   td ! A.class_ "td" $ string $ if rProposedBy nr == 0 then "System" else "Player " ++ (show $ rProposedBy nr)+   td ! A.class_ "td" $ string $ rRuleCode nr+   td ! A.class_ "td" $ string $ case rAssessedBy nr of+      Nothing -> "Not assessed"+      Just 0  -> "System"+      Just a  -> "Rule " ++ (show $ a)++viewEvents :: [EventHandler] -> Html+viewEvents [] = h3 "Events" >> h5 "No Events"+viewEvents ehs = do+   h3 "Events"+   table ! A.class_ "table" $ do+      thead $ do+         td ! A.class_ "td" $ text "Event Number"+         td ! A.class_ "td" $ text "By Rule"+         td ! A.class_ "td" $ text "Event"+      mapM_ viewEvent $ sort ehs++viewEvent :: EventHandler -> Html+viewEvent (EH eventNumber ruleNumber event _) = tr $ do+   td ! A.class_ "td" $ string . show $ eventNumber+   td ! A.class_ "td" $ string . show $ ruleNumber+   td ! A.class_ "td" $ string . show $ event++viewInputs :: PlayerNumber -> [EventHandler] -> RoutedNomyxServer Html+viewInputs pn ehs = do+   mis <- mapM (viewInput pn) $ sort ehs+   let is = catMaybes mis+   case length is of+      0 -> ok $ h3 "Inputs" >> h5 "No Inputs"+      _ -> ok $ do+         h3 "Inputs"+         table $ do+            mconcat is++viewInput :: PlayerNumber -> EventHandler -> RoutedNomyxServer (Maybe Html)+viewInput me (EH eventNumber _ (InputChoice pn title choices def) _) | me == pn = do+    link <- showURL (DoInputChoice pn eventNumber)+    lf  <- lift $ viewForm "user" $ inputChoiceForm title (map show choices) (show def)+    return $ Just $ tr $ td $ blazeForm lf (link)+viewInput me (EH _ _ (InputString pn title) _) | me == pn = do+    link <- showURL (DoInputString pn title)+    lf  <- lift $ viewForm "user" $ inputStringForm title+    return $ Just $ tr $ td $ blazeForm lf (link)+viewInput _ _ = return Nothing++viewVars :: [Var] -> Html+viewVars [] = h3 "Variables" >> h5 "No Variables"+viewVars vs = do+   h3 "Variables"+   table ! A.class_ "table" $ do+      thead $ do+         td ! A.class_ "td" $ text "Rule number"+         td ! A.class_ "td" $ text "Name"+         td ! A.class_ "td" $ text "Value"+      mapM_ viewVar vs++viewVar :: Var -> Html+viewVar (Var vRuleNumber vName vData) = tr $ do+   td ! A.class_ "td" $ string . show $ vRuleNumber+   td ! A.class_ "td" $ string . show $ vName+   td ! A.class_ "td" $ string . show $ vData+++newRuleForm :: (Maybe SubmitRule) -> NomyxForm SubmitRule+newRuleForm (Just sr) = newRuleForm' sr+newRuleForm Nothing = newRuleForm' (SubmitRule "" "" "")++newRuleForm' :: SubmitRule -> NomyxForm SubmitRule+newRuleForm' (SubmitRule name desc code) = pure SubmitRule  <*> RB.label "Name: " ++> (RB.inputText name)+                               <*> RB.label "      Short description: " ++> RB.inputText desc+                               <*> RB.label "      Code: " ++> RB.textarea 80 15 code+                                   `RBC.setAttr` A.class_ "code" `RBC.setAttr` A.placeholder "Enter here your rule" `RBC.setAttr` (A.title (toValue Help.code))+++viewRuleForm :: PlayerNumber -> (Maybe SubmitRule) -> RoutedNomyxServer Html+viewRuleForm pn sr = do+   link <- showURL (NewRule pn)+   lf  <- lift $ viewForm "user" $ newRuleForm sr+   ok $ do+      h3 "Propose a new rule:"+      blazeForm lf (link)++newRule :: PlayerNumber -> (TVar Multi) -> RoutedNomyxServer Html+newRule pn tm = do+   methodM POST+   m <- liftRouteT $ lift $ readTVarIO tm+   r <- liftRouteT $ eitherForm environment "user" (newRuleForm Nothing)+   link <- showURL $ Noop pn+   case r of+       Right sr -> do+          --t <- liftRouteT $ lift $ getCurrentTime+          --liftRouteT $ lift $ putStrLn $ "before: " ++ (show m) ++"\n" ++ (show t) ++"\n"++          --t' <- liftRouteT $ lift $ getCurrentTime+          --liftRouteT $ lift $ putStrLn $ "after: " ++ (show m) ++"\n" ++ (show t') ++"\n"+          webCommand tm pn $ MultiSubmitRule sr pn+          m' <- liftRouteT $ lift $ readTVarIO tm+          let rs = rules $ fromJust $ getPlayersGame pn m+          let rs' = rules $ fromJust $ getPlayersGame pn m'+          when (length rs' > length rs) $ liftRouteT $ lift $ sendMailsNewRule m' sr pn+       (Left _) -> liftRouteT $ lift $ putStrLn $ "cannot retrieve form data"+   seeOther link $ string "Redirecting..."+++viewOutput :: [Output] -> PlayerNumber -> Html+viewOutput [] _ = h3 "Output" >> h5 "No Output"+viewOutput os pn = do+   h3 "Output"+   let myos = map snd $ filter (\o -> fst o == pn) os+   mapM_ viewMessages [myos]++viewMessages :: [String] -> Html+viewMessages = mapM_ (\s -> string s >> br)+++newInputChoice :: PlayerNumber -> EventNumber -> (TVar Multi) -> RoutedNomyxServer Html+newInputChoice pn en tm = do+    multi <- liftRouteT $ lift $ atomically $ readTVar tm+    let mg = fromJust $ getPlayersGame pn multi+    let eventHandler = fromJust $ findEvent en (events mg)+    methodM POST+    let (title, choices, def) = getChoices eventHandler+    r <- liftRouteT $ eitherForm environment "user" (inputChoiceForm title choices def)+    link <- showURL $ Noop pn+    case r of+       (Right c) -> do+          liftRouteT $ lift $ putStrLn $ "choice:" ++ (show c)+          webCommand tm pn $ MultiInputChoiceResult en c pn+          seeOther link $ string "Redirecting..."+       (Left _) -> do+          liftRouteT $ lift $ putStrLn $ "cannot retrieve form data"+          seeOther link $ string "Redirecting..."++getChoices :: EventHandler -> (String, [String], String)+getChoices (EH _ _ (InputChoice _ title choices def) _) = (title, map show choices, show def)+getChoices _ = error "InputChoice event expected"++newInputString :: PlayerNumber -> String -> (TVar Multi) -> RoutedNomyxServer Html+newInputString pn title tm = do+    methodM POST+    r <- liftRouteT $ eitherForm environment "user" (inputStringForm title)+    link <- showURL $ Noop pn+    case r of+       (Right c) -> do+          liftRouteT $ lift $ putStrLn $ "entered:" ++ (show c)+          webCommand tm pn $ MultiInputStringResult title c pn+          seeOther link $ string "Redirecting..."+       (Left _) -> do+          liftRouteT $ lift $ putStrLn $ "cannot retrieve form data"+          seeOther link $ string "Redirecting..."+++inputChoiceForm :: String -> [String] -> String -> NomyxForm Int+inputChoiceForm title choices def = RB.label (title ++ " ") ++> inputRadio' (zip [0..] choices) ((==) $ fromJust $ elemIndex def choices)++inputStringForm :: String -> NomyxForm String+inputStringForm title = RB.label (title ++ " ") ++> RB.inputText ""+

@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+--+-- Module      :  Help+-- Copyright   :+-- License     :  OtherLicense+--+-- Maintainer  :  corentin.dupont@gmail.com+-- Stability   :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Web.Help where+upload = "You can upload your file containing custom rules here. File must be a haskell .hs file containing a module. Once correctly loaded, you will be able to propose the functions in the file as new rules."+code = "This is where you type in your new rule. Its type must be \"RuleFunc\". As a first rule, you can try to type \"nothing\", which is a rule that does nothing. Other examples can be found in the file Examples.hs accessible on the left tab."+actives = "Those rules are active and control the game. Usually, initial rules define how to propose and activate new rules (for example, a democratic vote) and how to win. Of course, this can be changed!"+pendings = "Rules are pending after being proposed by a player. Only another, active rule can activate those rules with instruction \"activateRule\"."+inputs = "Rules can trigger an input to gather data from the player, for example with the instruction \"onInputChoice\"."+events = "Rules can register on events, in order to be triggered when the event happens, for example with the instruction \"onEvent\"."+variables = "Rules can create variables to store data. For example, a rule creating a bank account with instruction \"newVar\" will make a new variable appear here."+outputs = "Rules can display text on players screen, with instruction \"output\"."

@@ -0,0 +1,133 @@+{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules#-}++module Web.Login where+++import Prelude hiding (div)+import Text.Blaze.Html5 hiding (map, label, br)+import Text.Blaze.Html5.Attributes hiding (dir, label)+import qualified Text.Blaze.Html5 as H+import Web.Routes.RouteT+import Text.Blaze.Internal+import Control.Monad.State+import Control.Concurrent.STM+import Language.Nomyx.Expression+import Utils+import Text.Reform.Happstack+import Text.Reform+import Debug.Trace.Helpers+import Happstack.Server+import Types+import Multi --TODO to remove+import Web.Common+import Web.Settings+import Web.Routes.Happstack()+import Control.Applicative+import Text.Reform.Blaze.String hiding (form)+import Data.Text hiding (map, zip, concatMap)+default (Integer, Double, Data.Text.Text)+++loginForm :: Maybe LoginPass -> NomyxForm LoginPass+loginForm (Just (LoginPass login _)) = loginForm' login+loginForm Nothing = loginForm' ""++loginForm' :: String -> NomyxForm LoginPass+loginForm' login = LoginPass <$> br ++> label "Please enter your login and password (if you don't have one, just invent it):" ++> br ++> br+                   ++>  label "Login: " ++> (inputText login) <*> label "    Password: " ++> inputPassword <++ label " "+++loginPage :: RoutedNomyxServer Html+loginPage = do+   link <- showURL PostLogin+   lf  <- lift $ viewForm "user" $ loginForm Nothing+   mainPage (blazeForm lf link)+             "Login to Nomyx"+             "Login to Nomyx"+             True++newPlayerPage :: LoginPass -> RoutedNomyxServer Html+newPlayerPage lp = do+   link <- showURL $ NewPlayerLogin lp+   lf  <- lift $ viewForm "user" $ loginForm (Just lp)+   mf  <- lift $ viewForm "user" $ settingsForm Nothing+   mainPage (do+                lf ! (disabled "")+                H.br >> H.br+                "New Player? Welcome!" >> H.br+                (blazeForm mf link))+             "Login to Nomyx"+             "New Player"+             True+++newPlayerLogin :: (TVar Multi) -> LoginPass -> RoutedNomyxServer Html+newPlayerLogin tm (LoginPass login password) = do+    methodM POST+    liftRouteT $ lift $ putStrLn $ "newPlayerLogin"+    r <- liftRouteT $ eitherForm environment "user" $ settingsForm Nothing+    case r of+       (Right ms) -> do+          mpn <- evalCommand tm $ checkLoginWeb login password+          case mpn of+             LoginOK pn -> do+                link <- showURL $ Noop pn+                webCommand tm pn $ MultiMailSettings ms pn+                seeOther link $ string "Redirecting..."+             WrongPassword -> do+                link <- showURL $ Login+                seeOther link $ string "Redirecting..."+             NewLogin -> do+                pn <- evalCommand tm $ getNewPlayerNumber+                link <- showURL $ Noop pn+                webCommand tm pn $ MultiNewPlayer PlayerMulti { mPlayerNumber = pn, mPlayerName = login, mPassword = password, inGame = Nothing, mMail = defaultMailSettings, lastRule = Nothing}+                webCommand tm pn $ MultiMailSettings ms pn+                seeOther link $ string "Redirecting..."+       (Left _) -> seeOther ("/Login?status=fail" :: String) $ string "Redirecting..."++++postLogin :: (TVar Multi) -> RoutedNomyxServer Html+postLogin tm = do+    methodM POST+    r <- liftRouteT $ eitherForm environment "user" $ loginForm Nothing+    case r of+       (Right lp) -> checkLoginPassword lp tm+       (Left _) -> seeOther ("/Login?status=fail" :: String) $ string "Redirecting..."++checkLoginPassword :: LoginPass -> (TVar Multi) -> RoutedNomyxServer Html+checkLoginPassword lp@(LoginPass login password) tm = do+          liftRouteT $ lift $ putStrLn $ "login:" ++ login+          liftRouteT $ lift $ putStrLn $ "password:" ++ password+          mpn <- evalCommand tm $ checkLoginWeb login password+          case mpn of+             LoginOK pn -> do+                link <- showURL $ Noop pn+                seeOther link $ string "Redirecting..."+             WrongPassword -> do+                link <- showURL $ Login+                seeOther link $ string "Redirecting..."+             NewLogin -> do+                link <- showURL $ NewPlayer lp+                seeOther link $ string "Redirecting..."++data LoginResult = LoginOK PlayerNumber | WrongPassword | NewLogin++checkLoginWeb :: PlayerName -> PlayerPassword -> State Multi LoginResult+checkLoginWeb name pwd = do+   mpn <- findPlayer name+   case mpn of+      Just pl -> do+         traceM $ "Trying name:" ++ mPlayerName pl+         case pwd == mPassword pl of+            True -> do+               traceM "password OK"+               return $ LoginOK $ mPlayerNumber pl+            False -> do+               traceM "password false"+               return WrongPassword+      Nothing -> do+         traceM "New player"+         return NewLogin++

@@ -0,0 +1,208 @@++{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, TemplateHaskell,+   EmptyDataDecls, TypeFamilies, MultiParamTypeClasses, DeriveDataTypeable, PackageImports, GADTs,+   ScopedTypeVariables, NamedFieldPuns, Rank2Types, DoAndIfThenElse, StandaloneDeriving, OverloadedStrings, ExtendedDefaultRules#-}++module Web.MainPage (launchWebServer) where++import Prelude hiding (div)+import Text.Blaze.Html5 hiding (map)+import Text.Blaze.Html5.Attributes hiding (dir)+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A+import Web.Routes.Site+import Web.Routes.PathInfo+import Web.Routes.Happstack+import Web.Routes.RouteT+import Text.Blaze.Internal+import Control.Monad+import Paths_Nomyx as PN+import Paths_Nomyx_Rules as PNR+import Control.Monad.State+import Data.Monoid+import Control.Concurrent.STM+import Language.Nomyx.Expression+import Text.Reform.Happstack+import Text.Reform+import Happstack.Server as HS+import System.Directory+import System.FilePath+import System.Posix.Files+import qualified Web.Help as Help+import Types+import Web.Game+import Web.Common+import Web.Login+import Web.Settings+import Web.NewGame+import qualified Text.Reform.Blaze.String as RB+import Utils+import Data.Maybe+import Data.List+import Data.Text(Text, pack)+default (Integer, Double, Data.Text.Text)+++viewMulti :: PlayerNumber -> Multi -> RoutedNomyxServer Html+viewMulti pn m = do+   let pl = fromJust $ find (\PlayerMulti {mPlayerNumber} -> pn==mPlayerNumber) (mPlayers m)+   gns <- viewGamesTab pn (games m)+   g <- case getPlayersGame pn m of+            Just g -> viewGame g pn (lastRule pl)+            Nothing -> ok $ h3 "Not in game"+   ok $ do+      div ! A.id "gameList" $ gns+      div ! A.id "game" $ g++viewGamesTab :: PlayerNumber -> [Game] -> RoutedNomyxServer Html+viewGamesTab pn gs = do+   gns <- mapM (viewGameName pn) gs+   newGameLink <- showURL (NewGame pn)+   uploadLink <- showURL (Upload pn)+   settingsLink <- showURL (Settings pn)+   up  <- lift $ viewForm "user" uploadForm+   dd <- lift $ lift $ PN.getDataDir+   mods <- lift $ lift $ getDirectoryContents $ dd </> modDir+   fmods <- lift $ lift $ filterM (getFileStatus . (\f -> joinPath [dd, modDir, f]) >=> return . isRegularFile) $ mods+   ok $ do+      h3 "Main menu" >> br+      "Active games:" >> br+      table $ do+         case gs of+            [] -> tr $ td "No Games"+            _ ->  sequence_ gns+      br >> "Nomyx language files:" >> br+      H.a "Rules examples" ! (href $ "/src/Language/Nomyx/Examples.hs") >> br+      H.a "Rules definitions" ! (href $ "/src/Language/Nomyx/Rule.hs") >> br+      H.a "Rules types" ! (href $ "/src/Language/Nomyx/Expression.hs") >> br+      mapM_ (\f -> (H.a $ toHtml f ) ! (href $ toValue (pathSeparator : modDir </> f)) >> br) fmods+      br >> "Upload new rules file:" >> br+      blazeForm up (uploadLink) ! (A.title $ toValue Help.upload)+      br >> "Settings:" >> br+      H.a "Create a new game" ! (href $ toValue newGameLink) >> br+      H.a "Player settings" ! (href $ toValue settingsLink) >> br+++viewGameName :: PlayerNumber -> Game -> RoutedNomyxServer Html+viewGameName pn g = do+   let gn = gameName g+   join <- showURL (JoinGame pn gn)+   leave <- showURL (LeaveGame pn)+   --subscribe <- showURL (SubscribeGame pn gn)+   unsubscribe <- showURL (UnsubscribeGame pn gn)+   ok $ do+      tr $ do+         td $ string $ gn+         td $ H.a "Join" ! (href $ toValue join)+         td $ H.a "Leave" ! (href $ toValue leave)+         --td $ H.a "Subscribe" ! (href $ toValue subscribe)+         td $ H.a "Unsubscribe" ! (href $ toValue unsubscribe)++++nomyxPage :: Multi -> PlayerNumber -> RoutedNomyxServer Html+nomyxPage multi pn = do+   m <- viewMulti pn multi+   mainPage (H.div ! A.id "multi" $ m)+             "Welcome to Nomyx!"+             (string $ "Welcome to Nomyx, " ++ (getPlayersName pn multi) ++ "!")+             False++nomyxPageServer :: PlayerNumber -> (TVar Multi) -> RoutedNomyxServer Html+nomyxPageServer pn tm = do+   multi <- liftRouteT $ lift $ atomically $ readTVar tm+   nomyxPage multi pn++nomyxSite :: (TVar Multi) -> Site PlayerCommand (ServerPartT IO Html)+nomyxSite tm = setDefault Login $ mkSitePI (runRouteT $ routedNomyxCommands tm)++routedNomyxCommands :: (TVar Multi) -> PlayerCommand -> RoutedNomyxServer Html+routedNomyxCommands _  (Login)                     = loginPage+routedNomyxCommands _  (NewPlayer lp)              = newPlayerPage lp+routedNomyxCommands tm (NewPlayerLogin lp)         = newPlayerLogin tm lp+routedNomyxCommands tm (PostLogin)                 = postLogin tm+routedNomyxCommands tm (Noop pn)                   = nomyxPageServer pn tm+routedNomyxCommands tm (JoinGame pn game)          = webCommand tm pn (MultiJoinGame game pn)        >> nomyxPageServer pn tm+routedNomyxCommands tm (LeaveGame pn)              = webCommand tm pn (MultiLeaveGame pn)            >> nomyxPageServer pn tm+routedNomyxCommands tm (SubscribeGame pn game)     = webCommand tm pn (MultiSubscribeGame game pn)   >> nomyxPageServer pn tm+routedNomyxCommands tm (UnsubscribeGame pn game)   = webCommand tm pn (MultiUnsubscribeGame game pn) >> nomyxPageServer pn tm+routedNomyxCommands tm (NewRule pn)                = newRule pn tm+routedNomyxCommands _  (NewGame pn)                = newGamePage pn+routedNomyxCommands tm (SubmitNewGame pn)          = newGame pn tm+routedNomyxCommands tm (DoInputChoice pn en)       = newInputChoice pn en tm+routedNomyxCommands tm (DoInputString pn en)       = newInputString pn en tm+routedNomyxCommands tm (Upload pn)                 = newUpload pn tm+routedNomyxCommands tm (Settings pn)               = settings pn tm+routedNomyxCommands tm (SubmitSettings pn)         = newSettings pn tm++++{-+nomyxPageComm' :: PlayerNumber -> (TVar Multi) -> StateT Multi IO () -> RoutedNomyxServer Html+nomyxPageComm' pn tm comm = do+    liftRouteT $ lift $ protectedExecCommand tm comm+    nomyxPageServer pn tm++protectedExecCommand :: (TVar Multi) -> StateT Multi IO a -> IO ()+protectedExecCommand tm sm = do+    --liftIO $ mapM_ (uncurry setResourceLimit) limits+    mv <- newEmptyMVar+    before <- atomically $ readTVar tm+    id <- forkIO $ CE.catchJust  (\e -> if isUserError e then Just () else Nothing) (execBlocking sm before mv) (\e-> putStrLn $ show e)+    forkIO $ watchDog' 10 id mv+    getCurrentTime >>= (\a -> putStrLn $ "before takevar " ++ show a)+    res <- takeMVar mv+    case res of+       Nothing -> (atomically $ writeTVar tm before) >> getCurrentTime >>= (\a -> putStrLn $ "writing before" ++ show a)+       Just (_, after) -> (atomically $ writeTVar tm after) >> getCurrentTime >>= (\a -> putStrLn $ "writing after " ++ show a)++watchDog' :: Int -> ThreadId -> MVar (Maybe x) -> IO ()+watchDog' t tid mv = do+   threadDelay $ t * 1000000+   killThread tid+   getCurrentTime >>= (\a -> putStrLn $ "process timeout " ++ show a)+   tryPutMVar mv Nothing+   return ()++execBlocking :: StateT Multi IO a -> Multi -> MVar (Maybe (a, Multi)) -> IO ()+execBlocking sm m mv = do+   hSetBuffering stdout NoBuffering+   getCurrentTime >>= (\a -> putStrLn $ "before runstate " ++ show a)+   res@(_, m') <- runStateT sm m --runStateT (inPlayersGameDo 1 $ liftT $ evalExp (do let (a::Int) = a in outputAll $ show a) 1) m --+   getCurrentTime >>= (\a -> putStrLn $ "after runstate " ++ show a)+   res' <- evaluate res+   putMVar mv (Just res')+-}+++uploadForm :: NomyxForm (FilePath, FilePath, ContentType)+uploadForm = RB.inputFile++newUpload :: PlayerNumber -> (TVar Multi) -> RoutedNomyxServer Html+newUpload pn tm = do+    methodM POST+    r <- liftRouteT $ eitherForm environment "user" uploadForm+    link <- showURL $ Noop pn+    case r of+       (Right (path,name,_)) -> webCommand tm pn $ MultiInputUpload pn path name+       (Left _) -> liftRouteT $ lift $ putStrLn $ "cannot retrieve form data"+    seeOther link $ string "Redirecting..."+++launchWebServer :: (TVar Multi) -> Network -> IO ()+launchWebServer tm net = do+   putStrLn $ "Starting web server...\nTo connect, drive your browser to \"" ++ nomyxURL net ++ "/Nomyx\""+   d <- PN.getDataDir+   d' <- PNR.getDataDir+   simpleHTTP nullConf {HS.port = Types.port net} $ server d d' tm net++--serving Nomyx web page as well as data from this package and the language library package+server :: FilePath -> FilePath -> (TVar Multi) -> Network -> NomyxServer Response+server d d' tm net = mconcat [+    serveDirectory EnableBrowsing [] d,+    serveDirectory EnableBrowsing [] d', do+       decodeBody (defaultBodyPolicy "/tmp/" 102400 4096 4096)+       html <- implSite (pack (nomyxURL net)) "/Nomyx" (nomyxSite tm)+       return $ toResponse html]++

@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules, OverloadedStrings, NamedFieldPuns#-}+++module Web.NewGame where++import Text.Blaze.Html5 hiding (map, label, br, textarea)+import Prelude hiding (div)+import Text.Reform+import Text.Blaze.Html5.Attributes hiding (label)+import Text.Reform.Blaze.String hiding (form)+import qualified Text.Reform.Blaze.Common as RBC+import Text.Reform.Happstack()+import Control.Applicative+import Types+import Happstack.Server+import Text.Reform.Happstack+import Web.Common+import Control.Monad.State+import Language.Nomyx.Expression+import Web.Routes.RouteT+import Control.Concurrent.STM+import Data.Text(Text)+import Text.Blaze.Internal(string)+default (Integer, Double, Data.Text.Text)+++data NewGameForm = NewGameForm GameName String++newGameForm :: NomyxForm NewGameForm+newGameForm = pure NewGameForm <*> br ++> label "Enter new game name: " ++> (inputText "") `RBC.setAttr` placeholder "Game name"  <++ br <++ br+                               <*> label "Enter game description, including a link to a place (e.g. a forum, a mailing list...) where the players can discuss their rules: " ++> br+                                   ++> (textarea 40 3 "") `RBC.setAttr` placeholder "Enter game description" `RBC.setAttr` class_ "gameDesc"+++newGamePage :: PlayerNumber -> RoutedNomyxServer Html+newGamePage pn = do+   newGameLink <- showURL (SubmitNewGame pn)+   mf <- lift $ viewForm "user" $ newGameForm+   mainPage (blazeForm mf newGameLink)+             "New game"+             "New game"+             False++newGame :: PlayerNumber -> (TVar Multi) -> RoutedNomyxServer Html+newGame pn tm = do+   methodM POST+   r <- liftRouteT $ eitherForm environment "user" newGameForm+   link <- showURL $ Noop pn+   case r of+      Left _ -> error $ "error: newGame"+      Right (NewGameForm name desc) -> webCommand tm pn $ MultiNewGame name desc pn+   seeOther link $ string "Redirecting..."

@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules, OverloadedStrings, NamedFieldPuns#-}+++module Web.Settings where++import Text.Blaze.Html5 hiding (map, label, br)++import Prelude hiding (div)+import Text.Reform+import Text.Reform.Blaze.String hiding (form)+import Text.Reform.Happstack()+import Control.Applicative+import Types+import Happstack.Server+import Text.Reform.Happstack+import Web.Common+import Control.Monad.State+import Language.Nomyx.Expression+import Web.Routes.RouteT+import Utils+import Control.Concurrent.STM+import Data.Maybe+import Data.Text(Text)+import Text.Blaze.Internal(string)+default (Integer, Double, Data.Text.Text)++++settingsForm :: (Maybe MailSettings) -> NomyxForm MailSettings+settingsForm (Just (MailSettings {mailTo, mailNewRule})) = settingsForm' mailTo mailNewRule+settingsForm Nothing = settingsForm' "" True++settingsForm':: String -> Bool -> NomyxForm MailSettings+settingsForm' mailTo mailNewRule = pure MailSettings <*> label "Please enter your mail: " ++> inputText mailTo <++ br+                             <*> pure True --label " send mail on new input needed from you: " ++> inputCheckbox True <++ label " " <++ br+                             <*> inputCheckbox mailNewRule <++ label " I want to be notified by email if a player proposes a new rule (recommended)" <++ br+                             <*> pure True --label " send mail on new output: " ++> inputCheckbox True <++ label " "+                             <*> pure True++settingsPage :: PlayerNumber -> MailSettings -> RoutedNomyxServer Html+settingsPage pn ms = do+   settingsLink <- showURL (SubmitSettings pn)+   mf <- lift $ viewForm "user" $ settingsForm (Just ms)+   mainPage (blazeForm mf settingsLink)+             "Player settings"+             "Player settings"+             False+++settings :: PlayerNumber -> (TVar Multi) -> RoutedNomyxServer Html+settings pn tm  = do+   pm <- evalCommand tm $ findPlayer' pn+   settingsPage pn $ mMail $ fromJust pm+++newSettings :: PlayerNumber -> (TVar Multi) -> RoutedNomyxServer Html+newSettings pn tm = do+   methodM POST+   r <- liftRouteT $ eitherForm environment "user" $ settingsForm Nothing+   link <- showURL $ Noop pn+   case r of+       Right ms -> webCommand tm pn $ MultiMailSettings ms pn+       (Left _) -> liftRouteT $ lift $ putStrLn $ "cannot retrieve form data"+   seeOther link $ string "Redirecting..."