HomeR, *NewR: List grants from extensions, not just direct ones

src/Vervis/Field/Person.hs

@@ -22,10 +22,12 @@ module Vervis.Field.Person
 where
 
 import Control.Monad.Trans.Except
+import Data.Bitraversable
 import Data.Char (isDigit)
 import Data.Maybe
 import Data.Text (Text)
-import Database.Esqueleto
+import Data.Traversable
+import Database.Persist
 import Yesod.Core
 import Yesod.Form.Fields
 import Yesod.Form.Functions
@@ -43,16 +45,22 @@ import qualified Web.ActivityPub as AP
 
 import Control.Monad.Trans.Except.Local
 import Data.Char.Local (isAsciiLetter)
+import Database.Persist.Local
 
 import Vervis.Actor
 import Vervis.Data.Actor
+import Vervis.Data.Collab
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident (text2shr)
+import Vervis.Persist.Actor
+import Vervis.Persist.Collab
 import Vervis.Recipient
 import Vervis.Settings
 
+import qualified Vervis.Recipient as VR
+
 checkPassLength :: Field Handler Text -> Field Handler Text
 checkPassLength =
     let msg :: Text
@@ -108,54 +116,57 @@ capField = checkMMap toCap fst fedUriField
         runExceptT $ (u,) <$> nameExceptT "Capability URI" (parseActivityURI u)
 
 factoryField personID = selectField $ do
-    l <- runDB $ do
+    rows <- runDB $ do
-        local <-
+        resourceIDs <- map (factoryResource . entityVal) <$> selectList [] []
-            E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` factory `E.InnerJoin` resource `E.InnerJoin` actor) -> do
+        actorIDs <- selectKeysList [RemoteActorType ==. AP.ActorTypeFactory] []
-                E.on $ resource E.^. ResourceActor E.==. actor E.^. ActorId
+        permits <- getPermitsForResources personID (Just resourceIDs) (Just actorIDs) AP.RoleWrite
-                E.on $ factory E.^. FactoryResource E.==. resource E.^. ResourceId
+        for permits $ \ (resource, grant, _, _) -> do
-                E.on $ topic E.^. PermitTopicLocalTopic E.==. factory E.^. FactoryResource
+            factory <-
-                E.on $ topic E.^. PermitTopicLocalId E.==. enable E.^. PermitTopicEnableLocalTopic
+                bitraverse
-                E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicLocalPermit
+                    (\ resourceID -> do
-                E.where_ $
+                        Resource actorID <- getJust resourceID
-                    permit E.^. PermitPerson E.==. E.val personID E.&&.
+                        actor <- getJust actorID
-                    permit E.^. PermitRole `E.in_` E.valList [AP.RoleWrite, AP.RoleMaintain, AP.RoleAdmin]
+                        factoryID <- getKeyByJust $ UniqueFactory resourceID
-                return (factory E.^. FactoryId, actor E.^. ActorName, enable E.^. PermitTopicEnableLocalGrant)
+                        return (factoryID, actorName actor)
-        remote <-
+                    )
-            E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` actor `E.InnerJoin` object `E.InnerJoin` i `E.InnerJoin` ract `E.InnerJoin` ro) -> do
+                    (\ actorID -> do
-                E.on $ ract E.^. RemoteActivityIdent E.==. ro E.^. RemoteObjectId
+                        actor <- getJust actorID
-                E.on $ enable E.^. PermitTopicEnableRemoteGrant E.==. ract E.^. RemoteActivityId
+                        uActor <- getRemoteActorURI actor
-                E.on $ object E.^. RemoteObjectInstance E.==. i E.^. InstanceId
+                        return (uActor, remoteActorName actor)
-                E.on $ actor E.^. RemoteActorIdent E.==. object E.^. RemoteObjectId
+                    )
-                E.on $ topic E.^. PermitTopicRemoteActor E.==. actor E.^. RemoteActorId
+                    resource
-                E.on $ topic E.^. PermitTopicRemoteId E.==. enable E.^. PermitTopicEnableRemoteTopic
+            return (factory, grant)
-                E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicRemotePermit
+
-                E.where_ $
+    hashActor <- VR.getHashLocalActor
-                    permit E.^. PermitPerson E.==. E.val personID E.&&.
-                    actor E.^. RemoteActorType E.==. E.val AP.ActorTypeFactory E.&&.
-                    permit E.^. PermitRole `E.in_` E.valList [AP.RoleWrite, AP.RoleMaintain, AP.RoleAdmin]
-                return (i E.^. InstanceHost, object E.^. RemoteObjectIdent, actor E.^. RemoteActorName, ro E.^. RemoteObjectIdent)
-        return $ map Left local ++ map Right remote
     hashFactory <- getEncodeKeyHashid
     hashItem <- getEncodeKeyHashid
     encodeRouteHome <- getEncodeRouteHome
+    let renderGrant = \case
+            Left (byKey, grantID) ->
+                encodeRouteHome $ activityRoute (hashActor byKey) (hashItem grantID)
+            Right uGrant ->
+                uGrant
     optionsPairs $
-        map (\case
+        map (\ (factory, grant) ->
-                Left (E.Value factoryID, E.Value name, E.Value grantID) ->
+            case factory of
+                Left (factoryID, name) ->
                     ( T.concat
                         [ "*", keyHashidText $ hashFactory factoryID
                         , " ", name
                         ]
                     , ( encodeRouteHome $ FactoryR $ hashFactory factoryID
-                      , encodeRouteHome $ FactoryOutboxItemR (hashFactory factoryID) (hashItem grantID)
+                      , renderGrant grant
                       )
                     )
-                Right (E.Value h, E.Value lu, E.Value mname, E.Value luGrant) ->
+                Right (uActor@(ObjURI h lu), mname) ->
                     ( T.concat
                         [ renderObjURI $ ObjURI h lu
                         , " "
                         , fromMaybe "(?)" mname
                         ]
-                    , (ObjURI h lu, ObjURI h luGrant)
+                    , ( uActor
+                      , renderGrant grant
+                      )
                     )
             )
-        l
+        rows

src/Vervis/Handler/Client.hs

@@ -73,6 +73,7 @@ import Control.Monad.Trans.Except
 import Data.Aeson
 import Data.Bifunctor
 import Data.Bitraversable
+import Data.Foldable
 import Data.Function
 import Data.Maybe
 import Data.List
@@ -270,10 +271,39 @@ getHomeR = do
             , AP.grantContext g
             )
 
+    getVia extendID = do
+        sender <-
+            requireEitherAlt
+                (getValBy $ UniquePermitTopicExtendLocal extendID)
+                (getValBy $ UniquePermitTopicExtendRemote extendID)
+                "PermitTopicExtend* neither"
+                "PermitTopicExtend* both"
+        case sender of
+            Left (PermitTopicExtendLocal _ enableID grantID) -> do
+                PermitTopicEnableLocal _ topicID _ <- getJust enableID
+                byk <- getPermitTopicLocal topicID
+                bye <- do
+                    m <- getLocalResourceEntity byk
+                    case m of
+                        Nothing -> error "I just found this PermitTopicLocal in DB but now the specific actor ID isn't found"
+                        Just bye -> pure bye
+                Resource aid <- getJust $ localResourceID bye
+                a <- getJust aid
+                let byk' = resourceToActor byk
+                return $ Left (byk', a)
+            Right (PermitTopicExtendRemote _ enableID _) -> do
+                PermitTopicEnableRemote _ topicID _ <- getJust enableID
+                PermitTopicRemote _ remoteActorID <- getJust topicID
+                remoteActor <- getJust remoteActorID
+                remoteObject <- getJust $ remoteActorIdent remoteActor
+                inztance <- getJust $ remoteObjectInstance remoteObject
+                return $ Right (inztance, remoteObject, remoteActor)
+
     personalOverview :: Entity Person -> Handler Html
     personalOverview (Entity pid person) = do
         (permits, invites) <- runDB $ do
             permits <- do
+
                 locals <- do
                     ls <- E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do
                         E.on $ topic E.^. PermitTopicLocalId E.==. enable E.^. PermitTopicEnableLocalTopic
@@ -309,13 +339,37 @@ getHomeR = do
                                             , info
                                             )
                         return
