UI: For each Permit, display delegator-Grant and extensions
This commit is contained in:
parent
119779b9b3
commit
e65563cd19
1 changed files with 48 additions and 12 deletions
|
@ -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|
|
||||
<span>
|
||||
[
|
||||
#{show role}
|
||||
]
|
||||
] #
|
||||
$maybe _ <- deleg
|
||||
\ [D] #
|
||||
$nothing
|
||||
\ [_] #
|
||||
^{actorLinkFedW actor}
|
||||
<ul>
|
||||
$forall u <- exts
|
||||
<li>
|
||||
<a href="#{renderObjURI u}">
|
||||
#{renderObjURI u}
|
||||
|]
|
||||
|
||||
getBrowseR :: Handler Html
|
||||
|
|
Loading…
Reference in a new issue