UI: Deck: 'Approve' button for accepting invites-to-projects

src/Database/Persist/Local.hs

@@ -23,6 +23,9 @@ module Database.Persist.Local
     , insertByEntity'
     , getE
     , getEntityE
+    , getByJust
+    , getKeyByJust
+    , getValByJust
     )
 where
 
@@ -119,3 +122,21 @@ getEntityE
        )
     => Key record -> e -> ExceptT e (ReaderT backend m) (Entity record)
 getEntityE key msg = Entity key <$> getE key msg
+
+getByJust u = do
+    me <- getBy u
+    case me of
+        Nothing -> error "getByJust"
+        Just e -> pure e
+
+getKeyByJust u = do
+    me <- getKeyBy u
+    case me of
+        Nothing -> error "getKeyByJust"
+        Just e -> pure e
+
+getValByJust u = do
+    me <- getValBy u
+    case me of
+        Nothing -> error "getValByJust"
+        Just e -> pure e

src/Vervis/Client.hs

@@ -41,6 +41,7 @@ module Vervis.Client
     , invite
     , remove
     , inviteComponent
+    , acceptProjectInvite
     )
 where
 
@@ -1271,3 +1272,57 @@ inviteComponent personID projectID uComp = do
             )
             pure
             routeOrRemote
+
+acceptProjectInvite
+    :: PersonId
+    -> LocalActorBy Key
+    -> Either ProjectId FedURI
+    -> FedURI
+    -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Accept URIMode)
+acceptProjectInvite personID component project uInvite = do
+
+    encodeRouteHome <- getEncodeRouteHome
+    theater <- asksSite appTheater
+    env <- asksSite appEnv
+    component' <- Vervis.Recipient.hashLocalActor component
+    project' <- bitraverse encodeKeyHashid pure project
+
+    let activity = AP.Accept uInvite Nothing
+
+    -- If project is remote, get it via HTTP/DB to determine its followers
+    -- collection
+    projectDB <-
+        bitraverse
+            pure
+            (\ u@(ObjURI h lu) -> do
+                instanceID <-
+                    lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
+                result <-
+                    ExceptT $ first (T.pack . displayException) <$>
+                        fetchRemoteActor instanceID h lu
+                case result of
+                    Left Nothing -> throwE "Project @id mismatch"
+                    Left (Just err) -> throwE $ T.pack $ displayException err
+                    Right Nothing -> throwE "Project isn't an actor"
+                    Right (Just actor) -> return (entityVal actor, u)
+            )
+            project'
+
+    senderHash <- encodeKeyHashid personID
+
+    let audProject =
+            case projectDB of
+                Left j ->
+                    AudLocal [LocalActorProject j] [LocalStageProjectFollowers j]
+                Right (remoteActor, ObjURI h lu) ->
+                    AudRemote h
+                        [lu]
+                        (maybeToList $ remoteActorFollowers remoteActor)
+        audComp =
+            AudLocal [component'] [localActorFollowers component']
+        audAuthor =
+            AudLocal [] [LocalStagePersonFollowers senderHash]
+
+        audience = [audComp, audProject, audAuthor]
+
+    return (Nothing, audience, activity)

src/Vervis/Foundation.hs

@@ -159,6 +159,7 @@ type TicketLoomKeyHashid        = KeyHashid TicketLoom
 type SigKeyKeyHashid            = KeyHashid SigKey
 type ProjectKeyHashid           = KeyHashid Project
 type CollabEnableKeyHashid      = KeyHashid CollabEnable
+type StemKeyHashid              = KeyHashid Stem
 
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
@@ -939,6 +940,7 @@ instance YesodBreadcrumbs App where
         DeckRemoveR _ _ -> ("", Nothing)
 
         DeckProjectsR d -> ("Projects", Just $ DeckR d)
+        DeckApproveCompR d c -> ("", Nothing)
 
         TicketR d t            -> ("#" <> keyHashidText t, Just $ DeckTicketsR d)
         TicketDiscussionR d t  -> ("Discussion", Just $ TicketR d t)

src/Vervis/Handler/Deck.hs

@@ -41,6 +41,7 @@ module Vervis.Handler.Deck
     , postDeckInviteR
     , postDeckRemoveR
     , getDeckProjectsR
+    , postDeckApproveCompR
 
 
 
@@ -537,13 +538,15 @@ getDeckProjectsR deckHash = do
         deck <- get404 deckID
         actor <- getJust $ deckActor deck
         stems <-
-            E.select $ E.from $ \ (ident `E.InnerJoin` stem `E.InnerJoin` accept `E.LeftOuterJoin` deleg) -> do
+            E.select $ E.from $ \ (ident `E.InnerJoin` stem `E.InnerJoin` accept `E.LeftOuterJoin` deleg `E.LeftOuterJoin` gestl `E.LeftOuterJoin` gestr) -> do
+                E.on $ E.just (stem E.^. StemId) E.==. gestr E.?. StemComponentGestureRemoteStem
+                E.on $ E.just (stem E.^. StemId) E.==. gestl E.?. StemComponentGestureLocalStem
                 E.on $ E.just (accept E.^. StemComponentAcceptId) E.==. deleg E.?. StemDelegateLocalStem
                 E.on $ stem E.^. StemId E.==. accept E.^. StemComponentAcceptStem
                 E.on $ ident E.^. StemIdentDeckStem E.==. stem E.^. StemId
                 E.where_ $ ident E.^. StemIdentDeckDeck E.==. E.val deckID
