{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, TemplateHaskell, EmptyDataDecls, TypeFamilies, MultiParamTypeClasses, DeriveDataTypeable, PackageImports, GADTs, ScopedTypeVariables, NamedFieldPuns, Rank2Types, DoAndIfThenElse, StandaloneDeriving, OverloadedStrings, ExtendedDefaultRules#-} module Web.MainPage (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 Text.Blaze.Internal import Control.Monad import Paths_Nomyx as PN import Paths_Nomyx_Rules as PNR import Control.Monad.State import Data.Monoid import Control.Concurrent.STM import Language.Nomyx.Expression import Text.Reform.Happstack import Text.Reform import Happstack.Server as HS import System.Directory import System.FilePath import System.Posix.Files import qualified Web.Help as Help import Types import Web.Game import Web.Common import Web.Login import Web.Settings import Web.NewGame import qualified Text.Reform.Blaze.String as RB import Utils import Data.Maybe import Data.List import Data.Text(Text, pack) default (Integer, Double, Data.Text.Text) viewMulti :: PlayerNumber -> Multi -> RoutedNomyxServer Html viewMulti pn m = do let pl = fromJust $ find (\PlayerMulti {mPlayerNumber} -> pn==mPlayerNumber) (mPlayers m) gns <- viewGamesTab pn (games m) g <- case getPlayersGame pn m of Just g -> viewGame g pn (lastRule pl) 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 newGameLink <- showURL (NewGame pn) uploadLink <- showURL (Upload pn) settingsLink <- showURL (Settings 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 "Main menu" >> br "Active games:" >> br table $ do case gs of [] -> tr $ td "No Games" _ -> sequence_ gns br >> "Nomyx language files:" >> br H.a "Rules examples" ! (href $ "/src/Language/Nomyx/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 (uploadLink) ! (A.title $ toValue Help.upload) br >> "Settings:" >> br H.a "Create a new game" ! (href $ toValue newGameLink) >> br H.a "Player settings" ! (href $ toValue settingsLink) >> br 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) nomyxPage :: Multi -> PlayerNumber -> RoutedNomyxServer Html nomyxPage multi pn = do m <- viewMulti pn multi mainPage (H.div ! A.id "multi" $ m) "Welcome to Nomyx!" (string $ "Welcome to Nomyx, " ++ (getPlayersName pn multi) ++ "!") False nomyxPageServer :: PlayerNumber -> (TVar Multi) -> RoutedNomyxServer Html nomyxPageServer pn tm = do multi <- liftRouteT $ lift $ atomically $ readTVar tm nomyxPage multi pn nomyxSite :: (TVar Multi) -> Site PlayerCommand (ServerPartT IO Html) nomyxSite tm = setDefault Login $ mkSitePI (runRouteT $ routedNomyxCommands tm) routedNomyxCommands :: (TVar Multi) -> PlayerCommand -> RoutedNomyxServer Html routedNomyxCommands _ (Login) = loginPage routedNomyxCommands _ (NewPlayer lp) = newPlayerPage lp routedNomyxCommands tm (NewPlayerLogin lp) = newPlayerLogin tm lp routedNomyxCommands tm (PostLogin) = postLogin tm routedNomyxCommands tm (Noop pn) = nomyxPageServer pn tm routedNomyxCommands tm (JoinGame pn game) = webCommand tm pn (MultiJoinGame game pn) >> nomyxPageServer pn tm routedNomyxCommands tm (LeaveGame pn) = webCommand tm pn (MultiLeaveGame pn) >> nomyxPageServer pn tm routedNomyxCommands tm (SubscribeGame pn game) = webCommand tm pn (MultiSubscribeGame game pn) >> nomyxPageServer pn tm routedNomyxCommands tm (UnsubscribeGame pn game) = webCommand tm pn (MultiUnsubscribeGame game pn) >> nomyxPageServer pn tm routedNomyxCommands tm (NewRule pn) = newRule pn tm routedNomyxCommands _ (NewGame pn) = newGamePage pn routedNomyxCommands tm (SubmitNewGame pn) = newGame pn tm routedNomyxCommands tm (DoInputChoice pn en) = newInputChoice pn en tm routedNomyxCommands tm (DoInputString pn en) = newInputString pn en tm routedNomyxCommands tm (Upload pn) = newUpload pn tm routedNomyxCommands tm (Settings pn) = settings pn tm routedNomyxCommands tm (SubmitSettings pn) = newSettings pn tm {- 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 newUpload :: PlayerNumber -> (TVar Multi) -> RoutedNomyxServer Html newUpload pn tm = do methodM POST r <- liftRouteT $ eitherForm environment "user" uploadForm link <- showURL $ Noop pn case r of (Right (path,name,_)) -> webCommand tm pn $ MultiInputUpload pn path name (Left _) -> liftRouteT $ lift $ putStrLn $ "cannot retrieve form data" seeOther link $ string "Redirecting..." launchWebServer :: (TVar Multi) -> Network -> IO () launchWebServer tm net = do putStrLn $ "Starting web server...\nTo connect, drive your browser to \"" ++ nomyxURL net ++ "/Nomyx\"" d <- PN.getDataDir d' <- PNR.getDataDir simpleHTTP nullConf {HS.port = Types.port net} $ server d d' tm net --serving Nomyx web page as well as data from this package and the language library package server :: FilePath -> FilePath -> (TVar Multi) -> Network -> NomyxServer Response server d d' tm net = mconcat [ serveDirectory EnableBrowsing [] d, serveDirectory EnableBrowsing [] d', do decodeBody (defaultBodyPolicy "/tmp/" 102400 4096 4096) html <- implSite (pack (nomyxURL net)) "/Nomyx" (nomyxSite tm) return $ toResponse html]