Link C2S handler with ClientMsg Person actor handler & port inviteC
This commit is contained in:
Pere Lev
parent
29904080df
commit
ffb5dadac7
15 changed files with 564 additions and 416 deletions
|
|
@ -17,6 +17,7 @@ module Control.Concurrent.Actor
|
|||
( Stage (..)
|
||||
, TheaterFor ()
|
||||
, ActFor ()
|
||||
, runActor
|
||||
, MonadActor (..)
|
||||
, asksEnv
|
||||
, Next ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -13,11 +13,6 @@
|
|||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
{-# 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
|
|
|
|||
Loading…
Reference in a new issue