Settings.hs

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

import Data.List
import Bein.Web.Pages.Login
import Database.HDBC
import Control.Monad.Trans
import Bein.Web.Pages.Common
import Bein.Web.Elements
import Bein.Web.Types
import Bein.Web.Commands
import Happstack.Server hiding (method)

settings :: BeinServerPart Response
settings = authenticated $ page (Just "Settings") HideSettings settingsPage noHtml

settingsPage :: Html -> BeinFormPart Html Html
settingsPage msg = 
  return msg <> defaults <> groupSettings

defaults :: BeinFormPart Html Html
defaults = do
  user <- lift $ asksUser
  mconcatM [ h2M << "Defaults", 
             formTo "defaults" setPermissions =<< paragraphM =<<: [ 
               alignedLabelM "Default permissions", html "Group can ", 
               labelM <! [for "gr"] << "Read", checkboxM "gr" "gr" (defaultGR user),
               labelM <! [for "gw"] << "Write", checkboxM "gw" "gw" (defaultGW user),
               html " / World can ",
               labelM <! [for "wr"] << "Read", checkboxM "wr" "wr" (defaultWR user),
               labelM <! [for "ww"] << "Write", checkboxM "ww" "ww" (defaultWW user),
               submitM "save" "Save" ] ]
    
setPermissions :: BeinServerPart (FormResponse Html)
setPermissions = withDataFn readPermissions updatePermissions
    where readPermissions :: RqData (Bool,Bool,Bool,Bool)
          readPermissions = do
            ngr <- lookCheckbox "gr"
            ngw <- lookCheckbox "gw"
            nwr <- lookCheckbox "wr"
            nww <- lookCheckbox "ww"
            return (ngr,ngw,nwr,nww)
          updatePermissions :: (Bool,Bool,Bool,Bool) -> BeinServerPart (FormResponse Html)
          updatePermissions (newgr,newgw,newwr,newww) = asksUser >>= \user ->
            updateSettings "update users set default_gr=?,default_gw=?,default_wr=?,default_ww=? where uid = ?"
              [toSql newgr, toSql newgw, toSql newwr, toSql newww, toSql $ uid user]
              "Failed to set default permissions:"
  
updateSettings :: String -> [SqlValue] -> String -> BeinServerPart (FormResponse Html)
updateSettings cmd args errMsg = 
  lift $ (update cmd args >> return (ContinuePageWithWrapper noHtml rereadUser))
    `catchR` (\e -> return $ ContinuePage (redParagraph $ errMsg ++ " " ++ show e))


groupSettings :: BeinFormPart Html Html
groupSettings = mconcatM [
  h2M << "Groups",
  defaultGroupForm,
  groupMembership ]
                                           
defaultGroupForm :: BeinFormPart Html Html                                           
defaultGroupForm = lift asksUser >>= \user -> 
  formTo "defaultgroup" setDefaultGroup =<< paragraphM =<<: [
    alignedLabelM "Default group",
    groupBox "defaultgroup" (groups user) (defaultGroup user),
    submitM "save" "Save" ]
  where setDefaultGroup :: BeinServerPart (FormResponse Html)
        setDefaultGroup = asksUser >>= \user -> withDataFn (readDefaultGroup user) (\thisGroup ->
          updateSettings "update users set default_group = ? where uid = ?" [toSql (gid thisGroup), toSql (uid user)]
            "Failed to change default group:")
        readDefaultGroup :: User -> RqData Group
        readDefaultGroup user = do
          newGid <- lookRead "defaultgroup"
          case find (\q -> gid q == newGid) (groups user) of
            Nothing -> fail ""
            Just g  -> return g
          
groupMembership :: BeinFormPart Html Html
groupMembership = lift asksUser >>= \user -> mconcatM [
  paragraphM =<< alignedLabelM "Group membership",
  tableM =<<: tableHeader : map groupLine (groups user),
  paragraphM =<< newGroupForm ]
  where tableHeader = trM =<<: [ thM << "Gid", thM << "Group name", thM << "Add user...", thM << "Leave group" ]
  
newGroupForm :: BeinFormPart Html Html
newGroupForm = do
  frm <- mconcatM [ strongM << "New group: ", textfieldM "newgroupname", submitM "create" "Create" ]
  formTo "creategroup" createGroup frm
  where createGroup :: BeinServerPart (FormResponse Html)
        createGroup = do
          user <- asksUser
          withDataFn (look "newgroupname") (\newGroupName ->
            updateSettings "select create_group(?,?)" [toSql newGroupName, toSql (uid user)]
              ("Failed to create group " ++ newGroupName ++ ":"))
            
data GroupOperation = Rename Int String | AddUser Int String | LeaveGroup Int deriving (Eq,Show,Read)

groupLine :: Group -> BeinFormPart Html Html
groupLine g = do
  frm <- mconcatM [
    hiddenM "gid" (show $ gid g),
    tdM << show (gid g),
    tdM =<<: [ textfieldM "groupname" <!> [value (groupName g)], submitM "rename" "Rename" ],
    tdM =<<: [ textfieldM "username", submitM "adduser" "Add User" ],
    tdM =<< submitM "leavegroup" "Leave group" ]
  trM =<< formTo "altergroup" updateGroup frm
              
  where updateGroup :: BeinServerPart (FormResponse Html)
        updateGroup = withDataFn readGroup updateGroup'
        updateGroup' :: GroupOperation -> BeinServerPart (FormResponse Html)
        updateGroup' (Rename thisGid newName) = 
          updateSettings "update groups set name = ? where gid = ?"
            [toSql newName, toSql thisGid] "Failed to rename group:"
        updateGroup' (AddUser thisGid newUsername) = do
          u <- lift $ getUser (WithUserName newUsername)
          g' <- lift $ getGroup (WithGid thisGid)
          guard2 (return $ ContinuePage $ redParagraph ("User " ++ newUsername ++ " does not exist."))
                 (return $ ContinuePage $ redParagraph ("No group exists with gid " ++ show thisGid ++ "."))
            (\user thisGroup -> updateSettings "insert into group_members(uid,gid) values (?,?)"
                              [toSql (uid user), toSql (gid thisGroup)] "Could not add member to group:") u g'
        updateGroup' (LeaveGroup thisGid) = asksUser >>= \user ->
          updateSettings "delete from group_members where uid = ? and gid = ?" [toSql (uid user), toSql thisGid]
            "Failed to remove you from group."
        readGroup :: RqData GroupOperation
        readGroup = do
          thisGid <- lookRead "gid"
          r <- lookSubmit "rename"
          a <- lookSubmit "adduser"
          l <- lookSubmit "leavegroup"
          case () of 
            _ | r -> look "groupname" >>= \thisGroup -> return (Rename thisGid thisGroup)
            _ | a -> look "username" >>= \u -> return (AddUser thisGid u)
            _ | l -> return (LeaveGroup thisGid)
            _ -> error "In groupLine, no submit buttons were pressed in form."