Templates.hs

{-# LANGUAGE DoAndIfThenElse      #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
--{-# LANGUAGE ApplicativeDo  #-}

module Nomyx.Web.Game.Templates where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.State
import           Data.Maybe
import           Data.Function (on)
import           Data.String
import           Data.List (sortBy, groupBy)
import           Data.Ord (comparing)
import           Data.Text                   (Text, pack, unpack)
import           Data.Text.Encoding
import           Happstack.Server            (Method (..), Response, methodM,
                                              ok, seeOther, toResponse)
import           Nomyx.Language
import           Nomyx.Core.Engine
import           Nomyx.Core.Session          as S
import           Nomyx.Core.Types            as T
import           Nomyx.Core.Utils
import           Nomyx.Web.Common            as NWC
import qualified Nomyx.Web.Help              as Help
import           Nomyx.Web.Types
import           Prelude                     hiding (div)
import           Text.Blaze.Html5            as H (Html, a, div, h2, h3, h4,
                                                   img, input, label, li, pre,
                                                   toValue, ul, (!), p, br)
import           Text.Blaze.Html5.Attributes as A (class_, disabled, for, href,
                                                   id, placeholder, src, type_,
                                                   value)
import           Text.Reform                 (eitherForm, viewForm, (++>),
                                              (<++))
import           Text.Reform.Blaze.Common    (setAttr)
import           Text.Reform.Blaze.String    (inputHidden, inputSubmit, label,
                                              textarea)
import qualified Text.Reform.Blaze.String    as RB
import           Text.Reform.Happstack       (environment)
import           Web.Routes.RouteT           (liftRouteT)
import           Happstack.Server            (ContentType)
import           Safe
import           Network.HTTP.Base                  (urlEncode)
default (Integer, Double, Data.Text.Text)


-- * Library display

viewLibrary :: Library -> Maybe LastRule -> GameName -> Bool -> RoutedNomyxServer Html
viewLibrary (Library rts ms) mlr gn isGameAdmin = do
  vrs <- mapM (viewPaneRuleTemplate gn mlr isGameAdmin) rts
  ok $ do
    div ! class_ "ruleList" $ viewRuleTemplateCats rts mlr
    div ! class_ "rules" $ sequence_ vrs

-- * left menu display

viewRuleTemplateCats :: [RuleTemplate] -> Maybe LastRule -> Html
viewRuleTemplateCats rts mlr = do
  let cat = (headDef "Not category" . _rCategory)
  let rts' = groupBy ((==) `on` cat) $ sortBy (comparing cat) rts
  h2 "Library of rules"
  ul $ mapM_  viewRuleTemplateCat rts'

viewRuleTemplateCat :: [RuleTemplate] -> Html
viewRuleTemplateCat rts = li $ do
   fromString $ headDef "No category" $ _rCategory $ head rts
   ul $ mapM_  viewRuleTemplateName rts

viewRuleTemplateName :: RuleTemplate -> Html
viewRuleTemplateName rt = li $ H.a (fromString $ _rName rt) ! A.class_ "ruleName" ! (A.href $ toValue $ "?ruleName=" ++ (idEncode $ _rName rt))


-- * main tab display

viewPaneRuleTemplate :: GameName -> Maybe LastRule -> Bool -> RuleTemplate -> RoutedNomyxServer Html
viewPaneRuleTemplate gn mlr isGameAdmin rt = do
  let toEdit = case mlr of
       Nothing -> (rt, "")
       Just lr -> if ((_rName $ fst lr) == (_rName rt)) then lr else (rt, "")
  com <- templateCommands gn rt
  view <- viewRuleTemplate gn toEdit isGameAdmin
  edit <- viewRuleTemplateEdit toEdit gn
  ok $ div ! A.class_ "rule" ! A.id (toValue $ idEncode $ _rName rt) $ do
    com
    view
    edit

-- ** Template commands

templateCommands :: GameName -> RuleTemplate -> RoutedNomyxServer Html
templateCommands gn rt = do
  let delLink = showRelURL (DelRuleTemplate gn (_rName rt))
  let idrt = idEncode $ _rName rt
  ok $ div ! A.class_ "commandrule" $ do
    p $ H.a "view"   ! (A.href $ toValue $ "?ruleName=" ++ idrt)
    p $ H.a "edit"   ! (A.href $ toValue $ "?ruleName=" ++ idrt ++ "&edit")
    p $ H.a "delete" ! (A.href $ toValue delLink)


delRuleTemplate :: GameName -> RuleName -> RoutedNomyxServer Response
delRuleTemplate gn rn = do
  pn <- fromJust <$> getPlayerNumber
  webCommand $ S.delRuleTemplate rn pn
  seeOther (showRelURL $ Menu Lib gn) $ toResponse "Redirecting..."


viewRuleTemplate :: GameName -> LastRule -> Bool -> RoutedNomyxServer Html
viewRuleTemplate gn (rt@(RuleTemplate name desc code author picture _ decls), err) isGameAdmin = do
  lf  <- liftRouteT $ lift $ viewForm "user" (submitRuleTemplatForm (Just rt) isGameAdmin)
  ok $ div ! A.class_ "viewrule" $ do
    viewRuleHead name picture desc author
    viewRuleCode code
    mapM (viewDecl gn) decls
    div $ pre $ fromString err
    blazeForm lf $ showRelURL (SubmitRule gn)


submitRuleTemplatForm :: (Maybe RuleTemplate) -> Bool -> NomyxForm (String, Maybe String)
submitRuleTemplatForm mrt isGameAdmin = 
   (,) <$> inputHidden (show mrt)
       <*> if isGameAdmin then inputSubmit "Admin submit" else pure Nothing

--submitRuleTemplatForm :: (Maybe RuleTemplate) -> Bool -> NomyxForm (String, Maybe String)
--submitRuleTemplatForm mrt isGameAdmin = do
--  srt <- inputHidden (show mrt)
--  admin <- if isGameAdmin then inputSubmit "Admin submit" else pure Nothing
--  return (srt, admin)

viewDecl :: GameName -> FilePath -> Html
viewDecl gn modPath = do
   let link = showRelURLParams (Menu Modules gn) [("modulePath", Just $ pack $ idEncode modPath)]
   H.a (fromString modPath) ! (A.href $ toValue $ link)
   H.br


-- | Submit a template to a given game
submitRuleTemplatePost :: GameName -> RoutedNomyxServer Response
submitRuleTemplatePost gn = toResponse <$> do
   methodM POST
   s <- getSession
   let gi = getGameByName gn s
   admin <- isGameAdmin (fromJust gi)
   r <- liftRouteT $ lift $ eitherForm environment "user" (submitRuleTemplatForm Nothing True)
   pn <- fromJust <$> getPlayerNumber
   rt <- case r of
      Right (srt, Nothing) -> do
         let rt = fromJust $ read srt
         webCommand $ submitRule rt pn gn
         return rt
      Right (srt, Just _)  -> do
         let rt = read srt
         webCommand $ adminSubmitRule rt pn gn
         return rt
      (Left _)            -> error "cannot retrieve form data"
   seeOther (showRelURLParams (Menu Lib gn) [("ruleName", Just $ pack $ idEncode $ _rName rt)]) $ "Redirecting..."


-- * Template edit

-- Edit a template
viewRuleTemplateEdit :: LastRule -> GameName -> RoutedNomyxServer Html
viewRuleTemplateEdit lr gn = do
  lf  <- liftRouteT $ lift $ viewForm "user" (newRuleTemplateForm (Just $ fst lr) True)
  ok $ div ! A.class_ "editRule" $ do
    blazeForm lf $ showRelURL $ NewRuleTemplate gn
    pre $ fromString $ snd lr

newRuleTemplateForm :: Maybe RuleTemplate -> Bool -> NomyxForm (RuleTemplate, Maybe String)
newRuleTemplateForm sr isGameAdmin = newRuleTemplateForm' (fromMaybe (RuleTemplate "" "" "" "" Nothing [] []) sr) isGameAdmin

newRuleTemplateForm' :: RuleTemplate -> Bool -> NomyxForm (RuleTemplate, Maybe String)
newRuleTemplateForm' rt isGameAdmin =
  (,) <$> newRuleTemplateForm'' rt
      <*> inputSubmit "Check"

newRuleTemplateForm'' :: RuleTemplate -> NomyxForm RuleTemplate
newRuleTemplateForm'' (RuleTemplate name desc code aut pic cat decls) =
  RuleTemplate <$>  RB.label "Name: " ++> RB.inputText name `setAttr` class_ "ruleName" <++ RB.br
               <*> (RB.label "      Short description: " ++> (RB.inputText desc `setAttr` class_ "ruleDescr") <++ RB.br)
               <*>  RB.label "      Code: " ++> textarea 80 15 code `setAttr` class_ "ruleCode" `setAttr` placeholder "Enter here your rule"
               <*>  (inputHidden aut)
               <*>  (read <$> (inputHidden $ show pic))
               <*>  (read <$> (inputHidden $ show cat))
               <*>  (read <$> (inputHidden $ show decls))

newRuleTemplate :: GameName -> RoutedNomyxServer Response
newRuleTemplate gn = toResponse <$> do
  methodM POST
  r <- liftRouteT $ lift $ eitherForm environment "user" (newRuleTemplateForm Nothing False)
  pn <- fromJust <$> getPlayerNumber
  case r of
     Right (rt, Nothing) -> do
       webCommand $ S.newRuleTemplate pn rt
       seeOther (showRelURLParams (Menu Lib gn) [("ruleName", Just $ pack $ idEncode $ _rName rt)]) $ "Redirecting..."
     Right (rt, Just _)  -> do
       webCommand $ S.checkRule rt pn gn
       seeOther (showRelURLParams (Menu Lib gn) [("ruleName", Just $ pack $ idEncode $ _rName rt), ("edit", Nothing)]) $ "Redirecting..."
     _ -> error "cannot retrieve form data"