forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Group: Implement Create handler, sending back an admin-Grant

Browse source
This commit is contained in:
Pere Lev 2023-11-21 16:52:16 +02:00
parent ea7476db9d
commit 8d543c0016
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
9 changed files with 120 additions and 26 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
migrations/551_2023-11-21_group_collab.model Normal file
View file

@ -0,0 +1,5 @@
CollabTopicGroup
collab CollabId
group GroupId
UniqueCollabTopicGroup collab

3
src/Vervis/API.hs
View file

@ -175,6 +175,9 @@ verifyResourceAddressed localRecips resource = do
verify (GrantResourceProject r) = do
routes <- lookup r $ recipProjects localRecips
guard $ routeProject routes
verify (GrantResourceGroup r) = do
routes <- lookup r $ recipGroups localRecips
guard $ routeGroup routes
verifyRemoteAddressed
:: Monad m => [(Host, NonEmpty LocalURI)] -> FedURI -> ExceptT Text m ()

70
src/Vervis/Actor/Group.hs
View file

@ -18,43 +18,109 @@ module Vervis.Actor.Group
)
where
import Control.Applicative
import Control.Exception.Base
import Control.Monad
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.Barbie
import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import Data.ByteString (ByteString)
import Data.Either
import Data.Foldable
import Data.Maybe
import Data.Text (Text)
import Data.Time.Clock
import Data.Traversable
import Database.Persist
import Database.Persist.Sql
import Optics.Core
import Yesod.Persist.Core
import qualified Data.Text as T
import qualified Database.Esqueleto as E
import Control.Concurrent.Actor
import Network.FedURI
import Web.Actor
import Web.Actor.Persist
import Yesod.MonadSite
import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local
import Data.Either.Local
import Database.Persist.Local
import Vervis.Access
import Vervis.ActivityPub
import Vervis.Actor
import Vervis.Actor.Common
import Vervis.Actor2
import Vervis.Cloth
import Vervis.Data.Actor
import Vervis.Data.Collab
import Vervis.Data.Discussion
import Vervis.FedURI
import Vervis.Federation.Util
import Vervis.Foundation
import Vervis.Model
import Vervis.Model hiding (groupCreate)
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
import Vervis.RemoteActorStore
import Vervis.Persist.Actor
import Vervis.Persist.Collab
import Vervis.Persist.Discussion
import Vervis.Ticket
-- Meaning: Someone has created a group with my ID URI
-- Behavior:
-- * Verify I'm in a just-been-created state
-- * Verify my creator and the Create sender are the same actor
-- * Create an admin Collab record in DB
-- * Send an admin Grant to the creator
-- * Get out of the just-been-created state
groupCreateMe
:: UTCTime
-> GroupId
-> Verse
-> ActE (Text, Act (), Next)
groupCreateMe =
topicCreateMe
groupActor GrantResourceGroup
CollabTopicGroupGroup CollabTopicGroup
groupCreate
:: UTCTime
-> GroupId
-> Verse
-> AP.Create URIMode
-> ActE (Text, Act (), Next)
groupCreate now groupID verse (AP.Create obj _muTarget) =
case obj of
AP.CreateTeam _ mlocal -> do
(h, local) <- fromMaybeE mlocal "No group id provided"
let luGroup = AP.actorId local
uMe <- do
groupHash <- encodeKeyHashid groupID
encodeRouteHome <- getEncodeRouteHome
return $ encodeRouteHome $ GroupR groupHash
unless (uMe == ObjURI h luGroup) $
throwE "The created group id isn't me"
groupCreateMe now groupID verse
_ -> throwE "Unsupported Create object for Group"
groupBehavior :: UTCTime -> GroupId -> VerseExt -> ActE (Text, Act (), Next)
groupBehavior now groupID (Left _verse@(Verse _authorIdMsig body)) =
groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) =
case AP.activitySpecific $ actbActivity body of
AP.CreateActivity create -> groupCreate now groupID verse create
_ -> throwE "Unsupported activity type for Group"
groupBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Group"

5
src/Vervis/Actor/Person/Client.hs
View file

