From 082eae7a51e411a911ff216da11957be2b46f5dd Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 27 Apr 2024 21:37:13 +0300 Subject: [PATCH] UI: Project: Children: Button for approving the Add --- src/Vervis/Foundation.hs | 2 + src/Vervis/Handler/Project.hs | 64 ++++++++++++++++++++++++++++++- src/Vervis/Persist/Collab.hs | 42 ++++++++++++++++++++ templates/project/children.hamlet | 6 ++- th/routes | 2 + 5 files changed, 114 insertions(+), 2 deletions(-) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index e3deb9e..406cafd 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -1042,3 +1042,5 @@ instance YesodBreadcrumbs App where ProjectRemoveParentR _ _ -> ("", Nothing) ProjectAddChildR _ -> ("", Nothing) + + ProjectApproveChildR _ _ -> ("", Nothing) diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 1b7d17c..d45f33b 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -48,6 +48,8 @@ module Vervis.Handler.Project , postProjectRemoveParentR , postProjectAddChildR + + , postProjectApproveChildR ) where @@ -744,7 +746,7 @@ getProjectChildrenR projectHash = do Right (actorID, addID) -> do RemoteActivity _ _ time <- getJust addID (,time) . Right <$> getRemoteActorData actorID - return (inviter, us, child, accept, time, role) + return (inviter, us, child, accept, time, role, sourceID) $(widgetFile "project/children") where getRemoteActorData actorID = do @@ -1079,3 +1081,63 @@ postProjectAddChildR projectHash = do Right removeID -> setMessage "Add sent" redirect $ ProjectChildrenR projectHash + +postProjectApproveChildR :: KeyHashid Project -> SourceId -> Handler Html +postProjectApproveChildR projectHash sourceID = do + projectID <- decodeKeyHashid404 projectHash + + personEntity@(Entity personID person) <- requireAuth + personHash <- encodeKeyHashid personID + encodeRouteHome <- getEncodeRouteHome + + result <- runExceptT $ do + mpidOrU <- lift $ runDB $ runMaybeT $ do + project <- MaybeT $ get projectID + _ <- MaybeT $ get sourceID + SourceHolderProject _ j <- + MaybeT $ getValBy $ UniqueSourceHolderProject sourceID + guard $ projectID == j + + uAdd <- lift $ do + add <- getSourceAdd sourceID + renderActivityURI add + + topic <- lift $ do + t <- bimap snd snd <$> getSourceTopic sourceID + bitraverse + (\case + Left j' -> pure j' + Right _g -> error "I'm a project, I have a Source with topic being Group" + ) + pure + t + lift $ + (projectResource project,uAdd,) <$> + bitraverse + pure + (getRemoteActorURI <=< getJust) + topic + (resourceID, uAdd, pidOrU) <- maybe notFound pure mpidOrU + (maybeSummary, audience, accept) <- do + uChild <- + case pidOrU of + Left j -> encodeRouteHome . ProjectR <$> encodeKeyHashid j + Right u -> pure u + let uParent = encodeRouteHome $ ProjectR projectHash + C.acceptParentChild personID uAdd uParent uChild + cap <- do + maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin + fromMaybeE maybeItem "You need to be have Admin access to the Project to approve children" + uCap <- lift $ renderActivityURI cap + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput (Just uCap) maybeSummary audience $ AP.AcceptActivity accept + let cap' = first (\ (la, i) -> (la, error "lah", i)) cap + handleViaActor + personID (Just cap') localRecips remoteRecips fwdHosts action + + case result of + Left e -> do + setMessage $ toHtml e + Right removeID -> + setMessage "Add sent" + redirect $ ProjectChildrenR projectHash diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index fabbaea..0ba2bb5 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -33,6 +33,7 @@ module Vervis.Persist.Collab , getComponentIdent , getSourceTopic + , getSourceAdd , getDestTopic , getDestHolder @@ -461,6 +462,47 @@ getSourceTopic sourceID = do (\ (Entity k v) -> pure (k, sourceTopicRemoteTopic v)) ident +getSourceAdd + :: MonadIO m + => SourceId + -> ReaderT SqlBackend m + (Either + (LocalActorBy Key, OutboxItemId) + FedURI + ) +getSourceAdd sourceID = do + usOrThem <- + requireEitherAlt + (getKeyBy $ UniqueSourceOriginUs sourceID) + (getKeyBy $ UniqueSourceOriginThem sourceID) + "Neither us nor them" + "Both us and them" + add <- + case usOrThem of + Left usID -> + requireEitherAlt + (fmap sourceUsGestureLocalAdd <$> getValBy (UniqueSourceUsGestureLocal usID)) + (fmap sourceUsGestureRemoteAdd <$> getValBy (UniqueSourceUsGestureRemote usID)) + "Neither local not remote" + "Both local and remote" + Right themID -> + requireEitherAlt + (fmap sourceThemGestureLocalAdd <$> getValBy (UniqueSourceThemGestureLocal themID)) + (fmap sourceThemGestureRemoteAdd <$> getValBy (UniqueSourceThemGestureRemote themID)) + "Neither local not remote" + "Both local and remote" + bitraverse + (\ addID -> do + OutboxItem outboxID _ time <- getJust addID + Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID + (,addID) <$> getLocalActor actorID + ) + (\ addID -> do + add <- getJust addID + getRemoteActivityURI add + ) + add + getDestTopic :: MonadIO m => DestId diff --git a/templates/project/children.hamlet b/templates/project/children.hamlet index 1df07fd..9cb06d5 100644 --- a/templates/project/children.hamlet +++ b/templates/project/children.hamlet @@ -48,7 +48,9 @@ $if haveAdmin Child accepted? Role Time - $forall (inviter, us, child, accept, time, role) <- invites + $if haveAdmin + Approve + $forall (inviter, us, child, accept, time, role, sourceID) <- invites ^{actorLinkFedW inviter} @@ -64,3 +66,5 @@ $if haveAdmin [_] #{show role} #{showDate time} + $if haveAdmin && (accept && not us) + ^{buttonW POST "Approve" (ProjectApproveChildR projectHash sourceID)} diff --git a/th/routes b/th/routes index 3d46a80..ed455be 100644 --- a/th/routes +++ b/th/routes @@ -358,3 +358,5 @@ /projects/#ProjectKeyHashid/parent/remove/#DestId ProjectRemoveParentR POST /projects/#ProjectKeyHashid/child/add ProjectAddChildR POST + +/projects/#ProjectKeyHashid/child/approve/#SourceId ProjectApproveChildR POST