Nomyx (empty) → 0.0.1
raw patch · 18 files changed
+2385/−0 lines, 18 filesdep +DebugTraceHelpersdep +MonadCatchIO-mtldep +Nomyx-Rulessetup-changed
Dependencies added: DebugTraceHelpers, MonadCatchIO-mtl, Nomyx-Rules, QuickCheck, base, binary, blaze-html, blaze-markup, bytestring, containers, directory, eprocess, filepath, happstack-server, hint, hint-server, hslogger, monad-loops, mtl, network, process, reform, reform-blaze, reform-happstack, regular, safe, stm, text, time, unix, utf8-string, web-routes, web-routes-happstack, web-routes-regular, web-routes-th
Files
- AUTHORS +1/−0
- LICENSE +27/−0
- Nomyx.cabal +38/−0
- README +36/−0
- Setup.lhs +6/−0
- TODO +28/−0
- data/static/css/nomyx.css +140/−0
- src/Commands.hs +149/−0
- src/Forms.hs +83/−0
- src/Game.hs +98/−0
- src/Help.hs +23/−0
- src/Interpret.hs +87/−0
- src/Main.hs +118/−0
- src/Multi.hs +332/−0
- src/Server.hs +256/−0
- src/Utils.hs +58/−0
- src/Web.hs +500/−0
- tests/Test.hs +405/−0
+ AUTHORS view
@@ -0,0 +1,1 @@+Corentin Dupont <corentin.dupont@gmail.com>
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright 2012, Corentin Dupont. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of its contributors may be+ used to endorse or promote products derived from this software without+ specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Nomyx.cabal view
@@ -0,0 +1,38 @@+name: Nomyx+version: 0.0.1+cabal-version: >=1.6+build-type: Simple+license: BSD3+license-file: LICENSE+maintainer: corentin.dupont@gmail.com+synopsis: A Nomic game in haskell, featuring automatic, machine-executed rules written by the players+description: A Nomic game in Haskell, with a dedicated language to create new rules.+ .+ Nomyx is a fabulous and strange game where you have the right to change the rules in the middle of the game!+ Indeed, changing the rules is the goal of the game. Changing a rule is considered as a move. Of course even that could be changed! The original (paper) game: www.nomic.net+category: game+author: Corentin Dupont+data-files: static/css/nomyx.css+data-dir: data+extra-source-files: TODO README AUTHORS tests/Test.hs+ +executable Nomyx+ build-depends: DebugTraceHelpers -any, MonadCatchIO-mtl -any,+ Nomyx-Rules -any, QuickCheck -any, base <5, binary -any,+ blaze-html ==0.5.*, blaze-markup -any, bytestring -any,+ containers -any, directory -any, eprocess -any, filepath -any,+ happstack-server ==7.*, hint -any, hint-server -any, hslogger -any,+ monad-loops -any, mtl ==2.*, 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+ main-is: Main.hs+ buildable: True+ extensions: CPP+ hs-source-dirs: src tests+ other-modules: Help Game Forms Multi Server Utils Interpret Web+ Commands+ ghc-options: -W+
+ README view
@@ -0,0 +1,36 @@+Nomyx+=========++A Nomic game in Haskell++Nomyx is a fabulous and strange game where you have the right to change the rules in the middle of the game!+In fact, changing the rules is the goal of the game. Changing a rule is considered as a move. Of course even that could be changed!+In this game, the player can enter new rules in a dedicated language, modify existing ones, thus changing completely the behaviour of the game.+The original (paper) game: www.nomic.net++Installation+============++To install, follow this procedure:+- download the source tar.gz+- extract it somewhere++$ cd <name>/Nomyx-Rules+$ cabal install+$ cd ../Nomyx +$ cabal install+++Execution+=========++Launch with the command:++$ Nomyx++and follow the instructions. You may connect using a web browser to the given address.+++Troubleshooting+===============+see file TODO for known bugs.
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain +
+ TODO view
@@ -0,0 +1,28 @@+ +TODO list + +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 + +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 + +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
+ data/static/css/nomyx.css view
@@ -0,0 +1,140 @@+h3{+ color:#04B404;+}++#multi {+ top:40px;+ vertical-align:middle;++}++#gameList {+ position:absolute;+ background-color:#F4F4F4;+ border:1px solid silver;+ width:250px;+ padding:10px;+ top:60px;+ left:20px;+ overflow: auto;+}++#game {+ position:absolute;+ background-color:#FFFFFF;+ border:1px solid silver;+ height:90%;+ top:60px;+ left:310px;+ right:20px;+ padding-left:10px;+ padding-right:10px;+ overflow: auto;+}++#gameCol {+ position:absolute;+ top:20px;+ left:20px;+ width:200px;+ background-color:#F4F4F4;+ border:1px solid silver;+ padding:10px;+}++#gameElem {+ position:absolute;+ height:90%;+ top:20px;+ left:250px;+ right:20px;+ /**/+}++.table {+ border:2px solid black;+ border-collapse:collapse;+ padding:6px;+}++.td {+ border:1px solid black;+ padding:6px;+}+++thead {+ font-weight:bold+ }++#gameName {+ float:left;+ margin-left:5%;+ padding:10px;+}++#victory {+ float:left;+ margin-left:5%;+ padding:10px;+}++#events, #inputs, #variables, #rules, #newRule, #Outputs {+ float:left;+ background-color:#F4F4F4;+ border:1px solid silver;+ padding-left:10px;+ padding-bottom:10px;+ padding-right:10px;+ width:100%;+ margin-bottom:10px;+}++++#header {+ border-top:1px solid silver;+ border-bottom:1px solid silver;+ margin-top:10px;+ margin-bottom:10px;+ color:gray;+ padding-top:10px;+ padding-bottom:5px;+ background-color:#F4F4F4;+ top:0;+ position:relative;+ width:100%;+}++#footer {+ border-top:1px solid silver;+ border-bottom:1px solid silver;+ margin-top:10px;+ margin-bottom:10px;+ color:gray;+ padding-top:10px;+ padding-bottom:5px;+ background-color:#F4F4F4;+ bottom:0;+ position:absolute;+ width:100%;+}+++#code {+ width:100%;+ height:150px;+ rows:20;+ cols:80;+}++input[type="file"]{+ font: normal 10px Arial;+}++#description {+ width:50%;++}++
+ src/Commands.hs view
@@ -0,0 +1,149 @@+++-- | This module handles intrepreting players' commands.+module Commands where+{-+import Text.ParserCombinators.Parsec+import Data.List+import Utils+import Multi+import Data.Maybe+import Language.Nomic.Expression+ +-- | All commands issuable. +data Command = ListGame +-- | Name + | NewGame + | JoinGame+ | LeaveGame+ | SubscribeGame+ | UnsubscribeGame+ | ShowSubscription+ | ShowSubGame + | SubmitRule+ | SubmitRuleI + | Constitution+ | ShowAllRules + | ListPlayers+ | ShowPendingActions+ | ShowMyPendingActions+ | ShowCompletedActions+ | DoMyActions+ | DoAction + | Amend+ | Help + | QuitNomic+ deriving (Eq, Show) + +-- | Command's Strings +commands = [--("newPlayer", NewPlayer, ": Internal command."), + ("listGame", ListGame, ": list the active games"), +-- ("name", Name, " <yourname>: change own name"), + ("newGame", NewGame, " <gamename>: start a new game"), + ("joinGame", JoinGame, " <gamename>: play in a game (you must be subscribed)"),+ ("leaveGame", LeaveGame, " <gamename>: stop playing in a game (you remain subscribed)"),+ ("subscribeGame", SubscribeGame, " <gamename>: subscribe to an existing game"),+ ("unsubscribeGame", UnsubscribeGame," <gamename>: unsubscribe to an existing game"),+ ("showSubscribtion", ShowSubscription, " <gamename>: show the subscribtions in the current game"),+ ("showSubGame", ShowSubGame, " <gamename>: show the subscribtions to that game"), + ("submitRule", SubmitRule, " <name> <text> <code>: submit a rule. your code must be in \"\""),+ ("iSubmitRule", SubmitRuleI, " submit a rule in interactive mode"), + ("showConstitution", Constitution, ": show the constitution (must be in a game)"),+ ("showAllRules ", ShowAllRules, ": show every rules: Active (the current Constitution), Pending (currently proposed rules), Rejected (Proposed and rejected rules) and Suppressed (Once Active but suppressed rules)"), + ("listPlayers", ListPlayers, ": show the list of the players"), + ("amendConstitution", Amend, ": amend the constitution with the currently proposed rules"),+ ("showPendingActions", ShowPendingActions, ": show all actions that has to be completed by players"), --TODO: verify "by players"+ ("showMyPendingActions", ShowMyPendingActions, ": show all actions that has to be completed by you"),+ ("iDoActions", DoMyActions, ": realize now all your actions, in interactive mode"),+ ("doAction", DoAction, " <num> <result>: give the result of your action n°num (the number is given by showmypendingactions)."),+ ("showCompletedActions", ShowCompletedActions, ": show all already completed actions"),+ ("help", Help, ": show an help message"), + ("quit", QuitNomic, ": quit Nomic")]++ + + + +-- | parseLine analysis the line and return a command with optionnal arguments +parseLine :: String -> Either ParseError (String, [String]) +parseLine = parse line "parse error" + +-- | line is the parsec parser to analyse a command with optionnal arguments +line :: Parser (String, [String]) +line = do skipMany space+ command <- simpleArg + skipMany space + args <- (quotedArg <|> simpleArg) `sepBy` spaces+ skipMany space --TODO: trailing spaces+ return (command, args)+ +-- | a simple argument's parser.+simpleArg :: Parser String+simpleArg = many1 $ noneOf " \n"++-- | a rule parser.+quotedArg :: Parser String+quotedArg = between (char '"') (char '"') $ many $ noneOf ('"' : ['\NUL'..'\US'])++ + +-- | runLine takes a String a executes the represented command, if any. +runLine :: String -> PlayerNumber -> Comm () +runLine s pn = do + let pl = parseLine s + case pl of + Left _ -> putCom "Command analysis error" + Right (comm, args) -> runCommand comm args pn+ putCom "\n" + + +-- | runCommand takes a String representing a command, optionnal arguments and runs it. +runCommand :: String -> [String] -> PlayerNumber -> Comm () +runCommand comm args pn = do+ let comm' = toLowerS comm+ let commands' = map (\(a,b,_) -> (toLowerS a, b)) commands+ --lookup the commands...+ case lookup comm' commands' of+ Just c -> runCommand' c args pn+ Nothing -> do+ --if not found, try abbreviations+ let mycomms = filter (\(sc, _) -> comm' `isPrefixOf` sc) commands' + case mycomms of + [] -> putCom "No command matchs your input" + (_ , c):[] -> runCommand' c args pn + _ -> putCom $ "Several commands match your input:\n\r" ++ concatMap (\(cs, _) -> cs ++ "\n\r") mycomms + + +-- | commandMulti takes a command and optionnal arguments and runs it. +runCommand' :: Command -> [String] -> PlayerNumber -> Comm () +runCommand' ListGame _ = listGame +--runCommand' Name (a:[]) = newName a +runCommand' NewGame (g:[]) = newGame g +runCommand' JoinGame (g:[]) = joinGame g+runCommand' LeaveGame _ = leaveGame+runCommand' SubscribeGame (g:[]) = subscribeGame g+runCommand' UnsubscribeGame (g:[]) = unsubscribeGame g+runCommand' ShowSubscription _ = showSubscribtion+runCommand' ShowSubGame (g:[]) = showSubGame g +runCommand' SubmitRule (name:text:rule:[]) = submitRule name text rule+runCommand' SubmitRuleI _ = myCatch submitRuleI +runCommand' Constitution _ = showConstitution+runCommand' ShowAllRules _ = showAllRules +runCommand' ListPlayers _ = listPlayers +runCommand' Amend _ = amendConstitution+runCommand' ShowPendingActions _ = showPendingActions+runCommand' ShowMyPendingActions _ = showMyPendingActions+runCommand' DoMyActions _ = doActionsI+runCommand' DoAction (num:result:[]) = doAction num result+runCommand' ShowCompletedActions _ = showCompletedActions+runCommand' QuitNomic _ = quit+runCommand' Help _ = const help +runCommand' c _ = const $ putCom $ "the number of arguments doesn't match. \nUsage: \n" ++ getCommandUsage c + +getCommandUsage :: Command -> String+getCommandUsage c = fromMaybe (error "getCommandUsage: Usage not found") $ lookup c $ map (\(a,b,c) -> (b,a++c)) commands++-- | issue an help message+help :: Comm ()+help = putCom $ "Nomic commands:\n" ++ concatMap (\(c, _, h) -> c ++"\t" ++ h ++ "\n\r") (tail commands)+-}
+ src/Forms.hs view
@@ -0,0 +1,83 @@++{-# 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]
+ src/Game.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable,+ FlexibleContexts, GeneralizedNewtypeDeriving,+ MultiParamTypeClasses, TemplateHaskell, TypeFamilies,+ TypeOperators, FlexibleInstances, NoMonomorphismRestriction,+ TypeSynonymInstances #-}++-- | This module implements Game management.+-- a game is a set of rules, and results of actions made by players (usually vote results)+-- the module manages the effects of rules over each others.+module Game (initialGame, activeRules, execWithGame, pendingRules, rejectedRules) where++import Language.Nomyx.Rule+import Control.Monad.State+import Data.List+import Language.Nomyx.Expression+import Language.Nomyx.Evaluation+import Examples+import Data.Time.Clock as T+++-- | 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",+ rProposedBy = 0,+ rRuleCode = "vote unanimity",+ rRuleFunc = vote unanimity,+ rStatus = Active,+ rAssessedBy = Nothing}++rVictory5Rules = Rule {+ rNumber = 3,+ rName = "Victory 5 accepted rules",+ rDescription = "Victory is achieved if you have 5 active rules",+ rProposedBy = 0,+ rRuleCode = "victoryXRules 5",+ rRuleFunc = victoryXRules 5,+ rStatus = Active,+ rAssessedBy = Nothing}++emptyGame name date = Game { gameName = name,+ rules = [],+ players = [],+ variables = [],+ events = [],+ outputs = [],+ victory = [],+ currentTime = date}++--initialGame :: Game+initialGame name date = flip execState (emptyGame name date) $ do+ evAddRule rVoteUnanimity+ evActivateRule (rNumber rVoteUnanimity) 0+ evAddRule rApplicationMetaRule+ evActivateRule (rNumber rApplicationMetaRule) 0+ evAddRule rVictory5Rules+ evActivateRule (rNumber rVictory5Rules) 0+++-- | 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'+++--accessors++activeRules :: Game -> [Rule]+activeRules = sort . filter (\(Rule {rStatus=rs}) -> rs==Active) . rules++pendingRules :: Game -> [Rule]+pendingRules = sort . filter (\(Rule {rStatus=rs}) -> rs==Pending) . rules++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)
+ src/Help.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+--+-- 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\"."
+ src/Interpret.hs view
@@ -0,0 +1,87 @@+-- | 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 + +import Language.Haskell.Interpreter +import Language.Haskell.Interpreter.Server +import Control.Monad() +import Paths_Nomyx +import Language.Nomyx.Expression +import System.Directory+import System.FilePath+import System.Posix.Files+import Control.Monad+++modDir = "modules"+ +-- | the server handle +startInterpreter :: IO ServerHandle +startInterpreter = do + h <- start+ dataDir <- liftIO getDataDir+ liftIO $ createDirectoryIfMissing True $ dataDir </> modDir + ir <- runIn h initializeInterpreter + case ir of + Right r -> do + putStrLn "Interpreter Loaded" + return $ Just r + Left e -> error $ "sHandle: initialization error:\n" ++ show e + return h ++getUploadModules :: IO([FilePath])+getUploadModules = do+ dataDir <- getDataDir+ all <- getDirectoryContents $ dataDir </> modDir+ files <- filterM (getFileStatus . (\f -> joinPath [dataDir, modDir, f]) >=> return . isRegularFile) all+ return $ map (\f -> joinPath [dataDir, modDir, f]) files+ +-- | initializes the interpreter by loading some modules. +initializeInterpreter :: Interpreter () +initializeInterpreter = do + fmods <- liftIO getUploadModules+ 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"]+ return () + +-- | 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 + +-- | reads a NamedRule. May produce an error if badly formed. +readNamedRule :: Rule -> ServerHandle -> IO RuleFunc +readNamedRule r sh = readRule (rRuleCode r) sh ++-- | check an uploaded file and reload +loadModule :: FilePath -> FilePath -> ServerHandle -> IO (Either InterpreterError ()) +loadModule dir name sh = do+ dataDir <- getDataDir+ c <- checkModule dir sh+ case c of+ Right _ -> do+ copyFile dir (dataDir </> modDir </> name)+ runIn sh $ initializeInterpreter+ return $ Right () + Left e -> do+ runIn sh $ initializeInterpreter+ return $ Left e++-- | 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+ liftIO $ putStrLn $ concat $ fmods+ loadModules (dir:fmods)+
+ src/Main.hs view
@@ -0,0 +1,118 @@+----------------------------------------------------------------------------- +-- +-- Module : Main +-- Copyright : +-- License : AllRightsReserved +-- +-- Maintainer : +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Main (main) where + +import System.Console.GetOpt +import System.Environment +import Web+import Multi+import Control.Concurrent+import Interpret+import Control.Concurrent.STM+import qualified System.Posix.Signals as S+import Control.Monad.CatchIO+import Control.Monad.Trans++-- | Entry point of the program.+main :: IO Bool +main = do + putStrLn "Welcome to Nomyx!"+ serverCommandUsage+ args <- getArgs + (flags, _) <- nomyxOpts args + --parseActions flags+ --let verbose = Verbose `elem` flags + if Test `elem` flags+ then return True--return allTests+ else do+ multi <- newTVarIO defaultMulti+ --start the haskell interpreter+ sh <- protectHandlers startInterpreter+ --start the web server+ forkIO $ launchWebServer sh multi+ forkIO $ launchTimeEvents multi+ --loop+ serverLoop multi+ return True++-- | a loop that will handle server commands +serverLoop :: TVar Multi -> IO () +serverLoop tm = do+ s <- getLine+ case s of+ "d" -> do+ m <- atomically $ readTVar tm+ putStrLn $ show m+ serverLoop tm+ "s" -> do+ putStrLn "saving state..."+ --createCheckpoint c+ serverLoop tm+ "q" -> return ()+ _ -> do+ putStrLn "command not recognized"+ serverLoop tm++serverCommandUsage :: IO ()+serverCommandUsage = do+ putStrLn "Server commands:"+ putStrLn "s -> save state"+ putStrLn "d -> debug"+ putStrLn "q -> quit"++ + +-- | Launch mode +data Flag + = Verbose | Version | Solo | Test + 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 ['s'] ["solo"] (NoArg Solo) "start solo" + , Option ['t'] ["tests"] (NoArg Test) "perform routine check" + ] + + +nomyxOpts :: [String] -> IO ([Flag], [String]) +nomyxOpts argv = + case getOpt Permute options argv of + (o,n,[] ) -> return (o,n) + (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) + where header = "Usage: Nomyx [OPTION...]" +++helper :: MonadCatchIO m => S.Handler -> S.Signal -> m S.Handler+helper handler signal = liftIO $ S.installHandler signal handler Nothing++signals :: [S.Signal]+signals = [ S.sigQUIT+ , S.sigINT+ , S.sigHUP+ , S.sigTERM+ ]++saveHandlers :: MonadCatchIO m => m [S.Handler]+saveHandlers = liftIO $ mapM (helper S.Ignore) signals++restoreHandlers :: MonadCatchIO m => [S.Handler] -> m [S.Handler]+restoreHandlers h = liftIO . sequence $ zipWith helper h signals+++protectHandlers :: MonadCatchIO m => m a -> m a+protectHandlers a = bracket saveHandlers restoreHandlers $ const a
+ src/Multi.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, GeneralizedNewtypeDeriving,+ MultiParamTypeClasses, TemplateHaskell, TypeFamilies, TypeOperators,+ TypeSynonymInstances, FlexibleInstances, GADTs #-}++-- | This module manages multi-player games and commands.+module Multi where+--Multi, PlayerPassword, GetMulti(..), FindPlayer(..), PlayerMulti(..), GetNewPlayerNumber(..), NewPlayerU(..),+-- listGame, newGame, joinGame, leaveGame, subscribeGame, unsubscribeGame, showSubscribtion, showSubGame, newPlayer,+-- submitRule, myCatch, submitRuleI, showConstitution, showAllRules, listPlayers, amendConstitution, showPendingActions,+-- showMyPendingActions, doActionsI, doAction', showCompletedActions, quit, getPendingActions, doAction, games, getPlayersGame,+-- getPlayersName) where+++import Prelude hiding (catch)+import Data.List+import Control.Monad.State+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.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 [] []++-- | 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+ Just o -> replace o o{ inGame = maybename} pl+ Nothing -> pl++newPlayerU :: PlayerMulti -> StateT Multi IO ()+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 = do+ ps <- gets mPlayers+ return $ length ps + 1+++addNewGame :: Game -> StateT Multi IO ()+addNewGame new = modify (\multi@Multi {games=gs} -> multi {games = new:gs})++getGameByName :: GameName -> StateT Multi IO (Maybe Game)+getGameByName gn = fmap (find (\(Game {gameName = n}) -> n==gn)) (gets games)++joinGamePlayer :: PlayerNumber -> GameName -> StateT Multi IO ()+joinGamePlayer pn game = modify (\multi -> multi {mPlayers = mayJoinGame (Just game) pn (mPlayers multi)})++leaveGameU :: PlayerNumber -> StateT Multi IO ()+leaveGameU pn = modify (\multi -> multi {mPlayers = mayJoinGame Nothing pn (mPlayers multi)})++-- | list the active games+listGame :: PlayerNumber -> StateT Multi IO ()+listGame _ = do+ gs <- gets games+ case length gs of+ 0 -> say "No active games"+ _ -> do+ say "Active games:"+ say $ concatMap (\g -> gameName g ++ "\n") gs++-- | starts a new game+newGame :: String -> PlayerNumber -> StateT Multi IO ()+newGame name _ = 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+ -- create a game with zero players+ modify (\m -> m {games = (initialGame name t):gs})+ False -> say $ "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 game pn = do+ mg <- getGameByName game+ case mg of+ Nothing -> say $ "No game by that name"+ Just g -> do+ say "subscribing first."+ subscribeGame (gameName g) pn+ say $ "Joining game: " ++ game+ joinGamePlayer pn game+++-- | leave a game (you remain subscribed).+leaveGame :: PlayerNumber -> StateT Multi IO ()+leaveGame pn = do+ leaveGameU pn+ say "You left the game (you remain subscribed)."+++-- | subcribe to a game.+subscribeGame :: GameName -> PlayerNumber -> StateT Multi IO ()+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!"+ Nothing -> do+ say $ "Subscribing to game: " ++ game+ put g {players = PlayerInfo { playerNumber = pn,+ playerName = getPlayersName pn m} : (players g)}+++-- | subcribe to a game.+unsubscribeGame :: GameName -> PlayerNumber -> StateT Multi IO ()+unsubscribeGame game pn = inGameDo game $ do+ g <- get+ case find (\(PlayerInfo { playerNumber=mypn}) -> mypn == pn ) (players g) of+ Nothing -> say "Not subscribed!"+ Just _ -> do+ say $ "Unsubscribing to game: " ++ game+ put g {players = filter (\PlayerInfo { playerNumber = mypn} -> mypn /= pn) (players g)}+++showSubGame :: GameName -> PlayerNumber -> StateT Multi IO ()+showSubGame g _ = inGameDo g $ do+ ps <- gets players+ say $ concatMap show ps++showSubscribtion :: PlayerNumber -> StateT Multi IO ()+showSubscribtion pn = inPlayersGameDo pn $ do+ ps <- gets players+ say $ 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+ 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."++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)++inputUpload :: PlayerNumber -> FilePath -> String -> ServerHandle -> StateT Multi IO ()+inputUpload pn dir mod sh = inPlayersGameDo pn $ do+ m <- lift $ loadModule dir mod sh+ case m of+ Right _ -> do+ output pn $ "File loaded: " ++ show dir ++ " Module " ++ show mod ++"\n"+ return ()+ Left e -> do+ output pn $ "Compiler error: " ++ show e ++ "\n"+ 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+++-- | show the constitution.+showConstitution :: PlayerNumber -> StateT Multi IO ()+showConstitution pn = inPlayersGameDo pn $ get >>= (say . show . activeRules)+++-- | show every rules (including pendings and deleted)+showAllRules :: PlayerNumber -> StateT Multi IO () +showAllRules pn = inPlayersGameDo pn $ get >>= (say . 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"+++-- | 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+ 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 pn action = do+ multi <- get+ let mg = getPlayersGame pn multi+ case mg of+ Nothing -> say "You must be in a game"+ Just g -> do+ myg <- lift $ execWithGame action g+ modifyGame myg++inGameDo :: GameName -> StateT Game IO () -> StateT Multi IO ()+inGameDo game action = do+ gs <- gets games+ case find (\(Game {gameName =n}) -> n==game) gs of+ Nothing -> say "No game by that name"+ Just g -> do+ myg <- lift $ execWithGame action g+ modifyGame myg++instance Ord PlayerMulti where+ (<=) = (<=) `on` mPlayerNumber+++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+++getTimes :: EventHandler -> Maybe UTCTime+getTimes (EH _ _ (Time t) _) = Just t+getTimes _ = Nothing+
+ src/Server.hs view
@@ -0,0 +1,256 @@+-- | This server handles asynchronous text connections.+-- It has 4 threads:+-- mainLoop: dispatch messages between every threads (this is the main program thread, not forked)+-- acceptLoop: handles new client connections+-- multiLoop: handles game commands. It contains the whole game state.+-- clientLoop: one per client, handles clients communications.++-- And 5 channels:+-- acceptChan: used by acceptLoop to publish new clients connections to mainLoop.+-- gameChan: used for the communication between mainLoop and multiLoop.+-- clientChan: one per client, use by the clients to communicate with mainLoop.+-- handleFree: one per client, used for upstream comunication with clientLoops, to control usage of the Handle.+-- debugChan: used to pass debug commands++ +module Server where ++{- +-- Module Network is the simple networking library, presenting a Handle-based interface. +import Network (listenOn, accept, sClose, Socket, + withSocketsDo, PortID(..)) + +import Control.Exception (finally)+import Control.Concurrent +import Control.Concurrent.STM +import Multi +import Control.Monad.State +import System.IO +import Data.Char +import Control.Applicative +import Data.List +import Network.BSD+import Language.Haskell.Interpreter.Server --TODO: hide in Interpret+import Control.Concurrent.Process hiding (Handle)+import Commands+import Data.Function (on)+import Language.Nomic.Expression++type ClientNumber = Int++-- | associate a player number with a handle +data PlayerClient = PlayerClient { cPlayerNumber :: PlayerNumber, + cHandle :: Handle} + deriving (Eq, Show) + +-- | A structure to hold the active games and players +data Server = Server { playerClients :: [PlayerClient],+ interpreterHandle :: ServerHandle}+ --deriving (Eq)++-- | A State to pass around active games and players. +-- Furthermore, the output are to be made with Comm to output to the right console. +type ServerState = StateT Server IO ()+ +-- the channels to pass commands+type CommandChan = TChan String++-- type of the channel to pass commands upstream to the client thread+--data ClientCommands = Ready | Quit+type ClientChan = TChan String+ +-- | communication between clients and server +data ClientComm = ClientComm {inChan :: TChan String,+ outChan :: TChan String,+ handle :: Handle} ++-- | a channel where to publish new clients connection+type AcceptChan = TChan ClientComm+ +defaultServer :: ServerHandle -> Server +defaultServer = Server []+ ++type DebugServer = (ServerState, TChan Server)++defaultDebugServer = do+ debugChan <- atomically newTChan+ return (debugViewState, debugChan)++ +-- | An helper function that makes it clear how to use the state transformer Server. +runWithServer :: Server -> ServerState -> IO () +runWithServer = flip evalStateT + + +-- | a loop that will handle game commands +runMulti :: AcceptChan -> DebugServer -> ServerHandle -> IO () +runMulti acceptChan debug sh = runWithServer (defaultServer sh) (mainLoop acceptChan [] debug)++ +-- | Start Nomic in server mode+serverStart :: PortNumber -> ServerHandle -> IO () +serverStart port sh = withSocketsDo $ do + servSock <- listenOn $ PortNumber port + host <- getHostName+ putStrLn $ "Starting telnet server...\nTo connect, try \"telnet " ++ host ++ " " ++ (show port) ++ "\" in a shell window" + startAll servSock sh `catch` (\_ -> putStrLn "serverStart: Closing") `finally` sClose servSock + + +-- | starts every threads+startAll :: Socket -> ServerHandle -> IO ()+startAll servSock sh = do + -- Fork the loop that will handle new client connections along with its channel + acceptChan <- atomically newTChan ++ --start the loop that will handle client's connections+ --forkIO $ acceptLoop servSock acceptChan+ spawn $ makeProcess id (acceptLoop servSock acceptChan)-- `catch` (\_ -> do putStrLn "acceptLoop: Closing"; return ())++ -- the multi loop will centralize and dispatch communications+ def <- defaultDebugServer+ runMulti acceptChan def sh++ + + +-- | the loop will handle new client connections and fork a subsequent thread for each client +acceptLoop :: Socket -> AcceptChan -> Process () () +acceptLoop servSock acceptChan = do -- acceptChan + (cHandle, _, _) <- lift $ accept servSock + --hSetEcho cHandle True + liftIO $ hSetBuffering cHandle NoBuffering + + -- Fork loops that will handle client communication + cc <- liftIO $ newClientComm cHandle + liftIO $ forkIO $ clientIn cc `catch` (\_ -> putStrLn "acceptLoop: clientIn exception")+ liftIO $ forkIO $ clientOut cc `catch` (\_ -> putStrLn "acceptLoop: clientOut exception")+ + -- publish new client connection with its chan and handle on acceptChan + lift $ atomically $ writeTChan acceptChan cc + acceptLoop servSock acceptChan +++newClientComm :: Handle -> IO ClientComm +newClientComm h = do+ inChan <- liftIO $ atomically newTChan+ outChan <- liftIO $ atomically newTChan+ return ClientComm {inChan = inChan,+ outChan = outChan,+ handle = h}++ +-- | a loop that will handle client communication +clientIn :: ClientComm -> IO () +clientIn cc = do+ s <- hGetLine $ handle cc+ atomically $ writeTChan (inChan cc) s+ clientIn cc++-- | a loop that will handle client communication +clientOut :: ClientComm -> IO () +clientOut cc = do+ s <- atomically $ readTChan (outChan cc)+ hPutStr (handle cc) s+ clientOut cc++ ++selectIn :: [ClientComm] -> STM (String, ClientComm) +selectIn l = do+ let f cc@ClientComm {inChan = ic} = do+ s <- readTChan ic+ return (s, cc)+ foldl orElse retry (map f l)++selectOut :: [ClientComm] -> STM (String, ClientComm) +selectOut l = do+ let f cc@ClientComm {outChan = oc} = do+ s <- readTChan oc+ return (s, cc)+ foldl orElse retry (map f l)++data ClientData = ClientAccept ClientComm+ | ClientInput (String, ClientComm)+ +-- | the server loop will dispatch messages between threads +mainLoop :: AcceptChan -> [ClientComm] -> DebugServer -> ServerState +mainLoop acceptChan clients d@(debugState, debugChan) = do++ --read on both acceptChan and all client's chans + r <- lift $ atomically $ (ClientAccept `fmap` readTChan acceptChan) + `orElse` + (ClientInput `fmap` selectIn clients)++ case r of + -- new data on the accept chan (CommandChan, ClientChan, Handle) + ClientAccept ca -> do+ --register new client+ newClient ca+ --loop + mainLoop acceptChan (ca:clients) d + + -- new data on the clients chan (String, ClientChan, Handle) + ClientInput (l,cc) -> do + -- do some filtering + let myLine = filter isPrint l + --putStrLn $ "data: " ++ myLine ++ " from handle: " ++ show h + case myLine of + "debug read" -> do+ s <- get+ --write state into the channel (for external reading).+ lift $ atomically $ writeTChan debugChan s+ "debug write" -> do+ --execute the debug monad.+ debugState+ "quit" -> playerQuit (handle cc)+ "" -> return ()+ -- every other command is passed through+ _ -> issuePlayerCommand myLine cc++++ --loop+ mainLoop acceptChan clients d + ++newClient :: ClientComm -> ServerState+newClient cc = do+ (Server pcs sh) <- get+ let comm = (Communication (inChan cc) (outChan cc) sh)+ pn <- liftIO $ evalStateT newPlayer comm+ modify (\ser -> ser { playerClients = PlayerClient { cPlayerNumber = pn, + cHandle = (handle cc)} : pcs})++ + +-- | issue the player's command with the right Comm and Multi environnement+issuePlayerCommand :: String -> ClientComm -> ServerState+issuePlayerCommand l cc = do+ (Server pcs sh) <- get+ let comm = (Communication (inChan cc) (outChan cc) sh) + --issue the player's command + case getPlayerNumber (handle cc) pcs of + Nothing -> error "issuePlayerCommand: player's handle not found" + Just pn -> liftIO $ evalStateT (runLine l pn) comm+++playerQuit :: Handle -> ServerState+playerQuit h = do+ pcs <- gets playerClients+ -- erase player client + modify (\ser -> ser { playerClients = filter (\PlayerClient {cHandle = myh} -> myh /= h) pcs})++-- | gives the player's number associated to that handle +getPlayerNumber :: Handle -> [PlayerClient] -> Maybe PlayerNumber +getPlayerNumber h ps = cPlayerNumber <$> find (\PlayerClient {cHandle = myh} -> myh==h) ps ++debugViewState :: ServerState+debugViewState = lift . print =<< get ++instance Ord PlayerClient where + (<=) = (<=) `on`cPlayerNumber++instance Show Server where+ show Server{playerClients =pcs} = "\n" ++ (show $ sort pcs)+-}
+ src/Utils.hs view
@@ -0,0 +1,58 @@+----------------------------------------------------------------------------- +-- +-- Module : Utils +-- Copyright : +-- License : AllRightsReserved +-- +-- Maintainer : +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Utils where + +import Data.Maybe +import Data.Char +import Control.Monad.State + +-- | this function will return just a if it can cast it to an a. +maybeRead :: Read a => String -> Maybe a +maybeRead = fmap fst . listToMaybe . reads + + + +-- | Replaces all instances of a value in a list by another value. +replace :: Eq a => a -- ^ Value to search + -> a -- ^ Value to replace it with + -> [a] -- ^ Input list + -> [a] -- ^ Output list +replace x y = map (\z -> if z == x then y else z) ++-- | 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"] +toLowerS = map toLower +isYes a = toLowerS a `elem` yes++-- | generic function to say things on transformers like GameState, ServerState etc.+say :: String -> StateT a IO () +say = lift . putStrLn++liftT :: Show s => State s a -> StateT s IO a+liftT st = do+ s1 <- get+ let (a, s) = runState st s1+ --lift $ putStrLn $ "putting " ++ show s+ put s+ return a++
+ src/Web.hs view
@@ -0,0 +1,500 @@++{-# 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++-- | 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+ | 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) -> IO ()+launchWebServer sh tm = do+ putStrLn "Starting web server...\nTo connect, drive your browser to \"http://localhost:8000/Login\""+ d <- PN.getDataDir+ d' <- PNR.getDataDir+ simpleHTTP nullConf $ server d d' sh tm++--serving Nomyx web page as well as data from this package and the language library package+server :: FilePath -> FilePath -> ServerHandle -> (TVar Multi) -> NomyxServer Response+server d d' sh tm = mconcat [+ serveDirectory EnableBrowsing [] d,+ serveDirectory EnableBrowsing [] d', do+ decodeBody (defaultBodyPolicy "/tmp/" 102400 4096 4096)+ html <- implSite (pack "http://localhost:8000") "/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+
+ tests/Test.hs view
@@ -0,0 +1,405 @@++-- | extensive testing.+-- to run all tests, run "allTests" and "testMultiX" +module Test where + +import Game +import Control.Monad.State +import Server+import System.IO+import Control.Concurrent.STM+import Control.Concurrent+import Comm+import Interpret+import Language.Haskell.Interpreter.Server+import NamedRule+import System.IO.Unsafe (unsafePerformIO)++--+--mysHandle = unsafePerformIO startInterpreter+--+--testComm :: ServerHandle -> Communication +--testComm sh = unsafePerformIO $ do+-- cc <- liftIO $ newClientComm stdin +-- liftIO $ forkIO $ clientIn cc `catch` (\_ -> putStrLn "acceptLoop: clientIn exception")+-- liftIO $ forkIO $ clientOut cc `catch` (\_ -> putStrLn "acceptLoop: clientOut exception")+-- return $ Communication (inChan cc) (outChan cc) sh+-- +--test :: Eq a => (StateT s Comm a) -> s -> a -> IO Bool+--test state s expected = do+-- inChan <- liftIO $ atomically newTChan+-- outChan <- liftIO $ atomically newTChan+-- let com = Communication inChan outChan mysHandle+-- res <- runWithComm com $ evalStateT state s+-- --atomically $ waitForTrue $ do+-- -- s <- readTChan outChan+-- -- lift $ putStr s+-- -- isEmptyTChan outChan+-- return $ res == expected+--+-- +---- Preliminaries +--nr1 = NamedRule {rNumber=1, rName ="Rule1", rText="test de règle 1", rProposedBy=2, rRule = r1, rStatus = Active, rejectedBy = Nothing} +--nr2 = NamedRule {rNumber=2, rName ="Rule2", rText="test de règle 2", rProposedBy=2, rRule = r2, rStatus = Active, rejectedBy = Nothing} +--nr3 = NamedRule {rNumber=3, rName ="Rule3", rText="test de règle 3", rProposedBy=3, rRule = r3, rStatus = Active, rejectedBy = Nothing} +-- +-- +--rs = [nr1, nr2] +-- +--g = Game {gameName = "test", rules = rs, actionResults = [], players = []} +-- +---- Test on Rules +--defaultNRrule r = NamedRule { rNumber = 1, +-- rName = "", +-- rText = "", +-- rProposedBy = 0, +-- rRule = r,+-- rStatus = Active,+-- rejectedBy = Nothing}+-- +--r1 = "MustBeEgalTo legal" +--r2 = "MustBeEgalTo (MustBeEgalTo legal)" +--r3 = "legal" +--r4 = "illegal" +--r5 = "TestRuleOver legal" +--r6 = "OfficialRule 1" -- r6 == r1 +--r7 = "immutable 1" +--+--+--+--+-- +--rtest1 = test (isRuleLegal (defaultNRrule r1) nr1) g (Right False) --a program cannot contain a whole representation of itself. +--rtest2 = test (isRuleLegal (defaultNRrule r2) nr1) g (Right True) --r2 contains a representation of r1. +----rtest3 = test (isRuleLegal (defaultNRrule (r1 ++ " `Rand` " ++ r1)) nr1) g (Right False) +----rtest4 = test (isRuleLegal (defaultNRrule (r1 ++ "`Ror`" ++ r2)) nr1) g (Right True) +--rtest5 = test (isRuleLegal (defaultNRrule r3) nr1) g (Right True) +--rtest6 = test (isRuleLegal (defaultNRrule r4) nr1) g (Right False) +--rtest7 = test (isRuleLegal (defaultNRrule r5) (defaultNRrule r1)) g (Right True) +--rtest8 = test (isRuleLegal (defaultNRrule r6) (defaultNRrule r3)) g (Right True) +--rtest9 = test (isRuleLegal (defaultNRrule r7) (defaultNRrule r4)) g (Right False) +-- +--ruleTestPassed = liftM and $ sequence [rtest1, rtest2, rtest5, rtest6, rtest7, rtest8, rtest9] +-- +-- +---- Some properties that rules must hold. +-- +---- prop_autoContain r = do +---- a <- isRuleLegal p p +---- return $ not a +---- where p = MustBeEgalTo r +-- +---- test on Observables +-- +--o1 = ruleOfficial +--o2 = (proposedBy ==. 1) &&. ruleOfficial +--o3 = (proposedBy ==. 1) ||. ruleOfficial +--o4 = (proposedBy ==. 2) &&. (not_ ruleOfficial) +--o5 = (proposedBy - 1) ==. 2 +--o6 = selfNumber ==. 1+--o7 = map_ (+ (konst 1)) AllPlayers +--o8 = foldr_ (+) (konst 1) AllPlayers +--o9 = and_ (konst [True, True])+--o10 = or_ (konst [False, True])+-- +--otest1 = test (evalObs o1 nr1 0) g (Right True) --(nr1 is official) +--otest1' = test (evalObs o1 nr3 0) g (Right False) --(nr1 is not official and should)+--otest2 = test (evalObs o2 nr1 0) g (Right False) --(nr1 is official but it's not Player 1's turn) +--otest3 = test (evalObs o3 nr1 0) g (Right True) --(nr1 is official or it's player 1 turn) +--otest4 = test (evalObs o4 nr1 0) g (Right False) --(nr1 is official and should not) +--otest5 = test (evalObs o5 nr1 0) g (Right False) --(nr1 is official and should not) +--otest6 = test (evalObs o6 nr3 1) g (Right True)+--otest7 = test (evalObs o7 nr3 1) Game {gameName = "test", rules = rs, actionResults = [], players = [PlayerInfo 3 "t", PlayerInfo 5 "u"]} (Right [4, 6])+--otest8 = test (evalObs o8 nr3 1) Game {gameName = "test", rules = rs, actionResults = [], players = [PlayerInfo 3 "t", PlayerInfo 5 "u"]} (Right 9)+--otest9 = test (evalObs o9 nr3 1) g (Right True)+--otest10 = test (evalObs o10 nr3 1) g (Right True) +-- +--obsTestPassed = liftM and $ sequence [otest1, otest1', otest2, otest3, otest4, otest5, otest6, otest7, otest8, otest9,+-- otest10 ] +-- +----testObs :: Obs a -> Either Actions a +----testObs o = test (evalObs o nr1 0) g +-- +---- Test with combination of the 2 +-- +---- if this rule is officialized, Player 2 cannot play anymore +--cr1 = "Cond (oRuleProposedBy ==. 2) Illegal Legal" +-- +---- Only new rules are affected +--cr2 = "Cond (oRuleOfficial) Legal Illegal" +-- +---- applicable only on turn 3 +---- cr3 r = Cond (oTurn `oEqu` 3) r Legal +-- +---- the total is that cr3 forbidden player 2 to play at turn 3. +-- +--crtest1 = test (isRuleLegal (defaultNRrule cr1) nr1) g (Right False) --it's Player 2 to play, cr1 forbids that +--crtest2 = test (isRuleLegal (defaultNRrule cr2) nr1) g (Right True) --nr1 is official (ie included in the current ruleset) +--crtest3 = test (isRuleLegal (defaultNRrule cr2) nr3) g (Right False) --nr3 is not official +-- +--crTestPassed = liftM and $ sequence [crtest1, crtest2, crtest3] +-- +----testRule :: String -> Either Actions Bool +----testRule r = test (isRuleLegal (defaultNRrule r) nr1) g +--+---- action test+----g2 = Game {gameName = "test", rules = rs, actionResults = [Action 1 2 (oVote (Konst 1)) (Konst "For")], players = []}+----+----ar1 = "Cond (Vote (Konst \"Vote\") (Konst 1) ) Legal Illegal"+----atest1 = return $ findActionResult (oVote (Konst 1))+---- NamedRule {rNumber=2, rName ="Rule1", rText="test de règle 1", rProposedBy=2, rule = ar1, rStatus = Active, rejectedBy = Nothing}+---- 1+---- (actionResults g2) == Just (Action 1 2 (oVote (Konst 1)) (Just "For"))+----+----atest2 = test (evalObs (oVote (Konst 1))+---- NamedRule {rNumber=2, rName ="Rule1", rText="test de règle 1", rProposedBy=2, rule = ar1, rStatus = Active, rejectedBy = Nothing}+---- 1) g2 (Right True)+----+----atest3 = test (isRuleLegal' (Cond (oVote (Konst 1) ) Legal Illegal)+---- NamedRule {rNumber=2, rName ="Rule1", rText="test de règle 1", rProposedBy=2, rule = r1, rStatus = Pending, rejectedBy = Nothing}+---- 1) g2 (Right True)+----+----atest4 = test (isRuleLegal NamedRule {rNumber=1, rName ="Rule1", rText="test de règle 1", rProposedBy=2, rule = ar1, rStatus = Active, rejectedBy = Nothing}+---- NamedRule {rNumber=2, rName ="Rule1", rText="test de règle 1", rProposedBy=2, rule = r1, rStatus = Pending, rejectedBy = Nothing})+---- g2 (Right True)+----+----actionTestPassed = liftM and $ sequence [atest1, atest2, atest3, atest4]+-- +---- Other test +-- +-- +--cnr1 = NamedRule {rNumber=1, rName ="Rule1", rText="test de règle 1", rProposedBy=1, rRule = cr1, rStatus = Active, rejectedBy = Nothing} +--cnr2 = NamedRule {rNumber=2, rName ="Rule2", rText="test de règle 2", rProposedBy=2, rRule = cr2, rStatus = Active, rejectedBy = Nothing} +-- +--gs2 = Game {gameName="Jeu", rules = [cnr2], actionResults = [], players = []} +--+--+-- +--isRuleLegalToCurrentRuleSetTest1 = test (isLegal cnr2) gs2 (Right Nothing)+-- +--isRuleLegalToCurrentRuleSetTest2 = test (isLegal cnr1) gs2 (Right Nothing) +--+--applyRuleToCurrentRuleSet :: IO Game +--applyRuleToCurrentRuleSet = runWithComm (testComm mysHandle) $ execStateT (applyTo cnr1) gs2 --empty the active ruleset because it's P2 turn +--applyRuleToCurrentRuleSetTest = do g <- applyRuleToCurrentRuleSet+-- return $ null ( activeRules g ) +-- +---- Visual test +-- +--playTest1 = runStateT (amend cnr1) gs2 -- the proposed rule is illegal (it is not allready official) +--playTest2 = runStateT (amend cnr2) gs2 -- the proposed rule is legal (it is allready official). It is added to the ruleset. Its execution doesn't modify the ruleset. +-- +--voteTest = test (isRuleLegal (defaultNRrule ("voteRule 1")) nr1) g+-- +--+---- monadic test in mono player+----+----putChan :: ClientComm -> String -> IO ()+----putChan ClientComm {inChan = ic} l = do+---- putStrLn $ "-> " ++ l+---- threadDelay 100000+---- atomically $ writeTChan ic l+---- putChar '\n'+----+----+----noVote :: ServerState+----noVote = do+---- modify (\s @ Server { multi = m@Multi { games = g:gs}} ->+---- s {multi = m{ games = g { rules = [NamedRule {rNumber=1, rName ="NoVote", rText="", rProposedBy=0, rule = "Legal", rStatus = Active, rejectedBy = Nothing},+---- NamedRule {rNumber=2, rName ="Immutable Rules", rText="The rule #1 must not be suppressed", rProposedBy=0, rule = "immutable 1", rStatus = Active, rejectedBy = Nothing}]}:gs }})+----+------debugIdentify :: ServerState+----+----+------ monadic test in multi player+----testMulti1 :: IO Bool+----testMulti1 = do+----+---- --opening a handle to simulate each player+---- h1 <- openFile "/dev/stdout" ReadWriteMode+---- h2 <- openFile "/dev/stdout" ReadWriteMode+---- h3 <- openFile "/dev/stdout" ReadWriteMode+---- cc1 <- newClientComm h1+---- cc2 <- newClientComm h2+---- cc3 <- newClientComm h3+---- let put1 = putChan cc1+---- let put2 = putChan cc2+---- let put3 = putChan cc3+----+----+---- debugChan <- atomically newTChan+---- acceptChan <- atomically newTChan+----+---- forkIO $ clientOut cc1+---- forkIO $ clientOut cc2+---- forkIO $ clientOut cc3+----+----+---- forkIO $ runWithServer (defaultServer mysHandle) (mainLoop acceptChan [cc1, cc2, cc3] (debugViewState, debugChan))+----+---- -- simulate connection of the clients+---- atomically $ writeTChan acceptChan cc1+----+---- put1 "coco"+---- put1 "coco"+---- put1 "newgame g1"+---- put1 "join g1"+----+---- put1 "submitRule testRule3 testRuletext Legal"+----+---- atomically $ writeTChan acceptChan cc2+---- put2 "jaja"+---- put2 "jaja"+---- put2 "join g1"+---- put2 "submitRule testRule4 testRuletext \"eraseRule 3\""+----+---- put1 "amendconstitution"+---- put2 "submitRule testRule5 testRuletext Illegal"+----+---- put1 "showallrules"+----+---- atomically $ writeTChan acceptChan cc3+----+---- put3 "mimi"+---- put3 "mimi"+---- put3 "newgame g2"+---- put3 "join g2"+---- put3 "submitRule testRule3 testRuletext \"eraseRule 1\""+----+---- put3 "showallrules"+----+---- put1 "debug read"+----+---- s <- liftIO $ atomically $ readTChan debugChan+---- putStrLn $ show s+---- putStrLn $ show $ endServer1 mysHandle h1 h2 h3+----+---- return $ (show s) == (show $ endServer1 mysHandle h1 h2 h3)+----+----endServer1 :: ServerHandle -> Handle -> Handle -> Handle -> Server+----endServer1 sh h1 h2 h3 = Server {+---- multi = Multi {+---- games = [Game { gameName = "g1",+---- rules = [nrVote,+---- nrImmutable,+---- NamedRule {rNumber=3, rName ="testRule3", rText="testRuletext", rProposedBy=1, rule = "Legal", rStatus = Pending, rejectedBy = Nothing},+---- NamedRule {rNumber=4, rName ="testRule4", rText="testRuletext", rProposedBy=2, rule = "eraseRule 3", rStatus = Pending, rejectedBy = Nothing},+---- NamedRule {rNumber=5, rName ="testRule5", rText="testRuletext", rProposedBy=2, rule = "Illegal", rStatus = Pending, rejectedBy = Nothing}],+---- actionResults = [],+---- players = [PlayerInfo {playerNumber=1, playerName ="coco"},+---- PlayerInfo {playerNumber=2, playerName ="jaja"}]},+---- Game { gameName = "g2",+---- rules = [nrVote,+---- nrImmutable,+---- NamedRule {rNumber=3, rName ="testRule3", rText="testRuletext", rProposedBy=3, rule = "eraseRule 1", rStatus = Pending, rejectedBy = Nothing}],+---- actionResults = [],+---- players = [PlayerInfo {playerNumber=3, playerName ="mimi"}]}],+---- mPlayers = [PlayerMulti { mPlayerNumber = 1, mPlayerName = "coco", mPassword ="coco", inGame = Just "g1"},+---- PlayerMulti { mPlayerNumber = 2, mPlayerName = "jaja", mPassword ="jaja", inGame = Just "g1"},+---- PlayerMulti { mPlayerNumber = 3, mPlayerName = "mimi", mPassword ="mimi", inGame = Just "g2"}]},+---- playerClients = [PlayerClient { cPlayerNumber = 1, cHandle = h1},+---- PlayerClient { cPlayerNumber = 2, cHandle = h2},+---- PlayerClient { cPlayerNumber = 3, cHandle = h3}]}+----+----+------ monadic test on actions+----testMulti2 :: IO Bool+----testMulti2 = do+----+---- --opening a handle to simulate each player+---- h1 <- openFile "/dev/stdout" ReadWriteMode+---- h2 <- openFile "/dev/stdout" ReadWriteMode+---- cc1 <- newClientComm h1+---- cc2 <- newClientComm h2+---- let put1 = putChan cc1+---- let put2 = putChan cc2+----+---- debugChan <- atomically newTChan+---- acceptChan <- atomically newTChan+----+---- _ <- forkIO $ runWithServer (defaultServer mysHandle) (mainLoop acceptChan [cc1, cc2] (return (), debugChan))+----+----+----+----+---- forkIO $ clientOut cc1+---- forkIO $ clientOut cc2+----+---- -- simulate connection of the clients+---- atomically $ writeTChan acceptChan cc1+---- put1 "coco"+---- put1 "coco"+---- put1 "newgame g1"+---- put1 "join g1"+---- put1 "submitRule testRule3 testRuletext \"Legal\""+----+---- atomically $ writeTChan acceptChan cc2+---- put2 "nono"+---- put2 "nono"+---- put2 "join g1"+---- put2 "submitRule testRule4 testRuletext \"eraseRule 3\""+---- --getLine+---- put1 "showpendingactions"+---- --getLine+----+---- put1 "showmypendingactions"+---- --getLine+---- put1 "doaction 1 True"+---- --getLine+---- put1 "showcompletedactions"+---- --getLine+----+---- put1 "showpendingactions"+---- --getLine+----+---- put2 "doaction 1 True"+---- put1 "amendconstitution"+---- --getLine+----+---- put1 "debug read"+----+---- let endrules = [nrVote,+---- nrImmutable,+---- NamedRule {rNumber=3, rName ="testRule3", rText="testRuletext", rProposedBy=1, rule = "Legal", rStatus = Active, rejectedBy = Nothing},+---- NamedRule {rNumber=4, rName ="testRule4", rText="testRuletext", rProposedBy=2, rule = "eraseRule 3", rStatus = Pending, rejectedBy = Nothing}]+---- let endActions = [Action 1 3 (Vote (Konst "Please vote") (Konst 2)) (Just True),+---- Action 1 3 (Vote (Konst "Please vote") (Konst 1)) (Just True)]+----+---- s <- liftIO $ atomically $ readTChan debugChan+---- --putStrLn $ "Test result:" ++ show (head $ games $ multi s)+----+---- putStrLn $ show (rules $ head $ games $ multi s)+---- putStrLn $ show endrules+---- putStrLn $ show (actionResults $ head $ games $ multi s)+---- putStrLn $ show endActions+----+----+---- return $ (sort $ rules $ head $ games $ multi s) == endrules+---- && (actionResults $ head $ games $ multi s) == endActions+----+--+---- instances+----instance Arbitrary Rule where +---- arbitrary = sized (arbtree 0 maxkey) +---- where maxkey = 1000 +---- +----arbtree :: Int -> Int -> Int -> Gen (Rule) +----arbtree lo hi n +---- | n <= 0 = elements [Legal, Illegal] +---- | lo >= hi = elements [Legal, Illegal] +---- | otherwise = do{ i <- choose (lo,hi) +---- ; m <- choose (1,30) +---- ; let (ml,mr) | m==(1::Int)= (1,2) +---- | m==2 = (2,1) +---- | m==3 = (1,1) +---- | otherwise = (2,2) +---- ; l <- arbtree lo (i-1) (n `div` ml) +---- ; r <- arbtree (i+1) hi (n `div` mr) +---- ; return (Rand l r) +---- } +--+---- Gather all test +-- +--allTests = liftM and $ sequence [ruleTestPassed, obsTestPassed, crTestPassed, --actionTestPassed,+-- applyRuleToCurrentRuleSetTest] --, testMulti1, testMulti2] -- must allways be True+--