naskya/vervis
1
0
Fork 0
mirror of https://code.naskya.net/repos/ndqEd synced 2025-01-10 20:46:47 +09:00
Code Activity

Web.ActivityPub: Allow Create object to be a Ticket

Browse source
This commit is contained in:
fr33domlover 2020-02-10 14:51:32 +00:00
parent 0de98a9cdd
commit 6d25d7ec2c
4 changed files with 30 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/Vervis/API.hs
View file

@ -352,7 +352,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
Just $ TextHtml $ TL.toStrict $ renderHtml summary Just $ TextHtml $ TL.toStrict $ renderHtml summary
, activityAudience = aud , activityAudience = aud
, activitySpecific = CreateActivity Create , activitySpecific = CreateActivity Create
{ createObject = Note { createObject = CreateNote Note
{ noteId = Just luNote { noteId = Just luNote
, noteAttrib = luAttrib , noteAttrib = luAttrib
, noteAudience = aud , noteAudience = aud

14
src/Vervis/Federation.hs
View file

@ -266,8 +266,11 @@ handleSharerInbox now shrRecip (ActivityAuthRemote author) body =
case activitySpecific $ actbActivity body of case activitySpecific $ actbActivity body of
AcceptActivity accept -> AcceptActivity accept ->
sharerAcceptF shrRecip now author body accept sharerAcceptF shrRecip now author body accept
CreateActivity (Create note) -> CreateActivity (Create obj) ->
sharerCreateNoteF now shrRecip author body note case obj of
CreateNote note ->
sharerCreateNoteF now shrRecip author body note
_ -> return "Unsupported create object type for sharers"
FollowActivity follow -> FollowActivity follow ->
sharerFollowF shrRecip now author body follow sharerFollowF shrRecip now author body follow
OfferActivity offer -> OfferActivity offer ->
@ -293,8 +296,11 @@ handleProjectInbox now shrRecip prjRecip auth body = do
ActivityAuthLocal local -> throwE $ errorLocalForwarded local ActivityAuthLocal local -> throwE $ errorLocalForwarded local
ActivityAuthRemote ra -> return ra ActivityAuthRemote ra -> return ra
case activitySpecific $ actbActivity body of case activitySpecific $ actbActivity body of
CreateActivity (Create note) -> CreateActivity (Create obj) ->
projectCreateNoteF now shrRecip prjRecip remoteAuthor body note case obj of
CreateNote note ->
projectCreateNoteF now shrRecip prjRecip remoteAuthor body note
_ -> error "Unsupported create object type for projects"
FollowActivity follow -> FollowActivity follow ->
projectFollowF shrRecip prjRecip now remoteAuthor body follow projectFollowF shrRecip prjRecip now remoteAuthor body follow
OfferActivity offer -> OfferActivity offer ->

2
src/Vervis/Migration.hs
View file

@ -467,7 +467,7 @@ changes hLocal ctx =
, activitySummary = Nothing , activitySummary = Nothing
, activityAudience = aud , activityAudience = aud
, activitySpecific = CreateActivity Create , activitySpecific = CreateActivity Create
{ createObject = Note { createObject = CreateNote Note
{ noteId = Just luNote { noteId = Just luNote
, noteAttrib = luAttrib , noteAttrib = luAttrib
, noteAudience = aud , noteAudience = aud

22
src/Web/ActivityPub.hs
View file

@ -55,6 +55,7 @@ module Web.ActivityPub
-- * Activity -- * Activity
, Accept (..) , Accept (..)
, CreateObject (..)
, Create (..) , Create (..)
, Follow (..) , Follow (..)
, Offer (..) , Offer (..)
@ -1074,15 +1075,28 @@ encodeAccept authority (Accept obj mresult)
= "object" .= obj = "object" .= obj
<> "result" .=? (ObjURI authority <$> mresult) <> "result" .=? (ObjURI authority <$> mresult)
data CreateObject u = CreateNote (Note u) | CreateTicket (Ticket u)
instance ActivityPub CreateObject where
jsonldContext = error "jsonldContext CreateObject"
parseObject o
= second CreateNote <$> parseObject o
<|> second CreateTicket <$> parseObject o
toSeries au (CreateNote o) = toSeries au o
toSeries au (CreateTicket o) = toSeries au o
data Create u = Create data Create u = Create
{ createObject :: Note u { createObject :: CreateObject u
} }
parseCreate :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Create u) parseCreate :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Create u)
parseCreate o a luActor = do parseCreate o a luActor = do
note <- withAuthorityT a $ parseObject =<< o .: "object" obj <- withAuthorityT a $ parseObject =<< o .: "object"
unless (luActor == noteAttrib note) $ fail "Create actor != Note attrib" unless (luActor == attrib obj) $ fail "Create actor != object attrib"
return $ Create note return $ Create obj
where
attrib (CreateNote note) = noteAttrib note
attrib (CreateTicket ticket) = ticketAttributedTo ticket
encodeCreate :: UriMode u => Authority u -> LocalURI -> Create u -> Series encodeCreate :: UriMode u => Authority u -> LocalURI -> Create u -> Series
encodeCreate authority actor (Create obj) = encodeCreate authority actor (Create obj) =