diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,1 @@ +Corentin Dupont diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright 2012, Corentin Dupont. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Nomyx.cabal b/Nomyx.cabal new file mode 100644 --- /dev/null +++ b/Nomyx.cabal @@ -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 + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 /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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -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 diff --git a/data/static/css/nomyx.css b/data/static/css/nomyx.css new file mode 100644 --- /dev/null +++ b/data/static/css/nomyx.css @@ -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%; + +} + + diff --git a/src/Commands.hs b/src/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Commands.hs @@ -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, " : change own name"), + ("newGame", NewGame, " : start a new game"), + ("joinGame", JoinGame, " : play in a game (you must be subscribed)"), + ("leaveGame", LeaveGame, " : stop playing in a game (you remain subscribed)"), + ("subscribeGame", SubscribeGame, " : subscribe to an existing game"), + ("unsubscribeGame", UnsubscribeGame," : unsubscribe to an existing game"), + ("showSubscribtion", ShowSubscription, " : show the subscribtions in the current game"), + ("showSubGame", ShowSubGame, " : show the subscribtions to that game"), + ("submitRule", SubmitRule, " : 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, " : 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) +-} diff --git a/src/Forms.hs b/src/Forms.hs new file mode 100644 --- /dev/null +++ b/src/Forms.hs @@ -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] diff --git a/src/Game.hs b/src/Game.hs new file mode 100644 --- /dev/null +++ b/src/Game.hs @@ -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) diff --git a/src/Help.hs b/src/Help.hs new file mode 100644 --- /dev/null +++ b/src/Help.hs @@ -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\"." diff --git a/src/Interpret.hs b/src/Interpret.hs new file mode 100644 --- /dev/null +++ b/src/Interpret.hs @@ -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) + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 diff --git a/src/Multi.hs b/src/Multi.hs new file mode 100644 --- /dev/null +++ b/src/Multi.hs @@ -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 + diff --git a/src/Server.hs b/src/Server.hs new file mode 100644 --- /dev/null +++ b/src/Server.hs @@ -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) +-} diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -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 + + diff --git a/src/Web.hs b/src/Web.hs new file mode 100644 --- /dev/null +++ b/src/Web.hs @@ -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 + diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -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 +--