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