UI: Project: Provide buttons for removing children

src/Vervis/Data/Actor.hs

@@ -23,7 +23,7 @@ module Vervis.Data.Actor
     , parseStampRoute
     , localActorID
     , localResourceID
-    , parseLocalURI
+    , WA.parseLocalURI
     , parseFedURIOld
     , parseLocalActorE
     , parseLocalActorE'
@@ -33,6 +33,8 @@ module Vervis.Data.Actor
     , parseActorURI'
     , parseResourceURI
     , parseResourceURI'
+    , renderActivityURI
+    , renderActivityURI'
     )
 where
 
@@ -51,7 +53,6 @@ import qualified Data.HashMap.Strict as HM
 import qualified Data.Text as T
 
 import Network.FedURI
-import Web.Actor
 import Yesod.ActivityPub
 import Yesod.Actor
 import Yesod.FedURI
@@ -198,7 +199,7 @@ parseFedURIOld
 parseFedURIOld u@(ObjURI h lu) = do
     hl <- hostIsLocalOld h
     if hl
-        then Left <$> parseLocalURI lu
+        then Left <$> WA.parseLocalURI lu
         else pure $ Right u
 
 parseLocalActorE
@@ -238,7 +239,7 @@ parseActorURI u = do
 
 parseActorURI' :: FedURI -> VA.ActE (Either (LocalActorBy Key) FedURI)
 parseActorURI' u = do
-    routeOrRemote <- parseFedURI u
+    routeOrRemote <- WA.parseFedURI u
     bitraverse
         parseLocalActorE'
         pure
@@ -257,8 +258,31 @@ parseResourceURI u = do
 
 parseResourceURI' :: FedURI -> VA.ActE (Either (LocalResourceBy Key) FedURI)
 parseResourceURI' u = do
-    routeOrRemote <- parseFedURI u
+    routeOrRemote <- WA.parseFedURI u
     bitraverse
         parseLocalResourceE'
         pure
         routeOrRemote
+
+renderActivityURI
+    :: (MonadSite m, SiteEnv m ~ App)
+    => Either (LocalActorBy Key, OutboxItemId) FedURI
+    -> m FedURI
+renderActivityURI = \case
+    Left (la, i) -> do
+        encodeRouteHome <- getEncodeRouteHome
+        lah <- hashLocalActor la
+        ih <- encodeKeyHashid i
+        return $ encodeRouteHome $ activityRoute lah ih
+    Right u -> pure u
+
+renderActivityURI'
+    :: Either (LocalActorBy Key, OutboxItemId) FedURI
+    -> VA.Act FedURI
+renderActivityURI' = \case
+    Left (la, i) -> do
+        encodeRouteHome <- WA.getEncodeRouteHome
+        lah <- VA.hashLocalActor la
+        ih <- WAP.encodeKeyHashid i
+        return $ encodeRouteHome $ activityRoute lah ih
+    Right u -> pure u

src/Vervis/Foundation.hs

@@ -1037,3 +1037,5 @@ instance YesodBreadcrumbs App where
         ProjectChildrenR j -> ("Child projects", Just $ ProjectR j)
         ProjectParentsR j -> ("Parent projects", Just $ ProjectR j)
         ProjectParentLiveR j d -> (keyHashidText d, Just $ ProjectParentsR j)
+
+        ProjectRemoveChildR _ _ -> ("", Nothing)

src/Vervis/Handler/Project.hs

@@ -43,6 +43,8 @@ module Vervis.Handler.Project
     , getProjectChildrenR
     , getProjectParentsR
     , getProjectParentLiveR
+
+    , postProjectRemoveChildR
     )
 where
 
@@ -97,6 +99,7 @@ import Yesod.Persist.Local
 import Vervis.Access
 import Vervis.Actor (resourceToActor)
 import Vervis.API
+import Vervis.Data.Actor
 import Vervis.Data.Collab
 import Vervis.Federation.Auth
 import Vervis.Federation.Discussion
@@ -598,7 +601,7 @@ getProjectChildrenR projectHash = do
             encodeRouteHome $ ProjectR $ hashProject childID
         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
@@ -625,13 +628,13 @@ getProjectChildrenR projectHash = do
     where
 
     getChildren projectID = fmap (sortOn $ view _2) $ liftA2 (++)
