Add activity types Follow, Accept, Reject

This commit is contained in:
fr33domlover 2019-03-13 23:37:58 +00:00
parent a8bb43255f
commit 24c091a248
2 changed files with 101 additions and 32 deletions

View file

@ -143,10 +143,10 @@ postInboxR = do
_ -> Left "More than one Content-Type given" _ -> Left "More than one Content-Type given"
HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now
(h, luActor) <- f2l <$> liftE result (h, luActor) <- f2l <$> liftE result
d@(Doc h' (CreateActivity c)) <- requireJsonBody d@(Doc h' a) <- requireJsonBody
unless (h == h') $ unless (h == h') $
throwE "Activity host doesn't match signature key host" throwE "Activity host doesn't match signature key host"
unless (createActor c == luActor) $ unless (activityActor a == luActor) $
throwE "Activity's actor != Signature key's actor" throwE "Activity's actor != Signature key's actor"
return (contentType, d) return (contentType, d)
@ -218,14 +218,16 @@ postOutboxR = do
(h, actor) = f2l $ route2uri $ SharerR shr (h, actor) = f2l $ route2uri $ SharerR shr
actorID = renderUrl $ SharerR shr actorID = renderUrl $ SharerR shr
appendPath u t = u { luriPath = luriPath u <> t } appendPath u t = u { luriPath = luriPath u <> t }
activity = CreateActivity Create activity = Activity
{ createId = appendPath actor "/fake-activity" { activityId = appendPath actor "/fake-activity"
, createTo = to , activityActor = actor
, createActor = actor , activitySpecific = CreateActivity Create
, createObject = Note { createTo = to
{ noteId = appendPath actor "/fake-note" , createObject = Note
, noteReplyTo = Nothing { noteId = appendPath actor "/fake-note"
, noteContent = msg , noteReplyTo = Nothing
, noteContent = msg
}
} }
} }
manager <- getsYesod appHttpManager manager <- getsYesod appHttpManager

View file

@ -34,7 +34,11 @@ module Web.ActivityPub
-- * Activity -- * Activity
, Note (..) , Note (..)
, Accept (..)
, Create (..) , Create (..)
, Follow (..)
, Reject (..)
, SpecificActivity (..)
, Activity (..) , Activity (..)
-- * Utilities -- * Utilities
@ -330,24 +334,28 @@ encodeNote host (Note id_ mreply content) attrib to =
<> "inReplyTo" .=? mreply <> "inReplyTo" .=? mreply
<> "content" .= content <> "content" .= content
data Accept = Accept
{ acceptObject :: FedURI
}
parseAccept :: Object -> Parser Accept
parseAccept o = Accept <$> o .: "object"
encodeAccept :: Accept -> Series
encodeAccept (Accept obj) = "object" .= obj
data Create = Create data Create = Create
{ createId :: LocalURI { createTo :: FedURI
, createTo :: FedURI
, createActor :: LocalURI
, createObject :: Note , createObject :: Note
} }
parseCreate :: Object -> Parser (Text, Create) parseCreate :: Object -> Text -> LocalURI -> Parser Create
parseCreate o = do parseCreate o h luActor = do
typ <- o .: "type"
unless (typ == ("Create" :: Text)) $ fail "type isn't Create"
(h, id_) <- f2l <$> o .: "id"
luActor <- withHost h $ f2l <$> o .: "actor"
(note, luAttrib, uTo) <- withHost h $ parseNote =<< o .: "object" (note, luAttrib, uTo) <- withHost h $ parseNote =<< o .: "object"
unless (luActor == luAttrib) $ fail "Create actor != Note attrib" unless (luActor == luAttrib) $ fail "Create actor != Note attrib"
uTo' <- o .: "to" uTo' <- o .: "to"
unless (uTo == uTo') $ fail "Create to != Note to" unless (uTo == uTo') $ fail "Create to != Note to"
return (h, Create id_ uTo luActor note) return $ Create uTo note
where where
withHost h a = do withHost h a = do
(h', v) <- a (h', v) <- a
@ -355,24 +363,83 @@ parseCreate o = do
then return v then return v
else fail "URI host mismatch" else fail "URI host mismatch"
encodeCreate :: Text -> Create -> Series encodeCreate :: Text -> LocalURI -> Create -> Series
encodeCreate host (Create id_ to actor obj) encodeCreate host actor (Create to obj)
= "type" .= ("Create" :: Text) = "to" .= to
<> "id" .= l2f host id_
<> "to" .= to
<> "actor" .= l2f host actor
<> "object" `pair` encodeNote host obj actor to <> "object" `pair` encodeNote host obj actor to
data Activity = CreateActivity Create data Follow = Follow
{ followObject :: FedURI
, followHide :: Bool
}
parseFollow :: Object -> Parser Follow
parseFollow o =
Follow
<$> o .: "object"
<*> o .: (frg <> "hide")
encodeFollow :: Follow -> Series
encodeFollow (Follow obj hide)
= "object" .= obj
<> (frg <> "hide") .= hide
data Reject = Reject
{ rejectObject :: FedURI
}
parseReject :: Object -> Parser Reject
parseReject o = Reject <$> o .: "object"
encodeReject :: Reject -> Series
encodeReject (Reject obj) = "object" .= obj
data SpecificActivity
= AcceptActivity Accept
| CreateActivity Create
| FollowActivity Follow
| RejectActivity Reject
data Activity = Activity
{ activityId :: LocalURI
, activityActor :: LocalURI
, activitySpecific :: SpecificActivity
}
instance ActivityPub Activity where instance ActivityPub Activity where
jsonldContext _ = ContextAS2 jsonldContext _ = ContextAS2
parseObject o = do parseObject o = do
typ <- o .: "type" (h, id_) <- f2l <$> o .: "id"
case typ of actor <- withHost h $ f2l <$> o .: "actor"
"Create" -> second CreateActivity <$> parseCreate o (,) h . Activity id_ actor <$> do
_ -> fail $ "Unrecognized activity type: " ++ T.unpack typ typ <- o .: "type"
toSeries host (CreateActivity c) = encodeCreate host c case typ of
"Accept" -> AcceptActivity <$> parseAccept o
"Create" -> CreateActivity <$> parseCreate o h actor
"Follow" -> FollowActivity <$> parseFollow o
"Reject" -> RejectActivity <$> parseReject o
_ -> fail $ "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 specific)
= "type" .= activityType specific
<> "id" .= l2f host id_
<> "actor" .= l2f host actor
<> encodeSpecific host actor specific
where
activityType :: SpecificActivity -> Text
activityType (AcceptActivity _) = "Accept"
activityType (CreateActivity _) = "Create"
activityType (FollowActivity _) = "Follow"
activityType (RejectActivity _) = "Reject"
encodeSpecific _ _ (AcceptActivity a) = encodeAccept a
encodeSpecific h u (CreateActivity a) = encodeCreate h u a
encodeSpecific _ _ (FollowActivity a) = encodeFollow a
encodeSpecific _ _ (RejectActivity a) = encodeReject a
typeActivityStreams2 :: ContentType typeActivityStreams2 :: ContentType
typeActivityStreams2 = "application/activity+json" typeActivityStreams2 = "application/activity+json"