diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index 3d5dcf5..123c181 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -1038,6 +1038,7 @@ instance YesodBreadcrumbs App where
ProjectParentsR j -> ("Parent projects", Just $ ProjectR j)
ProjectParentLiveR j d -> (keyHashidText d, Just $ ProjectParentsR j)
+ ProjectRemoveComponentR _ _ -> ("", Nothing)
ProjectRemoveChildR _ _ -> ("", Nothing)
ProjectRemoveParentR _ _ -> ("", Nothing)
diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs
index ccdcc94..c7ad104 100644
--- a/src/Vervis/Handler/Project.hs
+++ b/src/Vervis/Handler/Project.hs
@@ -44,6 +44,7 @@ module Vervis.Handler.Project
, getProjectParentsR
, getProjectParentLiveR
+ , postProjectRemoveComponentR
, postProjectRemoveChildR
, postProjectRemoveParentR
@@ -519,7 +520,7 @@ getProjectComponentsR projectHash = do
return (inztance, remoteObject, remoteActor)
)
byKeyOrRaid
- return (identView, componentRole c, outboxItemPublished i)
+ return (identView, componentRole c, outboxItemPublished i, cid)
ds <-
E.select $ E.from $ \ (comp `E.LeftOuterJoin` enable) -> do
E.on $ E.just (comp E.^. ComponentId) E.==. enable E.?. ComponentEnableComponent
@@ -968,6 +969,53 @@ getProjectParentLiveR projectHash startHash = do
getBy404 $ UniqueDestHolderProject destID
unless (j == projectID) notFound
+postProjectRemoveComponentR :: KeyHashid Project -> ComponentId -> Handler Html
+postProjectRemoveComponentR projectHash componentID = 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
+ Component j _ <- MaybeT $ get componentID
+ guard $ projectID == j
+ _ <- MaybeT $ getBy $ UniqueComponentEnable componentID
+
+ topic <- lift $ bimap snd snd <$> getComponentIdent componentID
+ lift $
+ (projectResource project,) <$>
+ bitraverse
+ pure
+ (getRemoteActorURI <=< getJust)
+ topic
+ (resourceID, pidOrU) <- maybe notFound pure mpidOrU
+ (maybeSummary, audience, remove) <- do
+ uComponent <-
+ case pidOrU of
+ Left c -> encodeRouteHome . renderLocalResource <$> hashLocalResource (componentResource c)
+ Right u -> pure u
+ let uCollection = encodeRouteHome $ ProjectComponentsR projectHash
+ C.remove personID uComponent 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 components"
+ 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 $ ProjectComponentsR projectHash
+
postProjectRemoveChildR :: KeyHashid Project -> SourceId -> Handler Html
postProjectRemoveChildR projectHash sourceID = do
projectID <- decodeKeyHashid404 projectHash
diff --git a/templates/project/components.hamlet b/templates/project/components.hamlet
index 15c8689..7598ce2 100644
--- a/templates/project/components.hamlet
+++ b/templates/project/components.hamlet
@@ -22,12 +22,15 @@ $#
Invite a component: diff --git a/th/routes b/th/routes index 659deb0..ce53035 100644 --- a/th/routes +++ b/th/routes @@ -367,6 +367,7 @@ /projects/#ProjectKeyHashid/parents ProjectParentsR GET /projects/#ProjectKeyHashid/parents/#DestUsStartKeyHashid/live ProjectParentLiveR GET +/projects/#ProjectKeyHashid/component/remove/#ComponentId ProjectRemoveComponentR POST /projects/#ProjectKeyHashid/child/remove/#SourceId ProjectRemoveChildR POST /projects/#ProjectKeyHashid/parent/remove/#DestId ProjectRemoveParentR POST