-        (map (\ (E.Value role, E.Value time, E.Value child, Entity _ actor) ->
+        (map (\ (E.Value role, E.Value time, E.Value child, Entity _ actor, E.Value sourceID) ->
-                (role, time, Left (child, actor))
+                (role, time, Left (child, actor), sourceID)
              )
             <$> 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 sourceID) ->
-                (role, time, Right (i, ro, ra))
+                (role, time, Right (i, ro, ra), sourceID)
              )
             <$> getRemotes projectID
         )
@@ -651,6 +654,7 @@ getProjectChildrenR projectHash = do
                 , grant E.^. OutboxItemPublished
                 , topic E.^. SourceTopicProjectChild
                 , actor
+                , source E.^. SourceId
                 )
 
     getRemotes projectID =
@@ -670,9 +674,14 @@ getProjectChildrenR projectHash = do
                 , i
                 , ro
                 , ra
+                , source E.^. SourceId
                 )
 
     getHtml projectID project actor children = 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
             sources <- E.select $ E.from $ \ (source `E.InnerJoin` holder `E.LeftOuterJoin` deleg) -> do
                 E.on $ E.just (source E.^. SourceId) E.==. deleg E.?. SourceUsSendDelegatorSource
@@ -909,3 +918,60 @@ getProjectParentLiveR projectHash startHash = do
         Entity _ (DestHolderProject _ j) <-
             getBy404 $ UniqueDestHolderProject destID
         unless (j == projectID) notFound
+
+postProjectRemoveChildR :: KeyHashid Project -> SourceId -> Handler Html
+postProjectRemoveChildR projectHash sourceID = 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 sourceID
+            SourceHolderProject _ j <-
+                MaybeT $ getValBy $ UniqueSourceHolderProject sourceID
+            guard $ projectID == j
+            _ <- MaybeT $ getBy $ UniqueSourceUsSendDelegator sourceID
+
+            topic <- lift $ do
+                t <- bimap snd snd <$> getSourceTopic sourceID
+                bitraverse
+                    (\case
+                        Left j' -> pure j'
+                        Right _g -> error "I'm a project, I have a Source with topic being Group"
+                    )
+                    pure
+                    t
+            lift $
+                (projectResource project,) <$>
+                bitraverse
+                    pure
+                    (getRemoteActorURI <=< getJust)
+                    topic
+        (resourceID, pidOrU) <- maybe notFound pure mpidOrU
+        (maybeSummary, audience, remove) <- do
+            uChild <-
+                case pidOrU of
+                    Left j -> encodeRouteHome . ProjectR <$> encodeKeyHashid j
+                    Right u -> pure u
+            let uCollection = encodeRouteHome $ ProjectChildrenR projectHash
+            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"
+        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 $ ProjectChildrenR projectHash

src/Vervis/Persist/Collab.hs

@@ -52,6 +52,7 @@ module Vervis.Persist.Collab
     , getGrantActivityBody
 
     , getPermitsForResource
+    , getCapability
     )
 where
 
@@ -1074,3 +1075,95 @@ getPermitsForResource personID actor = do
                         return (Right u, Right (inztance, remoteObject, remoteActor))
             return (uExt, role, Just via)
     return $ directsFinal ++ extsFinal
+
+getCapability
+    :: MonadIO m
+    => PersonId
+    -> Either ResourceId RemoteActorId
+    -> AP.Role
+    -> ReaderT SqlBackend m
+        (Maybe (Either (LocalActorBy Key, OutboxItemId) FedURI))
+getCapability personID actor role = do
+    maybeDirect <-
+        case actor of
+            Left resourceID ->
+                fmap (fmap (Left . (resourceID,)) . listToMaybe) $
+                E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do
+                    E.on $ topic E.^. PermitTopicLocalId E.==. enable E.^. PermitTopicEnableLocalTopic
+                    E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicLocalPermit
+                    E.where_ $
+                        permit E.^. PermitPerson E.==. E.val personID E.&&.
+                        topic E.^. PermitTopicLocalTopic E.==. E.val resourceID E.&&.
+                        permit E.^. PermitRole E.>=. E.val role
+                    E.orderBy [E.desc $ enable E.^. PermitTopicEnableLocalId]
+                    E.limit 1
+                    return $ enable E.^. PermitTopicEnableLocalGrant
+            Right actorID ->
+                fmap (fmap Right . listToMaybe) $
+                E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do
+                    E.on $ topic E.^. PermitTopicRemoteId E.==. enable E.^. PermitTopicEnableRemoteTopic
+                    E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicRemotePermit
+                    E.where_ $
+                        permit E.^. PermitPerson E.==. E.val personID E.&&.
+                        topic E.^. PermitTopicRemoteActor E.==. E.val actorID E.&&.
+                        permit E.^. PermitRole E.>=. E.val role
+                    E.orderBy [E.desc $ enable E.^. PermitTopicEnableRemoteId]
+                    E.limit 1
+                    return $ enable E.^. PermitTopicEnableRemoteGrant
+    maybeDirect' <- for maybeDirect $ \case
+        Left (resourceID, E.Value grantID) -> do
+            lr <- getLocalResource resourceID
+            let la = resourceToActor lr
+            return $ Left (la, grantID)
+        Right (E.Value grantID) -> do
+            grant <- getJust grantID
+            u <- getRemoteActivityURI grant
+            return $ Right u
+    maybeExt <-
+        listToMaybe <$>
+        case actor of
+            Left resourceID ->
+                E.select $ E.from $ \ (permit `E.InnerJoin` gesture `E.InnerJoin` send `E.InnerJoin` extend `E.InnerJoin` resource) -> do
+                    E.on $ extend E.^. PermitTopicExtendId E.==. resource E.^. PermitTopicExtendResourceLocalPermit
+                    E.on $ send E.^. PermitPersonSendDelegatorId E.==. extend E.^. PermitTopicExtendPermit
+                    E.on $ gesture E.^. PermitPersonGestureId E.==. send E.^. PermitPersonSendDelegatorPermit
+                    E.on $ permit E.^. PermitId E.==. gesture E.^. PermitPersonGesturePermit
+                    E.where_ $
+                        permit E.^. PermitPerson E.==. E.val personID E.&&.
+                        resource E.^. PermitTopicExtendResourceLocalResource E.==. E.val resourceID E.&&.
+                        extend E.^. PermitTopicExtendRole E.>=. E.val role
+                    E.orderBy [E.desc $ extend E.^. PermitTopicExtendId]
+                    E.limit 1
+                    return $ extend E.^. PermitTopicExtendId
+            Right actorID ->
+                E.select $ E.from $ \ (permit `E.InnerJoin` gesture `E.InnerJoin` send `E.InnerJoin` extend `E.InnerJoin` resource) -> do
+                    E.on $ extend E.^. PermitTopicExtendId E.==. resource E.^. PermitTopicExtendResourceRemotePermit
+                    E.on $ send E.^. PermitPersonSendDelegatorId E.==. extend E.^. PermitTopicExtendPermit
+                    E.on $ gesture E.^. PermitPersonGestureId E.==. send E.^. PermitPersonSendDelegatorPermit
+                    E.on $ permit E.^. PermitId E.==. gesture E.^. PermitPersonGesturePermit
+                    E.where_ $
+                        permit E.^. PermitPerson E.==. E.val personID E.&&.
+                        resource E.^. PermitTopicExtendResourceRemoteActor E.==. E.val actorID E.&&.
+                        extend E.^. PermitTopicExtendRole E.>=. E.val role
+                    E.orderBy [E.desc $ extend E.^. PermitTopicExtendId]
+                    E.limit 1
+                    return $ extend E.^. PermitTopicExtendId
+    maybeExt' <- for maybeExt $ \ (E.Value extendID) -> do
+        sender <-
+            requireEitherAlt
+                (getValBy $ UniquePermitTopicExtendLocal extendID)
+                (getValBy $ UniquePermitTopicExtendRemote extendID)
+                "PermitTopicExtend* neither"
+                "PermitTopicExtend* both"
+        case sender of
+            Left (PermitTopicExtendLocal _ enableID grantID) -> do
+                PermitTopicEnableLocal _ topicID _ <- getJust enableID
+                PermitTopicLocal _ resourceID <- getJust topicID
+                byk <- getLocalResource resourceID
+                let byk' = resourceToActor byk
+                return $ Left (byk', grantID)
+            Right (PermitTopicExtendRemote _ _enableID grantID) -> do
+                grant <- getJust grantID
+                u <- getRemoteActivityURI grant
+                return $ Right u
+    return $ maybeDirect' <|> maybeExt'

templates/project/children.hamlet

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

th/routes

@@ -353,3 +353,5 @@
 /projects/#ProjectKeyHashid/children ProjectChildrenR GET
 /projects/#ProjectKeyHashid/parents  ProjectParentsR  GET
 /projects/#ProjectKeyHashid/parents/#DestUsStartKeyHashid/live ProjectParentLiveR GET
+
+/projects/#ProjectKeyHashid/children/remove/#SourceId ProjectRemoveChildR POST