@ -98,6 +98,9 @@ verifyResourceAddressed localRecips resource = do
verify (GrantResourceProject r) = do
routes <- lookup r $ recipProjects localRecips
guard $ routeProject routes
verify (GrantResourceGroup r) = do
routes <- lookup r $ recipGroups localRecips
guard $ routeGroup routes
verifyProjectAddressed localRecips projectID = do
projectHash <- encodeKeyHashid projectID
@ -1131,6 +1134,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
Left (GrantResourceProject l) -> Just $ LocalActorProject l
Left (GrantResourceGroup l) -> Just $ LocalActorGroup l
Right _ -> Nothing
, case recipientHash of
Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
@ -1143,6 +1147,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l
Left (GrantResourceGroup l) -> Just $ LocalStageGroupFollowers l
Right _ -> Nothing
, case recipientHash of
Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p

4
src/Vervis/Client.hs
View file

@ -1144,6 +1144,8 @@ invite personID uRecipient uResourceCollabs role = do
AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
Left (GrantResourceProject l) ->
AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
Left (GrantResourceGroup l) ->
AudLocal [LocalActorGroup l] [LocalStageGroupFollowers l]
Right (remoteActor, ObjURI h lu) ->
AudRemote h
[lu]
@ -1259,6 +1261,8 @@ remove personID uRecipient uResourceCollabs = do
AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
Left (GrantResourceProject l) ->
AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
Left (GrantResourceGroup l) ->
AudLocal [LocalActorGroup l] [LocalStageGroupFollowers l]
Right (remoteActor, ObjURI h lu) ->
AudRemote h
[lu]

16
src/Vervis/Data/Collab.hs
View file

@ -455,13 +455,15 @@ grantResourceActorID :: GrantResourceBy Identity -> ActorId
grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r
grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d
grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l
grantResourceActorID (GrantResourceProject (Identity l)) = projectActor l
grantResourceActorID (GrantResourceProject (Identity j)) = projectActor j
grantResourceActorID (GrantResourceGroup (Identity g)) = groupActor g
data GrantResourceBy f
= GrantResourceRepo (f Repo)
| GrantResourceDeck (f Deck)
| GrantResourceLoom (f Loom)
| GrantResourceProject (f Project)
| GrantResourceGroup (f Group)
deriving (Generic, FunctorB, TraversableB, ConstraintsB)
deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f)
@ -476,6 +478,8 @@ unhashGrantResourcePure ctx = f
GrantResourceLoom <$> decodeKeyHashidPure ctx l
f (GrantResourceProject l) =
GrantResourceProject <$> decodeKeyHashidPure ctx l
f (GrantResourceGroup l) =
GrantResourceGroup <$> decodeKeyHashidPure ctx l
unhashGrantResource resource = do
ctx <- asksSite siteHashidsContext
@ -501,6 +505,8 @@ hashGrantResource (GrantResourceLoom k) =
GrantResourceLoom <$> encodeKeyHashid k
hashGrantResource (GrantResourceProject k) =
GrantResourceProject <$> encodeKeyHashid k
hashGrantResource (GrantResourceGroup k) =
GrantResourceGroup <$> encodeKeyHashid k
hashGrantResource' (GrantResourceRepo k) =
GrantResourceRepo <$> WAP.encodeKeyHashid k
@ -510,6 +516,8 @@ hashGrantResource' (GrantResourceLoom k) =
GrantResourceLoom <$> WAP.encodeKeyHashid k
hashGrantResource' (GrantResourceProject k) =
GrantResourceProject <$> WAP.encodeKeyHashid k
hashGrantResource' (GrantResourceGroup k) =
GrantResourceGroup <$> WAP.encodeKeyHashid k
getGrantResource (GrantResourceRepo k) e =
GrantResourceRepo <$> getEntityE k e
@ -519,6 +527,8 @@ getGrantResource (GrantResourceLoom k) e =
GrantResourceLoom <$> getEntityE k e
getGrantResource (GrantResourceProject k) e =
GrantResourceProject <$> getEntityE k e
getGrantResource (GrantResourceGroup k) e =
GrantResourceGroup <$> getEntityE k e
getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
where
@ -530,12 +540,15 @@ getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
fmap GrantResourceLoom <$> getEntity k
getGrantResourceEntity (GrantResourceProject k) =
fmap GrantResourceProject <$> getEntity k
getGrantResourceEntity (GrantResourceGroup k) =
fmap GrantResourceGroup <$> getEntity k
grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f
grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r
grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d
grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l
grantResourceLocalActor (GrantResourceProject l) = LocalActorProject l
grantResourceLocalActor (GrantResourceGroup l) = LocalActorGroup l
data ComponentBy f
= ComponentRepo (f Repo)
@ -578,6 +591,7 @@ resourceToComponent = \case
GrantResourceDeck k -> Just $ ComponentDeck k
GrantResourceLoom k -> Just $ ComponentLoom k
GrantResourceProject _ -> Nothing
GrantResourceGroup _ -> Nothing
data GrantRecipBy' f
= GrantRecipPerson' (f Person)

