From 06c520f6aa5e89bc3b8a6955763d2826c8463193 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 22 Aug 2022 16:59:22 +0000 Subject: [PATCH] C2S: Implement grantC and enable in person outbox handler --- src/Database/Persist/Local.hs | 9 + src/Vervis/API.hs | 308 ++++++++++++++++++++++++++++++++++ src/Vervis/Access.hs | 96 ++++++++++- src/Vervis/Foundation.hs | 1 - src/Vervis/Handler/Person.hs | 2 + 5 files changed, 414 insertions(+), 2 deletions(-) diff --git a/src/Database/Persist/Local.hs b/src/Database/Persist/Local.hs index 73bce67..b0a07c2 100644 --- a/src/Database/Persist/Local.hs +++ b/src/Database/Persist/Local.hs @@ -22,6 +22,7 @@ module Database.Persist.Local , insertBy' , insertByEntity' , getE + , getEntityE ) where @@ -110,3 +111,11 @@ getE key msg = do case mval of Nothing -> throwE msg 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 diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 8f452df..987a63b 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -13,6 +13,9 @@ - . -} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + module Vervis.API ( addBundleC , applyC @@ -20,6 +23,7 @@ module Vervis.API , createNoteC , createTicketTrackerC , followC + , grantC , offerTicketC , offerDepC , resolveC @@ -39,6 +43,7 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Crypto.Hash import Data.Aeson +import Data.Barbie import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) @@ -58,6 +63,7 @@ import Data.Traversable import Data.Tuple import Database.Persist hiding (deleteBy) import Database.Persist.Sql hiding (deleteBy) +import GHC.Generics import Network.HTTP.Client import Network.HTTP.Types.Header import Network.HTTP.Types.URI @@ -106,6 +112,7 @@ import Data.Tuple.Local import Database.Persist.Local import Yesod.Persist.Local +import Vervis.Access import Vervis.ActivityPub import Vervis.ActorKey import Vervis.Cloth @@ -1462,6 +1469,307 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje ibiid <- insert $ InboxItem True 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 :: Entity Person -> Maybe TextHtml diff --git a/src/Vervis/Access.hs b/src/Vervis/Access.hs index ea09f7c..8fc55a8 100644 --- a/src/Vervis/Access.hs +++ b/src/Vervis/Access.hs @@ -13,6 +13,11 @@ - . -} +{-# 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 @@ -57,27 +62,42 @@ module Vervis.Access , checkRepoAccess' , checkRepoAccess , checkProjectAccess + , GrantResourceBy (..) + , verifyCapability ) where import Control.Applicative ((<|>)) +import Control.Monad import Control.Monad.IO.Class +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.Foldable import Data.Maybe +import Data.Text (Text) import Database.Persist.Class import Database.Persist.Sql (SqlBackend) import Database.Persist.Types (Entity (..)) +import GHC.Generics import qualified Database.Esqueleto as E import Yesod.Hashids 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.Ident import Vervis.Model.Role import Vervis.Query +import Vervis.Recipient data ObjectAccessStatus = NoSuchObject | ObjectAccessDenied | ObjectAccessAllowed @@ -219,3 +239,77 @@ checkProjectAccess mpid op deckHash = do return $ topic E.^. CollabTopicLocalDeckCollab 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) + +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 () diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 8d9b629..e992c4a 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -83,7 +83,6 @@ import Text.Email.Local import Text.Jasmine.Local (discardm) import Yesod.Paginate.Local -import Vervis.Access import Vervis.ActorKey import Vervis.FedURI import Vervis.Hook diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index f60c9c3..84acf3d 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -173,6 +173,8 @@ postPersonOutboxR personHash = do AP.CreateTicketTracker detail mlocal -> createTicketTrackerC eperson actorDB summary audience detail mlocal mtarget _ -> throwE "Unsupported Create 'object' type" + AP.GrantActivity grant -> + grantC eperson actorDB mcap summary audience grant {- AddActivity (AP.Add obj target) -> case obj of