Add noteAudience; record recipient of local remotely-targetted activities in DB

config/models

@@ -225,6 +225,7 @@ TicketClaimRequest
 Discussion
 
 RemoteDiscussion
+    sharer   RemoteSharerId
     instance InstanceId
     ident    LocalURI
     discuss  DiscussionId

migrations/2019_03_19.model

@@ -3,6 +3,7 @@ RemoteRawObject
     received UTCTime
 
 RemoteDiscussion
+    sharer   RemoteSharerId
     instance InstanceId
     ident    Text
     discuss  DiscussionId

src/Vervis/Federation.hs

@@ -146,7 +146,7 @@ handleActivity raw hActor iidActor rsidActor (Activity _id _luActor audience spe
                 rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&.
                 m E.^. MessageRoot `op` E.val did
             return (rm E.^. RemoteMessageId, m E.^. MessageId)
-    handleCreate iidActor hActor rsidActor raw audience (Note mluNote _luAttrib muParent muContext mpublished content) = do
+    handleCreate iidActor hActor rsidActor raw audience (Note mluNote _luAttrib _aud muParent muContext mpublished content) = do
         luNote <- fromMaybeE mluNote "Got Create Note without note id"
         (shr, prj) <- do
             uRecip <- parseAudience audience

src/Vervis/Handler/Discussion.hs

@@ -106,7 +106,7 @@ getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do
     m <- getJust $ localMessageRest lm
     route2fed <- getEncodeRouteFed
     encodeHid <- getsYesod appHashidEncode
-    uContext <- do
+    (uRecip, uContext) <- do
         let did = messageRoot m
         mt <- getValBy $ UniqueTicketDiscussion did
         mrd <- getValBy $ UniqueRemoteDiscussion did
@@ -116,11 +116,22 @@ getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do
             (Just t, Nothing) -> do
                 j <- getJust $ ticketProject t
                 s <- getJust $ projectSharer j
-                return $ route2fed $
+                let shr = sharerIdent s
-                    TicketR (sharerIdent s) (projectIdent j) (ticketNumber t)
+                    prj = projectIdent j
+                return
+                    ( route2fed $ ProjectR shr prj
+                    , route2fed $ TicketR shr prj $ ticketNumber t
+                    )
             (Nothing, Just rd) -> do
-                i <- getJust $ remoteDiscussionInstance rd
+                let iid = remoteDiscussionInstance rd
-                return $ l2f (instanceHost i) (remoteDiscussionIdent rd)
+                i <- getJust iid
+                rs <- getJust $ remoteDiscussionSharer rd
+                unless (iid == remoteSharerInstance rs) $
+                    fail "RemoteDiscussion and its sharer on different hosts"
+                return
+                    ( l2f (instanceHost i) (remoteSharerIdent rs)
+                    , l2f (instanceHost i) (remoteDiscussionIdent rd)
+                    )
     muParent <- for (messageParent m) $ \ midParent -> do
         mlocal <- getBy $ UniqueLocalMessage midParent
         mremote <- getValBy $ UniqueRemoteMessage midParent
@@ -143,6 +154,7 @@ getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do
     return $ Doc host Note
         { noteId        = Just $ route2local $ MessageR shr lmhid
         , noteAttrib    = route2local $ SharerR shr
+        , noteAudience  = deliverTo uRecip
         , noteReplyTo   = Just $ fromMaybe uContext muParent
         , noteContext   = Just uContext
         , notePublished = Just $ messageCreated m

src/Vervis/Handler/Inbox.hs

@@ -250,17 +250,12 @@ postOutboxR = do
                 activity = Activity
                     { activityId       = appendPath actor "/fake-activity"
                     , activityActor    = actor
-                    , activityAudience = Audience
+                    , activityAudience = deliverTo to
-                        { audienceTo      = V.singleton to
-                        , audienceBto     = V.empty
-                        , audienceCc      = V.empty
-                        , audienceBcc     = V.empty
-                        , audienceGeneral = V.empty
-                        }
                     , activitySpecific = CreateActivity Create
                         { createObject = Note
                             { noteId        = Just $ appendPath actor "/fake-note"
                             , noteAttrib    = actor
+                            , noteAudience  = deliverTo to
                             , noteReplyTo   = mparent
                             , noteContext   = mcontext
                             , notePublished = Just now

src/Web/ActivityPub.hs

@@ -44,6 +44,7 @@ module Web.ActivityPub
 
       -- * Utilities
     , publicURI
+    , deliverTo
     , hActivityPubActor
     , provideAP
     , APGetError (..)
@@ -316,10 +317,67 @@ instance ActivityPub Actor where
         <> "inbox"             .=     l2f host inbox
         <> "publicKey"         `pair` encodePublicKeySet host pkeys
 
+data Audience = Audience
+    { audienceTo      :: Vector FedURI
+    , audienceBto     :: Vector FedURI
+    , audienceCc      :: Vector FedURI
+    , audienceBcc     :: Vector FedURI
+    , audienceGeneral :: Vector FedURI
+    }
+
+deliverTo :: FedURI -> Audience
+deliverTo to = Audience
+    { audienceTo      = V.singleton to
+    , audienceBto     = V.empty
+    , audienceCc      = V.empty
+    , audienceBcc     = V.empty
+    , audienceGeneral = V.empty
+    }
+
+newtype AdaptAudience = AdaptAudience
+    { unAdapt :: FedURI
+    }
+
+instance FromJSON AdaptAudience where
+    parseJSON = parseJSON . adapt
+        where
+        adapt v =
+            case v of
+                String t
+                    | t == "Public"    -> String publicT
+                    | t == "as:Public" -> String publicT
+                _ -> v
+
+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
+    where
+    obj .:& key = do
+        vec <- obj .:? key .!= V.empty
+        return $ unAdapt <$> vec
+
+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 Note = Note
     { noteId        :: Maybe LocalURI
     , noteAttrib    :: LocalURI
-    --, noteTo      :: FedURI
+    , noteAudience  :: Audience
     , noteReplyTo   :: Maybe FedURI
     , noteContext   :: Maybe FedURI
     , notePublished :: Maybe UTCTime
@@ -350,14 +408,16 @@ instance ActivityPub Note where
             Note
                 <$> withHostM h (fmap f2l <$> o .:? "id")
                 <*> pure attrib
+                <*> parseAudience o
                 <*> o .:? "inReplyTo"
                 <*> o .:? "context"
                 <*> o .:? "published"
                 <*> o .:  "content"
-    toSeries host (Note mid attrib mreply mcontext mpublished content)
+    toSeries host (Note mid attrib aud mreply mcontext mpublished content)
         =  "type"         .=  ("Note" :: Text)
         <> "id"           .=? (l2f host <$> mid)
         <> "attributedTo" .=  l2f host attrib
+        <> encodeAudience aud
         <> "inReplyTo"    .=? mreply
         <> "context"      .=? mcontext
         <> "published"    .=? mpublished
@@ -452,54 +512,6 @@ 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
-    }
-
-newtype AdaptAudience = AdaptAudience
-    { unAdapt :: FedURI
-    }
-
-instance FromJSON AdaptAudience where
-    parseJSON = parseJSON . adapt
-        where
-        adapt v =
-            case v of
-                String t
-                    | t == "Public"    -> String publicT
-                    | t == "as:Public" -> String publicT
-                _ -> v
-
-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
-    where
-    obj .:& key = do
-        vec <- obj .:? key .!= V.empty
-        return $ unAdapt <$> vec
-
-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