Parse/encoding audience targetting activity fields

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

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"
     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 :: Text -> Note -> LocalURI -> Encoding
-encodeNote host (Note id_ mreply content) attrib to =
+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"
+    return $ Create note
-    unless (uTo == uTo') $ fail "Create to != Note to"
-    return $ Create uTo 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)
+encodeCreate host actor (Create obj) =
-    =  "to"       .=     to
+    "object" `pair` encodeNote host obj actor
-    <> "object"   `pair` encodeNote host obj actor to
 
 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