diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 64374be..6c85240 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -352,7 +352,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source Just $ TextHtml $ TL.toStrict $ renderHtml summary , activityAudience = aud , activitySpecific = CreateActivity Create - { createObject = Note + { createObject = CreateNote Note { noteId = Just luNote , noteAttrib = luAttrib , noteAudience = aud diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 1c6552f..d9629c7 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -266,8 +266,11 @@ handleSharerInbox now shrRecip (ActivityAuthRemote author) body = case activitySpecific $ actbActivity body of AcceptActivity accept -> sharerAcceptF shrRecip now author body accept - CreateActivity (Create note) -> - sharerCreateNoteF now shrRecip author body note + CreateActivity (Create obj) -> + case obj of + CreateNote note -> + sharerCreateNoteF now shrRecip author body note + _ -> return "Unsupported create object type for sharers" FollowActivity follow -> sharerFollowF shrRecip now author body follow OfferActivity offer -> @@ -293,8 +296,11 @@ handleProjectInbox now shrRecip prjRecip auth body = do ActivityAuthLocal local -> throwE $ errorLocalForwarded local ActivityAuthRemote ra -> return ra case activitySpecific $ actbActivity body of - CreateActivity (Create note) -> - projectCreateNoteF now shrRecip prjRecip remoteAuthor body note + CreateActivity (Create obj) -> + case obj of + CreateNote note -> + projectCreateNoteF now shrRecip prjRecip remoteAuthor body note + _ -> error "Unsupported create object type for projects" FollowActivity follow -> projectFollowF shrRecip prjRecip now remoteAuthor body follow OfferActivity offer -> diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index ea7be65..bb9782b 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -467,7 +467,7 @@ changes hLocal ctx = , activitySummary = Nothing , activityAudience = aud , activitySpecific = CreateActivity Create - { createObject = Note + { createObject = CreateNote Note { noteId = Just luNote , noteAttrib = luAttrib , noteAudience = aud diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 63a840f..3c73a21 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -55,6 +55,7 @@ module Web.ActivityPub -- * Activity , Accept (..) + , CreateObject (..) , Create (..) , Follow (..) , Offer (..) @@ -1074,15 +1075,28 @@ encodeAccept authority (Accept obj mresult) = "object" .= obj <> "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 - { createObject :: Note u + { createObject :: CreateObject u } parseCreate :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Create u) parseCreate o a luActor = do - note <- withAuthorityT a $ parseObject =<< o .: "object" - unless (luActor == noteAttrib note) $ fail "Create actor != Note attrib" - return $ Create note + obj <- withAuthorityT a $ parseObject =<< o .: "object" + unless (luActor == attrib obj) $ fail "Create actor != object attrib" + return $ Create obj + where + attrib (CreateNote note) = noteAttrib note + attrib (CreateTicket ticket) = ticketAttributedTo ticket encodeCreate :: UriMode u => Authority u -> LocalURI -> Create u -> Series encodeCreate authority actor (Create obj) =