From e65563cd19c124275317143fc11ce966118ee719 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 9 Dec 2023 07:58:16 +0200 Subject: [PATCH] UI: For each Permit, display delegator-Grant and extensions --- src/Vervis/Handler/Client.hs | 60 ++++++++++++++++++++++++++++-------- 1 file changed, 48 insertions(+), 12 deletions(-) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index c017650..71cfa34 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -79,6 +79,7 @@ import Network.FedURI import Web.Text import Yesod.ActivityPub import Yesod.Auth.Unverified +import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite import Yesod.RenderSource @@ -108,6 +109,8 @@ import Vervis.Settings import Vervis.Web.Actor import Vervis.Widget.Tracker +import qualified Vervis.Recipient as VR + -- | Account verification email resend form getResendVerifyEmailR :: Handler Html getResendVerifyEmailR = do @@ -142,11 +145,11 @@ getHomeR = do E.where_ $ permit E.^. PermitPerson E.==. E.val pid E.orderBy [E.asc $ enable E.^. PermitTopicEnableLocalId] return - ( permit E.^. PermitId + ( enable E.^. PermitTopicEnableLocalPermit , permit E.^. PermitRole , topic E.^. PermitTopicLocalId ) - for ls $ \ (E.Value permitID, E.Value role, E.Value topicID) -> do + for ls $ \ (E.Value gestureID, E.Value role, E.Value topicID) -> do topic <- getPermitTopicLocal topicID actorID <- do ma <- getLocalActorEntity topic @@ -154,11 +157,23 @@ getHomeR = do Nothing -> error "Impossible, we should have found the local actor in DB" Just a -> pure $ localActorID a actor <- getJust actorID + delegator <- getKeyBy $ UniquePermitPersonSendDelegator gestureID + exts <- + case delegator of + Nothing -> pure [] + Just sendID -> do + topicHash <- VR.hashLocalActor topic + hashItem <- getEncodeKeyHashid + encodeRouteHome <- getEncodeRouteHome + map (encodeRouteHome . activityRoute topicHash . hashItem . permitTopicExtendLocalGrant . entityVal) <$> + selectList [PermitTopicExtendLocalPermit ==. sendID] [Asc PermitTopicExtendLocalId] return - ( permitID + ( gestureID , role + , delegator , localActorType topic , Left (topic, actor) + , exts ) remotes <- do rs <- E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do @@ -167,23 +182,34 @@ getHomeR = do E.where_ $ permit E.^. PermitPerson E.==. E.val pid E.orderBy [E.asc $ enable E.^. PermitTopicEnableRemoteId] return - ( permit E.^. PermitId + ( enable E.^. PermitTopicEnableRemotePermit , permit E.^. PermitRole , topic E.^. PermitTopicRemoteActor ) - for rs $ \ (E.Value permitID, E.Value role, E.Value remoteActorID) -> do + for rs $ \ (E.Value gestureID, E.Value role, E.Value remoteActorID) -> do remoteActor <- getJust remoteActorID remoteObject <- getJust $ remoteActorIdent remoteActor inztance <- getJust $ remoteObjectInstance remoteObject + delegator <- getKeyBy $ UniquePermitPersonSendDelegator gestureID + exts <- + case delegator of + Nothing -> pure [] + Just sendID -> do + es <- selectList [PermitTopicExtendRemotePermit ==. sendID] [Asc PermitTopicExtendRemoteId] + for es $ \ (Entity _ (PermitTopicExtendRemote _ _ grantID)) -> do + grant <- getJust grantID + getRemoteActivityURI grant return - ( permitID + ( gestureID , role + , delegator , remoteActorType remoteActor , Right (inztance, remoteObject, remoteActor) + , exts ) return $ locals ++ remotes let (people, repos, decks, looms, projects, groups, others) = - partitionByActorType (view _3) (view _1) permits + partitionByActorType (view _4) (view _1) permits if null people then pure () else error "Bug: Person as a PermitTopic" @@ -207,12 +233,22 @@ getHomeR = do x = deleteFirstsBy ((==) `on` key) xs (p ++ r ++ d ++ l ++ j ++ g) in (p, r, d, l, j, g, x) - item (_permitID, role, _typ, actor) = + item (_permitID, role, deleg, _typ, actor, exts) = [whamlet| - [ - #{show role} - ] - ^{actorLinkFedW actor} + + [ + #{show role} + ] # + $maybe _ <- deleg + \ [D] # + $nothing + \ [_] # + ^{actorLinkFedW actor} +