Nomyx 0.2.0 → 0.2.1
raw patch · 12 files changed
+109/−86 lines, 12 filesdep +Unixutilsdep ~Nomyx-Language
Dependencies added: Unixutils
Dependency ranges changed: Nomyx-Language
Files
- Nomyx.cabal +11/−11
- TODO +2/−2
- src/Interpret.hs +1/−1
- src/Mail.hs +1/−1
- src/Main.hs +12/−8
- src/Multi.hs +10/−5
- src/Serialize.hs +1/−3
- src/Test.hs +1/−0
- src/Web/Common.hs +51/−5
- src/Web/Game.hs +9/−6
- src/Web/MainPage.hs +7/−40
- src/Web/Settings.hs +3/−4
Nomyx.cabal view
@@ -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
TODO view
@@ -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
src/Interpret.hs view
@@ -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 ()
src/Mail.hs view
@@ -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
src/Main.hs view
@@ -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..."
src/Multi.hs view
@@ -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)
src/Serialize.hs view
@@ -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
src/Test.hs view
@@ -202,3 +202,4 @@ condMoneyTransfer m = (_vName $ head $ _variables $ G._game $ head $ _games m) == "Accounts" +--voidRule $ let a = a + 1 in outputAll (show a)
src/Web/Common.hs view
@@ -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."
src/Web/Game.hs view
@@ -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 ""
src/Web/MainPage.hs view
@@ -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..."
src/Web/Settings.hs view
@@ -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