forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Wrap AP Ticket in an Offer activity, this is how tickets will be created

Browse source
This commit is contained in:
fr33domlover 2019-06-06 14:16:48 +00:00
parent b69442b448
commit d73b113b4f
1 changed files with 29 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

35
src/Web/ActivityPub.hs
View file

@ -48,6 +48,7 @@ module Web.ActivityPub
, Accept (..) , Accept (..)
, Create (..) , Create (..)
, Follow (..) , Follow (..)
, Offer (..)
, Reject (..) , Reject (..)
, Audience (..) , Audience (..)
, SpecificActivity (..) , SpecificActivity (..)
@ -776,6 +777,30 @@ encodeFollow (Follow obj hide)
= "object" .= obj = "object" .= obj
<> (frg <> "hide") .= hide <> (frg <> "hide") .= hide
data Offer = Offer
{ offerObject :: Ticket
, offerTarget :: FedURI
}
parseOffer :: Object -> Text -> LocalURI -> Parser Offer
parseOffer o h luActor = do
ticket <- withHost h $ parseObject =<< o .: "object"
unless (luActor == ticketAttributedTo ticket) $
fail "Offer actor != Ticket attrib"
target <- o .: "target"
for_ (ticketLocal ticket) $ \ (host, local) -> do
let (hTarget, luTarget) = f2l target
unless (hTarget == host) $
fail "Offer target host != Ticket local host"
unless (luTarget == ticketContext local) $
fail "Offer target != Ticket context"
return $ Offer ticket target
encodeOffer :: Text -> LocalURI -> Offer -> Series
encodeOffer host actor (Offer obj target)
= "object" `pair` pairs (toSeries host obj)
<> "target" .= target
data Reject = Reject data Reject = Reject
{ rejectObject :: FedURI { rejectObject :: FedURI
} }
@ -790,6 +815,7 @@ data SpecificActivity
= AcceptActivity Accept = AcceptActivity Accept
| CreateActivity Create | CreateActivity Create
| FollowActivity Follow | FollowActivity Follow
| OfferActivity Offer
| RejectActivity Reject | RejectActivity Reject
data Activity = Activity data Activity = Activity
@ -813,16 +839,11 @@ instance ActivityPub Activity where
"Accept" -> AcceptActivity <$> parseAccept o "Accept" -> AcceptActivity <$> parseAccept o
"Create" -> CreateActivity <$> parseCreate o h actor "Create" -> CreateActivity <$> parseCreate o h actor
"Follow" -> FollowActivity <$> parseFollow o "Follow" -> FollowActivity <$> parseFollow o
"Offer" -> OfferActivity <$> parseOffer o h actor
"Reject" -> RejectActivity <$> parseReject o "Reject" -> RejectActivity <$> parseReject o
_ -> _ ->
fail $ fail $
"Unrecognized activity type: " ++ T.unpack typ "Unrecognized activity type: " ++ T.unpack typ
where
withHost h a = do
(h', v) <- a
if h == h'
then return v
else fail "URI host mismatch"
toSeries host (Activity id_ actor audience specific) toSeries host (Activity id_ actor audience specific)
= "type" .= activityType specific = "type" .= activityType specific
<> "id" .= l2f host id_ <> "id" .= l2f host id_
@ -834,10 +855,12 @@ instance ActivityPub Activity where
activityType (AcceptActivity _) = "Accept" activityType (AcceptActivity _) = "Accept"
activityType (CreateActivity _) = "Create" activityType (CreateActivity _) = "Create"
activityType (FollowActivity _) = "Follow" activityType (FollowActivity _) = "Follow"
activityType (OfferActivity _) = "Offer"
activityType (RejectActivity _) = "Reject" activityType (RejectActivity _) = "Reject"
encodeSpecific _ _ (AcceptActivity a) = encodeAccept a encodeSpecific _ _ (AcceptActivity a) = encodeAccept a
encodeSpecific h u (CreateActivity a) = encodeCreate h u a encodeSpecific h u (CreateActivity a) = encodeCreate h u a
encodeSpecific _ _ (FollowActivity a) = encodeFollow a encodeSpecific _ _ (FollowActivity a) = encodeFollow a
encodeSpecific h u (OfferActivity a) = encodeOffer h u a
encodeSpecific _ _ (RejectActivity a) = encodeReject a encodeSpecific _ _ (RejectActivity a) = encodeReject a
typeActivityStreams2 :: ContentType typeActivityStreams2 :: ContentType