diff --git a/src/Control/Concurrent/Actor.hs b/src/Control/Concurrent/Actor.hs
index 0c28e37..65c3b5f 100644
--- a/src/Control/Concurrent/Actor.hs
+++ b/src/Control/Concurrent/Actor.hs
@@ -17,6 +17,7 @@ module Control.Concurrent.Actor
( Stage (..)
, TheaterFor ()
, ActFor ()
+ , runActor
, MonadActor (..)
, asksEnv
, Next ()
diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs
index e5cf13f..14636a8 100644
--- a/src/Vervis/API.hs
+++ b/src/Vervis/API.hs
@@ -17,7 +17,8 @@
{-# LANGUAGE DeriveGeneric #-}
module Vervis.API
- ( acceptC
+ ( handleViaActor
+ , acceptC
--, addBundleC
, applyC
--, noteC
@@ -26,7 +27,6 @@ module Vervis.API
, createRepositoryC
, createTicketTrackerC
, followC
- , inviteC
, offerTicketC
--, offerDepC
, resolveC
@@ -74,9 +74,11 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
+import Control.Concurrent.Actor
import Database.Persist.JSON
import Development.PatchMediaType
import Network.FedURI
+import Text.Read (readMaybe)
import Web.ActivityPub hiding (Patch (..), Ticket, Follow, Repo (..), ActorLocal (..), ActorDetail (..), Actor (..))
import Web.Text
import Yesod.ActivityPub
@@ -95,8 +97,8 @@ import qualified Data.Git.Local as G (createRepo)
import qualified Data.Text.UTF8.Local as TU
import qualified Darcs.Local.Repository as D (createRepo)
-import Vervis.Access
import Vervis.ActivityPub
+import Vervis.Actor hiding (hashLocalActor)
import Vervis.Cloth
import Vervis.Darcs
import Vervis.Data.Actor
@@ -127,6 +129,33 @@ import Vervis.Ticket
import Vervis.Web.Delivery
import Vervis.Web.Repo
+handleViaActor
+ :: PersonId
+ -> Maybe
+ (Either
+ (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
+ FedURI
+ )
+ -> RecipientRoutes
+ -> [(Host, NonEmpty LocalURI)]
+ -> [Host]
+ -> AP.Action URIMode
+ -> ExceptT Text Handler OutboxItemId
+handleViaActor personID maybeCap localRecips remoteRecips fwdHosts action = do
+ theater <- asksSite appTheater
+ let maybeCap' = first (\ (byKey, _, i) -> (byKey, i)) <$> maybeCap
+ msg = ClientMsg maybeCap' localRecips remoteRecips fwdHosts action
+ maybeResult <-
+ liftIO $ callIO theater (LocalActorPerson personID) (Right msg)
+ itemText <-
+ case maybeResult of
+ Nothing -> error "Person not found in theater"
+ Just (Left e) -> throwE e
+ Just (Right t) -> return t
+ case readMaybe $ T.unpack itemText of
+ Nothing -> error "read itemText failed"
+ Just outboxItemID -> return outboxItemID
+
verifyResourceAddressed
:: (MonadSite m, YesodHashids (SiteEnv m))
=> RecipientRoutes -> GrantResourceBy Key -> ExceptT Text m ()
@@ -1838,237 +1867,6 @@ followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
}
}
--- Meaning: The human wants to invite someone A to a resource R
--- Behavior:
--- * Some basic sanity checks
--- * Parse the Invite
--- * Make sure not inviting myself
--- * Verify that a capability is specified
--- * If resource is local, verify it exists in DB
--- * Verify the target A and resource R are addressed in the Invite
--- * Insert Invite to my inbox
--- * Asynchrnously:
--- * Deliver a request to the resource
--- * Deliver a notification to the target
--- * Deliver a notification to my followers
-inviteC
- :: Entity Person
- -> Actor
- -> Maybe
- (Either
- (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
- FedURI
- )
- -> RecipientRoutes
- -> [(Host, NonEmpty LocalURI)]
- -> [Host]
- -> AP.Action URIMode
- -> AP.Invite URIMode
- -> ExceptT Text Handler OutboxItemId
-inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action invite = do
- error "Disabled for actor refactoring"
-{-
- -- Check input
- (resource, recipient) <- parseInvite (Left senderPersonID) invite
- _capID <- fromMaybeE maybeCap "No capability provided"
-
- -- If resource is remote, HTTP GET it and its managing actor, and insert to
- -- our DB. If resource is local, find it in our DB.
- resourceDB <-
- bitraverse
- (runDBExcept . flip getGrantResource "Grant context not found in DB")
- (\ u@(ObjURI h lu) -> do
- instanceID <-
- lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
- result <-
- ExceptT $ first (T.pack . show) <$>
- fetchRemoteResource instanceID h lu
- case result of
- Left (Entity actorID actor) ->
- return (remoteActorIdent actor, actorID, u)
- Right (objectID, luManager, (Entity actorID _)) ->
- return (objectID, actorID, ObjURI h luManager)
- )
- resource
-
- -- If recipient is remote, HTTP GET it, make sure it's an actor, and insert
- -- it to our DB. If recipient is local, find it in our DB.
- recipientDB <-
- bitraverse
- (runDBExcept . flip getGrantRecip "Grant recipient not found in DB")
- (\ u@(ObjURI h lu) -> do
- instanceID <-
- lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
- result <-
- ExceptT $ first (T.pack . displayException) <$>
- fetchRemoteActor' instanceID h lu
- case result of
- Left Nothing -> throwE "Recipient @id mismatch"
- Left (Just err) -> throwE $ T.pack $ displayException err
- Right Nothing -> throwE "Recipient isn't an actor"
- Right (Just actor) -> return (entityKey actor, u)
- )
- recipient
-
- -- Verify that resource and recipient are addressed by the Invite
- bitraverse_
- (verifyResourceAddressed localRecips . bmap entityKey)
- (\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
- resourceDB
- bitraverse_
- (verifyRecipientAddressed localRecips . bmap entityKey)
- (verifyRemoteAddressed remoteRecips . snd)
- recipientDB
-
- now <- liftIO getCurrentTime
- senderHash <- encodeKeyHashid senderPersonID
-
- ? <- withDBExcept $ do
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- (obiidInvite, deliverHttpInvite) <- runDBExcept $ do
-
- -- Insert the Invite activity to author's outbox
- inviteID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
- _luInvite <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) inviteID action
-
- -- Deliver the Invite activity to local recipients, and schedule
- -- delivery for unavailable remote recipients
- deliverHttpInvite <- do
- sieve <- do
- resourceHash <- bitraverse hashGrantResource pure resource
- recipientHash <- bitraverse hashGrantRecip pure recipient
- let sieveActors = catMaybes
- [ case resourceHash of
- Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
- Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
- Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
- Right _ -> Nothing
- , case recipientHash of
- Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
- Right _ -> Nothing
- ]
- sieveStages = catMaybes
- [ Just $ LocalStagePersonFollowers senderHash
- , case resourceHash of
- Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
- Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
- Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
- Right _ -> Nothing
- , case recipientHash of
- Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p
- Right _ -> Nothing
- ]
- return $ makeRecipientSet sieveActors sieveStages
- let localRecipsFinal = localRecipSieve sieve False localRecips
- deliverActivityDB
- (LocalActorPerson senderHash) (personActor senderPerson)
- localRecipsFinal remoteRecips fwdHosts inviteID action
-
- -- If resource is local, verify it has received the Grant
- case resourceDB of
- Left localResource -> do
- let resourceActorID =
- case localResource of
- GrantResourceRepo (Entity _ r) -> repoActor r
- GrantResourceDeck (Entity _ d) -> deckActor d
- GrantResourceLoom (Entity _ l) -> loomActor l
- verifyActorHasItem resourceActorID inviteID "Local topic didn't receive the Invite"
- Right _ -> pure ()
-
- -- If recipient is local, verify it has received the invite
- case recipientDB of
- Left (GrantRecipPerson (Entity _ p)) ->
- verifyActorHasItem (personActor p) inviteID "Local recipient didn't receive the Invite"
- Right _ -> pure ()
-
- -- Return instructions for HTTP delivery to remote recipients
- return (inviteID, deliverHttpInvite)
-
-
-
-
-
-
- -- Notify the resource
-
-
-
-
-
-
-
-
-
-
- -- Launch asynchronous HTTP delivery of the Grant activity
- lift $ do
- forkWorker "inviteC: async HTTP Grant delivery" deliverHttpInvite
-
- return obiidInvite
-
- where
-
- fetchRemoteResource instanceID host localURI = do
- maybeActor <- withDB $ runMaybeT $ do
- roid <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID localURI
- MaybeT $ getBy $ UniqueRemoteActor roid
- case maybeActor of
- Just actor -> return $ Right $ Left actor
- Nothing -> do
- manager <- asksEnv getHttpManager
- errorOrResource <- fetchResource manager host localURI
- case errorOrResource of
- Left maybeError ->
- return $ Left $ maybe ResultIdMismatch ResultGetError maybeError
- Right resource -> do
- case resource of
- ResourceActor (AP.Actor local detail) -> withDB $ do
- roid <- either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
- let ra = RemoteActor
- { remoteActorIdent = roid
- , remoteActorName =
- AP.actorName detail <|> AP.actorUsername detail
- , remoteActorInbox = AP.actorInbox local
- , remoteActorFollowers = AP.actorFollowers local
- , remoteActorErrorSince = Nothing
- }
- Right . Left . either id id <$> insertByEntity' ra
- ResourceChild luId luManager -> do
- roid <- withDB $ either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
- result <- fetchRemoteActor' instanceID host luManager
- return $
- case result of
- Left e -> Left $ ResultSomeException e
- Right (Left Nothing) -> Left ResultIdMismatch
- Right (Left (Just e)) -> Left $ ResultGetError e
- Right (Right Nothing) -> Left ResultNotActor
- Right (Right (Just actor)) -> Right $ Right (roid, luManager, actor)
-
- verifyRecipientAddressed localRecips recipient = do
- recipientHash <- hashGrantRecip recipient
- fromMaybeE (verify recipientHash) "Recipient not addressed"
- where
- verify (GrantRecipPerson p) = do
- routes <- lookup p $ recipPeople localRecips
- guard $ routePerson routes
-
- hashGrantRecip (GrantRecipPerson k) =
- GrantRecipPerson <$> encodeKeyHashid k
--}
-
offerTicketC
:: Entity Person
-> Actor
diff --git a/src/Vervis/Access.hs b/src/Vervis/Access.hs
index ca1a757..111b731 100644
--- a/src/Vervis/Access.hs
+++ b/src/Vervis/Access.hs
@@ -13,11 +13,6 @@
- .
-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-- | In this module I'd like to collect all the operation access checks. When a
-- given user asks to perform a certain operation, do we accept the request and
-- perform the changes to our database etc.? The functions here should provide
@@ -62,22 +57,6 @@ module Vervis.Access
, checkRepoAccess'
, checkRepoAccess
, checkProjectAccess
-
- , GrantResourceBy (..)
- , unhashGrantResourcePure
- , unhashGrantResource
- , unhashGrantResourceE
- , unhashGrantResource'
- , unhashGrantResourceE'
- , unhashGrantResource404
- , hashGrantResource
- , getGrantResource
- , getGrantResource404
-
- , grantResourceLocalActor
-
- , verifyCapability
- , verifyCapability'
)
where
@@ -107,6 +86,8 @@ import Web.Actor.Persist (stageHashidsContext)
import Yesod.Hashids
import Yesod.MonadSite
+import qualified Web.Actor.Persist as WAP
+
import Control.Monad.Trans.Except.Local
import Data.Either.Local
import Database.Persist.Local
@@ -269,142 +250,3 @@ checkProjectAccess mpid op deckHash = do
return $ topic E.^. CollabTopicDeckCollab
asUser = fmap RoleID . deckCollabUser
asAnon = fmap RoleID . deckCollabAnon
-
-data GrantResourceBy f
- = GrantResourceRepo (f Repo)
- | GrantResourceDeck (f Deck)
- | GrantResourceLoom (f Loom)
- deriving (Generic, FunctorB, TraversableB, ConstraintsB)
-
-deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f)
-
-unhashGrantResourcePure ctx = f
- where
- f (GrantResourceRepo r) =
- GrantResourceRepo <$> decodeKeyHashidPure ctx r
- f (GrantResourceDeck d) =
- GrantResourceDeck <$> decodeKeyHashidPure ctx d
- f (GrantResourceLoom l) =
- GrantResourceLoom <$> decodeKeyHashidPure ctx l
-
-unhashGrantResource resource = do
- ctx <- asksSite siteHashidsContext
- return $ unhashGrantResourcePure ctx resource
-
-unhashGrantResourceE resource e =
- ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource
-
-unhashGrantResource' resource = do
- ctx <- asksEnv stageHashidsContext
- return $ unhashGrantResourcePure ctx resource
-
-unhashGrantResourceE' resource e =
- ExceptT $ maybe (Left e) Right <$> unhashGrantResource' resource
-
-unhashGrantResource404 = maybe notFound return <=< unhashGrantResource
-
-hashGrantResource (GrantResourceRepo k) =
- GrantResourceRepo <$> encodeKeyHashid k
-hashGrantResource (GrantResourceDeck k) =
- GrantResourceDeck <$> encodeKeyHashid k
-hashGrantResource (GrantResourceLoom k) =
- GrantResourceLoom <$> encodeKeyHashid k
-
-getGrantResource (GrantResourceRepo k) e =
- GrantResourceRepo <$> getEntityE k e
-getGrantResource (GrantResourceDeck k) e =
- GrantResourceDeck <$> getEntityE k e
-getGrantResource (GrantResourceLoom k) e =
- GrantResourceLoom <$> getEntityE k e
-
-getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
- where
- getGrantResourceEntity (GrantResourceRepo k) =
- fmap GrantResourceRepo <$> getEntity k
- getGrantResourceEntity (GrantResourceDeck k) =
- fmap GrantResourceDeck <$> getEntity k
- getGrantResourceEntity (GrantResourceLoom k) =
- fmap GrantResourceLoom <$> getEntity k
-
-grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f
-grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r
-grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d
-grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l
-
-verifyCapability
- :: MonadIO m
- => (LocalActorBy Key, OutboxItemId)
- -> Either PersonId RemoteActorId
- -> GrantResourceBy Key
- -> ExceptT Text (ReaderT SqlBackend m) ()
-verifyCapability (capActor, capItem) actor resource = do
-
- -- Find the activity itself by URI in the DB
- nameExceptT "Capability activity not found" $
- verifyLocalActivityExistsInDB capActor capItem
-
- -- Find the Collab record for that activity
- collabID <- do
- maybeEnable <- lift $ getValBy $ UniqueCollabEnableGrant capItem
- collabEnableCollab <$>
- fromMaybeE maybeEnable "No CollabEnable for this activity"
-
- -- Find the recipient of that Collab
- recipID <-
- lift $ bimap collabRecipLocalPerson collabRecipRemoteActor <$>
- requireEitherAlt
- (getValBy $ UniqueCollabRecipLocal collabID)
- (getValBy $ UniqueCollabRecipRemote collabID)
- "No collab recip"
- "Both local and remote recips for collab"
-
- -- Verify the recipient is the expected one
- unless (recipID == actor) $
- throwE "Collab recipient is someone else"
-
- -- Find the local topic, on which this Collab gives access
- topic <- lift $ do
- maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
- maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
- maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
- case (maybeRepo, maybeDeck, maybeLoom) of
- (Nothing, Nothing, Nothing) -> error "Collab without topic"
- (Just r, Nothing, Nothing) ->
- return $ GrantResourceRepo $ collabTopicRepoRepo r
- (Nothing, Just d, Nothing) ->
- return $ GrantResourceDeck $ collabTopicDeckDeck d
- (Nothing, Nothing, Just l) ->
- return $ GrantResourceLoom $ collabTopicLoomLoom l
- _ -> error "Collab with multiple topics"
-
- -- Verify that topic is indeed the sender of the Grant
- unless (grantResourceLocalActor topic == capActor) $
- error "Grant sender isn't the topic"
-
- -- Verify the topic matches the resource specified
- unless (topic == resource) $
- throwE "Capability topic is some other local resource"
-
- -- Since there are currently no roles, and grants allow only the "Admin"
- -- role that supports every operation, we don't need to check role access
- return ()
-
-verifyCapability'
- :: MonadIO m
- => (LocalActorBy Key, OutboxItemId)
- -> Either
- (LocalActorBy Key, ActorId, OutboxItemId)
- (RemoteAuthor, LocalURI, Maybe ByteString)
- -> GrantResourceBy Key
- -> ExceptT Text (ReaderT SqlBackend m) ()
-verifyCapability' cap actor resource = do
- actorP <- processActor actor
- verifyCapability cap actorP resource
- where
- processActor = bitraverse processLocal processRemote
- where
- processLocal (actorByKey, _, _) =
- case actorByKey of
- LocalActorPerson personID -> return personID
- _ -> throwE "Non-person local actors can't get Grants at the moment"
- processRemote (author, _, _) = pure $ remoteAuthorId author
diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs
index c75ac3c..a78cd47 100644
--- a/src/Vervis/Actor.hs
+++ b/src/Vervis/Actor.hs
@@ -300,11 +300,11 @@ data Verse = Verse
}
data ClientMsg = ClientMsg
- { _cmMaybeCap :: Maybe (Either (LocalActorBy Key, OutboxItemId) FedURI)
- , _cmLocalRecips :: RecipientRoutes
- , _cmRemoteRecips :: [(Host, NonEmpty LocalURI)]
- , _cmFwdHosts :: [Host]
- , _cmAction :: AP.Action URIMode
+ { cmMaybeCap :: Maybe (Either (LocalActorBy Key, OutboxItemId) FedURI)
+ , cmLocalRecips :: RecipientRoutes
+ , cmRemoteRecips :: [(Host, NonEmpty LocalURI)]
+ , cmFwdHosts :: [Host]
+ , cmAction :: AP.Action URIMode
}
type VerseExt = Either Verse ClientMsg
diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs
index 5a28ca5..4b6ef88 100644
--- a/src/Vervis/Actor/Person/Client.hs
+++ b/src/Vervis/Actor/Person/Client.hs
@@ -18,23 +18,37 @@ module Vervis.Actor.Person.Client
)
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.Foldable
+import Data.List.NonEmpty (NonEmpty)
+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 Control.Concurrent.Actor
import Network.FedURI
+import Web.Actor
+import Web.Actor.Persist
import Yesod.MonadSite
import qualified Web.ActivityPub as AP
@@ -42,15 +56,183 @@ import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local
import Database.Persist.Local
+import Vervis.Access
+import Vervis.ActivityPub
import Vervis.Actor
+import Vervis.Actor2
import Vervis.Cloth
+import Vervis.Data.Actor
+import Vervis.Data.Collab
import Vervis.Data.Discussion
+import Vervis.Data.Follow
import Vervis.FedURI
-import Vervis.Federation.Util
+import Vervis.Fetch
import Vervis.Foundation
import Vervis.Model
+import Vervis.Persist.Actor
+import Vervis.Persist.Collab
import Vervis.Persist.Discussion
+import Vervis.Persist.Follow
+import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localRecipSieve)
+import Vervis.RemoteActorStore
import Vervis.Ticket
+verifyResourceAddressed :: RecipientRoutes -> GrantResourceBy Key -> ActE ()
+verifyResourceAddressed localRecips resource = do
+ resourceHash <- hashGrantResource' resource
+ fromMaybeE (verify resourceHash) "Local resource not addressed"
+ where
+ verify (GrantResourceRepo r) = do
+ routes <- lookup r $ recipRepos localRecips
+ guard $ routeRepo routes
+ verify (GrantResourceDeck d) = do
+ routes <- lookup d $ recipDecks localRecips
+ guard $ routeDeck $ familyDeck routes
+ verify (GrantResourceLoom l) = do
+ routes <- lookup l $ recipLooms localRecips
+ guard $ routeLoom $ familyLoom routes
+
+verifyRecipientAddressed localRecips recipient = do
+ recipientHash <- hashGrantRecip recipient
+ fromMaybeE (verify recipientHash) "Recipient not addressed"
+ where
+ verify (GrantRecipPerson p) = do
+ routes <- lookup p $ recipPeople localRecips
+ guard $ routePerson routes
+
+verifyRemoteAddressed :: [(Host, NonEmpty LocalURI)] -> FedURI -> ActE ()
+verifyRemoteAddressed remoteRecips u =
+ fromMaybeE (verify u) "Given remote entity not addressed"
+ where
+ verify (ObjURI h lu) = do
+ lus <- lookup h remoteRecips
+ guard $ lu `elem` lus
+
+-- Meaning: The human wants to invite someone A to a resource R
+-- Behavior:
+-- * Some basic sanity checks
+-- * Parse the Invite
+-- * Make sure not inviting myself
+-- * Verify that a capability is specified
+-- * If resource is local, verify it exists in DB
+-- * Verify the target A and resource R are addressed in the Invite
+-- * Insert Invite to my inbox
+-- * Asynchrnously deliver to:
+-- * Resource+followers
+-- * Target+followers
+-- * My followers
+clientInvite
+ :: UTCTime
+ -> PersonId
+ -> ClientMsg
+ -> AP.Invite URIMode
+ -> ActE OutboxItemId
+clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) invite = do
+
+ -- Check input
+ (resource, recipient) <- parseInvite (Left $ LocalActorPerson personMeID) invite
+ _capID <- fromMaybeE maybeCap "No capability provided"
+
+ -- If resource is remote, HTTP GET it and its managing actor, and insert to
+ -- our DB. If resource is local, find it in our DB.
+ resourceDB <-
+ bitraverse
+ (withDBExcept . flip getGrantResource "Grant context not found in DB")
+ (\ u@(ObjURI h lu) -> do
+ instanceID <-
+ lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+ result <-
+ ExceptT $ first (T.pack . show) <$>
+ fetchRemoteResource instanceID h lu
+ case result of
+ Left (Entity actorID actor) ->
+ return (remoteActorIdent actor, actorID, u)
+ Right (objectID, luManager, (Entity actorID _)) ->
+ return (objectID, actorID, ObjURI h luManager)
+ )
+ resource
+
+ -- If recipient is remote, HTTP GET it, make sure it's an actor, and insert
+ -- it to our DB. If recipient is local, find it in our DB.
+ recipientDB <-
+ bitraverse
+ (withDBExcept . flip getGrantRecip "Grant recipient not found in DB")
+ (\ u@(ObjURI h lu) -> do
+ instanceID <-
+ lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+ result <-
+ ExceptT $ first (T.pack . displayException) <$>
+ fetchRemoteActor' instanceID h lu
+ case result of
+ Left Nothing -> throwE "Recipient @id mismatch"
+ Left (Just err) -> throwE $ T.pack $ displayException err
+ Right Nothing -> throwE "Recipient isn't an actor"
+ Right (Just actor) -> return (entityKey actor, u)
+ )
+ recipient
+
+ -- Verify that resource and recipient are addressed by the Invite
+ bitraverse_
+ (verifyResourceAddressed localRecips . bmap entityKey)
+ (\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
+ resourceDB
+ bitraverse_
+ (verifyRecipientAddressed localRecips . bmap entityKey)
+ (verifyRemoteAddressed remoteRecips . snd)
+ recipientDB
+
+ (actorMeID, localRecipsFinal, inviteID) <- withDBExcept $ do
+
+ -- Grab me from DB
+ (personMe, actorMe) <- lift $ do
+ p <- getJust personMeID
+ (p,) <$> getJust (personActor p)
+
+ -- Insert the Invite activity to my outbox
+ inviteID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
+ _luInvite <- lift $ updateOutboxItem' (LocalActorPerson personMeID) inviteID action
+
+ -- Prepare local recipients for Invite delivery
+ sieve <- lift $ do
+ resourceHash <- bitraverse hashGrantResource' pure resource
+ recipientHash <- bitraverse hashGrantRecip pure recipient
+ senderHash <- encodeKeyHashid personMeID
+ let sieveActors = catMaybes
+ [ case resourceHash of
+ Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
+ Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
+ Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
+ Right _ -> Nothing
+ , case recipientHash of
+ Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
+ Right _ -> Nothing
+ ]
+ sieveStages = catMaybes
+ [ Just $ LocalStagePersonFollowers senderHash
+ , case resourceHash of
+ Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
+ Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
+ Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
+ Right _ -> Nothing
+ , case recipientHash of
+ Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p
+ Right _ -> Nothing
+ ]
+ return $ makeRecipientSet sieveActors sieveStages
+ return
+ ( personActor personMe
+ , localRecipSieve sieve False localRecips
+ , inviteID
+ )
+
+ lift $ sendActivity
+ (LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips
+ fwdHosts inviteID action
+ return inviteID
+
clientBehavior :: UTCTime -> PersonId -> ClientMsg -> ActE (Text, Act (), Next)
-clientBehavior _ _ _ = throwE "ClientMsg handlers coming soon!"
+clientBehavior now personID msg =
+ done . T.pack . show =<<
+ case AP.actionSpecific $ cmAction msg of
+ AP.InviteActivity invite -> clientInvite now personID msg invite
+ _ -> throwE "Unsupported activity type for C2S"
diff --git a/src/Vervis/Actor2.hs b/src/Vervis/Actor2.hs
index ce0f2e0..f93cbe3 100644
--- a/src/Vervis/Actor2.hs
+++ b/src/Vervis/Actor2.hs
@@ -28,13 +28,20 @@ module Vervis.Actor2
, makeAudSenderWithFollowers
, getActivityURI
, getActorURI
+ -- * Running actor pieces in Handler
+ , runAct
+ , runActE
+ -- * Fetching remote objects
+ , fetchRemoteResource
)
where
+import Control.Applicative
import Control.Concurrent.STM.TVar
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
import Data.Barbie
import Data.Bifunctor
import Data.ByteString (ByteString)
@@ -49,7 +56,7 @@ import Data.Traversable
import Data.Typeable
import Database.Persist.Sql
import GHC.Generics
-import UnliftIO.Exception
+import UnliftIO.Exception hiding (Handler)
import Web.Hashids
import qualified Data.Aeson as A
@@ -65,15 +72,19 @@ import Web.Actor.Deliver
import Web.Actor.Persist
import qualified Web.ActivityPub as AP
+import qualified Yesod.MonadSite as YM
import Control.Monad.Trans.Except.Local
+import Database.Persist.Local
import Vervis.Actor
import Vervis.Data.Actor
import Vervis.FedURI
+import Vervis.Fetch
import Vervis.Foundation
import Vervis.Model hiding (Actor, Message)
import Vervis.Recipient (renderLocalActor, localRecipSieve', localActorFollowers, Aud (..), ParsedAudience (..), parseAudience')
+import Vervis.RemoteActorStore
import Vervis.Settings
askLatestInstanceKey :: Act (Maybe (Route App, ActorKey))
@@ -372,3 +383,48 @@ getActorURI (Left (actorByKey, _, _)) = do
actorByHash <- hashLocalActor actorByKey
return $ encodeRouteHome $ renderLocalActor actorByHash
getActorURI (Right (author, _, _)) = pure $ remoteAuthorURI author
+
+runAct :: Act a -> Handler a
+runAct act = do
+ theater <- YM.asksSite appTheater
+ env <- YM.asksSite appEnv
+ liftIO $ runActor theater env act
+
+runActE :: ActE a -> ExceptT Text Handler a
+runActE (ExceptT act) = ExceptT $ runAct act
+
+fetchRemoteResource instanceID host localURI = do
+ maybeActor <- withDB $ runMaybeT $ do
+ roid <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID localURI
+ MaybeT $ getBy $ UniqueRemoteActor roid
+ case maybeActor of
+ Just actor -> return $ Right $ Left actor
+ Nothing -> do
+ manager <- asksEnv envHttpManager
+ errorOrResource <- AP.fetchResource manager host localURI
+ case errorOrResource of
+ Left maybeError ->
+ return $ Left $ maybe ResultIdMismatch ResultGetError maybeError
+ Right resource -> do
+ case resource of
+ AP.ResourceActor (AP.Actor local detail) -> withDB $ do
+ roid <- either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
+ let ra = RemoteActor
+ { remoteActorIdent = roid
+ , remoteActorName =
+ AP.actorName detail <|> AP.actorUsername detail
+ , remoteActorInbox = AP.actorInbox local
+ , remoteActorFollowers = AP.actorFollowers local
+ , remoteActorErrorSince = Nothing
+ }
+ Right . Left . either id id <$> insertByEntity' ra
+ AP.ResourceChild luId luManager -> do
+ roid <- withDB $ either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
+ result <- fetchRemoteActor' instanceID host luManager
+ return $
+ case result of
+ Left e -> Left $ ResultSomeException e
+ Right (Left Nothing) -> Left ResultIdMismatch
+ Right (Left (Just e)) -> Left $ ResultGetError e
+ Right (Right Nothing) -> Left ResultNotActor
+ Right (Right (Just actor)) -> Right $ Right (roid, luManager, actor)
diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs
index 280364d..ab9083b 100644
--- a/src/Vervis/Client.hs
+++ b/src/Vervis/Client.hs
@@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- - Written in 2019, 2020, 2022 by fr33domlover .
+ - Written in 2019, 2020, 2022, 2023 by fr33domlover .
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@@ -37,6 +37,7 @@ module Vervis.Client
, createDeck
, createLoom
, createRepo
+ , invite
)
where
@@ -78,7 +79,10 @@ import Data.Either.Local
import Database.Persist.Local
import Vervis.ActivityPub
+import Vervis.Actor
+import Vervis.Actor2
import Vervis.Cloth
+import Vervis.Data.Collab
import Vervis.Data.Ticket
import Vervis.FedURI
import Vervis.Foundation
@@ -943,3 +947,84 @@ createRepo senderHash name desc = do
}
return (Nothing, audience, detail)
+
+invite
+ :: PersonId
+ -> FedURI
+ -> FedURI
+ -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Invite URIMode)
+invite personID uRecipient uResource = do
+
+ theater <- asksSite appTheater
+ env <- asksSite appEnv
+
+ let activity = AP.Invite (Left RoleAdmin) uRecipient uResource
+ (resource, recipient) <-
+ runActE $ parseInvite (Left $ LocalActorPerson personID) activity
+
+ -- If resource is remote, we need to get it from DB/HTTP to determine its
+ -- managing actor & followers collection
+ resourceDB <-
+ bitraverse
+ hashGrantResource
+ (\ u@(ObjURI h lu) -> do
+ instanceID <-
+ lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
+ result <-
+ ExceptT $ first (T.pack . show) <$>
+ runAct (fetchRemoteResource instanceID h lu)
+ case result of
+ Left (Entity _ actor) ->
+ return (actor, u)
+ Right (_objectID, luManager, (Entity _ actor)) ->
+ return (actor, ObjURI h luManager)
+ )
+ resource
+
+ -- If target is remote, get it via HTTP/DB to determine its followers
+ -- collection
+ recipientDB <-
+ bitraverse
+ (runActE . hashGrantRecip)
+ (\ u@(ObjURI h lu) -> do
+ instanceID <-
+ lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
+ result <-
+ ExceptT $ first (T.pack . displayException) <$>
+ fetchRemoteActor instanceID h lu
+ case result of
+ Left Nothing -> throwE "Recipient @id mismatch"
+ Left (Just err) -> throwE $ T.pack $ displayException err
+ Right Nothing -> throwE "Recipient isn't an actor"
+ Right (Just actor) -> return (entityVal actor, u)
+ )
+ recipient
+
+ senderHash <- encodeKeyHashid personID
+
+ let audResource =
+ case resourceDB of
+ Left (GrantResourceRepo r) ->
+ AudLocal [LocalActorRepo r] [LocalStageRepoFollowers r]
+ Left (GrantResourceDeck d) ->
+ AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
+ Left (GrantResourceLoom l) ->
+ AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
+ Right (remoteActor, ObjURI h lu) ->
+ AudRemote h
+ [lu]
+ (maybeToList $ remoteActorFollowers remoteActor)
+ audRecipient =
+ case recipientDB of
+ Left (GrantRecipPerson p) ->
+ AudLocal [] [LocalStagePersonFollowers p]
+ Right (remoteActor, ObjURI h lu) ->
+ AudRemote h
+ [lu]
+ (maybeToList $ remoteActorFollowers remoteActor)
+ audAuthor =
+ AudLocal [] [LocalStagePersonFollowers senderHash]
+
+ audience = [audResource, audRecipient, audAuthor]
+
+ return (Nothing, audience, activity)
diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs
index 0209753..f8b09a7 100644
--- a/src/Vervis/Data/Collab.hs
+++ b/src/Vervis/Data/Collab.hs
@@ -20,6 +20,7 @@
module Vervis.Data.Collab
( GrantRecipBy (..)
+ , hashGrantRecip
, parseInvite
, parseJoin
@@ -28,6 +29,20 @@ module Vervis.Data.Collab
, parseReject
, grantResourceActorID
+
+ , GrantResourceBy (..)
+ , unhashGrantResourcePure
+ , unhashGrantResource
+ , unhashGrantResourceE
+ , unhashGrantResource'
+ , unhashGrantResourceE'
+ , unhashGrantResource404
+ , hashGrantResource
+ , hashGrantResource'
+ , getGrantResource
+ , getGrantResource404
+
+ , grantResourceLocalActor
)
where
@@ -38,14 +53,15 @@ import Data.Bifunctor
import Data.Bitraversable
import Data.Functor.Identity
import Data.Text (Text)
+import Database.Persist
import Database.Persist.Types
import GHC.Generics
+import Yesod.Core
import Control.Concurrent.Actor
import Data.Time.Clock
import Network.FedURI
import Web.Actor
-import Web.Actor.Persist
import Yesod.ActivityPub
import Yesod.Actor
import Yesod.FedURI
@@ -53,12 +69,13 @@ import Yesod.Hashids
import Yesod.MonadSite (asksSite)
import qualified Web.ActivityPub as AP
+import qualified Web.Actor.Persist as WAP
import Control.Monad.Trans.Except.Local
+import Database.Persist.Local
-import Vervis.Access
import Vervis.Actor
-import Vervis.Actor2
+--import Vervis.Actor2
import Vervis.Data.Actor
import Vervis.FedURI
import Vervis.Foundation
@@ -77,6 +94,9 @@ deriving instance AllBF Eq f GrantRecipBy => Eq (GrantRecipBy f)
parseGrantRecip (PersonR p) = Just $ GrantRecipPerson p
parseGrantRecip _ = Nothing
+hashGrantRecip (GrantRecipPerson k) =
+ GrantRecipPerson <$> WAP.encodeKeyHashid k
+
unhashGrantRecipPure ctx = f
where
f (GrantRecipPerson p) =
@@ -87,7 +107,7 @@ unhashGrantRecipOld resource = do
return $ unhashGrantRecipPure ctx resource
unhashGrantRecip resource = do
- ctx <- asksEnv stageHashidsContext
+ ctx <- asksEnv WAP.stageHashidsContext
return $ unhashGrantRecipPure ctx resource
unhashGrantRecipEOld resource e =
@@ -245,3 +265,71 @@ grantResourceActorID :: GrantResourceBy Identity -> ActorId
grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r
grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d
grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l
+
+data GrantResourceBy f
+ = GrantResourceRepo (f Repo)
+ | GrantResourceDeck (f Deck)
+ | GrantResourceLoom (f Loom)
+ deriving (Generic, FunctorB, TraversableB, ConstraintsB)
+
+deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f)
+
+unhashGrantResourcePure ctx = f
+ where
+ f (GrantResourceRepo r) =
+ GrantResourceRepo <$> decodeKeyHashidPure ctx r
+ f (GrantResourceDeck d) =
+ GrantResourceDeck <$> decodeKeyHashidPure ctx d
+ f (GrantResourceLoom l) =
+ GrantResourceLoom <$> decodeKeyHashidPure ctx l
+
+unhashGrantResource resource = do
+ ctx <- asksSite siteHashidsContext
+ return $ unhashGrantResourcePure ctx resource
+
+unhashGrantResourceE resource e =
+ ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource
+
+unhashGrantResource' resource = do
+ ctx <- asksEnv WAP.stageHashidsContext
+ return $ unhashGrantResourcePure ctx resource
+
+unhashGrantResourceE' resource e =
+ ExceptT $ maybe (Left e) Right <$> unhashGrantResource' resource
+
+unhashGrantResource404 = maybe notFound return <=< unhashGrantResource
+
+hashGrantResource (GrantResourceRepo k) =
+ GrantResourceRepo <$> encodeKeyHashid k
+hashGrantResource (GrantResourceDeck k) =
+ GrantResourceDeck <$> encodeKeyHashid k
+hashGrantResource (GrantResourceLoom k) =
+ GrantResourceLoom <$> encodeKeyHashid k
+
+hashGrantResource' (GrantResourceRepo k) =
+ GrantResourceRepo <$> WAP.encodeKeyHashid k
+hashGrantResource' (GrantResourceDeck k) =
+ GrantResourceDeck <$> WAP.encodeKeyHashid k
+hashGrantResource' (GrantResourceLoom k) =
+ GrantResourceLoom <$> WAP.encodeKeyHashid k
+
+getGrantResource (GrantResourceRepo k) e =
+ GrantResourceRepo <$> getEntityE k e
+getGrantResource (GrantResourceDeck k) e =
+ GrantResourceDeck <$> getEntityE k e
+getGrantResource (GrantResourceLoom k) e =
+ GrantResourceLoom <$> getEntityE k e
+
+getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
+ where
+ getGrantResourceEntity (GrantResourceRepo k) =
+ fmap GrantResourceRepo <$> getEntity k
+ getGrantResourceEntity (GrantResourceDeck k) =
+ fmap GrantResourceDeck <$> getEntity k
+ getGrantResourceEntity (GrantResourceLoom k) =
+ fmap GrantResourceLoom <$> getEntity k
+
+grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f
+grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r
+grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d
+grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l
diff --git a/src/Vervis/Data/Ticket.hs b/src/Vervis/Data/Ticket.hs
index 31d3286..13e2206 100644
--- a/src/Vervis/Data/Ticket.hs
+++ b/src/Vervis/Data/Ticket.hs
@@ -75,7 +75,7 @@ import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local
-import Vervis.Access
+import Vervis.Data.Collab
import Vervis.Foundation
import Vervis.FedURI
import Vervis.Model
diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs
index b174baf..7a759e2 100644
--- a/src/Vervis/Federation/Ticket.hs
+++ b/src/Vervis/Federation/Ticket.hs
@@ -94,11 +94,11 @@ import qualified Data.Text.UTF8.Local as TU
import Development.PatchMediaType
-import Vervis.Access
import Vervis.ActivityPub
import Vervis.Actor
import Vervis.Cloth
import Vervis.Data.Actor
+import Vervis.Data.Collab
import Vervis.Data.Ticket
import Vervis.Darcs
import Vervis.Web.Delivery
diff --git a/src/Vervis/Fetch.hs b/src/Vervis/Fetch.hs
index 0393b72..e7553f4 100644
--- a/src/Vervis/Fetch.hs
+++ b/src/Vervis/Fetch.hs
@@ -80,7 +80,7 @@ import qualified Data.Git.Local as G (createRepo)
import qualified Data.Text.UTF8.Local as TU
import qualified Darcs.Local.Repository as D (createRepo)
-import Vervis.Access
+--import Vervis.Access
import Vervis.ActivityPub
import Vervis.Cloth
import Vervis.Data.Actor
diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs
index bd88f53..6693648 100644
--- a/src/Vervis/Handler/Person.hs
+++ b/src/Vervis/Handler/Person.hs
@@ -235,7 +235,6 @@ postPersonOutboxR personHash = do
AP.CreatePatchTracker detail repos mlocal ->
run createPatchTrackerC detail repos mlocal mtarget
_ -> throwE "Unsupported Create 'object' type"
- AP.InviteActivity invite -> run inviteC invite
{-
AddActivity (AP.Add obj target) ->
case obj of
@@ -254,7 +253,10 @@ postPersonOutboxR personHash = do
_ -> throwE "Unsupported Offer 'object' type"
AP.ResolveActivity resolve -> run resolveC resolve
AP.UndoActivity undo -> run undoC undo
- _ -> throwE "Unsupported activity type"
+ _ ->
+ handleViaActor
+ (entityKey eperson) maybeCap localRecips remoteRecips
+ fwdHosts action
getPersonOutboxItemR
:: KeyHashid Person -> KeyHashid OutboxItem -> Handler TypedContent
diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs
index e278ed9..30e8776 100644
--- a/src/Vervis/Persist/Actor.hs
+++ b/src/Vervis/Persist/Actor.hs
@@ -59,7 +59,7 @@ import qualified Web.Actor.Persist as WAP
import Control.Monad.Trans.Except.Local
import Database.Persist.Local
-import Vervis.Actor2 ()
+--import Vervis.Actor2 ()
import Vervis.Data.Actor
import Vervis.FedURI
import Vervis.Foundation
diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs
index bfa4d6f..c57d50e 100644
--- a/src/Vervis/Persist/Collab.hs
+++ b/src/Vervis/Persist/Collab.hs
@@ -20,21 +20,36 @@ module Vervis.Persist.Collab
, getTopicGrants
, getTopicInvites
, getTopicJoins
+
+ , verifyCapability
+ , verifyCapability'
)
where
+import Control.Monad
import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
+import Data.Bifunctor
+import Data.Bitraversable
+import Data.ByteString (ByteString)
+import Data.Text (Text)
import Data.Time.Clock
import Database.Persist.Sql
import qualified Database.Esqueleto as E
+import Network.FedURI
+
+import Control.Monad.Trans.Except.Local
+import Data.Either.Local
import Database.Persist.Local
-import Vervis.Access
+import Vervis.Actor
import Vervis.Data.Collab
import Vervis.Model
+import Vervis.Persist.Actor
getCollabTopic
:: MonadIO m => CollabId -> ReaderT SqlBackend m (GrantResourceBy Key)
@@ -219,3 +234,81 @@ getTopicJoins topicCollabField topicActorField resourceID =
(Just (personID, time), Nothing) -> (Left personID, time)
(Nothing, Just (remoteActorID, time)) -> (Right remoteActorID, time)
(Just _, Just _) -> error "Multi recip"
+
+verifyCapability
+ :: MonadIO m
+ => (LocalActorBy Key, OutboxItemId)
+ -> Either PersonId RemoteActorId
+ -> GrantResourceBy Key
+ -> ExceptT Text (ReaderT SqlBackend m) ()
+verifyCapability (capActor, capItem) actor resource = do
+
+ -- Find the activity itself by URI in the DB
+ nameExceptT "Capability activity not found" $
+ verifyLocalActivityExistsInDB capActor capItem
+
+ -- Find the Collab record for that activity
+ collabID <- do
+ maybeEnable <- lift $ getValBy $ UniqueCollabEnableGrant capItem
+ collabEnableCollab <$>
+ fromMaybeE maybeEnable "No CollabEnable for this activity"
+
+ -- Find the recipient of that Collab
+ recipID <-
+ lift $ bimap collabRecipLocalPerson collabRecipRemoteActor <$>
+ requireEitherAlt
+ (getValBy $ UniqueCollabRecipLocal collabID)
+ (getValBy $ UniqueCollabRecipRemote collabID)
+ "No collab recip"
+ "Both local and remote recips for collab"
+
+ -- Verify the recipient is the expected one
+ unless (recipID == actor) $
+ throwE "Collab recipient is someone else"
+
+ -- Find the local topic, on which this Collab gives access
+ topic <- lift $ do
+ maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
+ maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
+ maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
+ case (maybeRepo, maybeDeck, maybeLoom) of
+ (Nothing, Nothing, Nothing) -> error "Collab without topic"
+ (Just r, Nothing, Nothing) ->
+ return $ GrantResourceRepo $ collabTopicRepoRepo r
+ (Nothing, Just d, Nothing) ->
+ return $ GrantResourceDeck $ collabTopicDeckDeck d
+ (Nothing, Nothing, Just l) ->
+ return $ GrantResourceLoom $ collabTopicLoomLoom l
+ _ -> error "Collab with multiple topics"
+
+ -- Verify that topic is indeed the sender of the Grant
+ unless (grantResourceLocalActor topic == capActor) $
+ error "Grant sender isn't the topic"
+
+ -- Verify the topic matches the resource specified
+ unless (topic == resource) $
+ throwE "Capability topic is some other local resource"
+
+ -- Since there are currently no roles, and grants allow only the "Admin"
+ -- role that supports every operation, we don't need to check role access
+ return ()
+
+verifyCapability'
+ :: MonadIO m
+ => (LocalActorBy Key, OutboxItemId)
+ -> Either
+ (LocalActorBy Key, ActorId, OutboxItemId)
+ (RemoteAuthor, LocalURI, Maybe ByteString)
+ -> GrantResourceBy Key
+ -> ExceptT Text (ReaderT SqlBackend m) ()
+verifyCapability' cap actor resource = do
+ actorP <- processActor actor
+ verifyCapability cap actorP resource
+ where
+ processActor = bitraverse processLocal processRemote
+ where
+ processLocal (actorByKey, _, _) =
+ case actorByKey of
+ LocalActorPerson personID -> return personID
+ _ -> throwE "Non-person local actors can't get Grants at the moment"
+ processRemote (author, _, _) = pure $ remoteAuthorId author
diff --git a/src/Vervis/Persist/Ticket.hs b/src/Vervis/Persist/Ticket.hs
index 2531330..62d740b 100644
--- a/src/Vervis/Persist/Ticket.hs
+++ b/src/Vervis/Persist/Ticket.hs
@@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- - Written in 2022 by fr33domlover .
+ - Written in 2022, 2023 by fr33domlover .
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@@ -45,13 +45,14 @@ import Control.Monad.Trans.Except.Local
import Data.Either.Local
import Database.Persist.Local
-import Vervis.Access
import Vervis.Cloth
+import Vervis.Data.Collab
import Vervis.Data.Ticket
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model
import Vervis.Persist.Actor
+import Vervis.Persist.Collab
import Vervis.Recipient
getTicketResolve (Entity _ tr, resolve) = do