diff --git a/config/models b/config/models index 761cdf0..f8b8313 100644 --- a/config/models +++ b/config/models @@ -225,6 +225,7 @@ TicketClaimRequest Discussion RemoteDiscussion + sharer RemoteSharerId instance InstanceId ident LocalURI discuss DiscussionId diff --git a/migrations/2019_03_19.model b/migrations/2019_03_19.model index 0425887..a6f3980 100644 --- a/migrations/2019_03_19.model +++ b/migrations/2019_03_19.model @@ -3,6 +3,7 @@ RemoteRawObject received UTCTime RemoteDiscussion + sharer RemoteSharerId instance InstanceId ident Text discuss DiscussionId diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index ad6356a..7c86f7a 100644 --- a/src/Vervis/Federation.hs +++ b/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 diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index 8bc85b8..0989602 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/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 $ - TicketR (sharerIdent s) (projectIdent j) (ticketNumber t) + let shr = sharerIdent s + prj = projectIdent j + return + ( route2fed $ ProjectR shr prj + , route2fed $ TicketR shr prj $ ticketNumber t + ) (Nothing, Just rd) -> do - i <- getJust $ remoteDiscussionInstance rd - return $ l2f (instanceHost i) (remoteDiscussionIdent rd) + let iid = remoteDiscussionInstance 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 diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 772db50..83e06ef 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -250,17 +250,12 @@ 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 - } + , activityAudience = deliverTo to , activitySpecific = CreateActivity Create { createObject = Note { noteId = Just $ appendPath actor "/fake-note" , noteAttrib = actor + , noteAudience = deliverTo to , noteReplyTo = mparent , noteContext = mcontext , notePublished = Just now diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index a481e73..1da5a8d 100644 --- a/src/Web/ActivityPub.hs +++ b/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