UI: Personal Overview: Display info of received permits, not just the Grant URI

src/Vervis/Data/Actor.hs

@@ -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

src/Vervis/Handler/Client.hs

@@ -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
+                                    extIDs <-
-                                    map (encodeRouteHome . activityRoute topicHash . hashItem . permitTopicExtendLocalGrant  . entityVal) <$>
+                                        map (permitTopicExtendLocalGrant  . entityVal) <$>
-                                        selectList [PermitTopicExtendLocalPermit ==. sendID] [Asc PermitTopicExtendLocalId]
+                                            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
+                                    for es $ \ (Entity _ (PermitTopicExtendRemote _ _ extID)) -> do
-                                        grant <- getJust grantID
+                                        ext <- getJust extID
-                                        getRemoteActivityURI grant
+                                        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) =

src/Vervis/Persist/Actor.hs

@@ -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
+    :: MonadIO m
-    -> VA.ActDB (AP.Doc AP.Activity URIMode)
+    => 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

src/Vervis/Persist/Collab.hs

@@ -1032,8 +1032,9 @@ verifyNoEnabledGroupChildren groupID destDB = do
     verifyDestsNotEnabled destIDs
 
 getGrantActivityBody
-    :: Either OutboxItemId RemoteActivityId
+    :: MonadIO m
-    -> ActDB (AP.Doc AP.Activity URIMode, AP.Grant URIMode)
+    => 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