From a083b0d8667371a7c0f11395b2560bfcc5f235c0 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Wed, 12 Jul 2023 16:50:29 +0300 Subject: [PATCH] S2S: Update Project-Accept handler to handle Components --- src/Vervis/API.hs | 4 +- src/Vervis/Actor/Common.hs | 4 +- src/Vervis/Actor/Project.hs | 326 ++++++++++++++++++++++++++++------- src/Vervis/Data/Collab.hs | 2 +- src/Vervis/Persist/Collab.hs | 37 ++++ src/Web/ActivityPub.hs | 36 ++-- 6 files changed, 333 insertions(+), 76 deletions(-) diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 22f10f0..af73664 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -1195,7 +1195,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips , actionFulfills = [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] , actionSpecific = GrantActivity Grant - { grantObject = RoleAdmin + { grantObject = AP.RXRole RoleAdmin , grantContext = encodeRouteLocal $ LoomR loomHash , grantTarget = encodeRouteHome $ PersonR adminHash , grantResult = Nothing @@ -1431,7 +1431,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r , actionFulfills = [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] , actionSpecific = GrantActivity Grant - { grantObject = RoleAdmin + { grantObject = AP.RXRole RoleAdmin , grantContext = encodeRouteLocal $ RepoR repoHash , grantTarget = encodeRouteHome $ PersonR adminHash , grantResult = Nothing diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 2c2c082..885c25f 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -413,7 +413,7 @@ topicAccept topicActor topicResource now recipKey (Verse authorIdMsig body) acce , AP.actionAudience = AP.Audience recips [] [] [] [] [] , AP.actionFulfills = [AP.acceptObject accept] , AP.actionSpecific = AP.GrantActivity AP.Grant - { AP.grantObject = role + { AP.grantObject = AP.RXRole role , AP.grantContext = encodeRouteLocal $ renderLocalActor topicByHash , AP.grantTarget = @@ -1294,7 +1294,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now , AP.actionAudience = AP.Audience recips [] [] [] [] [] , AP.actionFulfills = [uCreate] , AP.actionSpecific = AP.GrantActivity AP.Grant - { AP.grantObject = AP.RoleAdmin + { AP.grantObject = AP.RXRole AP.RoleAdmin , AP.grantContext = encodeRouteLocal $ renderLocalActor topicByHash , AP.grantTarget = uCreator diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 707c67c..6154305 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -28,6 +28,7 @@ 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) @@ -91,7 +92,7 @@ import Vervis.Ticket -- * Verify I haven't seen a component-Accept on this Add -- * Otherwise, i.e. sender isn't the component: -- * Verify I've seen the component-Accept for this Add --- * Verify the Accept is authorized +-- * Verify the new Accept is authorized -- * If it's none of these, respond with error -- -- * In collab mode, verify the Collab isn't enabled yet @@ -123,14 +124,14 @@ import Vervis.Ticket -- * CC: Accept sender, Join sender's followers, my followers -- * For Invite-component mode: -- * Only if sender is the component --- * delegator-Grant with a result URI +-- * delegator-Grant -- * To: Component -- * CC: -- - Component's followers -- - My followers -- * For Add-component mode: -- * Only if sender isn't the component --- * delegator-Grant with a result URI +-- * delegator-Grant -- * To: Component -- * CC: -- - Component's followers @@ -169,17 +170,24 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do fromMaybeE a "Can't find acceptee in DB" -- See if the accepted activity is an Invite or Join where my collabs - -- URI is the resource, grabbing the Collab record from our DB - (collabID, fulfills, inviterOrJoiner) <- do + -- URI is the resource, grabbing the Collab record from our DB, + -- Or if the accepted activity is an Invite or Add where my components + -- URI is the resource, grabbing the Component record from our DB + collabOrComp <- do let adapt = maybe (Right Nothing) (either Left (Right . Just)) maybeCollab <- ExceptT $ fmap adapt $ runMaybeT $ - runExceptT (tryInviteCollab accepteeDB) <|> - runExceptT (tryJoinCollab accepteeDB) - fromMaybeE maybeCollab "Accepted activity isn't an Invite or Join I'm aware of" + runExceptT (Left <$> tryInviteCollab accepteeDB) <|> + runExceptT (Left <$> tryJoinCollab accepteeDB) <|> + runExceptT (Right <$> tryInviteComp accepteeDB) <|> + runExceptT (Right <$> tryAddComp accepteeDB) + fromMaybeE + maybeCollab + "Accepted activity isn't an Invite/Join/Add I'm aware of" - idsForAccept <- - bitraverse + idsForAccept <- bitraverse + + (\ (collabID, fulfills, inviterOrJoiner) -> (collabID,inviterOrJoiner,) <$> bitraverse -- If accepting an Invite, find the Collab recipient and verify -- it's the sender of the Accept @@ -217,65 +225,176 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do ) fulfills + ) - -- Verify the Collab isn't already validated - maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID - verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join" + (\ (componentID, ident, inviteOrAdd) -> (componentID, ident,) <$> bitraverse + + -- If accepting an Invite-component, there's nothing to check + -- at this point + pure + + -- If accepting an Add-component: + -- * If the sender is the component, verify I haven't seen + -- a component-Accept on this Add + -- * Otherwise, verify I've seen the component-Accept for + -- this Add and that the new Accept is authorized + (\ () -> do + maybeComponentAccept <- + lift $ + case bimap fst fst ident of + Left localID -> (() <$) <$> getBy (UniqueComponentAcceptLocal localID) + Right remoteID -> (() <$) <$> getBy (UniqueComponentAcceptRemote remoteID) + if componentIsAuthor ident + then + verifyNothingE + maybeComponentAccept + "I've already seen a ComponentAccept* on \ + \that Add" + else do + fromMaybeE + maybeComponentAccept + "I haven't yet seen the Component's Accept on \ + \the Add" + capID <- fromMaybeE maybeCap "No capability provided" + capability <- + case capID of + Left (capActor, _, capItem) -> return (capActor, capItem) + Right _ -> throwE "Capability is a remote URI, i.e. not authored by me" + verifyCapability' + capability + authorIdMsig + (GrantResourceProject projectID) + AP.RoleAdmin + ) + + inviteOrAdd + ) + + collabOrComp + + -- In collab mode, verify the Collab isn't already validated + -- In component mode, verify the Component isn't already validated + bitraverse_ + (\ (collabID, _, _) -> do + maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID + verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join" + ) + (\ (componentID, _, _) -> do + maybeEnabled <- lift $ getBy $ UniqueComponentEnable componentID + verifyNothingE maybeEnabled "I already sent a delegator-Grant for this Invite/Add" + ) + collabOrComp maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False for maybeAcceptDB $ \ acceptDB -> do - -- Record the Accept on the Collab - case (idsForAccept, acceptDB) of - (Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do - maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID - unless (isNothing maybeAccept) $ - throwE "This Invite already has an Accept by recip" - (Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do - maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID - unless (isJust maybeAccept) $ - throwE "This Invite already has an Accept by recip" - (Right fulfillsID, Left (_, _, acceptID)) -> do - maybeAccept <- lift $ insertUnique $ CollabApproverLocal fulfillsID acceptID - unless (isJust maybeAccept) $ - throwE "This Join already has an Accept" - (Right fulfillsID, Right (author, _, acceptID)) -> do - maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID - unless (isJust maybeAccept) $ - throwE "This Join already has an Accept" - _ -> error "topicAccept impossible" + idsForGrant <- case idsForAccept of + + -- In collab mode, record the Accept and enable the Collab + Left (collabID, inviterOrJoiner, collab) -> Left <$> do + case (collab, acceptDB) of + (Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID + unless (isNothing maybeAccept) $ + throwE "This Invite already has an Accept by recip" + (Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID + unless (isJust maybeAccept) $ + throwE "This Invite already has an Accept by recip" + (Right fulfillsID, Left (_, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabApproverLocal fulfillsID acceptID + unless (isJust maybeAccept) $ + throwE "This Join already has an Accept" + (Right fulfillsID, Right (author, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID + unless (isJust maybeAccept) $ + throwE "This Join already has an Accept" + _ -> error "projectAccept impossible" + grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now + lift $ insert_ $ CollabEnable collabID grantID + return (collabID, inviterOrJoiner, collab, grantID) + + -- In Invite-component mode, only if the Accept author is the + -- component, record the Accept and enable the Component + Right (componentID, ident, Left ()) -> fmap Right $ + lift $ if componentIsAuthor ident + then Just <$> do + case (ident, acceptDB) of + (Left (localID, _), Left (_, _, acceptID)) -> + insert_ $ ComponentAcceptLocal localID acceptID + (Right (remoteID, _), Right (_, _, acceptID)) -> + insert_ $ ComponentAcceptRemote remoteID acceptID + _ -> error "personAccept impossible ii" + grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + enableID <- insert $ ComponentEnable componentID grantID + return (componentID, ident, grantID, enableID, False) + else pure Nothing + + -- In Add-component mode: + -- * If the sender is the component, record the Accept + -- * Otherwise, record the Accept and enable the Component + Right (componentID, ident, Right ()) -> fmap Right $ + lift $ if componentIsAuthor ident + then do + case (ident, acceptDB) of + (Left (localID, _), Left (_, _, acceptID)) -> + insert_ $ ComponentAcceptLocal localID acceptID + (Right (remoteID, _), Right (_, _, acceptID)) -> + insert_ $ ComponentAcceptRemote remoteID acceptID + _ -> error "personAccept impossible iii" + return Nothing + else Just <$> do + case acceptDB of + Left (_, _, acceptID) -> + insert_ $ ComponentProjectGestureLocal componentID acceptID + Right (author, _, acceptID) -> + insert_ $ ComponentProjectGestureRemote componentID (remoteAuthorId author) acceptID + grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + enableID <- insert $ ComponentEnable componentID grantID + return (componentID, ident, grantID, enableID, True) -- Prepare forwarding of Accept to my followers let recipByID = grantResourceLocalActor $ GrantResourceProject projectID recipByHash <- hashLocalActor recipByID let sieve = makeRecipientSet [] [localActorFollowers recipByHash] - grantInfo <- do + maybeGrant <- + case idsForGrant of - -- Enable the Collab in our DB - grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now - lift $ insert_ $ CollabEnable collabID grantID + -- In collab mode, prepare a regular Grant + Left (collabID, inviterOrJoiner, collab, grantID) -> lift $ do + let isInvite = isLeft collab + grant@(actionGrant, _, _, _) <- do + Collab role <- getJust collabID + prepareCollabGrant isInvite inviterOrJoiner role + let recipByKey = LocalActorProject projectID + _luGrant <- updateOutboxItem' recipByKey grantID actionGrant + return $ Just (grantID, grant) - -- Prepare a Grant activity and insert to my outbox - let isInvite = isLeft fulfills - grant@(actionGrant, _, _, _) <- do - Collab role <- lift $ getJust collabID - lift $ prepareGrant isInvite inviterOrJoiner role - let recipByKey = grantResourceLocalActor $ GrantResourceProject projectID - _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant - return (grantID, grant) + -- In Invite-component mode, only if the Accept author is + -- the component, prepare a delegator-Grant + -- + -- In Add-component mode, only if the Accept author isn't + -- the component, prepare a delegator-Grant + Right comp -> for comp $ \ (_componentID, ident, grantID, enableID, includeAuthor) -> lift $ do + grant@(actionGrant, _, _, _) <- + prepareDelegGrant (bimap snd snd ident) enableID includeAuthor + let recipByKey = LocalActorProject projectID + _luGrant <- updateOutboxItem' recipByKey grantID actionGrant + return (grantID, grant) - return (recipActorID, sieve, grantInfo) + return (recipActorID, sieve, maybeGrant) case maybeNew of Nothing -> done "I already have this activity in my inbox" - Just (recipActorID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do - let recipByID = grantResourceLocalActor $ GrantResourceProject projectID + Just (recipActorID, sieve, maybeGrant) -> do + let recipByID = LocalActorProject projectID forwardActivity authorIdMsig body recipByID recipActorID sieve - lift $ sendActivity - recipByID recipActorID localRecipsGrant - remoteRecipsGrant fwdHostsGrant grantID actionGrant - done "Forwarded the Accept and published a Grant" + lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> + sendActivity + recipByID recipActorID localRecipsGrant + remoteRecipsGrant fwdHostsGrant grantID actionGrant + done "Forwarded the Accept and maybe published a Grant" where @@ -331,16 +450,50 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do (,remoteActorFollowers actor) <$> getRemoteActorURI actor return (collabID, Right fulfillsID, Right joiner) - {- - tryInviteComp (Left (actorByKey, _actorEntity, itemID)) = do - ComponentOriginInvite - ComponentProjectGestureLocal - tryInviteCollab (Right remoteActivityID) = do - ComponentOriginInvite - ComponentProjectGestureRemote - -} + verifyCompTopic :: ComponentId -> ActDBE () + verifyCompTopic componentID = do + Component j _ <- lift $ getJust componentID + unless (j == projectID) $ + throwE "Accept object is an Invite/Add for some other project" - prepareGrant isInvite sender role = do + tryInviteComp (Left (actorByKey, _actorEntity, itemID)) = do + ComponentProjectGestureLocal componentID _ <- + lift $ MaybeT $ getValBy $ + UniqueComponentProjectGestureLocalActivity itemID + _ <- lift $ MaybeT $ getBy $ UniqueComponentOriginInvite componentID + ExceptT $ lift $ runExceptT $ verifyCompTopic componentID + ident <- lift $ lift $ getComponentIdent componentID + return (componentID, ident, Left ()) + tryInviteComp (Right remoteActivityID) = do + ComponentProjectGestureRemote componentID _ _ <- + lift $ MaybeT $ getValBy $ + UniqueComponentProjectGestureRemoteActivity remoteActivityID + _ <- lift $ MaybeT $ getBy $ UniqueComponentOriginInvite componentID + ExceptT $ lift $ runExceptT $ verifyCompTopic componentID + ident <- lift $ lift $ getComponentIdent componentID + return (componentID, ident, Left ()) + + tryAddComp (Left (actorByKey, _actorEntity, itemID)) = do + ComponentGestureLocal originID _ <- + lift $ MaybeT $ getValBy $ UniqueComponentGestureLocalAdd itemID + ComponentOriginAdd componentID <- lift $ lift $ getJust originID + ExceptT $ lift $ runExceptT $ verifyCompTopic componentID + ident <- lift $ lift $ getComponentIdent componentID + return (componentID, ident, Right ()) + tryAddComp (Right remoteActivityID) = do + ComponentGestureRemote originID _ _ <- + lift $ MaybeT $ getValBy $ + UniqueComponentGestureRemoteAdd remoteActivityID + ComponentOriginAdd componentID <- lift $ lift $ getJust originID + ExceptT $ lift $ runExceptT $ verifyCompTopic componentID + ident <- lift $ lift $ getComponentIdent componentID + return (componentID, ident, Right ()) + + componentIsAuthor ident = + let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig + in author == bimap (componentActor . snd) snd ident + + prepareCollabGrant isInvite sender role = do encodeRouteHome <- getEncodeRouteHome encodeRouteLocal <- getEncodeRouteLocal @@ -382,7 +535,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do , AP.actionAudience = AP.Audience recips [] [] [] [] [] , AP.actionFulfills = [AP.acceptObject accept] , AP.actionSpecific = AP.GrantActivity AP.Grant - { AP.grantObject = role + { AP.grantObject = AP.RXRole role , AP.grantContext = encodeRouteLocal $ renderLocalActor topicByHash , AP.grantTarget = @@ -402,6 +555,57 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do return (action, recipientSet, remoteActors, fwdHosts) + prepareDelegGrant ident _enableID includeAuthor = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + (uComponent, audComponent) <- + case ident of + Left c -> do + a <- componentActor <$> hashComponent c + return + ( encodeRouteHome $ renderLocalActor a + , AudLocal [a] [localActorFollowers a] + ) + Right raID -> do + ra <- getJust raID + u@(ObjURI h lu) <- getRemoteActorURI ra + return + ( u + , AudRemote h [lu] (maybeToList $ remoteActorFollowers ra) + ) + audAuthor <- lift $ makeAudSenderOnly authorIdMsig + projectHash <- encodeKeyHashid projectID + let audProject = AudLocal [] [LocalStageProjectFollowers projectHash] + + audience = + if includeAuthor + then [audComponent, audProject, audAuthor] + else [audComponent, audProject] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience audience + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [AP.acceptObject accept] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXDelegator + , AP.grantContext = encodeRouteLocal $ ProjectR projectHash + , AP.grantTarget = uComponent + , AP.grantResult = Nothing + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Invoke + , AP.grantDelegates = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + checkExistingComponents :: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE () checkExistingComponents projectID componentDB = do diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 1c9d0fe..161aa16 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -253,7 +253,7 @@ parseGrant :: Host -> AP.Grant URIMode -> ActE - ( AP.Role + ( AP.RoleExt , Either (GrantResourceBy Key) LocalURI , Either (GrantRecipBy Key) FedURI , Maybe (LocalURI, Maybe Int) diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 2c1d7bf..c62662b 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -26,6 +26,8 @@ module Vervis.Persist.Collab , verifyCapability' , getGrant + + , getComponentIdent ) where @@ -356,3 +358,38 @@ getGrant topicCollabField topicActorField resourceID personID = do [] -> return Nothing [E.Value i] -> return $ Just i _ -> error $ "Multiple grants for a Person in resource#" ++ show resourceID + +getComponentIdent + :: MonadIO m + => ComponentId + -> ReaderT SqlBackend m + (Either + (ComponentLocalId, ComponentBy Key) + (ComponentRemoteId, RemoteActorId) + ) +getComponentIdent componentID = do + ident <- + requireEitherAlt + (getKeyBy $ UniqueComponentLocal componentID) + (getBy $ UniqueComponentRemote componentID) + "Found Component without ident" + "Found Component with both local and remote ident" + bitraverse + (\ localID -> do + maybeRepo <- getValBy $ UniqueComponentLocalRepo localID + maybeDeck <- getValBy $ UniqueComponentLocalDeck localID + maybeLoom <- getValBy $ UniqueComponentLocalLoom localID + fmap (localID,) $ return $ + case (maybeRepo, maybeDeck, maybeLoom) of + (Nothing, Nothing, Nothing) -> + error "Found ComponentLocal without ident" + (Just r, Nothing, Nothing) -> + ComponentRepo $ componentLocalRepoRepo r + (Nothing, Just d, Nothing) -> + ComponentDeck $ componentLocalDeckDeck d + (Nothing, Nothing, Just l) -> + ComponentLoom $ componentLocalLoomLoom l + _ -> error "Found ComponentLocal with multiple idents" + ) + (\ (Entity k v) -> pure (k, componentRemoteActor v)) + ident diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 7488079..853564f 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -67,6 +67,7 @@ module Web.ActivityPub , Commit (..) , Branch (..) , Role (..) + , RoleExt (..) , Duration (..) , Usage (..) @@ -1623,16 +1624,16 @@ data Role = RoleVisit | RoleReport | RoleTriage | RoleWrite | RoleMaintain | RoleAdmin deriving (Show, Read, Eq, Ord, Enum, Bounded) +parseRole "visit" = pure RoleVisit +parseRole "report" = pure RoleReport +parseRole "triage" = pure RoleTriage +parseRole "write" = pure RoleWrite +parseRole "maintain" = pure RoleMaintain +parseRole "admin" = pure RoleAdmin +parseRole t = fail $ "Unknown role: " ++ T.unpack t + instance FromJSON Role where - parseJSON = withText "Role" parse - where - parse "visit" = pure RoleVisit - parse "report" = pure RoleReport - parse "triage" = pure RoleTriage - parse "write" = pure RoleWrite - parse "maintain" = pure RoleMaintain - parse "admin" = pure RoleAdmin - parse t = fail $ "Unknown role: " ++ T.unpack t + parseJSON = withText "Role" parseRole instance ToJSON Role where toJSON = error "toJSON Role" @@ -1645,6 +1646,21 @@ instance ToJSON Role where RoleMaintain -> "maintain" RoleAdmin -> "admin" +data RoleExt = RXRole Role | RXDelegator deriving (Show, Read, Eq) + +instance FromJSON RoleExt where + parseJSON = withText "RoleExt" parse + where + parse "delegator" = pure RXDelegator + parse t = RXRole <$> parseRole t + +instance ToJSON RoleExt where + toJSON = error "toJSON RoleExt" + toEncoding r = + case r of + RXRole role -> toEncoding role + RXDelegator -> toEncoding ("delegator" :: Text) + data Duration = Duration Int instance FromJSON Duration where @@ -1851,7 +1867,7 @@ encodeFollow (Follow obj mcontext hide) <> "hide" .= hide data Grant u = Grant - { grantObject :: Role + { grantObject :: RoleExt , grantContext :: LocalURI , grantTarget :: ObjURI u , grantResult :: Maybe (LocalURI, Maybe Duration)