diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index d2de4da..877bf4b 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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) diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index 0c82dcd..9a3d155 100644 --- a/src/Vervis/Handler/Group.hs +++ b/src/Vervis/Handler/Group.hs @@ -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 + diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 0c8d3c1..36c07cd 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -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 diff --git a/th/routes b/th/routes index afbecf9..dd050c9 100644 --- a/th/routes +++ b/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