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 @@ $# . Role Project Since - $forall (project, role, since) <- stems + $if haveAdmin + Remove + $forall (project, role, since, stemID) <- stems #{show role} ^{projectLinkFedW project} #{showDate since} -$# ^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)} + $if haveAdmin + ^{buttonW POST "Remove" (DeckRemoveProjectR deckHash stemID)} $if haveAdmin

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 ------------------------------------------------------------------