Client: Use the new Add-based version of adding a component

This commit is contained in:
Pere Lev 2024-05-12 18:11:17 +03:00
parent f6dda396dd
commit 66c1818fcd
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
3 changed files with 8 additions and 92 deletions

View file

@ -44,7 +44,6 @@ module Vervis.Client
, invite
, add
, remove
, inviteComponent
, acceptProjectInvite
, acceptPersonalInvite
, acceptParentChild
@ -1396,77 +1395,6 @@ remove personID uRecipient uCollection = do
return (Nothing, audience, activity)
inviteComponent
:: PersonId
-> ProjectId
-> FedURI
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Invite URIMode)
inviteComponent personID projectID uComp = do
encodeRouteHome <- getEncodeRouteHome
theater <- asksSite appTheater
env <- asksSite appEnv
projectHash <- encodeKeyHashid projectID
let uComps = encodeRouteHome $ ProjectComponentsR projectHash
activity = AP.Invite AP.RoleAdmin uComp uComps
-- If component is remote, get it via HTTP/DB to determine its followers
-- collection
comp <- parseComp uComp
compDB <-
bitraverse
(runActE . hashComponent)
(\ 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 "Recipient @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Recipient isn't an actor"
Right (Just actor) -> return (entityVal actor, u)
)
comp
senderHash <- encodeKeyHashid personID
let audComp =
case compDB of
Left (ComponentRepo r) ->
AudLocal [LocalActorRepo r] [LocalStageRepoFollowers r]
Left (ComponentDeck d) ->
AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
Left (ComponentLoom l) ->
AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
Right (remoteActor, ObjURI h lu) ->
AudRemote h
[lu]
(maybeToList $ remoteActorFollowers remoteActor)
audProject =
AudLocal [LocalActorProject projectHash] [LocalStageProjectFollowers projectHash]
audAuthor =
AudLocal [] [LocalStagePersonFollowers senderHash]
audience = [audComp, audProject, audAuthor]
return (Nothing, audience, activity)
where
parseComp u = do
routeOrRemote <- parseFedURIOld u
bitraverse
(\ route -> do
c <-
fromMaybeE
(parseComponent route)
"Not a component route"
runActE $ unhashComponentE c "Contains invalid keyhashid"
)
pure
routeOrRemote
acceptProjectInvite
:: PersonId
-> LocalActorBy Key

View file

@ -612,23 +612,10 @@ postDeckAddProjectR deckHash = do
personHash <- encodeKeyHashid personID
encodeRouteHome <- getEncodeRouteHome
let uDeck = encodeRouteHome $ DeckR deckHash
let uCollection = encodeRouteHome $ DeckProjectsR deckHash
result <- runExceptT $ do
uCollection <- do
project <- do
u <- parseFedURIOld uProject
bitraverse parseLocalActorE pure u
case project of
Left la ->
encodeRouteHome . renderLocalActor <$> hashLocalActor la
Right (ObjURI h lu) -> do
manager <- asksSite appHttpManager
AP.ResourceWithCollections _ _ mluComponents _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
luComponents <- fromMaybeE mluComponents "No components collection"
return $ ObjURI h luComponents
(maybeSummary, audience, add) <- C.add personID uDeck uCollection AP.RoleAdmin
(maybeSummary, audience, add) <- C.add personID uProject uCollection AP.RoleAdmin
cap <- do
maybeItem <- lift $ runDB $ do
resourceID <- deckResource <$> get404 deckID

View file

@ -587,25 +587,26 @@ postProjectInviteCompR projectHash = do
personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID
encodeRouteHome <- getEncodeRouteHome
let uCollection = encodeRouteHome $ ProjectComponentsR projectHash
result <- runExceptT $ do
(maybeSummary, audience, invite) <-
C.inviteComponent personID projectID uComp
(maybeSummary, audience, add) <-
C.add personID uComp uCollection AP.RoleAdmin
cap <- do
maybeItem <- lift $ runDB $ do
resourceID <- projectResource <$> get404 projectID
getCapability personID (Left resourceID) AP.RoleAdmin
fromMaybeE maybeItem "You need to be have Admin access to the Project to invite components"
fromMaybeE maybeItem "You need to be have Admin access to the Project to add components"
uCap <- lift $ renderActivityURI cap
(localRecips, remoteRecips, fwdHosts, action) <-
C.makeServerInput (Just uCap) maybeSummary audience $ AP.InviteActivity invite
C.makeServerInput (Just uCap) maybeSummary audience $ AP.AddActivity add
let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
handleViaActor
personID (Just cap') localRecips remoteRecips fwdHosts action
case result of
Left e -> setMessage $ toHtml e
Right inviteID -> setMessage "Invite sent"
Right _addID -> setMessage "Add sent"
redirect $ ProjectComponentsR projectHash
getProjectChildrenR :: KeyHashid Project -> Handler TypedContent