sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 03:14:53 +09:00
Code Issues Activity

Web.ActivityPub: Add grantResult field, with optional duration

Browse source
This commit is contained in:
Pere Lev 2023-05-29 09:50:17 +03:00
parent 906b5e8f44
commit a22aeb85d0
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
5 changed files with 78 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
src/Vervis/API.hs
View file

@ -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
}
}

6
src/Vervis/Actor/Person.hs
View file

@ -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)

20
src/Vervis/Data/Collab.hs
View file

@ -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

4
src/Vervis/Federation/Collab.hs
View file

@ -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
}
}

55
src/Web/ActivityPub.hs
View file

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