UI: Personal Overview: Display info of received permits, not just the Grant URI
This commit is contained in:
Pere Lev
parent
68a3fcd7c8
commit
dae57c394d
4 changed files with 99 additions and 14 deletions
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -26,6 +26,8 @@ module Vervis.Data.Actor
|
|||
, parseFedURIOld
|
||||
, parseLocalActorE
|
||||
, parseLocalActorE'
|
||||
, parseActorURI
|
||||
, parseActorURI'
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -35,6 +37,7 @@ import Control.Monad
|
|||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Logger.CallStack
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Bitraversable
|
||||
import Data.Text (Text)
|
||||
import Database.Persist.Types
|
||||
import UnliftIO.Exception (try, SomeException, displayException)
|
||||
|
|
@ -186,7 +189,9 @@ parseFedURIOld u@(ObjURI h lu) = do
|
|||
then Left <$> parseLocalURI lu
|
||||
else pure $ Right u
|
||||
|
||||
parseLocalActorE :: Route App -> ExceptT Text Handler (LocalActorBy Key)
|
||||
parseLocalActorE
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
=> Route App -> ExceptT Text m (LocalActorBy Key)
|
||||
parseLocalActorE route = do
|
||||
actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route"
|
||||
unhashLocalActorE actorByHash "Invalid actor keyhashid"
|
||||
|
|
@ -195,3 +200,22 @@ parseLocalActorE' :: Route App -> VA.ActE (LocalActorBy Key)
|
|||
parseLocalActorE' route = do
|
||||
actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route"
|
||||
VA.unhashLocalActorE actorByHash "Invalid actor keyhashid"
|
||||
|
||||
parseActorURI
|
||||
:: (MonadSite m, SiteEnv m ~ App)
|
||||
=> FedURI
|
||||
-> ExceptT Text m (Either (LocalActorBy Key) FedURI)
|
||||
parseActorURI u = do
|
||||
routeOrRemote <- parseFedURIOld u
|
||||
bitraverse
|
||||
parseLocalActorE
|
||||
pure
|
||||
routeOrRemote
|
||||
|
||||
parseActorURI' :: FedURI -> VA.ActE (Either (LocalActorBy Key) FedURI)
|
||||
parseActorURI' u = do
|
||||
routeOrRemote <- parseFedURI u
|
||||
bitraverse
|
||||
parseLocalActorE'
|
||||
pure
|
||||
routeOrRemote
|
||||
|
|
|
|||
|
|
@ -145,7 +145,30 @@ getHomeR = do
|
|||
case mp of
|
||||
Just p -> personalOverview p
|
||||
Nothing -> redirect BrowseR
|
||||
|
||||
where
|
||||
|
||||
getExtInfo extID = do
|
||||
(_doc, g) <- getGrantActivityBody extID
|
||||
topicE <- runExceptT $ do
|
||||
a <- parseActorURI $ AP.grantContext g
|
||||
bitraverse
|
||||
(\ byK -> do
|
||||
byE <- getLocalActorEntityE byK "No such local actor in DB"
|
||||
actor <- lift $ getJust $ localActorID byE
|
||||
return (byK, actor)
|
||||
)
|
||||
(\ u ->
|
||||
over _3 entityVal <$>
|
||||
getRemoteActorE u "No such RemoteActor in DB"
|
||||
)
|
||||
a
|
||||
return
|
||||
( AP.grantObject g
|
||||
, topicE
|
||||
, AP.grantContext g
|
||||
)
|
||||
|
||||
personalOverview :: Entity Person -> Handler Html
|
||||
personalOverview (Entity pid _person) = do
|
||||
(permits, invites) <- runDB $ do
|
||||
|
|
@ -161,6 +184,7 @@ getHomeR = do
|
|||
, permit E.^. PermitRole
|
||||
, topic E.^. PermitTopicLocalId
|
||||
)
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
for ls $ \ (E.Value gestureID, E.Value role, E.Value topicID) -> do
|
||||
topic <- getPermitTopicLocal topicID
|
||||
actorID <- do
|
||||
|
|
@ -176,9 +200,15 @@ getHomeR = do
|
|||
Just sendID -> do
|
||||
topicHash <- VR.hashLocalActor topic
|
||||
hashItem <- getEncodeKeyHashid
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
map (encodeRouteHome . activityRoute topicHash . hashItem . permitTopicExtendLocalGrant . entityVal) <$>
|
||||
selectList [PermitTopicExtendLocalPermit ==. sendID] [Asc PermitTopicExtendLocalId]
|
||||
extIDs <-
|
||||
map (permitTopicExtendLocalGrant . entityVal) <$>
|
||||
selectList [PermitTopicExtendLocalPermit ==. sendID] [Asc PermitTopicExtendLocalId]
|
||||
for extIDs $ \ extID -> do
|
||||
info <- getExtInfo $ Left extID
|
||||
return
|
||||
( encodeRouteHome $ activityRoute topicHash $ hashItem extID
|
||||
, info
|
||||
)
|
||||
return
|
||||
( gestureID
|
||||
, role
|
||||
|
|
@ -208,9 +238,11 @@ getHomeR = do
|
|||
Nothing -> pure []
|
||||
Just sendID -> do
|
||||
es <- selectList [PermitTopicExtendRemotePermit ==. sendID] [Asc PermitTopicExtendRemoteId]
|
||||
for es $ \ (Entity _ (PermitTopicExtendRemote _ _ grantID)) -> do
|
||||
grant <- getJust grantID
|
||||
getRemoteActivityURI grant
|
||||
for es $ \ (Entity _ (PermitTopicExtendRemote _ _ extID)) -> do
|
||||
ext <- getJust extID
|
||||
u <- getRemoteActivityURI ext
|
||||
info <- getExtInfo $ Right extID
|
||||
return (u, info)
|
||||
return
|
||||
( gestureID
|
||||
, role
|
||||
|
|
@ -326,10 +358,21 @@ getHomeR = do
|
|||
\ [_] #
|
||||
^{actorLinkFedW actor}
|
||||
<ul>
|
||||
$forall u <- exts
|
||||
$forall (u, (roleExt, topicE, uTopic)) <- exts
|
||||
<li>
|
||||
<a href="#{renderObjURI u}">
|
||||
#{renderObjURI u}
|
||||
Grant
|
||||
$case roleExt
|
||||
$of AP.RXRole role
|
||||
[ #{show role} ] #
|
||||
$of AP.RXDelegator
|
||||
[? Delegator ?] #
|
||||
\ in #
|
||||
$case topicE
|
||||
$of Left _
|
||||
[? #{renderObjURI uTopic} ?]
|
||||
$of Right t
|
||||
[ ^{actorLinkFedW t} ]
|
||||
|]
|
||||
|
||||
invite (_fulfillsID, role, valid, accept, fulfillsHash, actor) =
|
||||
|
|
|
|||
|
|
@ -29,6 +29,9 @@ module Vervis.Persist.Actor
|
|||
, fillPerActorKeys
|
||||
, getPersonWidgetInfo
|
||||
, getActivityBody
|
||||
, getRemoteActor
|
||||
, getRemoteActorM
|
||||
, getRemoteActorE
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -37,6 +40,7 @@ import Control.Monad.IO.Class
|
|||
import Control.Monad.Logger.CallStack
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Aeson
|
||||
import Data.Barbie
|
||||
|
|
@ -237,8 +241,9 @@ getPersonWidgetInfo = bitraverse getLocal getRemote
|
|||
return (inztance, remoteObject, remoteActor)
|
||||
|
||||
getActivityBody
|
||||
:: Either OutboxItemId RemoteActivityId
|
||||
-> VA.ActDB (AP.Doc AP.Activity URIMode)
|
||||
:: MonadIO m
|
||||
=> Either OutboxItemId RemoteActivityId
|
||||
-> ReaderT SqlBackend m (AP.Doc AP.Activity URIMode)
|
||||
getActivityBody k = do
|
||||
obj <-
|
||||
persistJSONDoc <$>
|
||||
|
|
@ -248,3 +253,15 @@ getActivityBody k = do
|
|||
case fromJSON $ Object obj of
|
||||
Error s -> error $ "Parsing activity " ++ show k ++ " failed: " ++ s
|
||||
Success doc -> return doc
|
||||
|
||||
getRemoteActor = runMaybeT . getRemoteActorM
|
||||
|
||||
getRemoteActorM (ObjURI h lu) = do
|
||||
Entity instanceID inztance <- MaybeT $ getBy $ UniqueInstance h
|
||||
Entity objectID object <- MaybeT $ getBy $ UniqueRemoteObject instanceID lu
|
||||
actor <- MaybeT $ getBy $ UniqueRemoteActor objectID
|
||||
return (inztance, object, actor)
|
||||
|
||||
getRemoteActorE u e = do
|
||||
ma <- lift $ getRemoteActor u
|
||||
fromMaybeE ma e
|
||||
|
|
|
|||
|
|
@ -1032,8 +1032,9 @@ verifyNoEnabledGroupChildren groupID destDB = do
|
|||
verifyDestsNotEnabled destIDs
|
||||
|
||||
getGrantActivityBody
|
||||
:: Either OutboxItemId RemoteActivityId
|
||||
-> ActDB (AP.Doc AP.Activity URIMode, AP.Grant URIMode)
|
||||
:: MonadIO m
|
||||
=> Either OutboxItemId RemoteActivityId
|
||||
-> ReaderT SqlBackend m (AP.Doc AP.Activity URIMode, AP.Grant URIMode)
|
||||
getGrantActivityBody k = do
|
||||
doc@(AP.Doc _ act) <- getActivityBody k
|
||||
case AP.activitySpecific act of
|
||||
|
|
|
|||
Loading…
Reference in a new issue