diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index 437483a..86dc9c9 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -1039,3 +1039,4 @@ instance YesodBreadcrumbs App where
ProjectParentLiveR j d -> (keyHashidText d, Just $ ProjectParentsR j)
ProjectRemoveChildR _ _ -> ("", Nothing)
+ ProjectRemoveParentR _ _ -> ("", Nothing)
diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs
index 9c779b0..c3902a6 100644
--- a/src/Vervis/Handler/Project.hs
+++ b/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) ->
- (role, time, Left (parent, actor))
+ (map (\ (E.Value role, E.Value time, E.Value parent, Entity _ actor, E.Value destID) ->
+ (role, time, Left (parent, actor), destID)
)
<$> 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 destID) ->
+ (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
diff --git a/templates/project/parents.hamlet b/templates/project/parents.hamlet
index acc5152..0cd049a 100644
--- a/templates/project/parents.hamlet
+++ b/templates/project/parents.hamlet
@@ -22,11 +22,15 @@ $#