diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index c69845a..a2ca2b3 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -69,7 +69,7 @@ import qualified Data.CaseInsensitive as CI (mk) import qualified Data.HashMap.Strict as M (lookup, insert, adjust, fromList) import qualified Data.Text as T (pack, unpack, concat) import qualified Data.Text.Lazy as TL (toStrict) -import qualified Data.Vector as V (length, cons, init) +import qualified Data.Vector as V import qualified Network.Wai as W (requestMethod, rawPathInfo, requestHeaders) import Network.HTTP.Signature hiding (Algorithm (..)) @@ -221,9 +221,15 @@ postOutboxR = do activity = Activity { activityId = appendPath actor "/fake-activity" , activityActor = actor + , activityAudience = Audience + { audienceTo = V.singleton to + , audienceBto = V.empty + , audienceCc = V.empty + , audienceBcc = V.empty + , audienceGeneral = V.empty + } , activitySpecific = CreateActivity Create - { createTo = to - , createObject = Note + { createObject = Note { noteId = appendPath actor "/fake-note" , noteReplyTo = Nothing , noteContent = msg diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index e149d51..d69ef3d 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -38,6 +38,7 @@ module Web.ActivityPub , Create (..) , Follow (..) , Reject (..) + , Audience (..) , SpecificActivity (..) , Activity (..) @@ -79,6 +80,7 @@ import Data.Semigroup (Endo, First (..)) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Time.Clock (UTCTime) +import Data.Vector (Vector) import Network.HTTP.Client hiding (Proxy, proxy) import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither) import Network.HTTP.Client.Signature (signRequest) @@ -91,7 +93,7 @@ import Yesod.Core.Handler (ProvidedRep, provideRepType) import qualified Data.ByteString.Char8 as BC import qualified Data.HashMap.Strict as M (lookup) import qualified Data.Text as T (pack, unpack) -import qualified Data.Vector as V (fromList, toList) +import qualified Data.Vector as V import qualified Network.HTTP.Signature as S import Crypto.PublicVerifKey @@ -305,18 +307,17 @@ data Note = Note , noteContent :: Text } -parseNote :: Value -> Parser (Text, (Note, LocalURI, FedURI)) +parseNote :: Value -> Parser (Text, (Note, LocalURI)) parseNote = withObject "Note" $ \ o -> do typ <- o .: "type" unless (typ == ("Note" :: Text)) $ fail "type isn't Note" (h, id_) <- f2l <$> o .: "id" fmap (h,) $ - (,,) <$> (Note id_ + (,) <$> (Note id_ <$> o .:? "inReplyTo" <*> o .: "content" - ) - <*> withHost h (f2l <$> o .: "attributedTo") - <*> o .: "to" + ) + <*> withHost h (f2l <$> o .: "attributedTo") where withHost h a = do (h', v) <- a @@ -324,13 +325,12 @@ parseNote = withObject "Note" $ \ o -> do then return v else fail "URI host mismatch" -encodeNote :: Text -> Note -> LocalURI -> FedURI -> Encoding -encodeNote host (Note id_ mreply content) attrib to = +encodeNote :: Text -> Note -> LocalURI -> Encoding +encodeNote host (Note id_ mreply content) attrib = pairs $ "type" .= ("Note" :: Text) <> "id" .= l2f host id_ <> "attributedTo" .= l2f host attrib - <> "to" .= to <> "inReplyTo" .=? mreply <> "content" .= content @@ -345,17 +345,14 @@ encodeAccept :: Accept -> Series encodeAccept (Accept obj) = "object" .= obj data Create = Create - { createTo :: FedURI - , createObject :: Note + { createObject :: Note } parseCreate :: Object -> Text -> LocalURI -> Parser Create parseCreate o h luActor = do - (note, luAttrib, uTo) <- withHost h $ parseNote =<< o .: "object" + (note, luAttrib) <- 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 $ Create uTo note + return $ Create note where withHost h a = do (h', v) <- a @@ -364,9 +361,8 @@ parseCreate o h luActor = do else fail "URI host mismatch" encodeCreate :: Text -> LocalURI -> Create -> Series -encodeCreate host actor (Create to obj) - = "to" .= to - <> "object" `pair` encodeNote host obj actor to +encodeCreate host actor (Create obj) = + "object" `pair` encodeNote host obj actor data Follow = Follow { followObject :: FedURI @@ -394,6 +390,36 @@ parseReject o = Reject <$> o .: "object" encodeReject :: Reject -> Series encodeReject (Reject obj) = "object" .= obj +data Audience = Audience + { audienceTo :: Vector FedURI + , audienceBto :: Vector FedURI + , audienceCc :: Vector FedURI + , audienceBcc :: Vector FedURI + , audienceGeneral :: Vector FedURI + } + +parseAudience :: Object -> Parser Audience +parseAudience o = + Audience + <$> o .:? "to" .!= V.empty + <*> o .:? "bto" .!= V.empty + <*> o .:? "cc" .!= V.empty + <*> o .:? "bcc" .!= V.empty + <*> o .:? "audience" .!= V.empty + +encodeAudience :: Audience -> Series +encodeAudience (Audience to bto cc bcc aud) + = "to" .=% to + <> "bto" .=% bto + <> "cc" .=% cc + <> "bcc" .=% bcc + <> "audience" .=% aud + where + t .=% v = + if V.null v + then mempty + else t .= v + data SpecificActivity = AcceptActivity Accept | CreateActivity Create @@ -403,6 +429,7 @@ data SpecificActivity data Activity = Activity { activityId :: LocalURI , activityActor :: LocalURI + , activityAudience :: Audience , activitySpecific :: SpecificActivity } @@ -411,24 +438,30 @@ instance ActivityPub Activity where parseObject o = do (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 + fmap (h,) $ + Activity id_ actor + <$> parseAudience o + <*> 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) + toSeries host (Activity id_ actor audience specific) = "type" .= activityType specific <> "id" .= l2f host id_ <> "actor" .= l2f host actor + <> encodeAudience audience <> encodeSpecific host actor specific where activityType :: SpecificActivity -> Text