UI: Group: Implement parent/child process button POST handlers
This commit is contained in:
Pere Lev
parent
66c1818fcd
commit
533fc60fe1
4 changed files with 348 additions and 3 deletions
|
|
@ -897,6 +897,14 @@ instance YesodBreadcrumbs App where
|
|||
GroupChildLiveR j d -> (keyHashidText d, Just $ GroupChildrenR j)
|
||||
GroupParentsR j -> ("Parent teams", Just $ GroupR j)
|
||||
|
||||
GroupMemberLiveR j c -> (keyHashidText c, Just $ GroupMembersR j)
|
||||
GroupRemoveChildR _ _ -> ("", Nothing)
|
||||
GroupRemoveParentR _ _ -> ("", Nothing)
|
||||
GroupAddChildR _ -> ("", Nothing)
|
||||
GroupAddParentR _ -> ("", Nothing)
|
||||
GroupApproveChildR _ _ -> ("", Nothing)
|
||||
GroupApproveParentR _ _ -> ("", Nothing)
|
||||
|
||||
RepoR r -> ("Repo ^" <> keyHashidText r, Just HomeR)
|
||||
RepoInboxR r -> ("Inbox", Just $ RepoR r)
|
||||
RepoOutboxR r -> ("Outbox", Just $ RepoR r)
|
||||
|
|
|
|||
|
|
@ -38,6 +38,14 @@ module Vervis.Handler.Group
|
|||
, getGroupChildLiveR
|
||||
, getGroupParentsR
|
||||
|
||||
, getGroupMemberLiveR
|
||||
, postGroupRemoveChildR
|
||||
, postGroupRemoveParentR
|
||||
, postGroupAddChildR
|
||||
, postGroupAddParentR
|
||||
, postGroupApproveChildR
|
||||
, postGroupApproveParentR
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -77,6 +85,7 @@ import Yesod.Core
|
|||
import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
|
||||
import Yesod.Form.Functions (runFormPost, runFormGet)
|
||||
import Yesod.Form.Types (FormResult (..))
|
||||
import Yesod.Form
|
||||
import Yesod.Persist.Core (runDB, get404, getBy404)
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
|
|
@ -102,6 +111,7 @@ import Yesod.Persist.Local
|
|||
|
||||
import Vervis.Access
|
||||
import Vervis.API
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Discussion
|
||||
|
|
@ -598,6 +608,322 @@ getGroupParentsR groupHash = do
|
|||
getHtml groupID group actor parents = do
|
||||
$(widgetFile "group/parents")
|
||||
|
||||
getGroupMemberLiveR
|
||||
:: KeyHashid Group -> KeyHashid CollabEnable -> Handler ()
|
||||
getGroupMemberLiveR groupHash enableHash = do
|
||||
groupID <- decodeKeyHashid404 groupHash
|
||||
enableID <- decodeKeyHashid404 enableHash
|
||||
runDB $ do
|
||||
resourceID <- groupResource <$> get404 groupID
|
||||
CollabEnable collabID _ <- get404 enableID
|
||||
Collab _ resourceID' <- getJust collabID
|
||||
unless (resourceID == resourceID') notFound
|
||||
|
||||
postGroupRemoveParentR :: KeyHashid Group -> SourceId -> Handler Html
|
||||
postGroupRemoveParentR groupHash sourceID = do
|
||||
groupID <- decodeKeyHashid404 groupHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
result <- runExceptT $ do
|
||||
mpidOrU <- lift $ runDB $ runMaybeT $ do
|
||||
group <- MaybeT $ get groupID
|
||||
_ <- MaybeT $ get sourceID
|
||||
SourceHolderGroup _ j <-
|
||||
MaybeT $ getValBy $ UniqueSourceHolderGroup sourceID
|
||||
guard $ groupID == j
|
||||
_ <- MaybeT $ getBy $ UniqueSourceUsSendDelegator sourceID
|
||||
|
||||
topic <- lift $ do
|
||||
t <- bimap snd snd <$> getSourceTopic sourceID
|
||||
bitraverse
|
||||
(\case
|
||||
Right g' -> pure g'
|
||||
Left _j -> error "I'm a group, I have a Source with topic being Project"
|
||||
)
|
||||
pure
|
||||
t
|
||||
lift $
|
||||
(groupResource group,) <$>
|
||||
bitraverse
|
||||
pure
|
||||
(getRemoteActorURI <=< getJust)
|
||||
topic
|
||||
(resourceID, pidOrU) <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, remove) <- do
|
||||
uParent <-
|
||||
case pidOrU of
|
||||
Left j -> encodeRouteHome . GroupR <$> encodeKeyHashid j
|
||||
Right u -> pure u
|
||||
let uCollection = encodeRouteHome $ GroupParentsR groupHash
|
||||
C.remove personID uParent uCollection
|
||||
cap <- do
|
||||
maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
|
||||
fromMaybeE maybeItem "You need to be have Admin access to the Group to remove parents"
|
||||
uCap <- lift $ renderActivityURI cap
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
|
||||
let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
|
||||
handleViaActor
|
||||
personID (Just cap') localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
Right removeID ->
|
||||
setMessage "Remove sent"
|
||||
redirect $ GroupParentsR groupHash
|
||||
|
||||
postGroupRemoveChildR :: KeyHashid Group -> DestId -> Handler Html
|
||||
postGroupRemoveChildR groupHash destID = do
|
||||
groupID <- decodeKeyHashid404 groupHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
result <- runExceptT $ do
|
||||
mpidOrU <- lift $ runDB $ runMaybeT $ do
|
||||
group <- MaybeT $ get groupID
|
||||
_ <- MaybeT $ get destID
|
||||
DestHolderGroup _ j <-
|
||||
MaybeT $ getValBy $ UniqueDestHolderGroup destID
|
||||
guard $ groupID == j
|
||||
acceptID <- MaybeT $ getKeyBy $ UniqueDestUsAccept destID
|
||||
_ <- MaybeT $ getBy $ UniqueDestUsStart acceptID
|
||||
|
||||
topic <- lift $ do
|
||||
t <- bimap snd snd <$> getDestTopic destID
|
||||
bitraverse
|
||||
(\case
|
||||
Right g' -> pure g'
|
||||
Left _j -> error "I'm a group, I have a Dest with topic being Project"
|
||||
)
|
||||
pure
|
||||
t
|
||||
lift $
|
||||
(groupResource group,) <$>
|
||||
bitraverse
|
||||
pure
|
||||
(getRemoteActorURI <=< getJust)
|
||||
topic
|
||||
(resourceID, pidOrU) <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, remove) <- do
|
||||
uChild <-
|
||||
case pidOrU of
|
||||
Left j -> encodeRouteHome . GroupR <$> encodeKeyHashid j
|
||||
Right u -> pure u
|
||||
let uCollection = encodeRouteHome $ GroupChildrenR groupHash
|
||||
C.remove personID uChild uCollection
|
||||
cap <- do
|
||||
maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
|
||||
fromMaybeE maybeItem "You need to be have Admin access to the Group to remove children"
|
||||
uCap <- lift $ renderActivityURI cap
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
|
||||
let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
|
||||
handleViaActor
|
||||
personID (Just cap') localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
Right removeID ->
|
||||
setMessage "Remove sent"
|
||||
redirect $ GroupChildrenR groupHash
|
||||
|
||||
addChildForm = renderDivs $
|
||||
areq fedUriField "(URI) Child group" Nothing
|
||||
|
||||
postGroupAddChildR :: KeyHashid Group -> Handler Html
|
||||
postGroupAddChildR groupHash = do
|
||||
uChild <- runFormPostRedirect (GroupChildrenR groupHash) addChildForm
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let uCollection = encodeRouteHome $ GroupChildrenR groupHash
|
||||
|
||||
groupID <- decodeKeyHashid404 groupHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
|
||||
result <- runExceptT $ do
|
||||
group <- lift $ runDB $ get404 groupID
|
||||
(maybeSummary, audience, add) <- C.add personID uChild uCollection AP.RoleAdmin
|
||||
cap <- do
|
||||
let resourceID = groupResource group
|
||||
maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
|
||||
fromMaybeE maybeItem "You need to be have Admin access to the Group to add children"
|
||||
uCap <- lift $ renderActivityURI cap
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.AddActivity add
|
||||
let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
|
||||
handleViaActor
|
||||
personID (Just cap') localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
Right removeID ->
|
||||
setMessage "Add sent"
|
||||
redirect $ GroupChildrenR groupHash
|
||||
|
||||
addParentForm = renderDivs $
|
||||
areq fedUriField "(URI) Parent group" Nothing
|
||||
|
||||
postGroupAddParentR :: KeyHashid Group -> Handler Html
|
||||
postGroupAddParentR groupHash = do
|
||||
uParent <- runFormPostRedirect (GroupChildrenR groupHash) addParentForm
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let uCollection = encodeRouteHome $ GroupParentsR groupHash
|
||||
|
||||
groupID <- decodeKeyHashid404 groupHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
|
||||
result <- runExceptT $ do
|
||||
group <- lift $ runDB $ get404 groupID
|
||||
(maybeSummary, audience, add) <- C.add personID uParent uCollection AP.RoleAdmin
|
||||
cap <- do
|
||||
let resourceID = groupResource group
|
||||
maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
|
||||
fromMaybeE maybeItem "You need to be have Admin access to the Group to add parents"
|
||||
uCap <- lift $ renderActivityURI cap
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.AddActivity add
|
||||
let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
|
||||
handleViaActor
|
||||
personID (Just cap') localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
Right removeID ->
|
||||
setMessage "Add sent"
|
||||
redirect $ GroupParentsR groupHash
|
||||
|
||||
postGroupApproveParentR :: KeyHashid Group -> SourceId -> Handler Html
|
||||
postGroupApproveParentR groupHash sourceID = do
|
||||
groupID <- decodeKeyHashid404 groupHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
result <- runExceptT $ do
|
||||
mpidOrU <- lift $ runDB $ runMaybeT $ do
|
||||
group <- MaybeT $ get groupID
|
||||
_ <- MaybeT $ get sourceID
|
||||
SourceHolderGroup _ j <-
|
||||
MaybeT $ getValBy $ UniqueSourceHolderGroup sourceID
|
||||
guard $ groupID == j
|
||||
|
||||
uAdd <- lift $ do
|
||||
add <- getSourceAdd sourceID
|
||||
renderActivityURI add
|
||||
|
||||
topic <- lift $ do
|
||||
t <- bimap snd snd <$> getSourceTopic sourceID
|
||||
bitraverse
|
||||
(\case
|
||||
Right g' -> pure g'
|
||||
Left _j -> error "I'm a group, I have a Source with topic being Project"
|
||||
)
|
||||
pure
|
||||
t
|
||||
lift $
|
||||
(groupResource group,uAdd,) <$>
|
||||
bitraverse
|
||||
pure
|
||||
(getRemoteActorURI <=< getJust)
|
||||
topic
|
||||
(resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, accept) <- do
|
||||
uParent <-
|
||||
case pidOrU of
|
||||
Left j -> encodeRouteHome . GroupR <$> encodeKeyHashid j
|
||||
Right u -> pure u
|
||||
let uChild = encodeRouteHome $ GroupR groupHash
|
||||
C.acceptParentChild personID uAdd uParent uChild
|
||||
cap <- do
|
||||
maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
|
||||
fromMaybeE maybeItem "You need to be have Admin access to the Group to approve parents"
|
||||
uCap <- lift $ renderActivityURI cap
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.AcceptActivity accept
|
||||
let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
|
||||
handleViaActor
|
||||
personID (Just cap') localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
Right removeID ->
|
||||
setMessage "Accept sent"
|
||||
redirect $ GroupParentsR groupHash
|
||||
|
||||
postGroupApproveChildR :: KeyHashid Group -> DestId -> Handler Html
|
||||
postGroupApproveChildR groupHash destID = do
|
||||
groupID <- decodeKeyHashid404 groupHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
result <- runExceptT $ do
|
||||
mpidOrU <- lift $ runDB $ runMaybeT $ do
|
||||
group <- MaybeT $ get groupID
|
||||
_ <- MaybeT $ get destID
|
||||
DestHolderGroup _ j <-
|
||||
MaybeT $ getValBy $ UniqueDestHolderGroup destID
|
||||
guard $ groupID == j
|
||||
|
||||
uAdd <- lift $ do
|
||||
add <- getDestAdd destID
|
||||
renderActivityURI add
|
||||
|
||||
topic <- lift $ do
|
||||
t <- bimap snd snd <$> getDestTopic destID
|
||||
bitraverse
|
||||
(\case
|
||||
Right g' -> pure g'
|
||||
Left _j -> error "I'm a group, I have a Dest with topic being Project"
|
||||
)
|
||||
pure
|
||||
t
|
||||
lift $
|
||||
(groupResource group,uAdd,) <$>
|
||||
bitraverse
|
||||
pure
|
||||
(getRemoteActorURI <=< getJust)
|
||||
topic
|
||||
(resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, accept) <- do
|
||||
uChild <-
|
||||
case pidOrU of
|
||||
Left j -> encodeRouteHome . GroupR <$> encodeKeyHashid j
|
||||
Right u -> pure u
|
||||
let uParent = encodeRouteHome $ GroupR groupHash
|
||||
C.acceptParentChild personID uAdd uParent uChild
|
||||
cap <- do
|
||||
maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
|
||||
fromMaybeE maybeItem "You need to be have Admin access to the Group to approve children"
|
||||
uCap <- lift $ renderActivityURI cap
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.AcceptActivity accept
|
||||
let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
|
||||
handleViaActor
|
||||
personID (Just cap') localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
Right removeID ->
|
||||
setMessage "Accept sent"
|
||||
redirect $ GroupChildrenR groupHash
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1181,7 +1181,7 @@ postProjectAddParentR projectHash = do
|
|||
setMessage $ toHtml e
|
||||
Right removeID ->
|
||||
setMessage "Add sent"
|
||||
redirect $ ProjectChildrenR projectHash
|
||||
redirect $ ProjectParentsR projectHash
|
||||
|
||||
postProjectApproveComponentR :: KeyHashid Project -> ComponentId -> Handler Html
|
||||
postProjectApproveComponentR projectHash compID = do
|
||||
|
|
|
|||
15
th/routes
15
th/routes
|
|
@ -183,10 +183,21 @@
|
|||
/groups/#GroupKeyHashid/invite GroupInviteR GET POST
|
||||
/groups/#GroupKeyHashid/remove/#CollabId GroupRemoveR POST
|
||||
|
||||
/groups/#GroupKeyHashid/members/#CollabEnableKeyHashid/live GroupMemberLiveR GET
|
||||
|
||||
/groups/#GroupKeyHashid/children GroupChildrenR GET
|
||||
/groups/#GroupKeyHashid/children/#DestUsStartKeyHashid/live GroupChildLiveR GET
|
||||
/groups/#GroupKeyHashid/parents GroupParentsR GET
|
||||
|
||||
/groups/#GroupKeyHashid/child/remove/#DestId GroupRemoveChildR POST
|
||||
/groups/#GroupKeyHashid/parent/remove/#SourceId GroupRemoveParentR POST
|
||||
|
||||
/groups/#GroupKeyHashid/child/add GroupAddChildR POST
|
||||
/groups/#GroupKeyHashid/parent/add GroupAddParentR POST
|
||||
|
||||
/groups/#GroupKeyHashid/child/approve/#DestId GroupApproveChildR POST
|
||||
/groups/#GroupKeyHashid/parent/approve/#SourceId GroupApproveParentR POST
|
||||
|
||||
---- Repo --------------------------------------------------------------------
|
||||
|
||||
/repos/#RepoKeyHashid RepoR GET
|
||||
|
|
@ -344,6 +355,8 @@
|
|||
|
||||
---- Project -----------------------------------------------------------------
|
||||
|
||||
/new-project ProjectNewR GET POST
|
||||
|
||||
/projects/#ProjectKeyHashid ProjectR GET
|
||||
/projects/#ProjectKeyHashid/inbox ProjectInboxR GET POST
|
||||
/projects/#ProjectKeyHashid/errbox ProjectErrboxR GET
|
||||
|
|
@ -353,8 +366,6 @@
|
|||
|
||||
/projects/#ProjectKeyHashid/messages/#LocalMessageKeyHashid ProjectMessageR GET
|
||||
|
||||
/new-project ProjectNewR GET POST
|
||||
|
||||
/projects/#ProjectKeyHashid/stamps/#SigKeyKeyHashid ProjectStampR GET
|
||||
|
||||
/projects/#ProjectKeyHashid/collabs ProjectCollabsR GET
|
||||
|
|
|
|||
Loading…
Reference in a new issue