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 $ do
        person <- getJust pid
        selectList [RepoRoleSharer ==. personIdent person] []
    defaultLayout $(widgetFile "repo/role/list")

postRepoRolesR :: Handler Html
postRepoRolesR = do
    pid <- requireAuthId
    sid <- fmap personIdent $ runDB $ getJust pid
    ((result, widget), enctype) <- runFormPost $ newRepoRoleForm sid
    case result of
        FormSuccess nrr -> do
            runDB $ do
                let role = RepoRole
                        { repoRoleIdent  = nrrIdent nrr
                        , repoRoleSharer = sid
                        , 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
    sid <- fmap personIdent $ runDB $ getJust pid
    ((_result, widget), enctype) <- runFormPost $ newRepoRoleForm sid
    defaultLayout $(widgetFile "repo/role/new")

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

deleteRepoRoleR :: RlIdent -> Handler Html
deleteRepoRoleR rl = do
    pid <- requireAuthId
    runDB $ do
        person <- getJust pid
        let sid = personIdent person
        Entity rid _r <- getBy404 $ UniqueRepoRole sid 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
        sid <- personIdent <$> getJust pid
        Entity rid _r <- getBy404 $ UniqueRepoRole sid 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 = do
            sid <- personIdent <$> getJust pid
            fmap entityKey $ getBy404 $ UniqueRepoRole sid 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 = do
            sid <- personIdent <$> getJust pid
            fmap entityKey $ getBy404 $ UniqueRepoRole sid rl
    ((_result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid
    defaultLayout $(widgetFile "repo/role/op/new")

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

postProjectRolesR :: Handler Html
postProjectRolesR = do
    pid <- requireAuthId
    sid <- fmap personIdent $ runDB $ getJust pid
    ((result, widget), enctype) <- runFormPost $ newProjectRoleForm sid
    case result of
        FormSuccess npr -> do
            runDB $ do
                let role = ProjectRole
                        { projectRoleIdent  = nprIdent npr
                        , projectRoleSharer = sid
                        , 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
    sid <- fmap personIdent $ runDB $ getJust pid
    ((_result, widget), enctype) <- runFormPost $ newProjectRoleForm sid
    defaultLayout $(widgetFile "project/role/new")

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

deleteProjectRoleR :: RlIdent -> Handler Html
deleteProjectRoleR rl = do
    pid <- requireAuthId
    runDB $ do
        sid <- personIdent <$> getJust pid
        Entity rid _r <- getBy404 $ UniqueProjectRole sid 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
        sid <- personIdent <$> getJust pid
        Entity rid _r <- getBy404 $ UniqueProjectRole sid 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 = do
            sid <- personIdent <$> getJust pid
            fmap entityKey $ getBy404 $ UniqueProjectRole sid 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 = do
            sid <- personIdent <$> getJust pid
            fmap entityKey $ getBy404 $ UniqueProjectRole sid rl
    ((_result, widget), enctype) <- runFormPost $ newProjectRoleOpForm getrid
    defaultLayout $(widgetFile "project/role/op/new")