forge/Vervis
1
0
Fork 0
Code Pull requests Activity

UI: For each Permit, display delegator-Grant and extensions

Browse source
This commit is contained in:
Pere Lev 2023-12-09 07:58:16 +02:00
parent 119779b9b3
commit e65563cd19
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
1 changed files with 48 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

60
src/Vervis/Handler/Client.hs
View file

@ -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}
<span>
[
#{show role}
] #
$maybe _ <- deleg
\ [D] #
$nothing
\ [_] #
^{actorLinkFedW actor}
<ul>
$forall u <- exts
<li>
<a href="#{renderObjURI u}">
#{renderObjURI u}
|]
getBrowseR :: Handler Html