-                            ( gestureID
+                            ( role
-                            , role
-                            , delegator
                             , localActorType topic
                             , Left (topic, actor)
-                            , exts
+                            , Left (delegator, exts)
                             )
+
+                localsExt <- do
+                    ls <- E.select $ E.from $ \ (permit `E.InnerJoin` gesture `E.InnerJoin` send `E.InnerJoin` extend `E.InnerJoin` resource) -> do
+                        E.on $ extend E.^. PermitTopicExtendId E.==. resource E.^. PermitTopicExtendResourceLocalPermit
+                        E.on $ send E.^. PermitPersonSendDelegatorId E.==. extend E.^. PermitTopicExtendPermit
+                        E.on $ gesture E.^. PermitPersonGestureId E.==. send E.^. PermitPersonSendDelegatorPermit
+                        E.on $ permit E.^. PermitId E.==. gesture E.^. PermitPersonGesturePermit
+                        E.where_ $ permit E.^. PermitPerson E.==. E.val pid
+                        return
+                            ( resource E.^. PermitTopicExtendResourceLocalResource
+                            , permit E.^. PermitId
+                            , extend E.^. PermitTopicExtendId
+                            , extend E.^. PermitTopicExtendRole
+                            )
+                    for ls $ \ (E.Value resourceID, E.Value permitID, E.Value extendID, E.Value role) -> do
+                        Resource actorID <- getJust resourceID
+                        actor <- getJust actorID
+                        topic <- resourceToActor <$> getLocalResource resourceID
+                        via <- getVia extendID
+                        return
+                            ( role
+                            , localActorType topic
+                            , Left (topic, actor)
+                            , Right via
+                            )
+
                 remotes <- do
                     rs <- E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do
                         E.on $ topic E.^. PermitTopicRemoteId E.==. enable E.^. PermitTopicEnableRemoteTopic
@@ -344,14 +398,39 @@ getHomeR = do
                                         info <- getExtInfo $ Right extID
                                         return (u, info)
                         return
-                            ( gestureID
+                            ( role
-                            , role
-                            , delegator
                             , remoteActorType remoteActor
                             , Right (inztance, remoteObject, remoteActor)
-                            , exts
+                            , Left (delegator, exts)
                             )
-                return $ locals ++ remotes
+
+                remotesExt <- do
+                    rs <- E.select $ E.from $ \ (permit `E.InnerJoin` gesture `E.InnerJoin` send `E.InnerJoin` extend `E.InnerJoin` resource) -> do
+                        E.on $ extend E.^. PermitTopicExtendId E.==. resource E.^. PermitTopicExtendResourceRemotePermit
+                        E.on $ send E.^. PermitPersonSendDelegatorId E.==. extend E.^. PermitTopicExtendPermit
+                        E.on $ gesture E.^. PermitPersonGestureId E.==. send E.^. PermitPersonSendDelegatorPermit
+                        E.on $ permit E.^. PermitId E.==. gesture E.^. PermitPersonGesturePermit
+                        E.where_ $ permit E.^. PermitPerson E.==. E.val pid
+                        return
+                            ( resource E.^. PermitTopicExtendResourceRemoteActor
+                            , permit E.^. PermitId
+                            , extend E.^. PermitTopicExtendId
+                            , extend E.^. PermitTopicExtendRole
+                            )
+                    for rs $ \ (E.Value remoteActorID, E.Value permitID, E.Value extendID, E.Value role) -> do
+                        remoteActor <- getJust remoteActorID
+                        remoteObject <- getJust $ remoteActorIdent remoteActor
+                        inztance <- getJust $ remoteObjectInstance remoteObject
+                        via <- getVia extendID
+                        return
+                            ( role
+                            , remoteActorType remoteActor
+                            , Right (inztance, remoteObject, remoteActor)
+                            , Right via
+                            )
+
+                return $ locals ++ localsExt ++ remotes ++ remotesExt
+
             invites <- do
                 locals <- do
                     ls <- E.select $ E.from $ \ (permit `E.InnerJoin` fulfills `E.InnerJoin` topic `E.LeftOuterJoin` enable `E.LeftOuterJoin` valid `E.LeftOuterJoin` accept) -> do
@@ -418,8 +497,9 @@ getHomeR = do
                             )
                 return $ sortOn (view _1) $ locals ++ remotes
             return (permits, invites)
-        let (people, repos, decks, looms, projects, groups, factories, others) =
+        let grabU (i, ro, _ra) = (instanceHost i, remoteObjectIdent ro)
-                partitionByActorType (view _4) (view _1) permits
+            (people, repos, decks, looms, projects, groups, factories, others) =
+                partitionByActorType (view _2) (bimap fst grabU . view _3) permits
         if null people
             then pure ()
             else error "Bug: Person as a PermitTopic"
@@ -447,7 +527,7 @@ getHomeR = do
                 x = deleteFirstsBy ((==) `on` key) xs (p ++ r ++ d ++ l ++ j ++ g ++ f)
             in  (p, r, d, l, j, g, f, x)
 
-        item (_gestureID, role, deleg, _typ, actor, exts) =
+        item (role, _typ, actor, Left (deleg, exts)) =
             [whamlet|
                 <span>
                   [
@@ -475,6 +555,16 @@ getHomeR = do
                         $of Right t
                           [ ^{actorLinkFedW t} ]
             |]
+        item (role, _typ, actor, Right via) =
+            [whamlet|
+                <span>
+                  [
+                  #{show role}
+                  ] #
+                  ^{actorLinkFedW actor}
+                  \ via #
+                  ^{actorLinkFedW via}
+            |]
 
         invite (_fulfillsID, role, valid, accept, fulfillsHash, actor) =
             [whamlet|

src/Vervis/Persist/Collab.hs

@@ -56,6 +56,7 @@ module Vervis.Persist.Collab
     , getGrantActivityBody
 
     , getPermitsForResource
+    , getPermitsForResources
     , getCapability
 
     , getStems
@@ -1322,6 +1323,136 @@ getPermitsForResource personID actor = do
             return (uExt, role, Just via)
     return $ directsFinal ++ extsFinal
 
+getPermitsForResources
+    :: MonadIO m
+    => PersonId
+    -> Maybe [ResourceId]
+    -> Maybe [RemoteActorId]
+    -> AP.Role
+    -> ReaderT SqlBackend m
+        [ ( Either ResourceId RemoteActorId
+          , Either (LocalActorBy Key, OutboxItemId) FedURI
+          , AP.Role
+          , Maybe
+                (Either
+                    (LocalActorBy Key, Actor)
+                    (Instance, RemoteObject, RemoteActor)
+                )
+          )
+        ]
+getPermitsForResources personID localTopics remoteTopics minRole = do
+
+    directsLocal <-
+        E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do
+            E.on $ topic E.^. PermitTopicLocalId E.==. enable E.^. PermitTopicEnableLocalTopic
+            E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicLocalPermit
+            E.where_ $
+                permit E.^. PermitPerson E.==. E.val personID E.&&.
+                permit E.^. PermitRole `E.in_` E.valList [minRole .. maxBound]
+            for_ localTopics $ \ ids ->
+                E.where_ $ topic E.^. PermitTopicLocalTopic `E.in_` E.valList ids
+            return
+                ( topic E.^. PermitTopicLocalTopic
+                , permit E.^. PermitRole
+                , enable E.^. PermitTopicEnableLocalGrant
+                )
+    directsRemote <-
+        E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do
+            E.on $ topic E.^. PermitTopicRemoteId E.==. enable E.^. PermitTopicEnableRemoteTopic
+            E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicRemotePermit
+            E.where_ $
+                permit E.^. PermitPerson E.==. E.val personID E.&&.
+                permit E.^. PermitRole `E.in_` E.valList [minRole .. maxBound]
+            for_ remoteTopics $ \ ids ->
+                E.where_ $ topic E.^. PermitTopicRemoteActor `E.in_` E.valList ids
+            return
+                ( topic E.^. PermitTopicRemoteActor
+                , permit E.^. PermitRole
+                , enable E.^. PermitTopicEnableRemoteGrant
+                )
+
+    directsLocalFinal <-
+        for directsLocal $ \ (E.Value resourceID, E.Value role, E.Value grantID) -> do
+            lr <- getLocalResource resourceID
+            let la = resourceToActor lr
+            return (Left resourceID, Left (la, grantID), role, Nothing)
+    directsRemoteFinal <-
+        for directsRemote $ \ (E.Value actorID, E.Value role, E.Value grantID) -> do
+            grant <- getJust grantID
+            u <- getRemoteActivityURI grant
+            return (Right actorID, Right u, role, Nothing)
+
+    extsLocal <-
+        fmap (map $ over _1 Left) $
+        E.select $ E.from $ \ (permit `E.InnerJoin` gesture `E.InnerJoin` send `E.InnerJoin` extend `E.InnerJoin` resource) -> do
+            E.on $ extend E.^. PermitTopicExtendId E.==. resource E.^. PermitTopicExtendResourceLocalPermit
+            E.on $ send E.^. PermitPersonSendDelegatorId E.==. extend E.^. PermitTopicExtendPermit
+            E.on $ gesture E.^. PermitPersonGestureId E.==. send E.^. PermitPersonSendDelegatorPermit
+            E.on $ permit E.^. PermitId E.==. gesture E.^. PermitPersonGesturePermit
+            E.where_ $
+                permit E.^. PermitPerson E.==. E.val personID E.&&.
+                extend E.^. PermitTopicExtendRole `E.in_` E.valList [minRole .. maxBound]
+            for_ localTopics $ \ ids ->
+                E.where_ $ resource E.^. PermitTopicExtendResourceLocalResource `E.in_` E.valList ids
+            return
+                ( resource E.^. PermitTopicExtendResourceLocalResource
+                , permit E.^. PermitId
+                , extend E.^. PermitTopicExtendId
+                , extend E.^. PermitTopicExtendRole
+                )
+    extsRemote <-
+        fmap (map $ over _1 Right) $
+        E.select $ E.from $ \ (permit `E.InnerJoin` gesture `E.InnerJoin` send `E.InnerJoin` extend `E.InnerJoin` resource) -> do
+            E.on $ extend E.^. PermitTopicExtendId E.==. resource E.^. PermitTopicExtendResourceRemotePermit
+            E.on $ send E.^. PermitPersonSendDelegatorId E.==. extend E.^. PermitTopicExtendPermit
+            E.on $ gesture E.^. PermitPersonGestureId E.==. send E.^. PermitPersonSendDelegatorPermit
+            E.on $ permit E.^. PermitId E.==. gesture E.^. PermitPersonGesturePermit
+            E.where_ $
+                permit E.^. PermitPerson E.==. E.val personID E.&&.
+                extend E.^. PermitTopicExtendRole `E.in_` E.valList [minRole .. maxBound]
+            for_ remoteTopics $ \ ids ->
+                E.where_ $ resource E.^. PermitTopicExtendResourceRemoteActor `E.in_` E.valList ids
+            return
+                ( resource E.^. PermitTopicExtendResourceRemoteActor
+                , permit E.^. PermitId
+                , extend E.^. PermitTopicExtendId
+                , extend E.^. PermitTopicExtendRole
+                )
+    extsFinal <-
+        for (extsLocal ++ extsRemote) $ \ (resource, E.Value permitID, E.Value extendID, E.Value role) -> do
+            sender <-
+                requireEitherAlt
+                    (getValBy $ UniquePermitTopicExtendLocal extendID)
+                    (getValBy $ UniquePermitTopicExtendRemote extendID)
+                    "PermitTopicExtend* neither"
+                    "PermitTopicExtend* both"
+            (uExt, via) <-
+                case sender of
+                    Left (PermitTopicExtendLocal _ enableID grantID) -> do
+                        PermitTopicEnableLocal _ topicID _ <- getJust enableID
+                        byk <- getPermitTopicLocal topicID
+                        bye <- do
+                            m <- getLocalResourceEntity byk
+                            case m of
+                                Nothing -> error "I just found this PermitTopicLocal in DB but now the specific actor ID isn't found"
+                                Just bye -> pure bye
+                        rid <- grabLocalResourceID bye
+                        Resource aid <- getJust rid
+                        a <- getJust aid
+                        let byk' = resourceToActor byk
+                        return (Left (byk', grantID), Left (byk', a))
+                    Right (PermitTopicExtendRemote _ enableID grantID) -> do
+                        PermitTopicEnableRemote _ topicID _ <- getJust enableID
+                        PermitTopicRemote _ remoteActorID <- getJust topicID
+                        remoteActor <- getJust remoteActorID
+                        remoteObject <- getJust $ remoteActorIdent remoteActor
+                        inztance <- getJust $ remoteObjectInstance remoteObject
+                        grant <- getJust grantID
+                        u <- getRemoteActivityURI grant
+                        return (Right u, Right (inztance, remoteObject, remoteActor))
+            return (bimap E.unValue E.unValue resource, uExt, role, Just via)
+    return $ directsLocalFinal ++ directsRemoteFinal ++ extsFinal
+
 getCapability
     :: MonadIO m
     => PersonId