Web.ActivityPub: Add grantResult
field, with optional duration
This commit is contained in:
parent
906b5e8f44
commit
a22aeb85d0
5 changed files with 78 additions and 23 deletions
|
@ -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
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue