diff --git a/src/Vervis/Data/Actor.hs b/src/Vervis/Data/Actor.hs
index 9aa0832..5a84d4a 100644
--- a/src/Vervis/Data/Actor.hs
+++ b/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
diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index 6d2dbd4..437483a 100644
--- a/src/Vervis/Foundation.hs
+++ b/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)
diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs
index c93864f..9c779b0 100644
--- a/src/Vervis/Handler/Project.hs
+++ b/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) ->
- (role, time, Left (child, actor))
+ (map (\ (E.Value role, E.Value time, E.Value child, Entity _ actor, E.Value sourceID) ->
+ (role, time, Left (child, actor), sourceID)
)
<$> getLocals projectID
)
- (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra) ->
- (role, time, Right (i, ro, ra))
+ (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra, E.Value sourceID) ->
+ (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
diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs
index be7ddd5..fabbaea 100644
--- a/src/Vervis/Persist/Collab.hs
+++ b/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'
diff --git a/templates/project/children.hamlet b/templates/project/children.hamlet
index abd6eb4..f0407cc 100644
--- a/templates/project/children.hamlet
+++ b/templates/project/children.hamlet
@@ -22,11 +22,15 @@ $# .
| Role
| Since
| Child
- $forall (role, since, child) <- children
+ $if haveAdmin
+ | Remove
+ $forall (role, since, child, sourceID) <- children
|
| #{show role}
| #{showDate since}
| ^{projectLinkFedW child}
+ $if haveAdmin
+ | ^{buttonW POST "Remove" (ProjectRemoveChildR projectHash sourceID)}
Invites
diff --git a/th/routes b/th/routes
index 91159fb..a9b1a9c 100644
--- a/th/routes
+++ b/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
|