Add activity types Follow, Accept, Reject
This commit is contained in:
fr33domlover
parent
a8bb43255f
commit
24c091a248
2 changed files with 101 additions and 32 deletions
|
|
@ -143,10 +143,10 @@ postInboxR = do
|
|||
_ -> Left "More than one Content-Type given"
|
||||
HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now
|
||||
(h, luActor) <- f2l <$> liftE result
|
||||
d@(Doc h' (CreateActivity c)) <- requireJsonBody
|
||||
d@(Doc h' a) <- requireJsonBody
|
||||
unless (h == h') $
|
||||
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"
|
||||
return (contentType, d)
|
||||
|
||||
|
|
@ -218,14 +218,16 @@ postOutboxR = do
|
|||
(h, actor) = f2l $ route2uri $ SharerR shr
|
||||
actorID = renderUrl $ SharerR shr
|
||||
appendPath u t = u { luriPath = luriPath u <> t }
|
||||
activity = CreateActivity Create
|
||||
{ createId = appendPath actor "/fake-activity"
|
||||
, createTo = to
|
||||
, createActor = actor
|
||||
, createObject = Note
|
||||
{ noteId = appendPath actor "/fake-note"
|
||||
, noteReplyTo = Nothing
|
||||
, noteContent = msg
|
||||
activity = Activity
|
||||
{ activityId = appendPath actor "/fake-activity"
|
||||
, activityActor = actor
|
||||
, activitySpecific = CreateActivity Create
|
||||
{ createTo = to
|
||||
, createObject = Note
|
||||
{ noteId = appendPath actor "/fake-note"
|
||||
, noteReplyTo = Nothing
|
||||
, noteContent = msg
|
||||
}
|
||||
}
|
||||
}
|
||||
manager <- getsYesod appHttpManager
|
||||
|
|
|
|||
|
|
@ -34,7 +34,11 @@ module Web.ActivityPub
|
|||
|
||||
-- * Activity
|
||||
, Note (..)
|
||||
, Accept (..)
|
||||
, Create (..)
|
||||
, Follow (..)
|
||||
, Reject (..)
|
||||
, SpecificActivity (..)
|
||||
, Activity (..)
|
||||
|
||||
-- * Utilities
|
||||
|
|
@ -330,24 +334,28 @@ encodeNote host (Note id_ mreply content) attrib to =
|
|||
<> "inReplyTo" .=? mreply
|
||||
<> "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
|
||||
{ createId :: LocalURI
|
||||
, createTo :: FedURI
|
||||
, createActor :: LocalURI
|
||||
{ createTo :: FedURI
|
||||
, createObject :: Note
|
||||
}
|
||||
|
||||
parseCreate :: Object -> Parser (Text, Create)
|
||||
parseCreate o = do
|
||||
typ <- o .: "type"
|
||||
unless (typ == ("Create" :: Text)) $ fail "type isn't Create"
|
||||
(h, id_) <- f2l <$> o .: "id"
|
||||
luActor <- withHost h $ f2l <$> o .: "actor"
|
||||
parseCreate :: Object -> Text -> LocalURI -> Parser Create
|
||||
parseCreate o h luActor = do
|
||||
(note, luAttrib, uTo) <- withHost h $ parseNote =<< o .: "object"
|
||||
unless (luActor == luAttrib) $ fail "Create actor != Note attrib"
|
||||
uTo' <- o .: "to"
|
||||
unless (uTo == uTo') $ fail "Create to != Note to"
|
||||
return (h, Create id_ uTo luActor note)
|
||||
return $ Create uTo note
|
||||
where
|
||||
withHost h a = do
|
||||
(h', v) <- a
|
||||
|
|
@ -355,24 +363,83 @@ parseCreate o = do
|
|||
then return v
|
||||
else fail "URI host mismatch"
|
||||
|
||||
encodeCreate :: Text -> Create -> Series
|
||||
encodeCreate host (Create id_ to actor obj)
|
||||
= "type" .= ("Create" :: Text)
|
||||
<> "id" .= l2f host id_
|
||||
<> "to" .= to
|
||||
<> "actor" .= l2f host actor
|
||||
encodeCreate :: Text -> LocalURI -> Create -> Series
|
||||
encodeCreate host actor (Create to obj)
|
||||
= "to" .= 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
|
||||
jsonldContext _ = ContextAS2
|
||||
parseObject o = do
|
||||
typ <- o .: "type"
|
||||
case typ of
|
||||
"Create" -> second CreateActivity <$> parseCreate o
|
||||
_ -> fail $ "Unrecognized activity type: " ++ T.unpack typ
|
||||
toSeries host (CreateActivity c) = encodeCreate host c
|
||||
(h, id_) <- f2l <$> o .: "id"
|
||||
actor <- withHost h $ f2l <$> o .: "actor"
|
||||
(,) h . Activity id_ actor <$> do
|
||||
typ <- o .: "type"
|
||||
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 = "application/activity+json"
|
||||
|
|
|
|||
Loading…
Reference in a new issue