C2S: Implement grantC and enable in person outbox handler

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

src/Vervis/API.hs

@@ -13,6 +13,9 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+{-# 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

src/Vervis/Access.hs

@@ -13,6 +13,11 @@
  - <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
@@ -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 ()

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

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