mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-08 20:06:45 +09:00
255 lines
9.1 KiB
Haskell
255 lines
9.1 KiB
Haskell
{- 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 (ShrIdent, RlIdent, rl2text)
|
|
import Vervis.Role
|
|
import Vervis.Settings (widgetFile)
|
|
import Vervis.Widget.Role
|
|
|
|
getRepoRolesR :: ShrIdent -> Handler Html
|
|
getRepoRolesR shr = do
|
|
--roles <- runDB $ do
|
|
-- Entity sid _ <- getBy404 $ UniqueSharer shr
|
|
-- selectList [RepoRoleSharer ==. sid] []
|
|
graph <- runDB $ do
|
|
Entity sid _s <- getBy404 $ UniqueSharer shr
|
|
getRepoRoleGraph sid
|
|
defaultLayout $(widgetFile "repo/role/graph")
|
|
|
|
postRepoRolesR :: ShrIdent -> Handler Html
|
|
postRepoRolesR shr = do
|
|
sid <- fmap entityKey $ runDB $ getBy404 $ UniqueSharer shr
|
|
((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 shr
|
|
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 :: ShrIdent -> Handler Html
|
|
getRepoRoleNewR shr = do
|
|
sid <- fmap entityKey $ runDB $ getBy404 $ UniqueSharer shr
|
|
((_result, widget), enctype) <- runFormPost $ newRepoRoleForm sid
|
|
defaultLayout $(widgetFile "repo/role/new")
|
|
|
|
getRepoRoleR :: ShrIdent -> RlIdent -> Handler Html
|
|
getRepoRoleR shr rl = do
|
|
Entity _rid role <- runDB $ do
|
|
Entity sid _ <- getBy404 $ UniqueSharer shr
|
|
getBy404 $ UniqueRepoRole sid rl
|
|
defaultLayout $(widgetFile "repo/role/one")
|
|
|
|
deleteRepoRoleR :: ShrIdent -> RlIdent -> Handler Html
|
|
deleteRepoRoleR shr rl = do
|
|
runDB $ do
|
|
Entity sid _s <- getBy404 $ UniqueSharer shr
|
|
Entity rid _r <- getBy404 $ UniqueRepoRole sid rl
|
|
delete rid
|
|
setMessage "Role deleted."
|
|
redirect $ RepoRolesR shr
|
|
|
|
postRepoRoleR :: ShrIdent -> RlIdent -> Handler Html
|
|
postRepoRoleR shr rl = do
|
|
mmethod <- lookupPostParam "_method"
|
|
case mmethod of
|
|
Just "DELETE" -> deleteRepoRoleR shr rl
|
|
_ -> notFound
|
|
|
|
getRepoRoleOpsR :: ShrIdent -> RlIdent -> Handler Html
|
|
getRepoRoleOpsR shr rl = do
|
|
ops <- runDB $ do
|
|
Entity sid _s <- getBy404 $ UniqueSharer shr
|
|
Entity rid _r <- getBy404 $ UniqueRepoRole sid rl
|
|
as <- selectList [RepoAccessRole ==. rid] []
|
|
return $ map (repoAccessOp . entityVal) as
|
|
defaultLayout $(widgetFile "repo/role/op/list")
|
|
|
|
postRepoRoleOpsR :: ShrIdent -> RlIdent -> Handler Html
|
|
postRepoRoleOpsR shr rl = do
|
|
let getrid = do
|
|
Entity sid _ <- getBy404 $ UniqueSharer shr
|
|
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 shr 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 :: ShrIdent -> RlIdent -> Handler Html
|
|
getRepoRoleOpNewR shr rl = do
|
|
let getrid = do
|
|
Entity sid _ <- getBy404 $ UniqueSharer shr
|
|
fmap entityKey $ getBy404 $ UniqueRepoRole sid rl
|
|
((_result, widget), enctype) <- runFormPost $ newRepoRoleOpForm getrid
|
|
defaultLayout $(widgetFile "repo/role/op/new")
|
|
|
|
getProjectRolesR :: ShrIdent -> Handler Html
|
|
getProjectRolesR shr = do
|
|
--roles <- runDB $ do
|
|
-- Entity sid _ <- getBy404 $ UniqueSharer shr
|
|
-- selectList [ProjectRoleSharer ==. sid] []
|
|
graph <- runDB $ do
|
|
Entity sid _s <- getBy404 $ UniqueSharer shr
|
|
getProjectRoleGraph sid
|
|
defaultLayout $(widgetFile "project/role/graph")
|
|
|
|
postProjectRolesR :: ShrIdent -> Handler Html
|
|
postProjectRolesR shr = do
|
|
sid <- fmap entityKey $ runDB $ getBy404 $ UniqueSharer shr
|
|
((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 shr
|
|
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 :: ShrIdent -> Handler Html
|
|
getProjectRoleNewR shr = do
|
|
sid <- fmap entityKey $ runDB $ getBy404 $ UniqueSharer shr
|
|
((_result, widget), enctype) <- runFormPost $ newProjectRoleForm sid
|
|
defaultLayout $(widgetFile "project/role/new")
|
|
|
|
getProjectRoleR :: ShrIdent -> RlIdent -> Handler Html
|
|
getProjectRoleR shr rl = do
|
|
Entity _rid role <- runDB $ do
|
|
Entity sid _ <- getBy404 $ UniqueSharer shr
|
|
getBy404 $ UniqueProjectRole sid rl
|
|
defaultLayout $(widgetFile "project/role/one")
|
|
|
|
deleteProjectRoleR :: ShrIdent -> RlIdent -> Handler Html
|
|
deleteProjectRoleR shr rl = do
|
|
runDB $ do
|
|
Entity sid _s <- getBy404 $ UniqueSharer shr
|
|
Entity rid _r <- getBy404 $ UniqueProjectRole sid rl
|
|
delete rid
|
|
setMessage "Role deleted."
|
|
redirect $ ProjectRolesR shr
|
|
|
|
postProjectRoleR :: ShrIdent -> RlIdent -> Handler Html
|
|
postProjectRoleR shr rl = do
|
|
mmethod <- lookupPostParam "_method"
|
|
case mmethod of
|
|
Just "DELETE" -> deleteProjectRoleR shr rl
|
|
_ -> notFound
|
|
|
|
getProjectRoleOpsR :: ShrIdent -> RlIdent -> Handler Html
|
|
getProjectRoleOpsR shr rl = do
|
|
ops <- runDB $ do
|
|
Entity sid _s <- getBy404 $ UniqueSharer shr
|
|
Entity rid _r <- getBy404 $ UniqueProjectRole sid rl
|
|
as <- selectList [ProjectAccessRole ==. rid] []
|
|
return $ map (projectAccessOp . entityVal) as
|
|
defaultLayout $(widgetFile "project/role/op/list")
|
|
|
|
postProjectRoleOpsR :: ShrIdent -> RlIdent -> Handler Html
|
|
postProjectRoleOpsR shr rl = do
|
|
let getrid = do
|
|
Entity sid _ <- getBy404 $ UniqueSharer shr
|
|
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 shr 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 :: ShrIdent -> RlIdent -> Handler Html
|
|
getProjectRoleOpNewR shr rl = do
|
|
let getrid = do
|
|
Entity sid _ <- getBy404 $ UniqueSharer shr
|
|
fmap entityKey $ getBy404 $ UniqueProjectRole sid rl
|
|
((_result, widget), enctype) <- runFormPost $ newProjectRoleOpForm getrid
|
|
defaultLayout $(widgetFile "project/role/op/new")
|