From a22aeb85d09b9207f2d1f3ac1ca546fbd319be51 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Mon, 29 May 2023 09:50:17 +0300 Subject: [PATCH] Web.ActivityPub: Add `grantResult` field, with optional duration --- src/Vervis/API.hs | 16 +++++++--- src/Vervis/Actor/Person.hs | 6 ++-- src/Vervis/Data/Collab.hs | 20 ++++++++---- src/Vervis/Federation/Collab.hs | 4 ++- src/Web/ActivityPub.hs | 55 +++++++++++++++++++++++++++------ 5 files changed, 78 insertions(+), 23 deletions(-) diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 5cfdc82..4b00b23 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -336,6 +336,7 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re ) prepareGrant recipHash sender topic = do encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal topicHash <- grantResourceLocalActor <$> hashGrantResource topic @@ -362,8 +363,9 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re , actionFulfills = [AP.acceptObject accept] , actionSpecific = GrantActivity Grant { grantObject = Left RoleAdmin - , grantContext = encodeRouteHome $ renderLocalActor topicHash + , grantContext = encodeRouteLocal $ renderLocalActor topicHash , grantTarget = encodeRouteHome $ PersonR recipHash + , grantResult = Nothing } } @@ -1133,6 +1135,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips prepareGrant adminHash loomHash obiidCreate actors stages = do encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal obikhidCreate <- encodeKeyHashid obiidCreate let recips = map encodeRouteHome $ @@ -1146,8 +1149,9 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] , actionSpecific = GrantActivity Grant { grantObject = Left RoleAdmin - , grantContext = encodeRouteHome $ LoomR loomHash + , grantContext = encodeRouteLocal $ LoomR loomHash , grantTarget = encodeRouteHome $ PersonR adminHash + , grantResult = Nothing } } @@ -1355,6 +1359,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r prepareGrant adminHash repoHash obiidCreate actors stages = do encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal obikhidCreate <- encodeKeyHashid obiidCreate let recips = map encodeRouteHome $ @@ -1368,8 +1373,9 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] , actionSpecific = GrantActivity Grant { grantObject = Left RoleAdmin - , grantContext = encodeRouteHome $ RepoR repoHash + , grantContext = encodeRouteLocal $ RepoR repoHash , grantTarget = encodeRouteHome $ PersonR adminHash + , grantResult = Nothing } } @@ -1603,6 +1609,7 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip prepareGrant adminHash deckHash obiidCreate actors stages = do encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal obikhidCreate <- encodeKeyHashid obiidCreate let recips = map encodeRouteHome $ @@ -1616,8 +1623,9 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip [encodeRouteHome $ PersonOutboxItemR adminHash obikhidCreate] , actionSpecific = GrantActivity Grant { grantObject = Left RoleAdmin - , grantContext = encodeRouteHome $ DeckR deckHash + , grantContext = encodeRouteLocal $ DeckR deckHash , grantTarget = encodeRouteHome $ PersonR adminHash + , grantResult = Nothing } } diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index fc63521..631aa9d 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -164,12 +164,12 @@ personGrant now recipPersonID author body mfwd luGrant grant = do -- Check input (_remoteResource, recipient) <- do - (resource, recip) <- parseGrant grant let u@(ObjURI h _) = remoteAuthorURI author + (resource, recip, _mresult) <- parseGrant h grant resourceURI <- case resource of - Right (ObjURI h' r) | h == h' -> return (u, r) - _ -> throwE "Grant resource and Grant author are from different instances" + Right r -> return (u, r) + _ -> error "Remote Grant but parseGrant identified local resource" when (recip == Right u) $ throwE "Grant sender and target are the same remote actor" return (resourceURI, recip) diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index ec877f7..16caf16 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -156,20 +156,28 @@ parseJoin (AP.Join instrument object) = do nameExceptT "Join object" (parseTopic object) parseGrant - :: AP.Grant URIMode + :: Host + -> AP.Grant URIMode -> ActE - ( Either (GrantResourceBy Key) FedURI + ( Either (GrantResourceBy Key) LocalURI , Either (GrantRecipBy Key) FedURI + , Maybe (LocalURI, Maybe Int) ) -parseGrant (AP.Grant object context target) = do +parseGrant h (AP.Grant object context target mresult) = do verifyRole object - (,) <$> parseContext context + (,,) + <$> parseContext context <*> parseTarget target + <*> pure + (fmap + (\ (lu, md) -> (lu, (\ (AP.Duration i) -> i) <$> md)) + mresult + ) where verifyRole (Left AP.RoleAdmin) = pure () verifyRole (Right _) = throwE "ForgeFed Admin is the only role allowed currently" - parseContext u@(ObjURI h lu) = do + parseContext lu = do hl <- hostIsLocal h if hl then Left <$> do @@ -184,7 +192,7 @@ parseGrant (AP.Grant object context target) = do unhashGrantResourceE' resourceHash "Grant resource contains invalid hashid" - else pure $ Right u + else pure $ Right lu where parseGrantResource (RepoR r) = Just $ GrantResourceRepo r parseGrantResource (DeckR d) = Just $ GrantResourceDeck d diff --git a/src/Vervis/Federation/Collab.hs b/src/Vervis/Federation/Collab.hs index fea9c6b..7ee4ada 100644 --- a/src/Vervis/Federation/Collab.hs +++ b/src/Vervis/Federation/Collab.hs @@ -521,6 +521,7 @@ topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept ac prepareGrant sender = do encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal accepter <- getJust $ remoteAuthorId author let topicByHash = grantResourceLocalActor $ topicResource recipHash @@ -548,8 +549,9 @@ topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept ac , AP.actionFulfills = [AP.acceptObject accept] , AP.actionSpecific = AP.GrantActivity AP.Grant { AP.grantObject = Left AP.RoleAdmin - , AP.grantContext = encodeRouteHome $ renderLocalActor topicByHash + , AP.grantContext = encodeRouteLocal $ renderLocalActor topicByHash , AP.grantTarget = remoteAuthorURI author + , AP.grantResult = Nothing } } diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index e66f92a..4a77205 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -14,6 +14,8 @@ - . -} +{-# LANGUAGE StrictData #-} + module Web.ActivityPub ( -- * Type-safe manipulation tools -- @@ -60,6 +62,7 @@ module Web.ActivityPub , Commit (..) , Branch (..) , Role (..) + , Duration (..) -- * Activity , Accept (..) @@ -150,6 +153,7 @@ import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither) import Network.HTTP.Simple (JSONException) import Network.HTTP.Types.Header (HeaderName, hContentType) import Text.Email.Parser (EmailAddress) +import Text.Read (readMaybe) import Yesod.Core.Content (ContentType) import Yesod.Core.Handler (ProvidedRep, provideRepType) @@ -1491,6 +1495,26 @@ instance ToJSON Role where toEncoding $ case r of RoleAdmin -> "https://forgefed.org/ns#admin" :: Text +data Duration = Duration Int + +instance FromJSON Duration where + parseJSON = withText "Duration" parse + where + parse t = + case T.stripSuffix "S" =<< T.stripPrefix "PT" t of + Nothing -> fail $ "Not in PTS format: " ++ T.unpack t + Just t' -> + case readMaybe $ T.unpack t' of + Nothing -> fail $ "Not an Int: " ++ T.unpack t' + Just n -> do + guard $ n > 0 + return $ Duration n + +instance ToJSON Duration where + toJSON = error "toJSON Duration" + toEncoding (Duration i) = + toEncoding $ T.concat ["PT", T.pack $ show i, "S"] + data Accept u = Accept { acceptObject :: ObjURI u , acceptResult :: Maybe LocalURI @@ -1648,22 +1672,35 @@ encodeFollow (Follow obj mcontext hide) data Grant u = Grant { grantObject :: Either Role (ObjURI u) - , grantContext :: ObjURI u + , grantContext :: LocalURI , grantTarget :: ObjURI u + , grantResult :: Maybe (LocalURI, Maybe Duration) } -parseGrant :: UriMode u => Object -> Parser (Grant u) -parseGrant o = +parseGrant :: UriMode u => Authority u -> Object -> Parser (Grant u) +parseGrant h o = Grant <$> o .:+ "object" - <*> o .: "context" + <*> withAuthorityO h (o .: "context") <*> o .: "target" + <*> do mres <- o .:+? "result" + for mres $ \case + Left u -> (,Nothing) <$> withAuthorityO h (pure u) + Right r -> + (,) <$> withAuthorityO h (r .: "id") <*> r .:? "duration" -encodeGrant :: UriMode u => Grant u -> Series -encodeGrant (Grant obj context target) +encodeGrant :: UriMode u => Authority u -> Grant u -> Series +encodeGrant h (Grant obj context target mresult) = "object" .=+ obj - <> "context" .= context + <> "context" .= ObjURI h context <> "target" .= target + <> case mresult of + Nothing -> mempty + Just (result, mduration) -> + "result" `pair` pairs + ( "id" .= ObjURI h result + <> "duration" .=? mduration + ) data Invite u = Invite { inviteInstrument :: Either Role (ObjURI u) @@ -1891,7 +1928,7 @@ instance ActivityPub Activity where "Apply" -> ApplyActivity <$> parseApply o "Create" -> CreateActivity <$> parseCreate o a actor "Follow" -> FollowActivity <$> parseFollow o - "Grant" -> GrantActivity <$> parseGrant o + "Grant" -> GrantActivity <$> parseGrant a o "Invite" -> InviteActivity <$> parseInvite o "Join" -> JoinActivity <$> parseJoin o "Offer" -> OfferActivity <$> parseOffer o a actor @@ -1917,7 +1954,7 @@ instance ActivityPub Activity where encodeSpecific _ _ (ApplyActivity a) = encodeApply a encodeSpecific _ _ (CreateActivity a) = encodeCreate a encodeSpecific _ _ (FollowActivity a) = encodeFollow a - encodeSpecific _ _ (GrantActivity a) = encodeGrant a + encodeSpecific h _ (GrantActivity a) = encodeGrant h a encodeSpecific _ _ (InviteActivity a) = encodeInvite a encodeSpecific _ _ (JoinActivity a) = encodeJoin a encodeSpecific h u (OfferActivity a) = encodeOffer h u a