Parse/encoding audience targetting activity fields
This commit is contained in:
parent
24c091a248
commit
0e0afa78f9
2 changed files with 69 additions and 30 deletions
|
@ -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.HashMap.Strict as M (lookup, insert, adjust, fromList)
|
||||||
import qualified Data.Text as T (pack, unpack, concat)
|
import qualified Data.Text as T (pack, unpack, concat)
|
||||||
import qualified Data.Text.Lazy as TL (toStrict)
|
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 qualified Network.Wai as W (requestMethod, rawPathInfo, requestHeaders)
|
||||||
|
|
||||||
import Network.HTTP.Signature hiding (Algorithm (..))
|
import Network.HTTP.Signature hiding (Algorithm (..))
|
||||||
|
@ -221,9 +221,15 @@ postOutboxR = do
|
||||||
activity = Activity
|
activity = Activity
|
||||||
{ activityId = appendPath actor "/fake-activity"
|
{ activityId = appendPath actor "/fake-activity"
|
||||||
, activityActor = actor
|
, activityActor = actor
|
||||||
|
, activityAudience = Audience
|
||||||
|
{ audienceTo = V.singleton to
|
||||||
|
, audienceBto = V.empty
|
||||||
|
, audienceCc = V.empty
|
||||||
|
, audienceBcc = V.empty
|
||||||
|
, audienceGeneral = V.empty
|
||||||
|
}
|
||||||
, activitySpecific = CreateActivity Create
|
, activitySpecific = CreateActivity Create
|
||||||
{ createTo = to
|
{ createObject = Note
|
||||||
, createObject = Note
|
|
||||||
{ noteId = appendPath actor "/fake-note"
|
{ noteId = appendPath actor "/fake-note"
|
||||||
, noteReplyTo = Nothing
|
, noteReplyTo = Nothing
|
||||||
, noteContent = msg
|
, noteContent = msg
|
||||||
|
|
|
@ -38,6 +38,7 @@ module Web.ActivityPub
|
||||||
, Create (..)
|
, Create (..)
|
||||||
, Follow (..)
|
, Follow (..)
|
||||||
, Reject (..)
|
, Reject (..)
|
||||||
|
, Audience (..)
|
||||||
, SpecificActivity (..)
|
, SpecificActivity (..)
|
||||||
, Activity (..)
|
, Activity (..)
|
||||||
|
|
||||||
|
@ -79,6 +80,7 @@ import Data.Semigroup (Endo, First (..))
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
||||||
import Data.Time.Clock (UTCTime)
|
import Data.Time.Clock (UTCTime)
|
||||||
|
import Data.Vector (Vector)
|
||||||
import Network.HTTP.Client hiding (Proxy, proxy)
|
import Network.HTTP.Client hiding (Proxy, proxy)
|
||||||
import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
|
import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
|
||||||
import Network.HTTP.Client.Signature (signRequest)
|
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.ByteString.Char8 as BC
|
||||||
import qualified Data.HashMap.Strict as M (lookup)
|
import qualified Data.HashMap.Strict as M (lookup)
|
||||||
import qualified Data.Text as T (pack, unpack)
|
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 qualified Network.HTTP.Signature as S
|
||||||
|
|
||||||
import Crypto.PublicVerifKey
|
import Crypto.PublicVerifKey
|
||||||
|
@ -305,18 +307,17 @@ data Note = Note
|
||||||
, noteContent :: Text
|
, noteContent :: Text
|
||||||
}
|
}
|
||||||
|
|
||||||
parseNote :: Value -> Parser (Text, (Note, LocalURI, FedURI))
|
parseNote :: Value -> Parser (Text, (Note, LocalURI))
|
||||||
parseNote = withObject "Note" $ \ o -> do
|
parseNote = withObject "Note" $ \ o -> do
|
||||||
typ <- o .: "type"
|
typ <- o .: "type"
|
||||||
unless (typ == ("Note" :: Text)) $ fail "type isn't Note"
|
unless (typ == ("Note" :: Text)) $ fail "type isn't Note"
|
||||||
(h, id_) <- f2l <$> o .: "id"
|
(h, id_) <- f2l <$> o .: "id"
|
||||||
fmap (h,) $
|
fmap (h,) $
|
||||||
(,,) <$> (Note id_
|
(,) <$> (Note id_
|
||||||
<$> o .:? "inReplyTo"
|
<$> o .:? "inReplyTo"
|
||||||
<*> o .: "content"
|
<*> o .: "content"
|
||||||
)
|
)
|
||||||
<*> withHost h (f2l <$> o .: "attributedTo")
|
<*> withHost h (f2l <$> o .: "attributedTo")
|
||||||
<*> o .: "to"
|
|
||||||
where
|
where
|
||||||
withHost h a = do
|
withHost h a = do
|
||||||
(h', v) <- a
|
(h', v) <- a
|
||||||
|
@ -324,13 +325,12 @@ parseNote = withObject "Note" $ \ o -> do
|
||||||
then return v
|
then return v
|
||||||
else fail "URI host mismatch"
|
else fail "URI host mismatch"
|
||||||
|
|
||||||
encodeNote :: Text -> Note -> LocalURI -> FedURI -> Encoding
|
encodeNote :: Text -> Note -> LocalURI -> Encoding
|
||||||
encodeNote host (Note id_ mreply content) attrib to =
|
encodeNote host (Note id_ mreply content) attrib =
|
||||||
pairs
|
pairs
|
||||||
$ "type" .= ("Note" :: Text)
|
$ "type" .= ("Note" :: Text)
|
||||||
<> "id" .= l2f host id_
|
<> "id" .= l2f host id_
|
||||||
<> "attributedTo" .= l2f host attrib
|
<> "attributedTo" .= l2f host attrib
|
||||||
<> "to" .= to
|
|
||||||
<> "inReplyTo" .=? mreply
|
<> "inReplyTo" .=? mreply
|
||||||
<> "content" .= content
|
<> "content" .= content
|
||||||
|
|
||||||
|
@ -345,17 +345,14 @@ encodeAccept :: Accept -> Series
|
||||||
encodeAccept (Accept obj) = "object" .= obj
|
encodeAccept (Accept obj) = "object" .= obj
|
||||||
|
|
||||||
data Create = Create
|
data Create = Create
|
||||||
{ createTo :: FedURI
|
{ createObject :: Note
|
||||||
, createObject :: Note
|
|
||||||
}
|
}
|
||||||
|
|
||||||
parseCreate :: Object -> Text -> LocalURI -> Parser Create
|
parseCreate :: Object -> Text -> LocalURI -> Parser Create
|
||||||
parseCreate o h luActor = do
|
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"
|
unless (luActor == luAttrib) $ fail "Create actor != Note attrib"
|
||||||
uTo' <- o .: "to"
|
return $ Create note
|
||||||
unless (uTo == uTo') $ fail "Create to != Note to"
|
|
||||||
return $ Create uTo note
|
|
||||||
where
|
where
|
||||||
withHost h a = do
|
withHost h a = do
|
||||||
(h', v) <- a
|
(h', v) <- a
|
||||||
|
@ -364,9 +361,8 @@ parseCreate o h luActor = do
|
||||||
else fail "URI host mismatch"
|
else fail "URI host mismatch"
|
||||||
|
|
||||||
encodeCreate :: Text -> LocalURI -> Create -> Series
|
encodeCreate :: Text -> LocalURI -> Create -> Series
|
||||||
encodeCreate host actor (Create to obj)
|
encodeCreate host actor (Create obj) =
|
||||||
= "to" .= to
|
"object" `pair` encodeNote host obj actor
|
||||||
<> "object" `pair` encodeNote host obj actor to
|
|
||||||
|
|
||||||
data Follow = Follow
|
data Follow = Follow
|
||||||
{ followObject :: FedURI
|
{ followObject :: FedURI
|
||||||
|
@ -394,6 +390,36 @@ parseReject o = Reject <$> o .: "object"
|
||||||
encodeReject :: Reject -> Series
|
encodeReject :: Reject -> Series
|
||||||
encodeReject (Reject obj) = "object" .= obj
|
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
|
data SpecificActivity
|
||||||
= AcceptActivity Accept
|
= AcceptActivity Accept
|
||||||
| CreateActivity Create
|
| CreateActivity Create
|
||||||
|
@ -403,6 +429,7 @@ data SpecificActivity
|
||||||
data Activity = Activity
|
data Activity = Activity
|
||||||
{ activityId :: LocalURI
|
{ activityId :: LocalURI
|
||||||
, activityActor :: LocalURI
|
, activityActor :: LocalURI
|
||||||
|
, activityAudience :: Audience
|
||||||
, activitySpecific :: SpecificActivity
|
, activitySpecific :: SpecificActivity
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -411,24 +438,30 @@ instance ActivityPub Activity where
|
||||||
parseObject o = do
|
parseObject o = do
|
||||||
(h, id_) <- f2l <$> o .: "id"
|
(h, id_) <- f2l <$> o .: "id"
|
||||||
actor <- withHost h $ f2l <$> o .: "actor"
|
actor <- withHost h $ f2l <$> o .: "actor"
|
||||||
(,) h . Activity id_ actor <$> do
|
fmap (h,) $
|
||||||
typ <- o .: "type"
|
Activity id_ actor
|
||||||
case typ of
|
<$> parseAudience o
|
||||||
"Accept" -> AcceptActivity <$> parseAccept o
|
<*> do
|
||||||
"Create" -> CreateActivity <$> parseCreate o h actor
|
typ <- o .: "type"
|
||||||
"Follow" -> FollowActivity <$> parseFollow o
|
case typ of
|
||||||
"Reject" -> RejectActivity <$> parseReject o
|
"Accept" -> AcceptActivity <$> parseAccept o
|
||||||
_ -> fail $ "Unrecognized activity type: " ++ T.unpack typ
|
"Create" -> CreateActivity <$> parseCreate o h actor
|
||||||
|
"Follow" -> FollowActivity <$> parseFollow o
|
||||||
|
"Reject" -> RejectActivity <$> parseReject o
|
||||||
|
_ ->
|
||||||
|
fail $
|
||||||
|
"Unrecognized activity type: " ++ T.unpack typ
|
||||||
where
|
where
|
||||||
withHost h a = do
|
withHost h a = do
|
||||||
(h', v) <- a
|
(h', v) <- a
|
||||||
if h == h'
|
if h == h'
|
||||||
then return v
|
then return v
|
||||||
else fail "URI host mismatch"
|
else fail "URI host mismatch"
|
||||||
toSeries host (Activity id_ actor specific)
|
toSeries host (Activity id_ actor audience specific)
|
||||||
= "type" .= activityType specific
|
= "type" .= activityType specific
|
||||||
<> "id" .= l2f host id_
|
<> "id" .= l2f host id_
|
||||||
<> "actor" .= l2f host actor
|
<> "actor" .= l2f host actor
|
||||||
|
<> encodeAudience audience
|
||||||
<> encodeSpecific host actor specific
|
<> encodeSpecific host actor specific
|
||||||
where
|
where
|
||||||
activityType :: SpecificActivity -> Text
|
activityType :: SpecificActivity -> Text
|
||||||
|
|
Loading…
Reference in a new issue