vervis/src/Vervis/Handler/Role.hs

{- This file is part of Vervis.
 -
 - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

module Vervis.Handler.Role
    ( getRolesR
    , postRolesR
    , getRoleNewR
    , getRoleR
    , deleteRoleR
    , postRoleR
    , getRoleOpsR
    , postRoleOpsR
    , getRoleOpNewR
    )
where

import Prelude

import Database.Persist
import Text.Blaze.Html (Html)
import Yesod.Auth (requireAuthId)
import Yesod.Core (defaultLayout, setMessage)
import Yesod.Core.Handler (lookupPostParam, notFound, redirect)
import Yesod.Form.Functions (runFormPost)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, getBy404)

import Vervis.Form.Role
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident (RlIdent, rl2text)
import Vervis.Settings (widgetFile)

getRolesR :: Handler Html
getRolesR = do
    pid <- requireAuthId
    roles <- runDB $ selectList [RolePerson ==. pid] []
    defaultLayout $(widgetFile "role/list")

postRolesR :: Handler Html
postRolesR = do
    pid <- requireAuthId
    ((result, widget), enctype) <- runFormPost $ newRoleForm pid
    case result of
        FormSuccess nr -> do
            runDB $ do
                let role = Role
                        { roleIdent  = nrIdent nr
                        , rolePerson = pid
                        , roleDesc   = nrDesc nr
                        }
                insert_ role
            redirect $ RolesR
        FormMissing -> do
            setMessage "Field(s) missing"
            defaultLayout $(widgetFile "role/new")
        FormFailure _l -> do
            setMessage "Invalid input, see errors below"
            defaultLayout $(widgetFile "role/new")

getRoleNewR :: Handler Html
getRoleNewR = do
    pid <- requireAuthId
    ((_result, widget), enctype) <- runFormPost $ newRoleForm pid
    defaultLayout $(widgetFile "role/new")

getRoleR :: RlIdent -> Handler Html
getRoleR rl = do
    pid <- requireAuthId
    Entity _rid role <- runDB $ getBy404 $ UniqueRole pid rl
    defaultLayout $(widgetFile "role/one")

deleteRoleR :: RlIdent -> Handler Html
deleteRoleR rl = do
    pid <- requireAuthId
    runDB $ do
        Entity rid _r <- getBy404 $ UniqueRole pid rl
        delete rid
    setMessage "Role deleted."
    redirect RolesR

postRoleR :: RlIdent -> Handler Html
postRoleR rl = do
    mmethod <- lookupPostParam "_method"
    case mmethod of
        Just "DELETE" -> deleteRoleR rl
        _             -> notFound

getRoleOpsR :: RlIdent -> Handler Html
getRoleOpsR rl = do
    pid <- requireAuthId
    ops <- runDB $ do
        Entity rid _r <- getBy404 $ UniqueRole pid rl
        map (accessOp . entityVal) <$> selectList [AccessRole ==. rid] []
    defaultLayout $(widgetFile "role/op/list")

postRoleOpsR :: RlIdent -> Handler Html
postRoleOpsR rl = do
    pid <- requireAuthId
    let getrid = fmap entityKey $ getBy404 $ UniqueRole pid rl
    ((result, widget), enctype) <- runFormPost $ newRoleOpForm getrid
    case result of
        FormSuccess op -> do
            runDB $ do
                rid <- getrid
                let access = Access
                        { accessRole = rid
                        , accessOp   = op
                        }
                insert_ access
            redirect $ RoleOpsR rl
        FormMissing -> do
            setMessage "Field(s) missing"
            defaultLayout $(widgetFile "role/op/new")
        FormFailure _l -> do
            setMessage "Invalid input, see errors below"
            defaultLayout $(widgetFile "role/op/new")

getRoleOpNewR :: RlIdent -> Handler Html
getRoleOpNewR rl = do
    pid <- requireAuthId
    let getrid = fmap entityKey $ getBy404 $ UniqueRole pid rl
    ((_result, widget), enctype) <- runFormPost $ newRoleOpForm getrid
    defaultLayout $(widgetFile "role/op/new")