diff --git a/Nomyx.cabal b/Nomyx.cabal --- a/Nomyx.cabal +++ b/Nomyx.cabal @@ -1,5 +1,5 @@ name: Nomyx -version: 0.2.0 +version: 0.2.1 cabal-version: >=1.6 build-type: Simple license: BSD3 @@ -18,12 +18,12 @@ executable Nomyx build-depends: Cabal -any, DebugTraceHelpers -any, MissingH -any, - MonadCatchIO-mtl -any, Nomyx-Language ==0.2.0, QuickCheck -any, - acid-state -any, base <5, binary -any, blaze-html ==0.5.*, - blaze-markup -any, bytestring -any, containers -any, - data-accessor-transformers -any, data-lens -any, data-lens-fd -any, - data-lens-template -any, directory -any, eprocess -any, - extensible-exceptions -any, fb -any, filepath -any, + MonadCatchIO-mtl -any, Nomyx-Language ==0.2.1, QuickCheck -any, + Unixutils -any, acid-state -any, base <5, binary -any, + blaze-html ==0.5.*, blaze-markup -any, bytestring -any, + containers -any, data-accessor-transformers -any, data-lens -any, + data-lens-fd -any, data-lens-template -any, directory -any, + eprocess -any, extensible-exceptions -any, fb -any, filepath -any, happstack-authenticate -any, happstack-server ==7.*, hdaemonize -any, hint -any, hint-server -any, hscolour -any, hslogger -any, ixset -any, lenses -any, mime-mail -any, @@ -38,8 +38,8 @@ buildable: True extensions: CPP hs-source-dirs: src - other-modules: Multi Test Serialize Quotes Mail Types Utils - Interpret Web.Game Web.Settings Web.MainPage Web.NewGame Web.Login - Web.Help Web.Common - ghc-options: -W + other-modules: Types Mail Test Multi Serialize Utils Interpret + Quotes Web.Common Web.Help Web.NewGame Web.Game Web.Login + Web.Settings Web.MainPage + ghc-options: -W -threaded diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -3,14 +3,13 @@ Bugs: - check when error on parameters (for victory for example) -- sendmail is blocking the game -- delete invalid events (in case of exception): events may be triggered twice if not deleted - reading save file does not take absolute path - add global option to not send mails - store hide/show status of divs - forbid creating a player with same name - where clauses are not accepted by the interpreter - suppress player from game when logout (?) +- better manage event deletion: an event can be deleted twice using its number Improvements: - make code instructions in the active rules table clickable to access haddock documentation @@ -32,6 +31,7 @@ Futur Nomic: - ability to analyse rules, proof system - first pass of compilation to check reference (avoid calls to non-existant variables for ex.) +- more stateless language - interpreter (like tryhaskell.org) on the web page to debug rules - make a command line client diff --git a/src/Interpret.hs b/src/Interpret.hs --- a/src/Interpret.hs +++ b/src/Interpret.hs @@ -43,7 +43,7 @@ loadModules fmods setTopLevelModules $ map (dropExtension . takeFileName) fmods dataDir <- liftIO getDataDir - set [searchPath := [dataDir], languageExtensions := [GADTs, ScopedTypeVariables]] --, languageExtensions := [], installedModulesInScope := False + set [searchPath := [dataDir], languageExtensions := [GADTs, ScopedTypeVariables]] --, installedModulesInScope := False --TODO: get all exported modules of Nomyx library from cabal setImports importList return () diff --git a/src/Mail.hs b/src/Mail.hs --- a/src/Mail.hs +++ b/src/Mail.hs @@ -33,7 +33,7 @@ putStrLn $ "sending a mail to " ++ to forkIO $ simpleMail (Address Nothing (pack to)) (Address (Just "Nomyx Game") "Nomyx.Game@gmail.com") (pack object) "" (B.pack body) [] >>= renderSendMail putStrLn $ "done" - return () + newRuleBody :: PlayerName -> SubmitRule -> PlayerName -> Network -> Html newRuleBody playerName (SubmitRule name desc code) prop net = docTypeHtml $ do diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -48,6 +48,7 @@ import Happstack.Auth.Core.Auth (initialAuthState) import Data.Acid.Local (createCheckpointAndClose) import Happstack.Auth.Core.Profile (initialProfileState) +import System.Unix.Directory defaultLogFile :: FilePath defaultLogFile = "Nomyx.save" @@ -69,7 +70,6 @@ start :: [Flag] -> IO () start flags = do serverCommandUsage - --start the haskell interpreter sh <- protectHandlers startInterpreter if Test `elem` flags then do @@ -90,22 +90,26 @@ Nothing -> getHostName >>= return logFilePath <- getDataFileName logFile let settings sendMail = Settings logFilePath (Network host port) sendMail + dataDir <- getDataDir + let profilesDir = dataDir "profiles" + when (NoReadSaveFile `elem` flags) $ do + removeRecursiveSafely profilesDir + removeFile (_logFilePath $ settings True) multi <- case (findLoadTest flags) of Just testName -> loadTestName (settings False) testName sh - Nothing -> Main.loadMulti (settings True) (not $ NoReadSaveFile `elem` flags) sh + Nothing -> Main.loadMulti (settings True) sh --main loop - profilePath <- getDataDir - withAcid (Just $ profilePath "profiles") $ \acid -> do + withAcid (Just profilesDir) $ \acid -> do tvSession <- atomically $ newTVar (Session sh multi acid) --start the web server forkIO $ launchWebServer tvSession (Network host port) forkIO $ launchTimeEvents tvSession serverLoop tvSession logFile -loadMulti :: Settings -> Bool -> ServerHandle -> IO Multi -loadMulti set readSaveFile sh = do +loadMulti :: Settings -> ServerHandle -> IO Multi +loadMulti set sh = do fileExists <- doesFileExist $ _logFilePath $ set - multi <- case fileExists && readSaveFile of + multi <- case fileExists of True -> do putStrLn "Loading previous game" Serialize.loadMulti set sh `catch` @@ -121,7 +125,7 @@ case s of "d" -> do (Session _ m _) <- atomically $ readTVar ts - putStrLn $ show m + putStrLn $ displayMulti m serverLoop ts f "s" -> do putStrLn "saving state..." diff --git a/src/Multi.hs b/src/Multi.hs --- a/src/Multi.hs +++ b/src/Multi.hs @@ -96,9 +96,7 @@ -- | result of choice with radio buttons inputChoiceResult :: EventNumber -> Int -> PlayerNumber -> StateT Session IO () -inputChoiceResult eventNumber choiceIndex pn = do - tracePN pn $ "input choice result: Event " ++ (show eventNumber) ++ ", choice " ++ (show choiceIndex) - inPlayersGameDo_ pn $ update $ InputChoiceResult pn eventNumber choiceIndex +inputChoiceResult eventNumber choiceIndex pn = inPlayersGameDo_ pn $ update $ InputChoiceResult pn eventNumber choiceIndex -- TODO maybe homogeneise both inputs event -- | result of choice with text field @@ -185,19 +183,26 @@ -- | the initial rule set for a game. rVoteUnanimity = SubmitRule "Unanimity Vote" "A proposed rule will be activated if all players vote for it" - [cr|onRuleProposed $ voteWith unanimity $ assessOnEveryVotes|] + [cr|onRuleProposed $ voteWith_ unanimity $ assessOnEveryVotes |] rVictory5Rules = SubmitRule "Victory 5 accepted rules" "Victory is achieved if you have 5 active rules" [cr|victoryXRules 5|] +rVoteMajority = SubmitRule "Majority Vote" + "A proposed rule will be activated if a majority of players is reached, with a minimum of 2 players, and within oone day" + [cr|onRuleProposed $ voteWith_ (majority `withQuorum` 2) $ assessOnEveryVotes >> assessOnTimeDelay oneMinute |] + initialGame :: ServerHandle -> StateT LoggedGame IO () initialGame sh = do - update' (Just $ getRuleFunc sh) $ SystemAddRule rVoteUnanimity + update' (Just $ getRuleFunc sh) $ SystemAddRule rVoteMajority --rVoteUnanimity update' (Just $ getRuleFunc sh) $ SystemAddRule rVictory5Rules initialLoggedGame :: GameName -> GameDesc -> UTCTime -> ServerHandle -> IO LoggedGame initialLoggedGame name desc date sh = do let lg = LoggedGame (emptyGame name desc date) [] execStateT (initialGame sh) lg + +displayMulti :: Multi -> String +displayMulti m = concatMap (displayGame . _game) (_games m) diff --git a/src/Serialize.hs b/src/Serialize.hs --- a/src/Serialize.hs +++ b/src/Serialize.hs @@ -14,9 +14,7 @@ import Interpret save :: FilePath -> Multi -> IO() -save fp m = do - putStrLn "saving" - writeFile fp (show m) +save fp m = writeFile fp (show m) save' :: StateT Multi IO () save' = do diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -202,3 +202,4 @@ condMoneyTransfer m = (_vName $ head $ _variables $ G._game $ head $ _games m) == "Accounts" +--voidRule $ let a = a + 1 in outputAll (show a) diff --git a/src/Web/Common.hs b/src/Web/Common.hs --- a/src/Web/Common.hs +++ b/src/Web/Common.hs @@ -28,8 +28,16 @@ import Data.Text(Text, pack) import Web.Routes.Happstack() import Happstack.Auth (UserId(..), getUserId, AuthProfileURL) -import Control.Category ((>>>)) import Serialize +import Control.Concurrent + (putMVar, tryPutMVar, killThread, threadDelay, MVar, ThreadId, + takeMVar, forkIO, newEmptyMVar) +import qualified Control.Exception as CE (catchJust) +import System.IO.Error (isUserError) +import Data.Time as T (getCurrentTime) +import System.IO (stdout, hSetBuffering) +import GHC.IO.Handle.Types (BufferMode(..)) +import Control.Exception (evaluate) data NomyxError = PlayerNameRequired | GameNameRequired @@ -88,18 +96,56 @@ modDir = "modules" evalCommand :: (TVar Session) -> StateT Session IO a -> RoutedNomyxServer a -evalCommand ts sm = liftRouteT $ lift $ do +evalCommand ts sm = liftIO $ do s <- atomically $ readTVar ts evalStateT sm s webCommand :: (TVar Session) -> StateT Session IO () -> RoutedNomyxServer () -webCommand ts sm = liftRouteT $ lift $ do +webCommand ts sm = liftIO $ do s <- atomically $ readTVar ts s' <- execStateT sm s atomically $ writeTVar ts s' - save (_multi >>> _mSettings >>>_logFilePath $ s) (_multi s') --TODO not really nice to put that here + save (_logFilePath $ _mSettings $ _multi $ s') (_multi s') --TODO not really nice to put that here +webCommand' :: (TVar Session) -> StateT Session IO () -> RoutedNomyxServer () +webCommand' ts sm = liftIO $ do + s <- atomically $ readTVar ts + s' <- execStateT sm s + atomically $ writeTVar ts s' + save (_logFilePath $ _mSettings $ _multi $ s') (_multi s') --TODO not really nice to put that here + + +protectedExecCommand :: (TVar Session) -> StateT Session IO a -> IO () +protectedExecCommand ts ss = do + mv <- newEmptyMVar + before <- atomically $ readTVar ts + id <- forkIO $ CE.catchJust (\e -> if isUserError e then Just () else Nothing) (execBlocking ss before mv) (\e-> putStrLn $ show e) + forkIO $ watchDog' 10 id mv + T.getCurrentTime >>= (\a -> putStrLn $ "before takevar " ++ show a) + res <- takeMVar mv + case res of + Nothing -> (atomically $ writeTVar ts before) >> T.getCurrentTime >>= (\a -> putStrLn $ "writing before" ++ show a) + Just (_, after) -> (atomically $ writeTVar ts after) >> T.getCurrentTime >>= (\a -> putStrLn $ "writing after " ++ show a) + +watchDog' :: Int -> ThreadId -> MVar (Maybe x) -> IO () +watchDog' t tid mv = do + threadDelay $ t * 1000000 + killThread tid + T.getCurrentTime >>= (\a -> putStrLn $ "process timeout " ++ show a) + tryPutMVar mv Nothing + return () + +execBlocking :: StateT Session IO a -> Session -> MVar (Maybe (a, Session)) -> IO () +execBlocking ss s mv = do + hSetBuffering stdout NoBuffering + T.getCurrentTime >>= (\a -> putStrLn $ "before runstate " ++ show a) + res <- runStateT ss s --runStateT (inPlayersGameDo 1 $ liftT $ evalExp (do let (a::Int) = a in outputAll $ show a) 1) m -- + T.getCurrentTime >>= (\a -> putStrLn $ "after runstate " ++ show a) + res' <- evaluate res + putMVar mv (Just res') + + blazeResponse :: Html -> Response blazeResponse html = toResponseBS (C.pack "text/html;charset=UTF-8") $ renderHtml html @@ -164,7 +210,7 @@ getPlayerNumber :: (TVar Session) -> RoutedNomyxServer PlayerNumber getPlayerNumber ts = do - (T.Session _ _ (Profiles acidAuth acidProfile _)) <- liftRouteT $ lift $ readTVarIO ts + (T.Session _ _ (Profiles acidAuth acidProfile _)) <- liftIO $ readTVarIO ts uid <- getUserId acidAuth acidProfile case uid of Nothing -> error "not logged in." diff --git a/src/Web/Game.hs b/src/Web/Game.hs --- a/src/Web/Game.hs +++ b/src/Web/Game.hs @@ -33,6 +33,7 @@ import qualified Language.Haskell.HsColour.HTML as HSC import Language.Haskell.HsColour.Colourise hiding (string) import Multi as M +import Debug.Trace (trace) default (Integer, Double, Data.Text.Text) @@ -130,14 +131,16 @@ td ! A.class_ "td" $ text "Event Number" td ! A.class_ "td" $ text "By Rule" td ! A.class_ "td" $ text "Event" + --td ! A.class_ "td" $ text "Status" mapM_ viewEvent $ sort ehs viewEvent :: EventHandler -> Html -viewEvent (EH eventNumber ruleNumber event _) = tr $ do +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 + --td ! A.class_ "td" $ string . show $ status viewInputs :: PlayerNumber -> [EventHandler] -> RoutedNomyxServer Html viewInputs pn ehs = do @@ -146,11 +149,11 @@ ok $ showHideTitle "Inputs" True (length is == 0) (h3 "Inputs") $ table $ mconcat is viewInput :: PlayerNumber -> EventHandler -> RoutedNomyxServer (Maybe Html) -viewInput me (EH eventNumber _ (InputChoice pn title choices def) _) | me == pn = do +viewInput me (EH eventNumber _ (InputChoice pn title choices def) _ EvActive) | me == pn = do link <- showURL (DoInputChoice 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 +viewInput me (EH _ _ (InputString pn title) _ EvActive) | me == pn = do link <- showURL (DoInputString title) lf <- lift $ viewForm "user" $ inputStringForm title return $ Just $ tr $ td $ blazeForm lf (link) @@ -208,7 +211,7 @@ gn' <- getPlayersGame pn s' let rs = _rules $ _game $ fromJust gn let rs' = _rules $ _game $ fromJust gn' - when (length rs' > length rs) $ sendMailsNewRule s' sr pn + when (length rs' > length rs) $ trace "new rule mail " $ sendMailsNewRule s' sr pn (Left _) -> liftIO $ putStrLn $ "cannot retrieve form data" seeOther link $ string "Redirecting..." @@ -241,7 +244,7 @@ seeOther link $ string "Redirecting..." getChoices :: EventHandler -> (String, [String], String) -getChoices (EH _ _ (InputChoice _ title choices def) _) = (title, map show choices, show def) +getChoices (EH _ _ (InputChoice _ title choices def) _ _) = (title, map show choices, show def) getChoices _ = error "InputChoice event expected" newInputString :: String -> (TVar Session) -> RoutedNomyxServer Html @@ -260,7 +263,7 @@ inputChoiceForm :: String -> [String] -> String -> NomyxForm Int -inputChoiceForm title choices def = RB.label (title ++ " ") ++> inputRadio' (zip [0..] choices) ((==) $ fromJust $ elemIndex def choices) +inputChoiceForm title choices def = RB.label (title ++ " ") ++> inputRadio' (zip [0..] choices) ((==) $ fromJust $ elemIndex def choices) <++ RB.label " " inputStringForm :: String -> NomyxForm String inputStringForm title = RB.label (title ++ " ") ++> RB.inputText "" diff --git a/src/Web/MainPage.hs b/src/Web/MainPage.hs --- a/src/Web/MainPage.hs +++ b/src/Web/MainPage.hs @@ -43,6 +43,7 @@ import qualified Language.Nomyx.Game as G import qualified Multi as M import Happstack.Auth + default (Integer, Double, Data.Text.Text) @@ -104,17 +105,17 @@ td $ H.a "Leave" ! (href $ toValue leave) div ! A.id (toValue $ "openModalJoin" ++ gn) ! A.class_ "modalWindow" $ do div $ do - h2 "Joining the game. Please register in the Agora and introduce yourself to the other players! \n \ - If you do not which to play, you can just view the game." + h2 "Joining the game. Please register in the Agora (see the link) and introduce yourself to the other players! \n \ + If you do not wich to play, you can just view the game." H.a "Join" ! (href $ toValue join) ! A.class_ "join" ! (A.title $ toValue Help.join) H.a "View" ! (href $ toValue view) ! A.class_ "view" ! (A.title $ toValue Help.view) nomyxPage :: (TVar Session) -> RoutedNomyxServer Response nomyxPage ts = do pn <- getPlayerNumber ts - s <- liftRouteT $ lift $ atomically $ readTVar ts + s <- liftIO $ atomically $ readTVar ts m <- viewMulti pn s - name <- liftRouteT $ lift $ getPlayersName pn s + name <- liftIO $ getPlayersName pn s mainPage' "Welcome to Nomyx!" (string $ "Welcome to Nomyx, " ++ name ++ "!") (H.div ! A.id "multi" $ m) @@ -140,44 +141,10 @@ routedNomyxCommands ts PSettings = settings ts >>= return . toResponse routedNomyxCommands ts SubmitPlayerSettings = newSettings ts >>= return . toResponse -{- -nomyxPageComm' :: PlayerNumber -> (TVar Multi) -> StateT Multi IO () -> RoutedNomyxServer Html -nomyxPageComm' pn tm comm = do - liftRouteT $ lift $ protectedExecCommand tm comm - nomyxPageServer pn tm -protectedExecCommand :: (TVar Multi) -> StateT Multi IO a -> IO () -protectedExecCommand tm sm = do - --liftIO $ mapM_ (uncurry setResourceLimit) limits - mv <- newEmptyMVar - before <- atomically $ readTVar tm - id <- forkIO $ CE.catchJust (\e -> if isUserError e then Just () else Nothing) (execBlocking sm before mv) (\e-> putStrLn $ show e) - forkIO $ watchDog' 10 id mv - getCurrentTime >>= (\a -> putStrLn $ "before takevar " ++ show a) - res <- takeMVar mv - case res of - Nothing -> (atomically $ writeTVar tm before) >> getCurrentTime >>= (\a -> putStrLn $ "writing before" ++ show a) - Just (_, after) -> (atomically $ writeTVar tm after) >> getCurrentTime >>= (\a -> putStrLn $ "writing after " ++ show a) -watchDog' :: Int -> ThreadId -> MVar (Maybe x) -> IO () -watchDog' t tid mv = do - threadDelay $ t * 1000000 - killThread tid - getCurrentTime >>= (\a -> putStrLn $ "process timeout " ++ show a) - tryPutMVar mv Nothing - return () -execBlocking :: StateT Multi IO a -> Multi -> MVar (Maybe (a, Multi)) -> IO () -execBlocking sm m mv = do - hSetBuffering stdout NoBuffering - getCurrentTime >>= (\a -> putStrLn $ "before runstate " ++ show a) - res@(_, m') <- runStateT sm m --runStateT (inPlayersGameDo 1 $ liftT $ evalExp (do let (a::Int) = a in outputAll $ show a) 1) m -- - getCurrentTime >>= (\a -> putStrLn $ "after runstate " ++ show a) - res' <- evaluate res - putMVar mv (Just res') --} - uploadForm :: NomyxForm (FilePath, FilePath, ContentType) uploadForm = RB.inputFile @@ -187,10 +154,10 @@ pn <- getPlayerNumber ts r <- liftRouteT $ eitherForm environment "user" uploadForm link <- showURL MainPage - (T.Session sh _ _) <- liftRouteT $ lift $ readTVarIO ts + (T.Session sh _ _) <- liftIO $ readTVarIO ts case r of (Right (path,name,_)) -> webCommand ts $ M.inputUpload pn path name sh - (Left _) -> liftRouteT $ lift $ putStrLn $ "cannot retrieve form data" + (Left _) -> liftIO $ putStrLn $ "cannot retrieve form data" seeOther link $ string "Redirecting..." diff --git a/src/Web/Settings.hs b/src/Web/Settings.hs --- a/src/Web/Settings.hs +++ b/src/Web/Settings.hs @@ -23,7 +23,6 @@ import Multi import Utils import Language.Nomyx -import Debug.Trace (trace) default (Integer, Double, Data.Text.Text) @@ -42,9 +41,9 @@ <*> pure True uniqueName :: [String] -> String -> Either NomyxError String -uniqueName names name = case trace (name ++ (show names) ++ (show (name `elem` names))) $ (name `elem` names) of - True -> trace "left" $ Left UniquePlayerName - False ->trace "right" $ Right name +uniqueName names name = case name `elem` names of + True -> Left UniquePlayerName + False -> Right name settingsPage :: PlayerSettings-> [PlayerName] -> RoutedNomyxServer Html