UI: Add 'Accept' button to invites you haven't yet accepted

src/Vervis/Actor/Project.hs

@@ -295,7 +295,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                     case (collab, acceptDB) of
                         (Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do
                             maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID
-                            unless (isNothing maybeAccept) $
+                            unless (isJust maybeAccept) $
                                 throwE "This Invite already has an Accept by recip"
                         (Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do
                             maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID

src/Vervis/Client.hs

@@ -43,6 +43,7 @@ module Vervis.Client
     , remove
     , inviteComponent
     , acceptProjectInvite
+    , acceptPersonalInvite
     )
 where
 
@@ -1410,3 +1411,44 @@ acceptProjectInvite personID component project uInvite = do
         audience = [audComp, audProject, audAuthor]
 
     return (Nothing, audience, activity)
+
+acceptPersonalInvite
+    :: PersonId
+    -> Either (LocalActorBy Key) RemoteActorId
+    -> FedURI
+    -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Accept URIMode)
+acceptPersonalInvite personID resource uInvite = do
+
+    encodeRouteHome <- getEncodeRouteHome
+    resource' <- bitraverse VR.hashLocalActor pure resource
+
+    let activity = AP.Accept uInvite Nothing
+
+    -- If resource is remote, get it from DB to determine its followers
+    -- collection
+    resourceDB <-
+        bitraverse
+            pure
+            (\ remoteActorID -> lift $ runDB $ do
+                ra <- getJust remoteActorID
+                u <- getRemoteActorURI ra
+                return (ra, u)
+            )
+            resource'
+
+    senderHash <- encodeKeyHashid personID
+
+    let audResource =
+            case resourceDB of
+                Left la ->
+                    AudLocal [la] [localActorFollowers la]
+                Right (remoteActor, ObjURI h lu) ->
+                    AudRemote h
+                        [lu]
+                        (maybeToList $ remoteActorFollowers remoteActor)
+        audAuthor =
+            AudLocal [] [LocalStagePersonFollowers senderHash]
+
+        audience = [audResource, audAuthor]
+
+    return (Nothing, audience, activity)

src/Vervis/Foundation.hs

@@ -160,6 +160,7 @@ type SigKeyKeyHashid            = KeyHashid SigKey
 type ProjectKeyHashid           = KeyHashid Project
 type CollabEnableKeyHashid      = KeyHashid CollabEnable
 type StemKeyHashid              = KeyHashid Stem
+type PermitFulfillsInviteKeyHashid = KeyHashid PermitFulfillsInvite
 
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
@@ -856,6 +857,8 @@ instance YesodBreadcrumbs App where
         PublishRemoveR     -> ("Remove someone from a resource", Just HomeR)
         PublishResolveR     -> ("Close a ticket", Just HomeR)
 
+        AcceptInviteR _ -> ("", Nothing)
+
         PersonR p             -> ("Person ~" <> keyHashidText p, Just HomeR)
         PersonInboxR p        -> ("Inbox", Just $ PersonR p)
         PersonOutboxR p       -> ("Outbox", Just $ PersonR p)

src/Vervis/Handler/Client.hs

@@ -44,6 +44,8 @@ module Vervis.Handler.Client
 
     , getPublishResolveR
     , postPublishResolveR
+
+    , postAcceptInviteR
     )
 where
 
@@ -59,6 +61,7 @@ import Data.Text (Text)
 import Data.Time.Clock
 import Data.Traversable
 import Database.Persist
+import Network.HTTP.Types.Method
 import Text.Blaze.Html (preEscapedToHtml)
 import Optics.Core
 import Yesod.Auth
@@ -107,8 +110,10 @@ import Vervis.Persist.Collab
 import Vervis.Recipient
 import Vervis.Settings
 import Vervis.Web.Actor
+import Vervis.Widget
 import Vervis.Widget.Tracker
 
+import qualified Vervis.Client as C
 import qualified Vervis.Recipient as VR
 
 -- | Account verification email resend form
@@ -236,11 +241,13 @@ getHomeR = do
                                 Nothing -> error "Impossible, we should have found the local actor in DB"
                                 Just a -> pure $ localActorID a
                         actor <- getJust actorID
+                        fulfillsHash <- encodeKeyHashid fulfillsID
                         return
                             ( fulfillsID
                             , role
                             , () <$ valid
                             , accept
+                            , fulfillsHash
                             , Left (topic, actor)
                             )
                 remotes <- do
@@ -265,11 +272,13 @@ getHomeR = do
                         remoteActor <- getJust remoteActorID
                         remoteObject <- getJust $ remoteActorIdent remoteActor
                         inztance <- getJust $ remoteObjectInstance remoteObject
+                        fulfillsHash <- encodeKeyHashid fulfillsID
                         return
                             ( fulfillsID
                             , role
                             , () <$ valid
                             , accept
+                            , fulfillsHash
                             , Right (inztance, remoteObject, remoteActor)
                             )
                 return $ sortOn (view _1) $ locals ++ remotes
@@ -299,7 +308,7 @@ getHomeR = do
                 x = deleteFirstsBy ((==) `on` key) xs (p ++ r ++ d ++ l ++ j ++ g)
             in  (p, r, d, l, j, g, x)
 
-        item (_permitID, role, deleg, _typ, actor, exts) =
+        item (_gestureID, role, deleg, _typ, actor, exts) =
             [whamlet|
                 <span>
                   [
@@ -317,7 +326,7 @@ getHomeR = do
                         #{renderObjURI u}
             |]
 
-        invite (_fulfillsID, role, valid, accept, actor) =
+        invite (_fulfillsID, role, valid, accept, fulfillsHash, actor) =
             [whamlet|
                 <span>
                   [
@@ -330,7 +339,8 @@ getHomeR = do
                   $maybe _ <- accept
                     \ [You've accepted] #
                   $nothing
-                    \ [Accept Button] [Reject Button] #
+                    ^{buttonW POST "Accept" (AcceptInviteR fulfillsHash)}
+                  $#\ [Reject Button] #
                   ^{actorLinkFedW actor}
             |]
 
@@ -1397,9 +1407,6 @@ getPublishInviteR = do
 
 postPublishInviteR :: Handler ()
 postPublishInviteR = do
-    federation <- getsYesod $ appFederation . appSettings
-    unless federation badMethod
-
     (uRecipient, uResourceCollabs, role, (uCap, cap)) <-
         runFormPostRedirect PublishInviteR inviteForm
 
@@ -1499,3 +1506,50 @@ postPublishResolveR = do
         Right _ -> do
             setMessage "Resolve activity sent"
             redirect HomeR
+
+postAcceptInviteR :: KeyHashid PermitFulfillsInvite -> Handler ()
+postAcceptInviteR fulfillsHash = do
+    fulfillsID <- decodeKeyHashid404 fulfillsHash
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    encodeRouteHome <- getEncodeRouteHome
+
+    result <- runExceptT $ do
+        (uInvite, topic) <- lift $ runDB $ do
+            PermitFulfillsInvite permitID <- get404 fulfillsID
+            Permit p _ <- getJust permitID
+            unless (p == personID) notFound
+            uInvite <- do
+                i <-
+                    requireEitherAlt
+                        (getValBy $ UniquePermitTopicGestureLocal fulfillsID)
+                        (getValBy $ UniquePermitTopicGestureRemote fulfillsID)
+                        "Invite not found"
+                        "Multiple invites"
+                case i of
+                    Left (PermitTopicGestureLocal _ inviteID) -> do
+                        outboxID <- outboxItemOutbox <$> getJust inviteID
+                        actorID <- getKeyByJust $ UniqueActorOutbox outboxID
+                        actor <- getLocalActor actorID
+                        actorHash <- VR.hashLocalActor actor
+                        inviteHash <- encodeKeyHashid inviteID
+                        return $ encodeRouteHome $
+                            activityRoute actorHash inviteHash
+                    Right (PermitTopicGestureRemote _ _ inviteID) -> do
+                        invite <- getJust inviteID
+                        getRemoteActivityURI invite
+            topic <- bimap snd snd <$> getPermitTopic permitID
+            return (uInvite, topic)
+        (maybeSummary, audience, accept) <-
+            C.acceptPersonalInvite personID topic uInvite
+        (localRecips, remoteRecips, fwdHosts, action) <-
+            C.makeServerInput Nothing maybeSummary audience $
+                AP.AcceptActivity accept
+        handleViaActor
+            personID Nothing localRecips remoteRecips fwdHosts action
+
+    case result of
+        Left e -> setMessage $ toHtml e
+        Right _acceptID -> setMessage "Accept sent"
+    redirect HomeR

th/routes

@@ -136,6 +136,8 @@
 /publish/remove      PublishRemoveR     GET POST
 /publish/resolve     PublishResolveR    GET POST
 
+/accept-invite/#PermitFulfillsInviteKeyHashid AcceptInviteR POST
+
 ---- Person ------------------------------------------------------------------
 
 /people/#PersonKeyHashid                                 PersonR           GET