Client: Use the new Add-based version of adding a component
This commit is contained in:
parent
f6dda396dd
commit
66c1818fcd
3 changed files with 8 additions and 92 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue