C2S: Implement grantC and enable in person outbox handler

This commit is contained in:
fr33domlover 2022-08-22 16:59:22 +00:00
parent f42537eb1e
commit 06c520f6aa
5 changed files with 414 additions and 2 deletions

View file

@ -22,6 +22,7 @@ module Database.Persist.Local
, insertBy' , insertBy'
, insertByEntity' , insertByEntity'
, getE , getE
, getEntityE
) )
where where
@ -110,3 +111,11 @@ getE key msg = do
case mval of case mval of
Nothing -> throwE msg Nothing -> throwE msg
Just val -> return val Just val -> return val
getEntityE
:: ( PersistStoreRead backend
, MonadIO m
, PersistRecordBackend record backend
)
=> Key record -> e -> ExceptT e (ReaderT backend m) (Entity record)
getEntityE key msg = (Entity key) <$> getE key msg

View file

@ -13,6 +13,9 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>. - <http://creativecommons.org/publicdomain/zero/1.0/>.
-} -}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module Vervis.API module Vervis.API
( addBundleC ( addBundleC
, applyC , applyC
@ -20,6 +23,7 @@ module Vervis.API
, createNoteC , createNoteC
, createTicketTrackerC , createTicketTrackerC
, followC , followC
, grantC
, offerTicketC , offerTicketC
, offerDepC , offerDepC
, resolveC , resolveC
@ -39,6 +43,7 @@ import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Crypto.Hash import Crypto.Hash
import Data.Aeson import Data.Aeson
import Data.Barbie
import Data.Bifunctor import Data.Bifunctor
import Data.Bitraversable import Data.Bitraversable
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
@ -58,6 +63,7 @@ import Data.Traversable
import Data.Tuple import Data.Tuple
import Database.Persist hiding (deleteBy) import Database.Persist hiding (deleteBy)
import Database.Persist.Sql hiding (deleteBy) import Database.Persist.Sql hiding (deleteBy)
import GHC.Generics
import Network.HTTP.Client import Network.HTTP.Client
import Network.HTTP.Types.Header import Network.HTTP.Types.Header
import Network.HTTP.Types.URI import Network.HTTP.Types.URI
@ -106,6 +112,7 @@ import Data.Tuple.Local
import Database.Persist.Local import Database.Persist.Local
import Yesod.Persist.Local import Yesod.Persist.Local
import Vervis.Access
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.ActorKey import Vervis.ActorKey
import Vervis.Cloth import Vervis.Cloth
@ -1462,6 +1469,307 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje
ibiid <- insert $ InboxItem True ibiid <- insert $ InboxItem True
insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid
data GrantRecipBy f = GrantRecipPerson (f Person)
deriving (Generic, FunctorB, TraversableB, ConstraintsB)
grantC
:: Entity Person
-> Actor
-> Maybe FedURI
-> Maybe TextHtml
-> Audience URIMode
-> Grant URIMode
-> ExceptT Text Handler OutboxItemId
grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
-- Check input
(resourceK, recipientK) <- parseGrant grant
let input = adaptGrant resourceK recipientK
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
mrecips <- parseAudience audience
recips <- fromMaybeE mrecips "Create TicketTracker with no recipients"
checkFederation $ paudRemoteActors recips
return recips
verifyRecipients input localRecips remoteRecips
-- Verify the capability URI is one of:
-- * Outbox item URI of a local actor, i.e. a local activity
-- * A remote URI
uCap <- fromMaybeE muCap "No capability provided"
capID <- parseActivityURI "Grant capability" uCap
-- If recipient is remote, HTTP GET it, make sure it's an actor, and insert
-- it to our DB
inputHttp <- for input $ \ (resource, recipient) ->
fmap (resource,) $ bifor recipient pure $ \ (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
now <- liftIO getCurrentTime
senderHash <- encodeKeyHashid pidUser
(obiidGrant, deliverHttpGrant) <- runDBExcept $ do
-- Find resource (if local) and recipient (if local) in DB
inputDB <-
for inputHttp $ bitraverse
(flip getGrantResource "Grant context not found in DB")
(bitraverse
(flip getGrantRecip "Grant recipient not found in DB")
pure
)
-- If resource is loca, verify the specified capability gives relevant
-- access
for_ inputDB $ \ (resource, _) ->
verifyCapability capID pidUser (bmap entityKey resource)
-- Insert new Collab to DB
grantID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
for_ inputDB $ \ (resource, recipient) ->
lift $ insertCollab resource recipient grantID
-- Insert the Grant activity to author's outbox
docGrant <- lift $ insertGrantToOutbox senderHash now uCap blinded grantID
-- Deliver the Grant activity to local recipients, and schedule
-- delivery for unavailable remote recipients
remoteRecipsHttpGrant <- do
resourceH <- bitraverse hashGrantResource pure resourceK
recipientH <- bitraverse hashGrantRecip pure recipientK
let actors = catMaybes
[ case resourceH of
Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
Right _ -> Nothing
, case recipientH of
Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
Right _ -> Nothing
]
stages = catMaybes
[ Just $ LocalStagePersonFollowers senderHash
, case resourceH of
Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
Right _ -> Nothing
, case recipientH of
Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p
Right _ -> Nothing
]
sieve = makeRecipientSet actors stages
moreRemoteRecips <-
lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) grantID $
localRecipSieve sieve False localRecips
checkFederation moreRemoteRecips
lift $ deliverRemoteDB'' fwdHosts grantID remoteRecips moreRemoteRecips
-- For local resource/recipient, verify they've received the Grant
for_ inputDB $ \ (resource, recipient) -> do
let resourceActorID =
case resource of
GrantResourceRepo (Entity _ r) -> repoActor r
GrantResourceDeck (Entity _ d) -> deckActor d
GrantResourceLoom (Entity _ l) -> loomActor l
verifyActorHasItem resourceActorID grantID "Local topic didn't receive the Grant"
case recipient of
Left (GrantRecipPerson (Entity _ p)) ->
verifyActorHasItem (personActor p) grantID "Local recipient didn't receive the Grant"
Right _ -> return ()
-- Return instructions for HTTP delivery to remote recipients
return
( grantID
, deliverRemoteHttp' fwdHosts grantID docGrant remoteRecipsHttpGrant
)
-- Launch asynchronous HTTP delivery of the Grant activity
lift $ do
forkWorker "grantC: async HTTP Grant delivery" deliverHttpGrant
return obiidGrant
where
parseGrant
:: Grant URIMode
-> ExceptT Text Handler
( Either (GrantResourceBy Key) FedURI
, Either (GrantRecipBy Key) FedURI
)
parseGrant (Grant object context target) = do
verifyRole object
(,) <$> parseContext context
<*> parseTarget target
where
verifyRole (Left RoleAdmin) = pure ()
verifyRole (Right _) =
throwE "ForgeFed Admin is the only role allowed currently"
parseContext u@(ObjURI h lu) = do
hl <- hostIsLocal h
if hl
then Left <$> do
route <-
fromMaybeE
(decodeRouteLocal lu)
"Grant context isn't a valid route"
resourceHash <-
fromMaybeE
(parseGrantResource route)
"Grant context isn't a shared resource route"
unhashGrantResourceE
resourceHash
"Grant resource contains invalid hashid"
else pure $ Right u
where
parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
parseGrantResource _ = Nothing
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
parseTarget u@(ObjURI h lu) = do
hl <- hostIsLocal h
if hl
then Left <$> do
route <-
fromMaybeE
(decodeRouteLocal lu)
"Grant target isn't a valid route"
recipHash <-
fromMaybeE
(parseGrantRecip route)
"Grant target isn't a grant recipient route"
recipKey <-
unhashGrantRecipE
recipHash
"Grant target contains invalid hashid"
case recipKey of
GrantRecipPerson p | p == pidUser ->
throwE "Grant sender and recipient are the same Person"
_ -> return recipKey
else pure $ Right u
where
parseGrantRecip (PersonR p) = Just $ GrantRecipPerson p
parseGrantRecip _ = Nothing
unhashGrantRecipPure ctx = f
where
f (GrantRecipPerson p) =
GrantRecipPerson <$> decodeKeyHashidPure ctx p
unhashGrantRecip resource = do
ctx <- asksSite siteHashidsContext
return $ unhashGrantRecipPure ctx resource
unhashGrantRecipE resource e =
ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource
adaptGrant
:: Either (GrantResourceBy Key) FedURI
-> Either (GrantRecipBy Key) FedURI
-> Maybe (GrantResourceBy Key, Either (GrantRecipBy Key) FedURI)
adaptGrant (Right _) _ = Nothing
adaptGrant (Left resource) recip = Just (resource, recip)
verifyRecipients input localRecips remoteRecips =
for_ input $ \ (resourceK, recipientK) -> do
resourceH <- hashGrantResource resourceK
recipientH <- bitraverse hashGrantRecip pure recipientK
fromMaybeE (verifyResource resourceH) "Local resource not addressed"
fromMaybeE (verifyRecip recipientH) "Recipient not addressed"
where
verifyResource (GrantResourceRepo r) = do
routes <- lookup r $ recipRepos localRecips
guard $ routeRepo routes
verifyResource (GrantResourceDeck d) = do
routes <- lookup d $ recipDecks localRecips
guard $ routeDeck $ familyDeck routes
verifyResource (GrantResourceLoom l) = do
routes <- lookup l $ recipLooms localRecips
guard $ routeLoom $ familyLoom routes
verifyRecip (Left (GrantRecipPerson p)) = do
routes <- lookup p $ recipPeople localRecips
guard $ routePerson routes
verifyRecip (Right (ObjURI h lu)) = do
lus <- lookup h remoteRecips
guard $ lu `elem` lus
getGrantResource (GrantResourceRepo k) e =
GrantResourceRepo <$> getEntityE k e
getGrantResource (GrantResourceDeck k) e =
GrantResourceDeck <$> getEntityE k e
getGrantResource (GrantResourceLoom k) e =
GrantResourceLoom <$> getEntityE k e
getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e
insertCollab resource recipient grantID = do
collabID <- insert Collab
case resource of
GrantResourceRepo (Entity repoID _) ->
insert_ $ CollabTopicLocalRepo collabID repoID
GrantResourceDeck (Entity deckID _) ->
insert_ $ CollabTopicLocalDeck collabID deckID
GrantResourceLoom (Entity loomID _) ->
insert_ $ CollabTopicLocalLoom collabID loomID
insert_ $ CollabSenderLocal collabID grantID
case recipient of
Left (GrantRecipPerson (Entity personID _)) ->
insert_ $ CollabRecipLocal collabID personID
Right remoteActorID ->
insert_ $ CollabRecipRemote collabID remoteActorID
hashGrantResource (GrantResourceRepo k) =
GrantResourceRepo <$> encodeKeyHashid k
hashGrantResource (GrantResourceDeck k) =
GrantResourceDeck <$> encodeKeyHashid k
hashGrantResource (GrantResourceLoom k) =
GrantResourceLoom <$> encodeKeyHashid k
hashGrantRecip (GrantRecipPerson k) =
GrantRecipPerson <$> encodeKeyHashid k
insertGrantToOutbox senderHash now uCap blinded grantID = do
encodeRouteLocal <- getEncodeRouteLocal
hLocal <- asksSite siteInstanceHost
grantHash <- encodeKeyHashid grantID
let doc = Doc hLocal Activity
{ activityId =
Just $ encodeRouteLocal $
PersonOutboxItemR senderHash grantHash
, activityActor = encodeRouteLocal $ PersonR senderHash
, activityCapability = Just uCap
, activitySummary = summary
, activityAudience = blinded
, activityFulfills = []
, activitySpecific = GrantActivity grant
}
update grantID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return doc
verifyActorHasItem actorID itemID errorMessage = do
inboxID <- lift $ actorInbox <$> getJust actorID
maybeItem <- lift $ getBy $ UniqueInboxItemLocal inboxID itemID
void $ fromMaybeE maybeItem errorMessage
offerTicketC offerTicketC
:: Entity Person :: Entity Person
-> Maybe TextHtml -> Maybe TextHtml

View file

@ -13,6 +13,11 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>. - <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 -- | 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 -- 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 -- perform the changes to our database etc.? The functions here should provide
@ -57,27 +62,42 @@ module Vervis.Access
, checkRepoAccess' , checkRepoAccess'
, checkRepoAccess , checkRepoAccess
, checkProjectAccess , checkProjectAccess
, GrantResourceBy (..)
, verifyCapability
) )
where where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.Barbie
import Data.Foldable
import Data.Maybe import Data.Maybe
import Data.Text (Text)
import Database.Persist.Class import Database.Persist.Class
import Database.Persist.Sql (SqlBackend) import Database.Persist.Sql (SqlBackend)
import Database.Persist.Types (Entity (..)) import Database.Persist.Types (Entity (..))
import GHC.Generics
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Yesod.Hashids import Yesod.Hashids
import Yesod.MonadSite import Yesod.MonadSite
import Control.Monad.Trans.Except.Local
import Database.Persist.Local
import Vervis.ActivityPub
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Role import Vervis.Model.Role
import Vervis.Query import Vervis.Query
import Vervis.Recipient
data ObjectAccessStatus = data ObjectAccessStatus =
NoSuchObject | ObjectAccessDenied | ObjectAccessAllowed NoSuchObject | ObjectAccessDenied | ObjectAccessAllowed
@ -219,3 +239,77 @@ checkProjectAccess mpid op deckHash = do
return $ topic E.^. CollabTopicLocalDeckCollab return $ topic E.^. CollabTopicLocalDeckCollab
asUser = fmap RoleID . deckCollabUser asUser = fmap RoleID . deckCollabUser
asAnon = fmap RoleID . deckCollabAnon 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)
verifyCapability
:: Either (LocalActorBy KeyHashid, OutboxItemId) FedURI
-> PersonId
-> GrantResourceBy Key
-> ExceptT Text (ReaderT SqlBackend Handler) ()
verifyCapability capability personID resource = do
-- Find the activity itself by URI in the DB
grant <- do
mact <- getActivity capability
fromMaybeE mact "Capability activity not known to me"
-- Find the Collab record for that activity
cid <-
case grant of
Left (_actor, obiid) -> do
mcsl <- lift $ getValBy $ UniqueCollabSenderLocalActivity obiid
collabSenderLocalCollab <$>
fromMaybeE mcsl "Capability is a local activity but no matching capability"
Right ractid -> do
mcsr <- lift $ getValBy $ UniqueCollabSenderRemoteActivity ractid
collabSenderRemoteCollab <$>
fromMaybeE mcsr "Capability is a known remote activity but no matching capability"
-- Find the recipient of that Collab
recipID <- do
mcrl <- lift $ getValBy $ UniqueCollabRecipLocal cid
crl <- fromMaybeE mcrl "No local recip for capability"
mcrr <- lift $ getBy $ UniqueCollabRecipRemote cid
for_ mcrr $ \ _ -> error "Both local & remote recip for capability!"
return $ collabRecipLocalPerson crl
-- Verify the recipient is the expected one
unless (recipID == personID) $
throwE "Collab recipient is some other Person"
-- Verify the topic isn't remote
maybeRemote <- lift $ getBy $ UniqueCollabTopicRemote cid
verifyNothingE maybeRemote "Collab is for some other, remote topic"
-- Find the local topic, on which this Collab gives access
topic <- lift $ do
maybeRepo <- getValBy $ UniqueCollabTopicLocalRepo cid
maybeDeck <- getValBy $ UniqueCollabTopicLocalDeck cid
maybeLoom <- getValBy $ UniqueCollabTopicLocalLoom cid
case (maybeRepo, maybeDeck, maybeLoom) of
(Nothing, Nothing, Nothing) -> error "Collab without topic"
(Just r, Nothing, Nothing) ->
return $ GrantResourceRepo $ collabTopicLocalRepoRepo r
(Nothing, Just d, Nothing) ->
return $ GrantResourceDeck $ collabTopicLocalDeckDeck d
(Nothing, Nothing, Just l) ->
return $ GrantResourceLoom $ collabTopicLocalLoomLoom l
_ -> error "Collab with multiple topics"
-- Verify the topic matches the resource specified
unless (topic == resource) $
throwE "Capability topic is some other local resource"
-- Verify that the resource has accepted the grant, making it valid
maybeAccept <- lift $ getBy $ UniqueCollabTopicAcceptCollab cid
_ <- fromMaybeE maybeAccept "Collab not approved by the 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 ()

View file

@ -83,7 +83,6 @@ import Text.Email.Local
import Text.Jasmine.Local (discardm) import Text.Jasmine.Local (discardm)
import Yesod.Paginate.Local import Yesod.Paginate.Local
import Vervis.Access
import Vervis.ActorKey import Vervis.ActorKey
import Vervis.FedURI import Vervis.FedURI
import Vervis.Hook import Vervis.Hook

View file

@ -173,6 +173,8 @@ postPersonOutboxR personHash = do
AP.CreateTicketTracker detail mlocal -> AP.CreateTicketTracker detail mlocal ->
createTicketTrackerC eperson actorDB summary audience detail mlocal mtarget createTicketTrackerC eperson actorDB summary audience detail mlocal mtarget
_ -> throwE "Unsupported Create 'object' type" _ -> throwE "Unsupported Create 'object' type"
AP.GrantActivity grant ->
grantC eperson actorDB mcap summary audience grant
{- {-
AddActivity (AP.Add obj target) -> AddActivity (AP.Add obj target) ->
case obj of case obj of