Nomyx 0.0.1 → 0.0.3
raw patch · 8 files changed
+65/−439 lines, 8 filesdep +extensible-exceptionsdep +hdaemonizedep +muevaldep ~Nomyx-Rules
Dependencies added: extensible-exceptions, hdaemonize, mueval
Dependency ranges changed: Nomyx-Rules
Files
- Nomyx.cabal +13/−12
- README +2/−1
- TODO +4/−1
- data/static/css/nomyx.css +1/−1
- src/Main.hs +30/−10
- src/Multi.hs +6/−2
- src/Web.hs +9/−7
- tests/Test.hs +0/−405
Nomyx.cabal view
@@ -1,5 +1,5 @@ name: Nomyx-version: 0.0.1+version: 0.0.3 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -14,24 +14,25 @@ author: Corentin Dupont data-files: static/css/nomyx.css data-dir: data-extra-source-files: TODO README AUTHORS tests/Test.hs+extra-source-files: AUTHORS README TODO executable Nomyx build-depends: DebugTraceHelpers -any, MonadCatchIO-mtl -any,- Nomyx-Rules -any, QuickCheck -any, base <5, binary -any,+ Nomyx-Rules ==0.0.3, QuickCheck -any, base <5, binary -any, blaze-html ==0.5.*, blaze-markup -any, bytestring -any,- containers -any, directory -any, eprocess -any, 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+ containers -any, directory -any, eprocess -any,+ extensible-exceptions -any, filepath -any, happstack-server ==7.*,+ hdaemonize -any, hint -any, hint-server -any, hslogger -any,+ monad-loops -any, mtl ==2.*, mueval -any, network -any,+ process -any, reform -any, reform-blaze -any,+ reform-happstack -any, regular -any, safe -any, stm -any,+ text -any, time -any, unix -any, utf8-string -any,+ web-routes ==0.27.*, web-routes-happstack ==0.23.*,+ web-routes-regular ==0.19.*, web-routes-th -any main-is: Main.hs buildable: True extensions: CPP- hs-source-dirs: src tests+ hs-source-dirs: src other-modules: Help Game Forms Multi Server Utils Interpret Web Commands ghc-options: -W
README view
@@ -33,4 +33,5 @@ Troubleshooting ===============-see file TODO for known bugs.+See file TODO for known bugs.+Tested on Haskell-Platform 2012.1.0.0
TODO view
@@ -7,6 +7,9 @@ - store state in DB - make a command line client - make a clear login/session system +- colorize code +- make code instructions in the active rules table clickable to access haddock documentation +- mail server to send notices/events when other players played. Improves: @@ -15,12 +18,12 @@ - input sanitization and error reporting - avoid unrecoverable "error" in variables - add tests in main Nomyx +- secure interpreter with mueval: time limits, no unsafe instructions, memory limits... 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
data/static/css/nomyx.css view
@@ -129,7 +129,7 @@ } input[type="file"]{- font: normal 10px Arial;+ font: normal 11px Arial; } #description {
src/Main.hs view
@@ -24,24 +24,37 @@ import qualified System.Posix.Signals as S import Control.Monad.CatchIO import Control.Monad.Trans+import Test+import Data.Maybe+import Safe+import Network.BSD + -- | 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+ then do+ putStrLn $ "Tests result: " ++ show allTests+ return allTests else do+ serverCommandUsage multi <- newTVarIO defaultMulti --start the haskell interpreter sh <- protectHandlers startInterpreter --start the web server- forkIO $ launchWebServer sh multi+ port <- case (findPort flags) of+ Just p -> return $ read p+ Nothing -> return $ read "8000"+ host <- case (findHost flags) of+ Just h -> return h+ Nothing -> getHostName >>= return+ forkIO $ launchWebServer sh multi host port forkIO $ launchTimeEvents multi --loop serverLoop multi@@ -68,15 +81,13 @@ serverCommandUsage :: IO () serverCommandUsage = do putStrLn "Server commands:"- putStrLn "s -> save state"+ --putStrLn "s -> save state" putStrLn "d -> debug" putStrLn "q -> quit"-- -- | Launch mode data Flag - = Verbose | Version | Solo | Test + = Verbose | Version | Test | HostName String | Port String deriving (Show, Eq) -- | launch options description @@ -84,10 +95,10 @@ 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" + , Option ['t'] ["tests"] (NoArg Test) "perform routine check"+ , Option ['h'] ["host"] (ReqArg HostName "Hostname") "specify host name"+ , Option ['p'] ["port"] (ReqArg Port "Port") "specify port" ] - nomyxOpts :: [String] -> IO ([Flag], [String]) nomyxOpts argv = @@ -96,6 +107,15 @@ (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) where header = "Usage: Nomyx [OPTION...]" +findPort :: [Flag] -> Maybe String+findPort fs = headMay $ catMaybes $ map isPort fs where+ isPort (Port a) = Just a+ isPort _ = Nothing++findHost :: [Flag] -> Maybe String+findHost fs = headMay $ catMaybes $ map isHost fs where+ isHost (HostName a) = Just a+ isHost _ = Nothing helper :: MonadCatchIO m => S.Handler -> S.Signal -> m S.Handler helper handler signal = liftIO $ S.installHandler signal handler Nothing
src/Multi.hs view
@@ -77,6 +77,7 @@ 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)}) @@ -135,8 +136,9 @@ Just _ -> say "Already subscribed!" Nothing -> do say $ "Subscribing to game: " ++ game- put g {players = PlayerInfo { playerNumber = pn,- playerName = getPlayersName pn m} : (players g)}+ let player = PlayerInfo { playerNumber = pn, playerName = getPlayersName pn m}+ put g {players = player : (players g)}+ liftT $ triggerEvent (Player Arrive) (PlayerData player) -- | subcribe to a game.@@ -147,7 +149,9 @@ Nothing -> say "Not subscribed!" Just _ -> do say $ "Unsubscribing to game: " ++ game+ let player = PlayerInfo { playerNumber = pn, playerName = getPlayersName' g pn} put g {players = filter (\PlayerInfo { playerNumber = mypn} -> mypn /= pn) (players g)}+ liftT $ triggerEvent (Player Leave) (PlayerData player) showSubGame :: GameName -> PlayerNumber -> StateT Multi IO ()
src/Web.hs view
@@ -40,12 +40,14 @@ import System.FilePath import System.Posix.Files import qualified Help+import Network.BSD -- | associate a player number with a handle data PlayerClient = PlayerClient PlayerNumber deriving (Eq, Show) -- | A structure to hold the active games and players data Server = Server [PlayerClient] deriving (Eq, Show)+type Port = Int data PlayerCommand = Login | PostLogin@@ -468,20 +470,20 @@ 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\""+launchWebServer :: ServerHandle -> (TVar Multi) -> HostName -> Port -> IO ()+launchWebServer sh tm host portNumber = do+ putStrLn $ "Starting web server...\nTo connect, drive your browser to \"http://" ++ host ++ ":" ++ (show portNumber) ++ "/Login\"" d <- PN.getDataDir d' <- PNR.getDataDir- simpleHTTP nullConf $ server d d' sh tm+ simpleHTTP nullConf {port=portNumber} $ server d d' sh tm host portNumber --serving Nomyx web page as well as data from this package and the language library package-server :: FilePath -> FilePath -> ServerHandle -> (TVar Multi) -> NomyxServer Response-server d d' sh tm = mconcat [+server :: FilePath -> FilePath -> ServerHandle -> (TVar Multi) -> HostName -> Port -> NomyxServer Response+server d d' sh tm host port = mconcat [ serveDirectory EnableBrowsing [] d, serveDirectory EnableBrowsing [] d', do decodeBody (defaultBodyPolicy "/tmp/" 102400 4096 4096)- html <- implSite (pack "http://localhost:8000") "/Login" (nomyxSite sh tm)+ html <- implSite (pack ("http://" ++ host ++ ":" ++ (show port))) "/Login" (nomyxSite sh tm) return $ toResponse html] instance FromData NewRuleForm where
− tests/Test.hs
@@ -1,405 +0,0 @@---- | 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---