From 992e17f1ca5f746f97082c718ee6df40c5a01d7c Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Wed, 20 Mar 2024 01:50:09 +0200 Subject: [PATCH] UI, Client: Forms for adding and accepting a parent or child --- src/Vervis/Client.hs | 170 ++++++++++++++++++++++++++++- src/Vervis/Foundation.hs | 4 +- src/Vervis/Handler/Client.hs | 88 ++++++++++++++- templates/personal-overview.hamlet | 8 +- th/routes | 4 +- 5 files changed, 269 insertions(+), 5 deletions(-) diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 261c9bd..c15a590 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2022, 2023 by fr33domlover . + - Written in 2019, 2020, 2022, 2023, 2024 + - by fr33domlover . - - ♡ 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) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index f28de99..7758668 100644 --- a/src/Vervis/Foundation.hs +++ b/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 . - - ♡ 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) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 65c7f09..05e08fa 100644 --- a/src/Vervis/Handler/Client.hs +++ b/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 . - - ♡ 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| +

Add component/child/parent to a project/team +
+ ^{widget} + + |] + +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| +

Accept parent/child + + ^{widget} + + |] + +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 diff --git a/templates/personal-overview.hamlet b/templates/personal-overview.hamlet index dd73cc0..1d1427c 100644 --- a/templates/personal-overview.hamlet +++ b/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 . $# $# ♡ Copying is an act of love. Please copy, reuse and share. @@ -63,6 +63,12 @@ $# Comment on a ticket or merge request
  • Remove someone from a resource +
  • + + Add a component/child/parent to a project/team +
  • + + Accept parent/child

    Your teams diff --git a/th/routes b/th/routes index b6633a7..03730d8 100644 --- a/th/routes +++ b/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 . -- -- ♡ 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