UI: Project: Buttons for removing parents

src/Vervis/Foundation.hs

@@ -1039,3 +1039,4 @@ instance YesodBreadcrumbs App where
         ProjectParentLiveR j d -> (keyHashidText d, Just $ ProjectParentsR j)
 
         ProjectRemoveChildR _ _ -> ("", Nothing)
+        ProjectRemoveParentR _ _ -> ("", Nothing)

src/Vervis/Handler/Project.hs

@@ -45,6 +45,7 @@ module Vervis.Handler.Project
     , getProjectParentLiveR
 
     , postProjectRemoveChildR
+    , postProjectRemoveParentR
     )
 where
 
@@ -764,7 +765,7 @@ getProjectParentsR projectHash = do
             encodeRouteHome $ ProjectR $ hashProject parentID
         makeId (Right (i, ro, _)) =
             ObjURI (instanceHost i) (remoteObjectIdent ro)
-        makeItem (role, time, i) = AP.Relationship
+        makeItem (role, time, i, _) = AP.Relationship
             { AP.relationshipId           = Nothing
             , AP.relationshipExtraTypes   = []
             , AP.relationshipSubject      = encodeRouteHome $ ProjectR projectHash
@@ -791,13 +792,13 @@ getProjectParentsR projectHash = do
     where
 
     getParents projectID = fmap (sortOn $ view _2) $ liftA2 (++)
-        (map (\ (E.Value role, E.Value time, E.Value parent, Entity _ actor) ->
+        (map (\ (E.Value role, E.Value time, E.Value parent, Entity _ actor, E.Value destID) ->
-                (role, time, Left (parent, actor))
+                (role, time, Left (parent, actor), destID)
              )
             <$> getLocals projectID
         )
-        (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra) ->
+        (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra, E.Value destID) ->
-                (role, time, Right (i, ro, ra))
+                (role, time, Right (i, ro, ra), destID)
              )
             <$> getRemotes projectID
         )
@@ -818,6 +819,7 @@ getProjectParentsR projectHash = do
                 , grant E.^. OutboxItemPublished
                 , topic E.^. DestTopicProjectParent
                 , actor
+                , dest E.^. DestId
                 )
 
     getRemotes projectID =
@@ -838,9 +840,14 @@ getProjectParentsR projectHash = do
                 , i
                 , ro
                 , ra
+                , dest E.^. DestId
                 )
 
     getHtml projectID project actor parents = do
+        mp <- maybeAuthId
+        haveAdmin <- fmap isJust $ handlerToWidget $ runDB $ runMaybeT $ do
+            personID <- MaybeT $ pure mp
+            MaybeT $ getCapability personID (Left $ projectResource project) AP.RoleAdmin
         invites <- handlerToWidget $ runDB $ do
             dests <- E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.LeftOuterJoin` accept `E.LeftOuterJoin` delegl `E.LeftOuterJoin` delegr) -> do
                 E.on $ accept E.?. DestUsAcceptId E.==. delegr E.?. DestThemSendDelegatorRemoteDest
@@ -961,7 +968,7 @@ postProjectRemoveChildR projectHash sourceID = do
             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 Project to remove people"
+            fromMaybeE maybeItem "You need to be have Admin access to the Project to remove children"
         uCap <- lift $ renderActivityURI cap
         (localRecips, remoteRecips, fwdHosts, action) <-
             C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
@@ -975,3 +982,61 @@ postProjectRemoveChildR projectHash sourceID = do
         Right removeID ->
             setMessage "Remove sent"
     redirect $ ProjectChildrenR projectHash
+
+postProjectRemoveParentR :: KeyHashid Project -> DestId -> Handler Html
+postProjectRemoveParentR projectHash destID = do
+    projectID <- decodeKeyHashid404 projectHash
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    encodeRouteHome <- getEncodeRouteHome
+
+    result <- runExceptT $ do
+        mpidOrU <- lift $ runDB $ runMaybeT $ do
+            project <- MaybeT $ get projectID
+            _ <- MaybeT $ get destID
+            DestHolderProject _ j <-
+                MaybeT $ getValBy $ UniqueDestHolderProject destID
+            guard $ projectID == j
+            acceptID <- MaybeT $ getKeyBy $ UniqueDestUsAccept destID
+            _ <- MaybeT $ getBy $ UniqueDestUsStart acceptID
+
+            topic <- lift $ do
+                t <- bimap snd snd <$> getDestTopic destID
+                bitraverse
+                    (\case
+                        Left j' -> pure j'
+                        Right _g -> error "I'm a project, I have a Dest with topic being Group"
+                    )
+                    pure
+                    t
+            lift $
+                (projectResource project,) <$>
+                bitraverse
+                    pure
+                    (getRemoteActorURI <=< getJust)
+                    topic
+        (resourceID, pidOrU) <- maybe notFound pure mpidOrU
+        (maybeSummary, audience, remove) <- do
+            uParent <-
+                case pidOrU of
+                    Left j -> encodeRouteHome . ProjectR <$> encodeKeyHashid j
+                    Right u -> pure u
+            let uCollection = encodeRouteHome $ ProjectParentsR projectHash
+            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 Project 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 $ ProjectParentsR projectHash

templates/project/parents.hamlet

@@ -22,11 +22,15 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     <th>Role
     <th>Since
     <th>Parent
-  $forall (role, since, parent) <- parents
+    $if haveAdmin
+      <th>Remove
+  $forall (role, since, parent, destID) <- parents
     <tr>
       <td>#{show role}
       <td>#{showDate since}
       <td>^{projectLinkFedW parent}
+      $if haveAdmin
+        <td>^{buttonW POST "Remove" (ProjectRemoveParentR projectHash destID)}
 
 <h2>Invites
 

th/routes

@@ -354,4 +354,5 @@
 /projects/#ProjectKeyHashid/parents  ProjectParentsR  GET
 /projects/#ProjectKeyHashid/parents/#DestUsStartKeyHashid/live ProjectParentLiveR GET
 
-/projects/#ProjectKeyHashid/children/remove/#SourceId ProjectRemoveChildR POST
+/projects/#ProjectKeyHashid/child/remove/#SourceId ProjectRemoveChildR POST
+/projects/#ProjectKeyHashid/parent/remove/#DestId ProjectRemoveParentR POST