UI: Group: Implement parent/child process button POST handlers

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)

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
+
 
 
 

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

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