-                return (stem, deleg)
+                return (stem, deleg, gestl, gestr)
-        stems' <- for stems $ \ (Entity stemID stem, deleg) -> do
+        stems' <- for stems $ \ (Entity stemID stem, deleg, gestl, gestr) -> do
             j <- getStemProject stemID
             projectView <-
                 bitraverse
@@ -559,10 +562,70 @@ getDeckProjectsR deckHash = do
                         return (inztance, remoteObject, remoteActor)
                     )
                     j
-            return (projectView, stemRole stem, isJust deleg)
+            stemHash <- encodeKeyHashid stemID
+            return (projectView, stemRole stem, isJust deleg, isJust gestl || isJust gestr, stemHash)
         return (deck, actor, stems')
     defaultLayout $(widgetFile "deck/projects")
 
+postDeckApproveCompR :: KeyHashid Deck -> KeyHashid Stem -> Handler Html
+postDeckApproveCompR deckHash stemHash = do
+    deckID <- decodeKeyHashid404 deckHash
+    stemID <- decodeKeyHashid404 stemHash
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    encodeRouteHome <- getEncodeRouteHome
+
+    result <- runExceptT $ do
+        (uInvite, jidOrURI) <- lift $ runDB $ do
+            _ <- get404 deckID
+            _ <- get404 stemID
+            Entity _ (StemIdentDeck _ deckID') <- getBy404 $ UniqueStemIdentDeck stemID
+            unless (deckID' == deckID) notFound
+            uInvite <- do
+                Entity originID _ <- getBy404 $ UniqueStemOriginInvite stemID
+                i <-
+                    requireEitherAlt
+                        (getValBy $ UniqueStemProjectGestureLocal originID)
+                        (getValBy $ UniqueStemProjectGestureRemote originID)
+                        "Invite gesture not found"
+                        "Multiple invites"
+                case i of
+                    Left g -> do
+                        let k = stemProjectGestureLocalInvite g
+                        oi <- getJust k
+                        a <- getKeyByJust $ UniqueActorOutbox $ outboxItemOutbox oi
+                        p <- getKeyByJust $ UniquePersonActor a
+                        ph <- encodeKeyHashid p
+                        kh <- encodeKeyHashid k
+                        return $ encodeRouteHome $ PersonOutboxItemR ph kh
+                    Right g -> do
+                        a <- getJust $ stemProjectGestureRemoteInvite g
+                        o <- getJust $ remoteActivityIdent a
+                        h <- getJust $ remoteObjectInstance o
+                        return $ ObjURI (instanceHost h) (remoteObjectIdent o)
+            project <- getStemProject stemID
+            (uInvite,) <$> bitraverse pure (getRemoteActorURI <=< getJust) project
+        (maybeSummary, audience, accept) <-
+            C.acceptProjectInvite personID (LocalActorDeck deckID) jidOrURI uInvite
+        grantID <- do
+            maybeItem <- lift $ runDB $ getGrant CollabTopicDeckCollab CollabTopicDeckDeck deckID personID
+            fromMaybeE maybeItem "You need to be a collaborator in the Deck to remove people"
+        grantHash <- encodeKeyHashid grantID
+        let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash
+        (localRecips, remoteRecips, fwdHosts, action) <-
+            C.makeServerInput (Just uCap) maybeSummary audience $ AP.AcceptActivity accept
+        let cap =
+                Left (LocalActorDeck deckID, LocalActorDeck deckHash, grantID)
+        handleViaActor
+            personID (Just cap) localRecips remoteRecips fwdHosts action
+
+    case result of
+        Left e -> do
+            setMessage $ toHtml e
+        Right removeID -> do
+            setMessage "Remove sent"
+    redirect $ DeckProjectsR deckHash
 
 
 

templates/deck/projects.hamlet

@@ -21,7 +21,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     <th>Role
     <th>Project
     <th>Enabled
-  $forall (project, role, enabled) <- stems
+    <th>Approve
+  $forall (project, role, enabled, gestured, stemHash) <- stems
     <tr>
       <td>#{show role}
       <td>^{projectLinkFedW project}
@@ -30,4 +31,6 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
           [x]
         $else
           [_]
+      $if not gestured
+        <td>^{buttonW POST "Approve" (DeckApproveCompR deckHash stemHash)}
 $#    <td>^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)}

th/routes

@@ -225,6 +225,8 @@
 /decks/#DeckKeyHashid/remove/#CollabTopicDeckId   DeckRemoveR     POST
 /decks/#DeckKeyHashid/projects                    DeckProjectsR   GET
 
+/decks/#DeckKeyHashid/projects/approve/#StemKeyHashid DeckApproveCompR POST
+
 ---- Ticket ------------------------------------------------------------------
 
 /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid            TicketR            GET