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
    )
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")