diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 0b5f1c8..364b7c6 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -440,7 +440,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source , messageRoot = did } let activity luAct luNote = Doc host Activity - { activityId = luAct + { activityId = Just luAct , activityActor = luAttrib , activitySummary = Just $ TextHtml $ TL.toStrict $ renderHtml summary diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index f684aae..8949156 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -129,10 +129,14 @@ handleSharerInbox -> ExceptT Text Handler Text handleSharerInbox _now shrRecip (ActivityAuthLocalPerson pidAuthor) body = do (shrActivity, obiid) <- do + luAct <- + fromMaybeE + (activityId $ actbActivity body) + "Local activity: No 'id'" route <- - case decodeRouteLocal $ activityId $ actbActivity body of - Nothing -> throwE "Local activity: Not a valid route" - Just r -> return r + fromMaybeE + (decodeRouteLocal luAct) + "Local activity: Not a valid route" case route of SharerOutboxItemR shr obikhid -> (shr,) <$> decodeKeyHashidE obikhid "Local activity: ID is invalid hashid" @@ -169,10 +173,14 @@ handleSharerInbox _now shrRecip (ActivityAuthLocalPerson pidAuthor) body = do return $ "Activity inserted to inbox of /s/" <> recip handleSharerInbox _now shrRecip (ActivityAuthLocalProject jidAuthor) body = do (shrActivity, prjActivity, obiid) <- do + luAct <- + fromMaybeE + (activityId $ actbActivity body) + "Local activity: No 'id'" route <- - case decodeRouteLocal $ activityId $ actbActivity body of - Nothing -> throwE "Local activity: Not a valid route" - Just r -> return r + fromMaybeE + (decodeRouteLocal luAct) + "Local activity: Not a valid route" case route of ProjectOutboxItemR shr prj obikhid -> (shr,prj,) <$> decodeKeyHashidE obikhid "Local activity: ID is invalid hashid" diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index 3eeb428..f42e243 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -107,6 +107,8 @@ sharerCreateNoteF -> Note -> ExceptT Text Handler Text sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext mpublished _ _) = do + luCreate <- + fromMaybeE (activityId $ actbActivity body) "Create without 'id'" _luNote <- fromMaybeE mluNote "Note without note id" _published <- fromMaybeE mpublished "Note without 'published' field" uContext <- fromMaybeE muContext "Note without context" @@ -125,7 +127,8 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext valid <- checkContextParent context mparent case valid of Left e -> return $ Left e - Right _ -> Right <$> insertToInbox (personInbox personRecip) + Right _ -> + Right <$> insertToInbox luCreate (personInbox personRecip) where checkContextParent context mparent = runExceptT $ do case context of @@ -169,11 +172,10 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion" unless (messageRoot m == did) $ throwE "Remote parent belongs to a different discussion" - insertToInbox ibidRecip = do + insertToInbox luCreate ibidRecip = do let iidAuthor = remoteAuthorInstance author - luActivity = activityId $ actbActivity body jsonObj = PersistJSON $ actbObject body - ract = RemoteActivity iidAuthor luActivity jsonObj now + ract = RemoteActivity iidAuthor luCreate jsonObj now ractid <- either entityKey id <$> insertBy' ract ibiid <- insert $ InboxItem True mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid @@ -199,6 +201,8 @@ projectCreateNoteF -> Note -> ExceptT Text Handler Text projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent muCtx mpub src content) = do + luCreate <- + fromMaybeE (activityId $ actbActivity body) "Create without 'id'" luNote <- fromMaybeE mluNote "Note without note id" published <- fromMaybeE mpub "Note without 'published' field" uContext <- fromMaybeE muCtx "Note without context" @@ -224,7 +228,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent mremotesHttp <- runDBExcept $ do (sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent num mparent lift $ join <$> do - mmid <- insertToDiscussion luNote published ibid did meparent fsidTicket + mmid <- insertToDiscussion luCreate luNote published ibid did meparent fsidTicket for mmid $ \ (ractid, mid) -> do updateOrphans luNote did mid for msig $ \ sig -> do @@ -278,12 +282,12 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent return mid Nothing -> return $ Right $ l2f hParent luParent return (sid, fsidProject, ticketFollowers t, jid, ibid, did, meparent) - insertToDiscussion luNote published ibid did meparent fsid = do + insertToDiscussion luCreate luNote published ibid did meparent fsid = do let iidAuthor = remoteAuthorInstance author raidAuthor = remoteAuthorId author ractid <- either entityKey id <$> insertBy' RemoteActivity { remoteActivityInstance = iidAuthor - , remoteActivityIdent = activityId $ actbActivity body + , remoteActivityIdent = luCreate , remoteActivityContent = PersistJSON $ actbObject body , remoteActivityReceived = now } diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 24ec549..5f23573 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -102,6 +102,7 @@ sharerOfferTicketF -> ExceptT Text Handler Text sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do (hProject, shrProject, prjProject) <- parseTarget uTarget + luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'" deps <- checkOffer ticket hProject shrProject prjProject local <- hostIsLocal hProject runDBExcept $ do @@ -110,7 +111,7 @@ sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do p <- getValBy404 $ UniquePersonIdent sid return $ personInbox p when local $ checkTargetAndDeps shrProject prjProject deps - lift $ insertToInbox ibidRecip + lift $ insertToInbox luOffer ibidRecip where parseTarget u = do let (h, lu) = f2l u @@ -133,9 +134,8 @@ sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do mt <- lift $ getBy $ UniqueTicket jid dep unless (isJust mt) $ throwE "Local dep: No such ticket number in DB" - insertToInbox ibidRecip = do + insertToInbox luOffer ibidRecip = do let iidAuthor = remoteAuthorInstance author - luOffer = activityId $ actbActivity body jsonObj = PersistJSON $ actbObject body ract = RemoteActivity iidAuthor luOffer jsonObj now ractid <- either entityKey id <$> insertBy' ract @@ -172,6 +172,10 @@ projectOfferTicketF ] return t Right () -> do + luOffer <- + fromMaybeE + (activityId $ actbActivity body) + "Offer without 'id'" hLocal <- getsYesod siteInstanceHost deps <- checkOffer ticket hLocal shrRecip prjRecip msig <- checkForward shrRecip prjRecip @@ -181,7 +185,7 @@ projectOfferTicketF mremotesHttp <- runDBExcept $ do (sid, jid, ibid, fsid, tids) <- getProjectAndDeps deps lift $ join <$> do - mractid <- insertTicket jid ibid tids + mractid <- insertTicket luOffer jid ibid tids for mractid $ \ ractid -> for msig $ \ sig -> do remoteRecips <- deliverLocal ractid colls sid fsid (sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips @@ -234,12 +238,12 @@ projectOfferTicketF mtid <- lift $ getKeyBy $ UniqueTicket jid dep fromMaybeE mtid "Local dep: No such ticket number in DB" return (sid, jid, projectInbox j, projectFollowers j, tids) - insertTicket jid ibid deps = do + insertTicket luOffer jid ibid deps = do let iidAuthor = remoteAuthorInstance author raidAuthor = remoteAuthorId author ractid <- either entityKey id <$> insertBy' RemoteActivity { remoteActivityInstance = iidAuthor - , remoteActivityIdent = activityId $ actbActivity body + , remoteActivityIdent = luOffer , remoteActivityContent = PersistJSON $ actbObject body , remoteActivityReceived = now } diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 4cb1246..33c7dcd 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -317,7 +317,7 @@ changes hLocal ctx = let localUri = LocalURI "/x/y" "" fedUri = l2f "x.y" localUri doc = Doc "x.y" Activity - { activityId = localUri + { activityId = Nothing , activityActor = localUri , activitySummary = Nothing , activityAudience = Audience [] [] [] [] [] [] @@ -439,7 +439,7 @@ changes hLocal ctx = luAttrib = LocalURI ("/s/" <> shr2text shr) "" activity luAct luNote = Doc hLocal Activity - { activityId = luAct + { activityId = Just luAct , activityActor = luAttrib , activitySummary = Nothing , activityAudience = aud @@ -684,7 +684,7 @@ changes hLocal ctx = let localUri = LocalURI "/x/y" "" fedUri = l2f "x.y" localUri doc = Doc "x.y" Activity - { activityId = localUri + { activityId = Nothing , activityActor = localUri , activitySummary = Nothing , activityAudience = Audience [] [] [] [] [] [] @@ -748,7 +748,7 @@ changes hLocal ctx = : #{ticket20190612Title ticket}. |] doc luAct = Doc hLocal Activity - { activityId = luAct + { activityId = Just luAct , activityActor = author , activitySummary = Just $ TextHtml $ TL.toStrict $ renderHtml $ diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 298b317..a20bf7b 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -759,7 +759,7 @@ data SpecificActivity | RejectActivity Reject data Activity = Activity - { activityId :: LocalURI + { activityId :: Maybe LocalURI , activityActor :: LocalURI , activitySummary :: Maybe TextHtml , activityAudience :: Audience @@ -769,11 +769,12 @@ data Activity = Activity instance ActivityPub Activity where jsonldContext _ = [as2Context, forgeContext, extContext] parseObject o = do - (h, id_) <- f2l <$> o .: "id" - actor <- withHost h $ f2l <$> o .: "actor" + (h, actor) <- f2l <$> o .: "actor" fmap (h,) $ - Activity id_ actor - <$> (fmap (TextHtml . sanitizeBalance) <$> o .:? "summary") + Activity + <$> withHostMaybe h (fmap f2l <$> o .:? "id") + <*> pure actor + <*> (fmap (TextHtml . sanitizeBalance) <$> o .:? "summary") <*> parseAudience o <*> do typ <- o .: "type" @@ -788,7 +789,7 @@ instance ActivityPub Activity where "Unrecognized activity type: " ++ T.unpack typ toSeries host (Activity id_ actor summary audience specific) = "type" .= activityType specific - <> "id" .= l2f host id_ + <> "id" .=? (l2f host <$> id_) <> "actor" .= l2f host actor <> "summary" .=? summary <> encodeAudience audience