UI: Deck: Projects: Button for removal

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)

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

templates/deck/projects.hamlet

@@ -22,12 +22,15 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     <th>Role
     <th>Project
     <th>Since
-  $forall (project, role, since) <- stems
+    $if haveAdmin
+      <th>Remove
+  $forall (project, role, since, stemID) <- stems
     <tr>
       <td>#{show role}
       <td>^{projectLinkFedW project}
       <td>#{showDate since}
-$#    <td>^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)}
+      $if haveAdmin
+        <td>^{buttonW POST "Remove" (DeckRemoveProjectR deckHash stemID)}
 
 $if haveAdmin
   <p>Add deck to a project:

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