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
    ( getRepoRolesR
    , postRepoRolesR
    , getRepoRoleNewR
    , getRepoRoleR
    , deleteRepoRoleR
    , postRepoRoleR
    , getRepoRoleOpsR
    , postRepoRoleOpsR
    , getRepoRoleOpNewR
    , getProjectRolesR
    , postProjectRolesR
    , getProjectRoleNewR
    , getProjectRoleR
    , deleteProjectRoleR
    , postProjectRoleR
    , getProjectRoleOpsR
    , postProjectRoleOpsR
    , getProjectRoleOpNewR
    )
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)

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

postRepoRolesR :: Handler Html
postRepoRolesR = do
    pid <- requireAuthId
    ((result, widget), enctype) <- runFormPost $ newRepoRoleForm pid
    case result of
        FormSuccess nrr -> do
            runDB $ do
                let role = RepoRole
                        { repoRoleIdent  = nrrIdent nrr
                        , repoRolePerson = pid
                        , repoRoleDesc   = nrrDesc nrr
                        }
                insert_ role
            redirect $ RepoRolesR
        FormMissing -> do
            setMessage "Field(s) missing"
            defaultLayout $(widgetFile "repo/role/new")
        FormFailure _l -> do
            setMessage "Invalid input, see errors below"
            defaultLayout $(widgetFile "repo/role/new")

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

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

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

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

getRepoRoleOpsR :: RlIdent -> Handler Html
getRepoRoleOpsR rl = do
    pid <- requireAuthId
    ops <- runDB $ do
        Entity rid _r <- getBy404 $ UniqueRepoRole pid rl
        as <- selectList [RepoAccessRole ==. rid] []
        return $ map (repoAccessOp . entityVal) as
    defaultLayout $(widgetFile "repo/role/op/list")

postRepoRoleOpsR :: RlIdent -> Handler Html
postRepoRoleOpsR rl = do
    pid <- requireAuthId
    let getrid = fmap entityKey $ getBy404 $ UniqueRepoRole pid rl
    ((result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid
    case result of
        FormSuccess op -> do
            runDB $ do
                rid <- getrid
                let access = RepoAccess
                        { repoAccessRole = rid
                        , repoAccessOp   = op
                        }
                insert_ access
            redirect $ RepoRoleOpsR rl
        FormMissing -> do
            setMessage "Field(s) missing"
            defaultLayout $(widgetFile "repo/role/op/new")
        FormFailure _l -> do
            setMessage "Invalid input, see errors below"
            defaultLayout $(widgetFile "repo/role/op/new")

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

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

postProjectRolesR :: Handler Html
postProjectRolesR = do
    pid <- requireAuthId
    ((result, widget), enctype) <- runFormPost $ newProjectRoleForm pid
    case result of
        FormSuccess npr -> do
            runDB $ do
                let role = ProjectRole
                        { projectRoleIdent  = nprIdent npr
                        , projectRolePerson = pid
                        , projectRoleDesc   = nprDesc npr
                        }
                insert_ role
            redirect $ ProjectRolesR
        FormMissing -> do
            setMessage "Field(s) missing"
            defaultLayout $(widgetFile "project/role/new")
        FormFailure _l -> do
            setMessage "Invalid input, see errors below"
            defaultLayout $(widgetFile "project/role/new")

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

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

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

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

getProjectRoleOpsR :: RlIdent -> Handler Html
getProjectRoleOpsR rl = do
    pid <- requireAuthId
    ops <- runDB $ do
        Entity rid _r <- getBy404 $ UniqueProjectRole pid rl
        as <- selectList [ProjectAccessRole ==. rid] []
        return $ map (projectAccessOp . entityVal) as
    defaultLayout $(widgetFile "project/role/op/list")

postProjectRoleOpsR :: RlIdent -> Handler Html
postProjectRoleOpsR rl = do
    pid <- requireAuthId
    let getrid = fmap entityKey $ getBy404 $ UniqueProjectRole pid rl
    ((result, widget), enctype) <- runFormPost $ newProjectRoleOpForm getrid
    case result of
        FormSuccess op -> do
            runDB $ do
                rid <- getrid
                let access = ProjectAccess
                        { projectAccessRole = rid
                        , projectAccessOp   = op
                        }
                insert_ access
            redirect $ ProjectRoleOpsR rl
        FormMissing -> do
            setMessage "Field(s) missing"
            defaultLayout $(widgetFile "project/role/op/new")
        FormFailure _l -> do
            setMessage "Invalid input, see errors below"
            defaultLayout $(widgetFile "project/role/op/new")

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