MainPage.hs

{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, TemplateHaskell,
   EmptyDataDecls, TypeFamilies, MultiParamTypeClasses, DeriveDataTypeable, PackageImports, GADTs,
   ScopedTypeVariables, NamedFieldPuns, Rank2Types, DoAndIfThenElse, StandaloneDeriving, OverloadedStrings,
   ExtendedDefaultRules, RecordWildCards#-}

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_Language as PNL
import Control.Monad.State
import Data.Monoid
import Control.Concurrent.STM
import Language.Nomyx
import Happstack.Server as HS
import System.Directory
import System.FilePath
import System.Posix.Files
import qualified Web.Help as Help
import Types as T
import Web.Game
import Web.Common as W
import Web.Settings
import Web.NewGame
import Web.Login
import Utils
import Data.Maybe
import Data.Text(Text, pack)
import qualified Language.Nomyx.Game as G
import Happstack.Auth

default (Integer, Double, Data.Text.Text)


viewMulti :: PlayerNumber -> Session -> RoutedNomyxServer Html
viewMulti pn s = do
   pfd <- getProfile s pn
   let isAdmin = _isAdmin $ _pAdmin $ fromJust pfd
   gns <- viewGamesTab (map G._game $ _games $ _multi s) isAdmin
   mgn <- liftRouteT $ lift $ getPlayersGame pn s
   g <- case mgn of
      Just g -> viewGame (G._game g) pn (_pLastRule $ fromJust pfd) isAdmin
      Nothing -> ok $ h3 "Not viewing any game"
   ok $ do
      div ! A.id "gameList" $ gns
      div ! A.id "game" $ g

viewGamesTab :: [Game] -> Bool -> RoutedNomyxServer Html
viewGamesTab gs isAdmin = do
   gns <- mapM (viewGameName isAdmin) gs
   newGameLink <- showURL NewGame
   settingsLink <- showURL W.PlayerSettings
   advLink <- showURL Advanced
   logoutURL  <- showURL (U_AuthProfile $ AuthURL A_Logout)
   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 "Basic rules"       ! (href $ "/src/Language/Nomyx/Rule.hs") >> br
      H.a "Rules definitions" ! (href $ "/src/Language/Nomyx/Definition.hs") >> br
      H.a "Rules types"       ! (href $ "/src/Language/Nomyx/Expression.hs") >> br
      H.a "Voting system"     ! (href $ "/src/Language/Nomyx/Vote.hs") >> br
      mapM_ (\f -> (H.a $ toHtml f ) ! (href $ toValue (pathSeparator : modDir </> f)) >> br) fmods
      br >> "Settings:" >> br
      when isAdmin $ H.a "Create a new game" ! (href $ toValue newGameLink) >> br
      H.a "Player settings" ! (href $ toValue settingsLink) >> br
      H.a "Advanced"        ! (href $ toValue advLink) >> br
      H.a "Logout "         ! (href $ toValue logoutURL) >> br


viewGameName :: Bool -> Game -> RoutedNomyxServer Html
viewGameName isAdmin g = do
   let gn = _gameName g
   join  <- showURL (JoinGame gn)
   leave <- showURL (LeaveGame gn)
   view  <- showURL (ViewGame gn)
   del  <- showURL (DelGame gn)
   ok $ tr $ do
      td ! A.id "gameName" $ string $ (gn ++ "   ")
      td $ H.a "View"  ! (href $ toValue view) ! (A.title $ toValue Help.view)
      td $ H.a "Join"  ! (href $ toValue $ "#openModalJoin" ++ gn) ! (A.title $ toValue Help.join)
      td $ H.a "Leave" ! (href $ toValue leave)
      when isAdmin $ td $ H.a "Del"   ! (href $ toValue del)
      div ! A.id (toValue $ "openModalJoin" ++ gn) ! A.class_ "modalWindow" $ do
         div $ do
            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 <- liftIO $ atomically $ readTVar ts
   m <- viewMulti pn s
   name <- liftIO $ getPlayersName pn s
   playAs <- getPlayAs ts
   playAsName <- liftIO $ getPlayersName playAs s
   let body = do
       string $ "Welcome to Nomyx, " ++ name ++ "! "
       when (playAs /= pn) $ (b ! A.style "color:red;" $ string ("Playing as: " ++ playAsName ++ " (Player #" ++ (show playAs) ++ ")") )
   mainPage' "Welcome to Nomyx!"
            body
            (H.div ! A.id "multi" $ m)
            False

nomyxSite :: (TVar Session) -> Site PlayerCommand (ServerPartT IO Response)
nomyxSite tm = setDefault HomePage $ mkSitePI (runRouteT $ routedNomyxCommands tm)

routedNomyxCommands :: (TVar Session) -> PlayerCommand -> RoutedNomyxServer Response
routedNomyxCommands ts (U_AuthProfile auth)  = authenticate ts auth
routedNomyxCommands ts PostAuth              = postAuthenticate ts
routedNomyxCommands ts HomePage              = homePage ts
routedNomyxCommands ts MainPage              = nomyxPage ts
routedNomyxCommands ts (JoinGame game)       = joinGame ts game
routedNomyxCommands ts (LeaveGame game)      = leaveGame ts game
routedNomyxCommands ts (ViewGame game)       = viewGamePlayer ts game
routedNomyxCommands ts (DelGame game)        = delGame ts game
routedNomyxCommands ts NewRule               = newRule ts     >>= return . toResponse
routedNomyxCommands _  NewGame               = newGamePage    >>= return . toResponse
routedNomyxCommands ts SubmitNewGame         = newGamePost ts >>= return . toResponse
routedNomyxCommands ts (DoInput en)          = newInput en ts >>= return . toResponse
routedNomyxCommands ts Upload                = newUpload ts   >>= return . toResponse
routedNomyxCommands ts W.PlayerSettings      = playerSettings ts    >>= return . toResponse
routedNomyxCommands ts SubmitPlayerSettings  = newPlayerSettings ts >>= return . toResponse
routedNomyxCommands ts Advanced              = advanced ts    >>= return . toResponse
routedNomyxCommands ts SubmitPlayAs          = newPlayAsSettings ts >>= return . toResponse
routedNomyxCommands ts SubmitAdminPass       = newAdminPass ts >>= return . toResponse
routedNomyxCommands ts SubmitSettings        = newSettings ts >>= return . toResponse

launchWebServer :: (TVar Session) -> Network -> IO ()
launchWebServer tm net = do
   putStrLn $ "Starting web server...\nTo connect, drive your browser to \"" ++ nomyxURL net ++ "/Nomyx\""
   d <- PN.getDataDir
   d' <- PNL.getDataDir
   simpleHTTP nullConf {HS.port = T._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 Session) -> Network -> ServerPartT IO Response
server d d' tm net = mconcat [
    serveDirectory DisableBrowsing [] d,
    serveDirectory DisableBrowsing [] d',
    do decodeBody (defaultBodyPolicy "/tmp/" 102400 4096 4096)
       html <- implSite (pack (nomyxURL net)) "/Nomyx" (nomyxSite tm)
       return $ toResponse html]