4
src/Vervis/Migration/Entities.hs
View file

@ -64,6 +64,7 @@ module Vervis.Migration.Entities
, model_531_follow_request
, model_541_project
, model_542_component
, model_551_group_collab
)
where
@ -248,3 +249,6 @@ model_541_project = $(schema "541_2023-06-26_project")
model_542_component :: [Entity SqlBackend]
model_542_component = $(schema "542_2023-06-26_component")
model_551_group_collab :: [Entity SqlBackend]
model_551_group_collab = $(schema "551_2023-11-21_group_collab")

33
src/Vervis/Persist/Collab.hs
View file

@ -71,23 +71,7 @@ import Vervis.Persist.Actor
getCollabTopic
:: MonadIO m => CollabId -> ReaderT SqlBackend m (GrantResourceBy Key)
getCollabTopic collabID = do
maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
maybeProject <- getValBy $ UniqueCollabTopicProject collabID
return $
case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of
(Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
(Just r, Nothing, Nothing, Nothing) ->
GrantResourceRepo $ collabTopicRepoRepo r
(Nothing, Just d, Nothing, Nothing) ->
GrantResourceDeck $ collabTopicDeckDeck d
(Nothing, Nothing, Just l, Nothing) ->
GrantResourceLoom $ collabTopicLoomLoom l
(Nothing, Nothing, Nothing, Just l) ->
GrantResourceProject $ collabTopicProjectProject l
_ -> error "Found Collab with multiple topics"
getCollabTopic = fmap snd . getCollabTopic'
getCollabTopic'
:: MonadIO m => CollabId -> ReaderT SqlBackend m (ReaderT SqlBackend m (), GrantResourceBy Key)
@ -96,17 +80,20 @@ getCollabTopic' collabID = do
maybeDeck <- getBy $ UniqueCollabTopicDeck collabID
maybeLoom <- getBy $ UniqueCollabTopicLoom collabID
maybeProject <- getBy $ UniqueCollabTopicProject collabID
maybeGroup <- getBy $ UniqueCollabTopicGroup collabID
return $
case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of
(Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
(Just (Entity k r), Nothing, Nothing, Nothing) ->
case (maybeRepo, maybeDeck, maybeLoom, maybeProject, maybeGroup) of
(Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
(Just (Entity k r), Nothing, Nothing, Nothing, Nothing) ->
(delete k, GrantResourceRepo $ collabTopicRepoRepo r)
(Nothing, Just (Entity k d), Nothing, Nothing) ->
(Nothing, Just (Entity k d), Nothing, Nothing, Nothing) ->
(delete k, GrantResourceDeck $ collabTopicDeckDeck d)
(Nothing, Nothing, Just (Entity k l), Nothing) ->
(Nothing, Nothing, Just (Entity k l), Nothing, Nothing) ->
(delete k, GrantResourceLoom $ collabTopicLoomLoom l)
(Nothing, Nothing, Nothing, Just (Entity k l)) ->
(Nothing, Nothing, Nothing, Just (Entity k l), Nothing) ->
(delete k, GrantResourceProject $ collabTopicProjectProject l)
(Nothing, Nothing, Nothing, Nothing, Just (Entity k l)) ->
(delete k, GrantResourceGroup $ collabTopicGroupGroup l)
_ -> error "Found Collab with multiple topics"
getStemIdent :: MonadIO m => StemId -> ReaderT SqlBackend m (ComponentBy Key)

6
th/models
View file

@ -676,6 +676,12 @@ CollabTopicProject
UniqueCollabTopicProject collab
CollabTopicGroup
collab CollabId
group GroupId
UniqueCollabTopicGroup collab
CollabEnable
collab CollabId
grant OutboxItemId