Common.hs

{-# LANGUAGE ScopedTypeVariables #-}
module Bein.Web.Pages.Common where

import Database.HDBC
import Bein.Web.Elements 
import Bein.Web.Commands
import Bein.Web.Types
import Data.Monoid
import Control.Monad.Reader
import Control.Monad.Writer
import Happstack.Server as S hiding (method)
import qualified Text.XHtml as X
import Text.XHtml ((!))

data HideHeaderLink = HideHome | HideSettings | HideNone deriving (Eq,Show,Read)

-- | @page@ is the skeleton for all pages in Bein.  
page :: Maybe String -- ^ 'Nothing' for no title beyond "user@Bein"; 'Just "subtitle"' to add a subtitle.
        -> HideHeaderLink -- ^ which, if any, of the header links at the top right of the page to hide.
        -> (a -> BeinFormPart a Html) -- ^ The body of the page.  Should take a value to plug into 
                                      -- the page, such as for messages after operations.
        -> a -- ^ The value to plug into the body
        -> BeinServerPart Response
page ptitle hideLink pageBody plug = do
  setUTF8
  (b,posts) <- runWriterT (pageBody plug)
  h <- mconcatM [ pageHeader ptitle,
                  bodyM =<<: [ headerLinks hideLink, bodyTitle ptitle, thedivM <! [theclass "main-panel"] $ b ],
                  pageFooter ]
  mconcat ((nullDir >> (ok $ toResponse $ renderHtml h)) :
           map (\(postDir,postMonad) -> methodOnly POST >> dir postDir (postMonad >>= handlePost)) posts)
    where handlePost (ContinuePage v) = page ptitle hideLink pageBody v
          handlePost (ContinuePageWithWrapper v wrp) = wrp $ page ptitle hideLink pageBody v
          handlePost (NewResponse r) = return r
          handlePost (RedirectTo s) = seeOther s (toResponse "Redirecting...")

bodyTitle :: Maybe String -> BeinServerPart Html
bodyTitle Nothing = asks stUser >>= \user -> h1M << maybe "" userAtBein user
bodyTitle (Just s) = asks stUser >>= \user -> h1M <! [theclass "title-with-subtitle"] << maybe "" userAtBein user <>
                                           h1M <! [theclass "subtitle"] << s
    
pageHeader :: Maybe String -> BeinServerPart Html
pageHeader ptitle = do
  stylesheetUrl <- fullUrl "/default.css"
--  scriptUrl <- fullUrl "/script.js"
--  jqueryUrl <- fullUrl "/jquery.js"
  fullTitle <- asks stUser >>= \user -> return $ maybe "" userAtBein user ++ maybe "" (\t -> " - " ++  t) ptitle
  headerM =<<: [
    thetitleM << fullTitle,
    linkM <!> [rel "stylesheet", href stylesheetUrl, thetype "text/css"],
--    scriptM <! [thetype "text/javascript", src jqueryUrl] $ noHtml,
--    scriptM <! [thetype "text/javascript", src scriptUrl] $ noHtml,
    metaM <!> [httpequiv "Content-Type", content "text/html; charset=utf-8"]
    ]

headerLinks :: HideHeaderLink -> BeinServerPart Html
headerLinks toHide = paragraphM <! [identifier "header-links"] =<<: [ 
    (if toHide /= HideHome then home <> html " | " else noHtmlM),
    (if toHide /= HideSettings then settings <> html " | " else noHtmlM),
    signOut ]
    where linkTemplate target txt = fullUrl target >>= \t -> anchorM <! [href t] << txt
          home = linkTemplate "/" "Home"
          settings = linkTemplate "/settings" "Settings"
          signOut = linkTemplate "/signout" "Sign Out"


pageFooter :: BeinServerPart Html
pageFooter = thedivM <! [identifier "footer"] =<< paragraphM =<<: [
  html "Bein may eat your data.", brM, 
  html "Bein may launch nuclear missiles at Guam.", brM,
  html "We like to think this is unlikely.", brM,
  html "Contact its creator at ", ttM << "fred dot ross at epfl dot ch" ]

-- Body elements

objUrl :: String -> BeinServerPart String
objUrl p = do 
  obj <- asksObject
  fullUrl $ show (objId obj) ++ "/" ++ p

objectFormTo :: String -> BeinServerPart (FormResponse a) -> Html -> BeinFormPart a Html
objectFormTo url handler frm = do
  obj <- lift $ asksObject
  u <- lift $ fullUrl $ (show (objId obj) ++ "/" ++ case url of "" -> ""; '/':r -> r; r -> r)
  tell [(url,handler)]
  formM <! [method "post", action u] $ frm

formTo :: String -> BeinServerPart (FormResponse a) -> Html -> BeinFormPart a Html
formTo url handler frm = do
  tell [(url, handler)]
  formM <! [method "post", action url] $ frm

multipartFormTo :: String -> BeinServerPart (FormResponse a) -> Html -> BeinFormPart a Html
multipartFormTo url handler frm = do
  tell [(url, handler)]
  formM <! [method "post", action url, enctype "multipart/form-data"] $ frm


alignedLabelM :: (HTML a, Monad m) => a -> m Html
alignedLabelM txt = thespanM <! [theclass "inline-label"] << txt

redParagraph :: HTML a => a -> Html
redParagraph txt = X.paragraph ! [thestyle "text-align: center; color: red; font-weight: bold;"] X.<< txt

greenParagraph :: HTML a => a -> Html
greenParagraph txt = X.paragraph ! [thestyle "text-align: center; color: green; font-weight: bold;"] X.<< txt

formatPermissions :: Bool -> Bool -> Bool -> Bool -> String
formatPermissions pgr pgw pwr pww = formatHalf pgr pgw ++ "/" 
                                    ++ formatHalf pwr pww
  where formatHalf False False = "--"
        formatHalf False True = "w"
        formatHalf True False = "r"
        formatHalf True True = "rw"

groupBox :: Monad m => String -> [Group] -> Group -> m Html
groupBox ident gs currentGroup = selectM <! [identifier ident, name ident] =<<: map groupToOption gs
  where groupToOption g = optionM <! attrs g << groupName g
        attrs g = [value (show $ gid g)] ++ if currentGroup == g then [selected] else []


-- checkField :: HTML a => String -> a -> Bool -> Html
-- checkField identifier displayName isChecked = X.label $ checkbox identifier "True" ! (if isChecked then [checked] else []) <> toHtml displayName

-- groupBox :: String -> [Group] -> Group -> Html
-- groupBox ident groups currentGroup = select ! [identifier ident, name ident] $ mconcat $ map groupToOption groups
--   where groupToOption g = option ! attrs g << groupName g
--         attrs g = if currentGroup == g then [value (show $ gid g), selected] else [value (show $ gid g)]

-- formTo :: URL -> URL -> Html -> Html
-- formTo baseUrl to = form ! [X.method "post", action (joinURL baseUrl to)]
            
-- permissionBoxes :: Bool -> Bool -> Bool -> Bool -> Html
-- permissionBoxes gr gw wr ww = mconcat [
--   toHtml "Group can ", checkField "defaultgr" "Read" gr, toHtml " ", 
--   checkField "defaultgw" "Write" gw, toHtml " / ",
--   toHtml "World can ", checkField "defaultwr" "Read" wr, toHtml " ",
--   checkField "defaultww" "Write" ww ]
                              
-- buttonTo :: URL -> URL -> String -> Html
-- buttonTo baseUrl url txt = form ! [X.method "post", action (joinURL baseUrl url)] $ submit txt txt

        
-- formHtml :: X.HTML a => a -> BeinForm ()
-- formHtml = xml . toHtml

-- lookInputs :: RqData Env
-- lookInputs = do
--   inps <- asks fst
--   return $ map toFileOrField inps
--     where toFileOrField (n,i) | inputFilename i == Nothing = (n, Left $ toString (inputValue i))
--                               | otherwise = (n, Right (Text.Formlets.File { content = inputValue i, fileName = (fromJust (inputFilename i)), 
--                                                                             contentType = convertContentType (inputContentType i) }))
--           convertContentType ct = F.ContentType { F.ctType = S.ctType ct, F.ctSubtype = S.ctSubtype ct, F.ctParameters = S.ctParameters ct }


-- formlet :: String -> BeinForm b -> (b -> BeinM WebState (Either [String] ())) -> RereadOnUpdate -> BeinFormPart Html
-- formlet postDir frm successAction updatePolicy = do
--   let (extractor, xml, endState) = runFormState [] frm
--   tell [(postDir, response)]
--   return $ form ! [X.method "POST", action postDir] << (xml +++ X.submit "save" "Save")
--     where response :: BeinServerPart Response
--           response = methodOnly POST >> (authenticated $ withDataFn lookInputs $ \x -> do
--             let (extractor,_,_) = runFormState x frm
--             lift extractor >>= \v -> case v of
--               Failure errs -> asks stPage >>= \f -> f (mconcat $ map redParagraph errs)
--               Success s    -> lift (successAction s) >>= \r -> case r of
--                 Left errs -> asks stPage >>= \f -> updateState updatePolicy $ f (mconcat $ map redParagraph errs)
--                 Right ()  -> asks stPage >>= \f -> updateState updatePolicy $ f (greenParagraph "Succeeded."))

-- updateState :: RereadOnUpdate -> BeinServerPart m -> BeinServerPart m
-- updateState NoReread r = r
-- updateState RereadUser r = asks stUser >>= \u -> case u of
--   Nothing -> r
--   Just user -> lift (getUser (WithUid (uid user))) >>= \newUser -> local (\st -> st { stUser = newUser }) r
-- updateState RereadObject r = asksObject >>= \o -> lift (getObject (objId o)) >>= \(Just newObj) -> local (\st -> st { stObject = newObj }) r
-- updateState RereadUserAndObject r = updateState RereadUser (updateState RereadObject r)

rereadUser :: BeinServerPart Response -> BeinServerPart Response
rereadUser r = asks stUser >>= \u -> case u of
  Nothing   -> r
  Just user -> lift (getUser (WithUid (uid user))) >>= \newUser -> local (\st -> st { stUser = newUser }) r
  
rereadObject :: BeinServerPart Response -> BeinServerPart Response
rereadObject r = asksObject >>= \o -> lift (getObject (objId o)) >>= \(Just newObj) -> local (\st -> st { stObject = newObj }) r

hasPermissions :: String -> String -> BeinServerPart ()
hasPermissions groupTerm worldTerm = do
  user <- asksUser
  obj <- asksObject
  let q = "select id from headers where id = ? and (uid=? or (" ++ groupTerm ++ " = true and array[gid] <@ array" ++ 
          (show $ map gid $ groups user) ++ ") or " ++ worldTerm ++ " = true)"
  lift $ maybeRowQuery q [toSql (objId obj), toSql (uid user)] >>= \r -> case r of
      Nothing -> mzero
      Just _  -> return ()

hasReadPermissions :: BeinServerPart ()
hasReadPermissions = hasPermissions "gr" "wr"

hasWritePermissions :: BeinServerPart ()
hasWritePermissions = hasPermissions "gw" "ww"