From a03968ca0bb1cf4eaa7b29d53539f7b6888e9dd3 Mon Sep 17 00:00:00 2001
From: Pere Lev <pere@towards.vision>
Date: Thu, 8 Aug 2024 13:08:18 +0300
Subject: [PATCH] HomeR, *NewR: List grants from extensions, not just direct
ones
---
src/Vervis/Field/Person.hs | 79 ++++++++++++---------
src/Vervis/Handler/Client.hs | 114 ++++++++++++++++++++++++++----
src/Vervis/Persist/Collab.hs | 131 +++++++++++++++++++++++++++++++++++
3 files changed, 278 insertions(+), 46 deletions(-)
diff --git a/src/Vervis/Field/Person.hs b/src/Vervis/Field/Person.hs
index b54ccb0..4415da5 100644
--- a/src/Vervis/Field/Person.hs
+++ b/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
- local <-
- E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` factory `E.InnerJoin` resource `E.InnerJoin` actor) -> do
- E.on $ resource E.^. ResourceActor E.==. actor E.^. ActorId
- E.on $ factory E.^. FactoryResource E.==. resource E.^. ResourceId
- E.on $ topic E.^. PermitTopicLocalTopic E.==. factory E.^. FactoryResource
- 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 [AP.RoleWrite, AP.RoleMaintain, AP.RoleAdmin]
- return (factory E.^. FactoryId, actor E.^. ActorName, enable E.^. PermitTopicEnableLocalGrant)
- 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
- E.on $ ract E.^. RemoteActivityIdent E.==. ro E.^. RemoteObjectId
- E.on $ enable E.^. PermitTopicEnableRemoteGrant E.==. ract E.^. RemoteActivityId
- E.on $ object E.^. RemoteObjectInstance E.==. i E.^. InstanceId
- E.on $ actor E.^. RemoteActorIdent E.==. object E.^. RemoteObjectId
- E.on $ topic E.^. PermitTopicRemoteActor E.==. actor E.^. RemoteActorId
- 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.&&.
- 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
+ rows <- runDB $ do
+ resourceIDs <- map (factoryResource . entityVal) <$> selectList [] []
+ actorIDs <- selectKeysList [RemoteActorType ==. AP.ActorTypeFactory] []
+ permits <- getPermitsForResources personID (Just resourceIDs) (Just actorIDs) AP.RoleWrite
+ for permits $ \ (resource, grant, _, _) -> do
+ factory <-
+ bitraverse
+ (\ resourceID -> do
+ Resource actorID <- getJust resourceID
+ actor <- getJust actorID
+ factoryID <- getKeyByJust $ UniqueFactory resourceID
+ return (factoryID, actorName actor)
+ )
+ (\ actorID -> do
+ actor <- getJust actorID
+ uActor <- getRemoteActorURI actor
+ return (uActor, remoteActorName actor)
+ )
+ resource
+ return (factory, grant)
+
+ hashActor <- VR.getHashLocalActor
hashFactory <- getEncodeKeyHashid
hashItem <- getEncodeKeyHashid
encodeRouteHome <- getEncodeRouteHome
+ let renderGrant = \case
+ Left (byKey, grantID) ->
+ encodeRouteHome $ activityRoute (hashActor byKey) (hashItem grantID)
+ Right uGrant ->
+ uGrant
optionsPairs $
- map (\case
- Left (E.Value factoryID, E.Value name, E.Value grantID) ->
+ map (\ (factory, grant) ->
+ 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
diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs
index 1e6c79a..d15c166 100644
--- a/src/Vervis/Handler/Client.hs
+++ b/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
- , delegator
+ ( role
, 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
- , delegator
+ ( role
, 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) =
- partitionByActorType (view _4) (view _1) permits
+ let grabU (i, ro, _ra) = (instanceHost i, remoteObjectIdent ro)
+ (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|
diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs
index 0590dc6..4db8752 100644
--- a/src/Vervis/Persist/Collab.hs
+++ b/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