diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 5c76550..c69845a 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 320ae96..e149d51 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -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"