{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ScopedTypeVariables #-} module Nomyx.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 Control.Monad import Control.Monad.State import Data.Monoid import Data.Maybe import Data.String import Control.Concurrent.STM import Language.Nomyx import Happstack.Server as HS import System.FilePath import qualified Nomyx.Web.Help as Help import Nomyx.Web.Common as W import Nomyx.Web.Settings import Nomyx.Web.NewGame import Nomyx.Web.Login import Nomyx.Web.Game.Infos import Nomyx.Web.Game.Rules import Nomyx.Web.Game.IOs import Nomyx.Web.Game.NewRule import Nomyx.Web.Game.Details import Nomyx.Core.Profile as Profile import Nomyx.Core.Utils import Nomyx.Core.Types as T import Nomyx.Core.Engine import qualified Nomyx.Core.Session as S import Data.List import Data.Text(Text, pack) import Happstack.Auth import Paths_Nomyx_Language import Control.Monad.Error import Control.Applicative import Safe default (Integer, Double, Data.Text.Text) viewMulti :: (Maybe PlayerNumber) -> FilePath -> Session -> RoutedNomyxServer Html viewMulti mpn saveDir s = do (isAdmin, lr) <- case mpn of Just pn -> do pfd <- getProfile s pn let isAdmin = _pIsAdmin $ fromJustNote "viewMulti" pfd let lr = _pLastRule $ fromJustNote "viewMulti" pfd return (isAdmin, lr) Nothing -> return (False, Nothing) let gis = _gameInfos $ _multi s gns <- viewGamesTab (_gameInfos $ _multi s) isAdmin saveDir mpn vgs <- mapM (\gi -> viewGameInfo gi mpn lr isAdmin) gis ok $ do div ! A.id "gameList" $ gns sequence_ vgs viewGamesTab :: [GameInfo] -> Bool -> FilePath -> (Maybe PlayerNumber) -> RoutedNomyxServer Html viewGamesTab gis isAdmin saveDir mpn = do let canCreateGame = maybe False (\pn -> isAdmin || numberOfGamesOwned gis pn < 1) mpn let publicPrivate = partition ((== True) . _isPublic) gis let vgi = viewGameName isAdmin mpn public <- mapM vgi (fst publicPrivate) private <- mapM vgi (snd publicPrivate) newGameLink <- defLink NewGame (isJust mpn) settingsLink <- defLink W.PlayerSettings (isJust mpn) advLink <- defLink Advanced (isJust mpn) logoutURL <- defLink (Auth $ AuthURL A_Logout) (isJust mpn) loginURL <- showURL (Auth $ AuthURL A_Login) fmods <- liftIO $ getUploadedModules saveDir ok $ do h3 "Main menu" >> br case public of [] -> b "No public games" p:ps -> do b "Public games:" table $ do p ! A.style "font-weight:bold;" sequence_ ps br case private of [] -> "" p -> do b "Private games:" table $ sequence_ p br when canCreateGame $ H.a "Create a new game" ! (href $ toValue newGameLink) >> br br >> b "Help files:" >> br H.a "Rules examples" ! (href "/html/Language-Nomyx-Examples.html") ! target "_blank" >> br H.a "Nomyx language" ! (href "/html/Language-Nomyx.html") ! target "_blank" >> br when (fmods /= []) $ do br >> b "Uploaded files:" >> br mapM_ (\f -> (H.a $ toHtml f ) ! (href $ toValue (pathSeparator : uploadDir f)) >> br) (sort fmods) br >> b "Settings:" >> br H.a "Player settings" ! (href $ toValue settingsLink) >> br H.a "Advanced" ! (href $ toValue advLink) >> br H.a "Logout" ! (href $ toValue logoutURL) >> br H.a "Login" ! (href $ toValue loginURL) >> br viewGameInfo :: GameInfo -> (Maybe PlayerNumber) -> Maybe LastRule -> Bool -> RoutedNomyxServer Html viewGameInfo gi mpn mlr isAdmin = do let g = getGame gi let gn = _gameName g (pi, isGameAdmin, playAs, pn) <- case mpn of Just pn -> do let pi = Profile.getPlayerInfo g pn let isGameAdmin = isAdmin || maybe False (== pn) (_ownedBy gi) let playAs = maybe Nothing _playAs pi return (pi, isGameAdmin, playAs, pn) Nothing -> return (Nothing, False, Nothing, 0) rf <- viewRuleForm mlr (isJust pi) isGameAdmin (_gameName g) vios <- viewIOs (fromMaybe pn playAs) g vgd <- viewGameDesc g mpn playAs isGameAdmin ok $ div ! A.id (fromString $ (getElementName VisGame gn) ++ "Div") ! A.class_ (fromString $ ((getGroupName VisGame) ++ "Div") ++ " game") $ do div ! A.id "titleBar" $ do let attr :: String -> Attribute attr name = A.id (fromString $ (getElementName (VisGameTabs gn) name) ++ "Button") <> A.class_ (fromString $ (getGroupName (VisGameTabs gn)) ++ "Button" ++ " button") <> onclick (fromString $ setDivVisibilityAndSave (getGroupName (VisGameTabs gn)) (getElementName (VisGameTabs gn) name)) H.a "Description " ! attr "gameDesc" ! A.style "fontWeight:bold;" H.a "Rules " ! attr "rules" H.a "Inputs/Outputs " ! attr "ios" H.a "New rule " ! attr "newRule" H.a "Details " ! attr "details" let attr name = A.id (fromString $ (getElementName (VisGameTabs gn) name) ++ "Div") <> A.class_ (fromString $ (getGroupName (VisGameTabs gn)) ++ "Div" ++ " gameBox") div ! attr "gameDesc" ! A.style "display:inline;" $ vgd div ! attr "rules" ! A.style "display:none;" $ viewAllRules g div ! attr "ios" ! A.style "display:none;" $ vios div ! attr "newRule" ! A.style "display:none;" $ rf div ! attr "details" ! A.style "display:none;" $ viewDetails pn g data VisLevel = VisGame | VisGameTabs GameName deriving (Show) getElementName :: VisLevel -> String -> String getElementName vs name = (getGroupName vs) ++ "-" ++ (filter (/=' ') name) getGroupName :: VisLevel -> String getGroupName VisGame = "Game" getGroupName (VisGameTabs gn) = "GameTabs" ++ (filter (/=' ') gn) viewGameName :: Bool -> (Maybe PlayerNumber) -> GameInfo -> RoutedNomyxServer Html viewGameName isAdmin mpn gi = do let g = getGame gi let isGameAdmin = isAdmin || maybe False (==mpn) (Just $ _ownedBy gi) let gn = _gameName g let canView = isGameAdmin || _isPublic gi ok $ when canView $ do let attr = A.id (fromString $ ((getElementName VisGame gn) ++ "Button")) <> A.class_ (fromString $ ((getGroupName VisGame) ++ "Button") ++ " button") <> onclick (fromString $ setDivVisibilityAndSave (getGroupName VisGame) (getElementName VisGame gn)) tr $ td $ H.a (fromString (gn ++ " ")) ! (A.title $ toValue Help.view) ! attr joinGame :: GameName -> TVar Session -> RoutedNomyxServer Response joinGame gn ts = do pn <- fromJust <$> getPlayerNumber ts webCommand ts (S.joinGame gn pn) link <- showURL MainPage seeOther link $ toResponse "Redirecting..." leaveGame :: GameName -> TVar Session -> RoutedNomyxServer Response leaveGame gn ts = do pn <- fromJust <$> getPlayerNumber ts webCommand ts (S.leaveGame gn pn) link <- showURL MainPage seeOther link $ toResponse "Redirecting..." delGame :: GameName -> TVar Session -> RoutedNomyxServer Response delGame gn ts = do webCommand ts (S.delGame gn) link <- showURL MainPage seeOther link $ toResponse "Redirecting..." nomyxPage :: TVar Session -> RoutedNomyxServer Response nomyxPage ts = do mpn <- getPlayerNumber ts s <- liftIO $ atomically $ readTVar ts let saveDir = _saveDir $ _mSettings $ _multi s name <- case mpn of Just pn -> liftIO $ Profile.getPlayerName pn s Nothing -> return "Guest" m <- viewMulti mpn saveDir s mainPage' "Welcome to Nomyx!" (fromString $ "Welcome to Nomyx, " ++ name ++ "! ") (H.div ! A.id "multi" $ m) False nomyxSite :: TVar Session -> Site PlayerCommand (ServerPartT IO Response) nomyxSite tm = setDefault MainPage $ mkSitePI (runRouteT $ catchRouteError . flip routedNomyxCommands tm) routedNomyxCommands :: PlayerCommand -> (TVar Session) -> RoutedNomyxServer Response routedNomyxCommands NotLogged = notLogged routedNomyxCommands (Auth auth) = authenticate auth routedNomyxCommands PostAuth = postAuthenticate routedNomyxCommands MainPage = nomyxPage routedNomyxCommands (W.JoinGame game) = joinGame game routedNomyxCommands (W.LeaveGame game) = leaveGame game routedNomyxCommands (DelGame game) = delGame game routedNomyxCommands (NewRule game) = newRule game routedNomyxCommands NewGame = newGamePage routedNomyxCommands SubmitNewGame = newGamePost routedNomyxCommands (DoInput en fa ft g) = newInput en fa ft g routedNomyxCommands Upload = newUpload routedNomyxCommands W.PlayerSettings = playerSettings routedNomyxCommands SubmitPlayerSettings = newPlayerSettings routedNomyxCommands Advanced = advanced routedNomyxCommands (SubmitPlayAs game) = newPlayAs game routedNomyxCommands SubmitAdminPass = newAdminPass routedNomyxCommands SubmitSettings = newSettings routedNomyxCommands SaveFilePage = saveFilePage launchWebServer :: TVar Session -> Network -> IO () launchWebServer tm net = do putStrLn $ "Starting web server...\nTo connect, drive your browser to \"" ++ nomyxURL net ++ "/Nomyx\"" simpleHTTP nullConf {HS.port = T._port net} $ server tm net --serving Nomyx web page as well as data from this package and the language library package server :: TVar Session -> Network -> ServerPartT IO Response server ts net = do s <- liftIO $ atomically $ readTVar ts let set = _mSettings $ _multi s docdir <- liftIO getDocDir mconcat [ serveDirectory EnableBrowsing [] (_saveDir set), serveDirectory EnableBrowsing [] docdir, serveDirectory EnableBrowsing [] (_webDir set), serveDirectory EnableBrowsing [] (_sourceDir set), do decodeBody (defaultBodyPolicy "/tmp/" 102400 4096 4096) html <- implSite (pack (nomyxURL net)) "/Nomyx" (nomyxSite ts) return $ toResponse html] catchRouteError :: RoutedNomyxServer Response -> RoutedNomyxServer Response catchRouteError page = page `catchError` const backToLogin where backToLogin :: RoutedNomyxServer Response backToLogin = toResponse <$> do link <- showURL NotLogged seeOther link ("Redirecting..." :: String) getDocDir :: IO FilePath getDocDir = do datadir <- getDataDir let (as, _:bs) = break (== "share") $ splitDirectories datadir return $ joinPath $ as ++ ["share", "doc"] ++ bs