UI, Client: Forms for adding and accepting a parent or child

src/Vervis/Client.hs

@@ -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)

src/Vervis/Foundation.hs

@@ -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)
 

src/Vervis/Handler/Client.hs

@@ -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

templates/personal-overview.hamlet

@@ -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
 

th/routes

@@ -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