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

This commit is contained in:
Pere Lev 2023-12-09 10:24:20 +02:00
parent ce1e542401
commit ee91a6403e
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
5 changed files with 108 additions and 7 deletions

View file

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

View file

@ -43,6 +43,7 @@ module Vervis.Client
, remove , remove
, inviteComponent , inviteComponent
, acceptProjectInvite , acceptProjectInvite
, acceptPersonalInvite
) )
where where
@ -1410,3 +1411,44 @@ acceptProjectInvite personID component project uInvite = do
audience = [audComp, audProject, audAuthor] audience = [audComp, audProject, audAuthor]
return (Nothing, audience, activity) 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)

View file

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

View file

@ -44,6 +44,8 @@ module Vervis.Handler.Client
, getPublishResolveR , getPublishResolveR
, postPublishResolveR , postPublishResolveR
, postAcceptInviteR
) )
where where
@ -59,6 +61,7 @@ import Data.Text (Text)
import Data.Time.Clock import Data.Time.Clock
import Data.Traversable import Data.Traversable
import Database.Persist import Database.Persist
import Network.HTTP.Types.Method
import Text.Blaze.Html (preEscapedToHtml) import Text.Blaze.Html (preEscapedToHtml)
import Optics.Core import Optics.Core
import Yesod.Auth import Yesod.Auth
@ -107,8 +110,10 @@ import Vervis.Persist.Collab
import Vervis.Recipient import Vervis.Recipient
import Vervis.Settings import Vervis.Settings
import Vervis.Web.Actor import Vervis.Web.Actor
import Vervis.Widget
import Vervis.Widget.Tracker import Vervis.Widget.Tracker
import qualified Vervis.Client as C
import qualified Vervis.Recipient as VR import qualified Vervis.Recipient as VR
-- | Account verification email resend form -- | Account verification email resend form
@ -236,11 +241,13 @@ getHomeR = do
Nothing -> error "Impossible, we should have found the local actor in DB" Nothing -> error "Impossible, we should have found the local actor in DB"
Just a -> pure $ localActorID a Just a -> pure $ localActorID a
actor <- getJust actorID actor <- getJust actorID
fulfillsHash <- encodeKeyHashid fulfillsID
return return
( fulfillsID ( fulfillsID
, role , role
, () <$ valid , () <$ valid
, accept , accept
, fulfillsHash
, Left (topic, actor) , Left (topic, actor)
) )
remotes <- do remotes <- do
@ -265,11 +272,13 @@ getHomeR = do
remoteActor <- getJust remoteActorID remoteActor <- getJust remoteActorID
remoteObject <- getJust $ remoteActorIdent remoteActor remoteObject <- getJust $ remoteActorIdent remoteActor
inztance <- getJust $ remoteObjectInstance remoteObject inztance <- getJust $ remoteObjectInstance remoteObject
fulfillsHash <- encodeKeyHashid fulfillsID
return return
( fulfillsID ( fulfillsID
, role , role
, () <$ valid , () <$ valid
, accept , accept
, fulfillsHash
, Right (inztance, remoteObject, remoteActor) , Right (inztance, remoteObject, remoteActor)
) )
return $ sortOn (view _1) $ locals ++ remotes return $ sortOn (view _1) $ locals ++ remotes
@ -299,7 +308,7 @@ getHomeR = do
x = deleteFirstsBy ((==) `on` key) xs (p ++ r ++ d ++ l ++ j ++ g) x = deleteFirstsBy ((==) `on` key) xs (p ++ r ++ d ++ l ++ j ++ g)
in (p, r, d, l, j, g, x) in (p, r, d, l, j, g, x)
item (_permitID, role, deleg, _typ, actor, exts) = item (_gestureID, role, deleg, _typ, actor, exts) =
[whamlet| [whamlet|
<span> <span>
[ [
@ -317,7 +326,7 @@ getHomeR = do
#{renderObjURI u} #{renderObjURI u}
|] |]
invite (_fulfillsID, role, valid, accept, actor) = invite (_fulfillsID, role, valid, accept, fulfillsHash, actor) =
[whamlet| [whamlet|
<span> <span>
[ [
@ -330,7 +339,8 @@ getHomeR = do
$maybe _ <- accept $maybe _ <- accept
\ [You've accepted] # \ [You've accepted] #
$nothing $nothing
\ [Accept Button] [Reject Button] # ^{buttonW POST "Accept" (AcceptInviteR fulfillsHash)}
$#\ [Reject Button] #
^{actorLinkFedW actor} ^{actorLinkFedW actor}
|] |]
@ -1397,9 +1407,6 @@ getPublishInviteR = do
postPublishInviteR :: Handler () postPublishInviteR :: Handler ()
postPublishInviteR = do postPublishInviteR = do
federation <- getsYesod $ appFederation . appSettings
unless federation badMethod
(uRecipient, uResourceCollabs, role, (uCap, cap)) <- (uRecipient, uResourceCollabs, role, (uCap, cap)) <-
runFormPostRedirect PublishInviteR inviteForm runFormPostRedirect PublishInviteR inviteForm
@ -1499,3 +1506,50 @@ postPublishResolveR = do
Right _ -> do Right _ -> do
setMessage "Resolve activity sent" setMessage "Resolve activity sent"
redirect HomeR 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

View file

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