Parse/encoding audience targetting activity fields
This commit is contained in:
fr33domlover
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.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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
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
|
||||
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
|
||||
_ ->
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue