diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index 123c181..fcb3ef7 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -957,6 +957,7 @@ instance YesodBreadcrumbs App where
DeckProjectsR d -> ("Projects", Just $ DeckR d)
DeckApproveProjectR d c -> ("", Nothing)
+ DeckRemoveProjectR d c -> ("", Nothing)
DeckAddProjectR d -> ("", Nothing)
TicketR d t -> ("#" <> keyHashidText t, Just $ DeckTicketsR d)
diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs
index 00f4bdc..d534afe 100644
--- a/src/Vervis/Handler/Deck.hs
+++ b/src/Vervis/Handler/Deck.hs
@@ -45,6 +45,7 @@ module Vervis.Handler.Deck
, getDeckProjectsR
, postDeckAddProjectR
, postDeckApproveProjectR
+ , postDeckRemoveProjectR
@@ -615,7 +616,7 @@ getDeckProjectsR deckHash = do
)
getRemoteActorData
j
- return (projectView, stemRole stem, time)
+ return (projectView, stemRole stem, time, stemID)
drafts <-
E.select $ E.from $ \ (ident `E.InnerJoin` stem `E.LeftOuterJoin` accept `E.LeftOuterJoin` deleg) -> do
E.on $ accept E.?. StemComponentAcceptId E.==. deleg E.?. StemDelegateLocalStem
@@ -775,6 +776,59 @@ postDeckApproveProjectR deckHash stemID = do
setMessage "Accept sent"
redirect $ DeckProjectsR deckHash
+postDeckRemoveProjectR :: KeyHashid Deck -> StemId -> Handler Html
+postDeckRemoveProjectR deckHash stemID = do
+ deckID <- decodeKeyHashid404 deckHash
+
+ personEntity@(Entity personID person) <- requireAuth
+ personHash <- encodeKeyHashid personID
+ encodeRouteHome <- getEncodeRouteHome
+
+ result <- runExceptT $ do
+ mpidOrU <- lift $ runDB $ runMaybeT $ do
+ deck <- MaybeT $ get deckID
+ _ <- MaybeT $ get stemID
+ StemIdentDeck _ d <- MaybeT $ getValBy $ UniqueStemIdentDeck stemID
+ guard $ deckID == d
+ acceptID <- MaybeT $ getKeyBy $ UniqueStemComponentAccept stemID
+ _ <- MaybeT $ getBy $ UniqueStemDelegateLocal acceptID
+
+ uAdd <- lift $ do
+ add <- getStemAdd stemID
+ renderActivityURI add
+
+ topic <- lift $ getStemProject stemID
+ lift $
+ (deckResource deck,uAdd,) <$>
+ bitraverse
+ pure
+ (getRemoteActorURI <=< getJust)
+ topic
+ (resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU
+ (maybeSummary, audience, remove) <- do
+ uProject <-
+ case pidOrU of
+ Left j -> encodeRouteHome . ProjectR <$> encodeKeyHashid j
+ Right u -> pure u
+ let uCollection = encodeRouteHome $ DeckProjectsR deckHash
+ C.remove personID uProject uCollection
+ cap <- do
+ maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
+ fromMaybeE maybeItem "You need to be have Admin access to the Deck to remove projects"
+ 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 $ DeckProjectsR deckHash
+
{-
getProjectsR :: ShrIdent -> Handler Html
getProjectsR ident = do
diff --git a/templates/deck/projects.hamlet b/templates/deck/projects.hamlet
index 5c6c813..bc8a478 100644
--- a/templates/deck/projects.hamlet
+++ b/templates/deck/projects.hamlet
@@ -22,12 +22,15 @@ $#
Add deck to a project: diff --git a/th/routes b/th/routes index ce53035..0a86b2c 100644 --- a/th/routes +++ b/th/routes @@ -252,6 +252,7 @@ /decks/#DeckKeyHashid/add-project DeckAddProjectR POST /decks/#DeckKeyHashid/project/approve/#StemId DeckApproveProjectR POST +/decks/#DeckKeyHashid/project/remove/#StemId DeckRemoveProjectR POST ---- Ticket ------------------------------------------------------------------