forge/Vervis
1
0
Fork 0
Code Pull requests Activity

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

Browse source
This commit is contained in:
fr33domlover 2019-03-23 02:57:34 +00:00
parent 58a56b6743
commit 0032456925
6 changed files with 84 additions and 63 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
config/models
View file

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

1
migrations/2019_03_19.model
View file

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

2
src/Vervis/Federation.hs
View file

@ -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

22
src/Vervis/Handler/Discussion.hs
View file

@ -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

9
src/Vervis/Handler/Inbox.hs
View file

@ -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

112
src/Web/ActivityPub.hs
View file

@ -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