UI, Client: Forms for adding and accepting a parent or child
This commit is contained in:
Pere Lev
parent
acc42896f5
commit
992e17f1ca
5 changed files with 269 additions and 5 deletions
|
|
@ -1,6 +1,7 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2020, 2022, 2023, 2024
|
||||
- by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -40,10 +41,12 @@ module Vervis.Client
|
|||
, createProject
|
||||
, createGroup
|
||||
, invite
|
||||
, add
|
||||
, remove
|
||||
, inviteComponent
|
||||
, acceptProjectInvite
|
||||
, acceptPersonalInvite
|
||||
, acceptParentChild
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -1179,6 +1182,92 @@ invite personID uRecipient uResourceCollabs role = do
|
|||
|
||||
return (Nothing, audience, activity)
|
||||
|
||||
add :: PersonId
|
||||
-> FedURI
|
||||
-> FedURI
|
||||
-> AP.Role
|
||||
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Add URIMode)
|
||||
add personID uRecipient uCollection role = do
|
||||
|
||||
theater <- asksSite appTheater
|
||||
env <- asksSite appEnv
|
||||
|
||||
let activity = AP.Add (Left uRecipient) uCollection role Nothing
|
||||
(object, target, _role) <-
|
||||
runActE $ parseAdd (Left $ LocalActorPerson personID) activity
|
||||
|
||||
-- If target collection is remote, we need to get it from DB/HTTP to
|
||||
-- determine the resourc & its managing actor & followers collection
|
||||
target' <-
|
||||
bitraverse
|
||||
(pure . addTargetActor)
|
||||
(\ (ObjURI h luColl) -> do
|
||||
manager <- asksSite appHttpManager
|
||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
||||
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote collection has no 'context'"
|
||||
AP.ResourceWithCollections _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
||||
return $ ObjURI h lu
|
||||
)
|
||||
target
|
||||
targetDB <-
|
||||
bitraverse
|
||||
VR.hashLocalActor
|
||||
(\ u@(ObjURI h lu) -> do
|
||||
instanceID <-
|
||||
lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <-
|
||||
ExceptT $ first (T.pack . show) <$>
|
||||
runAct (fetchRemoteResource instanceID h lu)
|
||||
case result of
|
||||
Left (Entity _ actor) ->
|
||||
return (actor, u)
|
||||
Right (_objectID, luManager, (Entity _ actor)) ->
|
||||
return (actor, ObjURI h luManager)
|
||||
)
|
||||
target'
|
||||
|
||||
-- If object is remote, get it via HTTP/DB to determine its followers
|
||||
-- collection
|
||||
objectDB <-
|
||||
bitraverse
|
||||
VR.hashLocalActor
|
||||
(\ 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)
|
||||
)
|
||||
object
|
||||
|
||||
senderHash <- encodeKeyHashid personID
|
||||
|
||||
let audResource =
|
||||
case targetDB of
|
||||
Left la -> AudLocal [la] [localActorFollowers la]
|
||||
Right (remoteActor, ObjURI h lu) ->
|
||||
AudRemote h
|
||||
[lu]
|
||||
(maybeToList $ remoteActorFollowers remoteActor)
|
||||
audRecipient =
|
||||
case objectDB of
|
||||
Left la -> AudLocal [la] [localActorFollowers la]
|
||||
Right (remoteActor, ObjURI h lu) ->
|
||||
AudRemote h
|
||||
[lu]
|
||||
(maybeToList $ remoteActorFollowers remoteActor)
|
||||
audAuthor =
|
||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||
|
||||
audience = [audResource, audRecipient, audAuthor]
|
||||
|
||||
return (Nothing, audience, activity)
|
||||
|
||||
remove
|
||||
:: PersonId
|
||||
-> FedURI
|
||||
|
|
@ -1452,3 +1541,82 @@ acceptPersonalInvite personID resource uInvite = do
|
|||
audience = [audResource, audAuthor]
|
||||
|
||||
return (Nothing, audience, activity)
|
||||
|
||||
acceptParentChild
|
||||
:: PersonId
|
||||
-> FedURI
|
||||
-> FedURI
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Accept URIMode)
|
||||
acceptParentChild personID uAdd uParent uChild = do
|
||||
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let activity = AP.Accept uAdd Nothing
|
||||
|
||||
parent <- do
|
||||
u <- parseFedURIOld uParent
|
||||
bitraverse parseLocalActorE pure u
|
||||
child <- do
|
||||
u <- parseFedURIOld uChild
|
||||
bitraverse parseLocalActorE pure u
|
||||
|
||||
-- If parent is remote, get it via HTTP/DB to determine its followers
|
||||
-- collection
|
||||
parentDB <-
|
||||
bitraverse
|
||||
VR.hashLocalActor
|
||||
(\ 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 "Parent @id mismatch"
|
||||
Left (Just err) -> throwE $ T.pack $ displayException err
|
||||
Right Nothing -> throwE "Parent isn't an actor"
|
||||
Right (Just actor) -> return (entityVal actor, u)
|
||||
)
|
||||
parent
|
||||
|
||||
-- If child is remote, get it via HTTP/DB to determine its followers
|
||||
-- collection
|
||||
childDB <-
|
||||
bitraverse
|
||||
VR.hashLocalActor
|
||||
(\ 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 "Child @id mismatch"
|
||||
Left (Just err) -> throwE $ T.pack $ displayException err
|
||||
Right Nothing -> throwE "Child isn't an actor"
|
||||
Right (Just actor) -> return (entityVal actor, u)
|
||||
)
|
||||
child
|
||||
|
||||
senderHash <- encodeKeyHashid personID
|
||||
|
||||
let audParent =
|
||||
case parentDB of
|
||||
Left la -> AudLocal [la] [localActorFollowers la]
|
||||
Right (remoteActor, ObjURI h lu) ->
|
||||
AudRemote h
|
||||
[lu]
|
||||
(maybeToList $ remoteActorFollowers remoteActor)
|
||||
audChild =
|
||||
case childDB of
|
||||
Left la -> AudLocal [la] [localActorFollowers la]
|
||||
Right (remoteActor, ObjURI h lu) ->
|
||||
AudRemote h
|
||||
[lu]
|
||||
(maybeToList $ remoteActorFollowers remoteActor)
|
||||
audAuthor =
|
||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||
|
||||
audience = [audParent, audChild, audAuthor]
|
||||
|
||||
return (Nothing, audience, activity)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2018, 2019, 2022, 2023
|
||||
- Written in 2016, 2018, 2019, 2022, 2023, 2024
|
||||
- by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
|
|
@ -856,6 +856,8 @@ instance YesodBreadcrumbs App where
|
|||
PublishOfferMergeR -> ("Open MR", Just HomeR)
|
||||
PublishMergeR -> ("Apply MR", Just HomeR)
|
||||
PublishInviteR -> ("Invite someone to a resource", Just HomeR)
|
||||
PublishAddR -> ("Add a component/child/parent to a project/team", Just HomeR)
|
||||
PublishAcceptR -> ("Accept something", Just HomeR)
|
||||
PublishRemoveR -> ("Remove someone from a resource", Just HomeR)
|
||||
PublishResolveR -> ("Close a ticket", Just HomeR)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2018, 2019, 2020, 2022, 2023
|
||||
- Written in 2016, 2018, 2019, 2020, 2022, 2023, 2024
|
||||
- by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
|
|
@ -39,6 +39,12 @@ module Vervis.Handler.Client
|
|||
, getPublishInviteR
|
||||
, postPublishInviteR
|
||||
|
||||
, getPublishAddR
|
||||
, postPublishAddR
|
||||
|
||||
, getPublishAcceptR
|
||||
, postPublishAcceptR
|
||||
|
||||
, getPublishRemoveR
|
||||
, postPublishRemoveR
|
||||
|
||||
|
|
@ -1427,6 +1433,86 @@ postPublishInviteR = do
|
|||
setMessage "Invite activity sent"
|
||||
redirect HomeR
|
||||
|
||||
addForm = renderDivs $ (,,,)
|
||||
<$> areq fedUriField "(URI) Whom to add" Nothing
|
||||
<*> areq fedUriField "(URI) Into which collection" Nothing
|
||||
<*> areq roleField "Role" Nothing
|
||||
<*> areq capField "(URI) Grant activity to use for authorization" Nothing
|
||||
where
|
||||
roleField = selectField optionsEnum :: Field Handler AP.Role
|
||||
|
||||
getPublishAddR :: Handler Html
|
||||
getPublishAddR = do
|
||||
((_, widget), enctype) <- runFormPost addForm
|
||||
defaultLayout
|
||||
[whamlet|
|
||||
<h1>Add component/child/parent to a project/team
|
||||
<form method=POST action=@{PublishAddR} enctype=#{enctype}>
|
||||
^{widget}
|
||||
<input type=submit>
|
||||
|]
|
||||
|
||||
postPublishAddR :: Handler ()
|
||||
postPublishAddR = do
|
||||
(uRecipient, uCollection, role, (uCap, cap)) <-
|
||||
runFormPostRedirect PublishAddR addForm
|
||||
|
||||
(ep@(Entity pid _), a) <- getSender
|
||||
senderHash <- encodeKeyHashid pid
|
||||
|
||||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, inv) <- add pid uRecipient uCollection role
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
makeServerInput (Just uCap) maybeSummary audience (AP.AddActivity inv)
|
||||
handleViaActor pid (Just cap) localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left err -> do
|
||||
setMessage $ toHtml err
|
||||
redirect PublishAddR
|
||||
Right _ -> do
|
||||
setMessage "Add activity sent"
|
||||
redirect HomeR
|
||||
|
||||
acceptForm = renderDivs $ (,,,)
|
||||
<$> areq fedUriField "(URI) Activity to accept" Nothing
|
||||
<*> areq fedUriField "(URI) Parent" Nothing
|
||||
<*> areq fedUriField "(URI) Child" Nothing
|
||||
<*> areq capField "(URI) Grant activity to use for authorization" Nothing
|
||||
|
||||
getPublishAcceptR :: Handler Html
|
||||
getPublishAcceptR = do
|
||||
((_, widget), enctype) <- runFormPost acceptForm
|
||||
defaultLayout
|
||||
[whamlet|
|
||||
<h1>Accept parent/child
|
||||
<form method=POST action=@{PublishAcceptR} enctype=#{enctype}>
|
||||
^{widget}
|
||||
<input type=submit>
|
||||
|]
|
||||
|
||||
postPublishAcceptR :: Handler ()
|
||||
postPublishAcceptR = do
|
||||
(uAdd, uParent, uChild, (uCap, cap)) <-
|
||||
runFormPostRedirect PublishAcceptR acceptForm
|
||||
|
||||
(ep@(Entity pid _), a) <- getSender
|
||||
senderHash <- encodeKeyHashid pid
|
||||
|
||||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, accept) <- acceptParentChild pid uAdd uParent uChild
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
makeServerInput (Just uCap) maybeSummary audience (AP.AcceptActivity accept)
|
||||
handleViaActor pid (Just cap) localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left err -> do
|
||||
setMessage $ toHtml err
|
||||
redirect PublishAcceptR
|
||||
Right _ -> do
|
||||
setMessage "Accept activity sent"
|
||||
redirect HomeR
|
||||
|
||||
removeForm = renderDivs $ (,,)
|
||||
<$> areq fedUriField "(URI) Whom to remove" Nothing
|
||||
<*> areq fedUriField "(URI) From which resource collaborators collection" Nothing
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
$# This file is part of Vervis.
|
||||
$#
|
||||
$# Written in 2016, 2018, 2019, 2022, 2023
|
||||
$# Written in 2016, 2018, 2019, 2022, 2023, 2024
|
||||
$# by fr33domlover <fr33domlover@riseup.net>.
|
||||
$#
|
||||
$# ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
|
|
@ -63,6 +63,12 @@ $# Comment on a ticket or merge request
|
|||
<li>
|
||||
<a href=@{PublishRemoveR}>
|
||||
Remove someone from a resource
|
||||
<li>
|
||||
<a href=@{PublishAddR}>
|
||||
Add a component/child/parent to a project/team
|
||||
<li>
|
||||
<a href=@{PublishAcceptR}>
|
||||
Accept parent/child
|
||||
|
||||
<h2>Your teams
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
-- This file is part of Vervis.
|
||||
--
|
||||
-- Written in 2016, 2018, 2019, 2020, 2022, 2023
|
||||
-- Written in 2016, 2018, 2019, 2020, 2022, 2023, 2024
|
||||
-- by fr33domlover <fr33domlover@riseup.net>.
|
||||
--
|
||||
-- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
|
|
@ -133,6 +133,8 @@
|
|||
/publish/offer-merge PublishOfferMergeR GET POST
|
||||
/publish/merge PublishMergeR GET POST
|
||||
/publish/invite PublishInviteR GET POST
|
||||
/publish/add PublishAddR GET POST
|
||||
/publish/accept PublishAcceptR GET POST
|
||||
/publish/remove PublishRemoveR GET POST
|
||||
/publish/resolve PublishResolveR GET POST
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue