diff --git a/config/models b/config/models index 8872e76..5726ea4 100644 --- a/config/models +++ b/config/models @@ -364,6 +364,13 @@ LocalTicket UniqueLocalTicketDiscussion discuss UniqueLocalTicketFollowers followers +RemoteTicket + ticket TicketAuthorRemoteId + ident RemoteObjectId + + UniqueRemoteTicket ticket + UniqueRemoteTicketIdent ident + TicketProjectLocal ticket TicketId project ProjectId diff --git a/migrations/2020_04_09_rt.model b/migrations/2020_04_09_rt.model new file mode 100644 index 0000000..5962e28 --- /dev/null +++ b/migrations/2020_04_09_rt.model @@ -0,0 +1,6 @@ +RemoteTicket + ticket TicketAuthorRemoteId + ident RemoteObjectId + + UniqueRemoteTicket ticket + UniqueRemoteTicketIdent ident diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index c74df0e..e40ffae 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -322,20 +322,21 @@ deliverRemoteDB body ractid jid sig recips = do noError (RemoteRecipient _ _ _ (Just _), _ ) = Nothing deliverRemoteHTTP - :: UTCTime + :: (MonadSite m, SiteEnv m ~ App) + => UTCTime -> ShrIdent -> PrjIdent -> BL.ByteString -> ByteString -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))] - -> Handler () + -> m () deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do let deliver h inbox = let sender = ProjectR shrRecip prjRecip in forwardActivity (ObjURI h inbox) sig sender body traverse_ (fork . deliverFetched deliver now) fetched where - fork = forkHandler $ \ e -> logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e) + fork = forkWorker "Project inbox handler: delivery failed" deliverFetched deliver now ((_, h), recips@(r :| rs)) = do let (raid, _luActor, luInbox, fwid) = r e <- deliver h luInbox @@ -346,12 +347,12 @@ deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do else Just False Right _resp -> Just True case e' of - Nothing -> runDB $ do + Nothing -> runSiteDB $ do let recips' = NE.toList recips updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] updateWhere [ForwardingId <-. map fourth4 recips'] [ForwardingRunning =. False] Just success -> do - runDB $ + runSiteDB $ if success then delete fwid else do @@ -360,7 +361,7 @@ deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do for_ rs $ \ (raid, _luActor, luInbox, fwid) -> fork $ do e <- deliver h luInbox - runDB $ + runSiteDB $ case e of Left _err -> do updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 0475c93..b10cdad 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -298,10 +298,12 @@ handleProjectInbox now shrRecip prjRecip auth body = do ActivityAuthLocal local -> throwE $ errorLocalForwarded local ActivityAuthRemote ra -> return ra case activitySpecific $ actbActivity body of - CreateActivity (Create obj _target) -> + CreateActivity (Create obj mtarget) -> case obj of CreateNote note -> projectCreateNoteF now shrRecip prjRecip remoteAuthor body note + CreateTicket ticket -> + projectCreateTicketF now shrRecip prjRecip remoteAuthor body ticket mtarget _ -> error "Unsupported create object type for projects" FollowActivity follow -> projectFollowF shrRecip prjRecip now remoteAuthor body follow diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index c075ef8..bcb148d 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -18,6 +18,7 @@ module Vervis.Federation.Ticket , projectOfferTicketF , sharerCreateTicketF + , projectCreateTicketF ) where @@ -142,6 +143,48 @@ data OfferTicketRecipColl | OfferTicketRecipProjectTeam deriving Eq +findRelevantCollections shrRecip prjRecip hLocal = nub . mapMaybe decide . concatRecipients + where + decide u = do + let ObjURI h lu = u + guard $ h == hLocal + route <- decodeRouteLocal lu + case route of + ProjectTeamR shr prj + | shr == shrRecip && prj == prjRecip + -> Just OfferTicketRecipProjectTeam + ProjectFollowersR shr prj + | shr == shrRecip && prj == prjRecip + -> Just OfferTicketRecipProjectFollowers + _ -> Nothing + +-- | Perform inbox forwarding, delivering a remote activity we received to +-- local inboxes +deliverFwdLocal + :: RemoteActivityId + -> [OfferTicketRecipColl] + -> SharerId + -> FollowerSetId + -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] +deliverFwdLocal ractid recips sid fsid = do + (teamPids, teamRemotes) <- + if OfferTicketRecipProjectTeam `elem` recips + then getTicketTeam sid + else return ([], []) + (fsPids, fsRemotes) <- + if OfferTicketRecipProjectFollowers `elem` recips + then getFollowers fsid + else return ([], []) + let pids = union teamPids fsPids + remotes = unionRemotes teamRemotes fsRemotes + for_ pids $ \ pid -> do + ibid <- personInbox <$> getJust pid + ibiid <- insert $ InboxItem True + mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid + when (isNothing mibrid) $ + delete ibiid + return remotes + projectOfferTicketF :: UTCTime -> ShrIdent @@ -170,7 +213,7 @@ projectOfferTicketF checkOffer ticket hLocal shrRecip prjRecip msig <- checkForward shrRecip prjRecip let colls = - findRelevantCollections hLocal $ + findRelevantCollections shrRecip prjRecip hLocal $ activityAudience $ actbActivity body mremotesHttp <- runDBExcept $ do (sid, jid, ibid, fsid{-, tids-}) <- @@ -181,7 +224,7 @@ projectOfferTicketF insertTicket ra luOffer jid ibid {-tids-} for mticket $ \ (ractid, obiidAccept, docAccept) -> do msr <- for msig $ \ sig -> do - remoteRecips <- deliverLocal ractid colls sid fsid + remoteRecips <- deliverFwdLocal ractid colls sid fsid (sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips return (msr, obiidAccept, docAccept) lift $ for_ mremotesHttp $ \ (msr, obiidAccept, docAccept) -> do @@ -212,20 +255,6 @@ projectOfferTicketF " not using; local target isn't a project route" unless (shrTarget == shrRecip && prjTarget == prjRecip) $ throwE $ recip <> " not using; local target is a different project" - findRelevantCollections hLocal = nub . mapMaybe decide . concatRecipients - where - decide u = do - let ObjURI h lu = u - guard $ h == hLocal - route <- decodeRouteLocal lu - case route of - ProjectTeamR shr prj - | shr == shrRecip && prj == prjRecip - -> Just OfferTicketRecipProjectTeam - ProjectFollowersR shr prj - | shr == shrRecip && prj == prjRecip - -> Just OfferTicketRecipProjectFollowers - _ -> Nothing insertTicket ra luOffer jid ibid {-deps-} = do let iidAuthor = remoteAuthorInstance author roid <- @@ -296,31 +325,6 @@ projectOfferTicketF --insert_ $ RemoteFollow raidAuthor fsid False True return $ Just (ractid, obiidAccept, docAccept) - deliverLocal - :: RemoteActivityId - -> [OfferTicketRecipColl] - -> SharerId - -> FollowerSetId - -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] - deliverLocal ractid recips sid fsid = do - (teamPids, teamRemotes) <- - if OfferTicketRecipProjectTeam `elem` recips - then getTicketTeam sid - else return ([], []) - (fsPids, fsRemotes) <- - if OfferTicketRecipProjectFollowers `elem` recips - then getFollowers fsid - else return ([], []) - let pids = union teamPids fsPids - remotes = unionRemotes teamRemotes fsRemotes - for_ pids $ \ pid -> do - ibid <- personInbox <$> getJust pid - ibiid <- insert $ InboxItem True - mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid - when (isNothing mibrid) $ - delete ibiid - return remotes - insertAccept ra luOffer ltid obiid = do let uAuthor@(ObjURI hAuthor luAuthor) = remoteAuthorURI author ltkhid <- encodeKeyHashid ltid @@ -404,27 +408,21 @@ projectOfferTicketF insert_ $ InboxItemLocal ibid obiid ibiid return remotes -sharerCreateTicketF - :: UTCTime - -> ShrIdent - -> RemoteAuthor - -> ActivityBody +checkCreateTicket + :: RemoteAuthor -> AP.Ticket URIMode -> Maybe FedURI - -> ExceptT Text Handler Text -sharerCreateTicketF now shrRecip author body ticket muTarget = do - luCreate <- - fromMaybeE (activityId $ actbActivity body) "Create without 'id'" + -> ExceptT + Text + Handler + ( (Either (Bool, ShrIdent, PrjIdent) (Host, Maybe LocalURI, LocalURI)) + , TicketLocal + , UTCTime + ) +checkCreateTicket author ticket muTarget = do mtarget <- traverse (checkTracker "Create target") muTarget - context <- checkTicket ticket - targetAndContext <- checkTargetAndContext mtarget context - runDBExcept $ do - ibidRecip <- lift $ do - sid <- getKeyBy404 $ UniqueSharer shrRecip - p <- getValBy404 $ UniquePersonIdent sid - return $ personInbox p - checkTargetAndContextDB targetAndContext - lift $ insertToInbox luCreate ibidRecip + (context, ticketData, published) <- checkTicket ticket + (, ticketData, published) <$> checkTargetAndContext mtarget context where checkTracker name u@(ObjURI h lu) = do hl <- hostIsLocal h @@ -445,7 +443,7 @@ sharerCreateTicketF now shrRecip author body ticket muTarget = do checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext _summary _content _source muAssigned resolved) = do - (hTicket, _tlocal) <- fromMaybeE mlocal "Ticket without 'id'" + (hTicket, tlocal) <- fromMaybeE mlocal "Ticket without 'id'" hl <- hostIsLocal hTicket when hl $ throwE "Remote author claims to create local ticket" unless (hTicket == objUriAuthority (remoteAuthorURI author)) $ @@ -455,12 +453,12 @@ sharerCreateTicketF now shrRecip author body ticket muTarget = do uContext <- fromMaybeE muContext "Ticket without 'context'" context <- checkTracker "Ticket context" uContext - _ <- fromMaybeE mpublished "Warning: Ticket without 'published'" - verifyNothingE mupdated "Warning: Ticket has 'updated'" - verifyNothingE muAssigned "Warning: Ticket has 'assignedTo'" - when resolved $ throwE "Warning: Ticket is resolved" + pub <- fromMaybeE mpublished "Ticket without 'published'" + verifyNothingE mupdated "Ticket has 'updated'" + verifyNothingE muAssigned "Ticket has 'assignedTo'" + when resolved $ throwE "Ticket is resolved" - return context + return (context, tlocal, pub) checkTargetAndContext Nothing context = return $ @@ -484,6 +482,26 @@ sharerCreateTicketF now shrRecip author body ticket muTarget = do else throwE "Create target and ticket context are \ \different local projects" +sharerCreateTicketF + :: UTCTime + -> ShrIdent + -> RemoteAuthor + -> ActivityBody + -> AP.Ticket URIMode + -> Maybe FedURI + -> ExceptT Text Handler Text +sharerCreateTicketF now shrRecip author body ticket muTarget = do + luCreate <- + fromMaybeE (activityId $ actbActivity body) "Create without 'id'" + (targetAndContext, _, _) <- checkCreateTicket author ticket muTarget + runDBExcept $ do + ibidRecip <- lift $ do + sid <- getKeyBy404 $ UniqueSharer shrRecip + p <- getValBy404 $ UniquePersonIdent sid + return $ personInbox p + checkTargetAndContextDB targetAndContext + lift $ insertToInbox luCreate ibidRecip + where checkTargetAndContextDB (Left (_, shr, prj)) = do mj <- lift $ runMaybeT $ do sid <- MaybeT $ getKeyBy $ UniqueSharer shr @@ -506,3 +524,199 @@ sharerCreateTicketF now shrRecip author body ticket muTarget = do delete ibiid return $ "Activity already exists in inbox of /s/" <> recip Just _ -> return $ "Activity inserted to inbox of /s/" <> recip + +projectCreateTicketF + :: UTCTime + -> ShrIdent + -> PrjIdent + -> RemoteAuthor + -> ActivityBody + -> AP.Ticket URIMode + -> Maybe FedURI + -> ExceptT Text Handler Text +projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do + luCreate <- + fromMaybeE (activityId $ actbActivity body) "Create without 'id'" + (targetAndContext, tlocal, published) <- checkCreateTicket author ticket muTarget + case targetAndContext of + Left (_, shrContext, prjContext) + | shrRecip == shrContext && prjRecip == prjContext -> do + msig <- checkForward shrRecip prjRecip + msgOrRecips <- lift $ runDB $ do + (sidProject, jid, obidProject, ibidProject, fsidProject) <- getProject + mractidCreate <- insertCreate luCreate ibidProject + case mractidCreate of + Nothing -> return $ Left "Already have this activity in project inbox, ignoring" + Just ractidCreate -> do + (obiidAccept, docAccept, localRecipsAccept, remoteRecipsAccept, fwdAccept) <- insertAccept obidProject luCreate tlocal + result <- insertTicket jid (AP.ticketId tlocal) published ractidCreate obiidAccept + case result of + Left False -> do + delete obiidAccept + return $ Left "Already have a ticket opened by this activity, ignoring" + Left True -> do + delete obiidAccept + return $ Left "Already have this ticket, ignoring" + Right () -> do + hLocal <- getsYesod siteInstanceHost + let colls = findRelevantCollections shrRecip prjRecip hLocal $ activityAudience $ actbActivity body + mremoteRecipsHttpCreateFwd <- for msig $ \ sig -> do + remoteRecips <- deliverFwdLocal ractidCreate colls sidProject fsidProject + (sig,) <$> deliverRemoteDB (actbBL body) ractidCreate jid sig remoteRecips + remoteRecipsHttpAccept <- do + moreRemoteRecipsAccept <- deliverLocal' False (LocalActorProject shrRecip prjRecip) ibidProject obiidAccept localRecipsAccept + deliverRemoteDB' fwdAccept obiidAccept remoteRecipsAccept moreRemoteRecipsAccept + return $ Right (mremoteRecipsHttpCreateFwd, remoteRecipsHttpAccept, obiidAccept, docAccept, fwdAccept) + case msgOrRecips of + Left msg -> return msg + Right (mremoteRecipsHttpCreateFwd, remoteRecipsHttpAccept, obiidAccept, docAccept, fwdAccept) -> do + for_ mremoteRecipsHttpCreateFwd $ \ (sig, recips) -> forkWorker "projectCreateTicketF inbox forwarding" $ deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig recips + forkWorker "projectCreateTicketF deliver Accept" $ deliverRemoteHttp fwdAccept obiidAccept docAccept remoteRecipsHttpAccept + return "Accepting and listing new remote author hosted ticket" + _ -> return "Create/Ticket against different project, ignoring" + where + getProject = do + sid <- getKeyBy404 $ UniqueSharer shrRecip + Entity jid j <- getBy404 $ UniqueProject prjRecip sid + return (sid, jid, projectOutbox j, projectInbox j, projectFollowers j) + + insertCreate luCreate ibidProject = do + roid <- either entityKey id <$> insertBy' RemoteObject + { remoteObjectInstance = remoteAuthorInstance author + , remoteObjectIdent = luCreate + } + let raidAuthor = remoteAuthorId author + ractidCreate <- either entityKey id <$> insertBy' RemoteActivity + { remoteActivityIdent = roid + , remoteActivityContent = persistJSONFromBL $ actbBL body + , remoteActivityReceived = now + } + ibiid <- insert $ InboxItem False + mibirid <- + insertUnique $ InboxItemRemote ibidProject ractidCreate ibiid + case mibirid of + Nothing -> do + delete ibiid + return Nothing + Just _ -> return $ Just ractidCreate + + insertAccept obidProject luCreate tlocal = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hLocal <- asksSite siteInstanceHost + obiidAccept <- insert OutboxItem + { outboxItemOutbox = obidProject + , outboxItemActivity = + persistJSONObjectFromDoc $ Doc hLocal emptyActivity + , outboxItemPublished = now + } + obikhidAccept <- encodeKeyHashid obiidAccept + summary <- do + let uAuthor@(ObjURI hAuthor luAuthor) = remoteAuthorURI author + ra <- getJust $ remoteAuthorId author + TextHtml . TL.toStrict . renderHtml <$> + withUrlRenderer + [hamlet| +

+ + $maybe name <- remoteActorName ra + #{name} + $nothing + #{renderAuthority hAuthor}#{localUriPath luAuthor} + \'s ticket accepted and listed by project # + + ./s/#{shr2text shrRecip}/p/#{prj2text prjRecip} + \: # + + #{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}. + |] + let localRecipsA = + [ + ] + localRecipsC = + [ LocalPersonCollectionProjectTeam shrRecip prjRecip + , LocalPersonCollectionProjectFollowers shrRecip prjRecip + ] + remoteRecipsA = + objUriLocal (remoteAuthorURI author) :| [] + remoteRecipsC = + [ LocalURI $ localUriPath (objUriLocal $ remoteAuthorURI author) <> "/followers" + , AP.ticketParticipants tlocal + , AP.ticketTeam tlocal + ] + localRecips = + map encodeRouteHome $ + map renderLocalActor localRecipsA ++ + map renderLocalPersonCollection localRecipsC + remoteRecips = + map (ObjURI $ objUriAuthority $ remoteAuthorURI author) $ + NE.toList remoteRecipsA ++ remoteRecipsC + recips = localRecips ++ remoteRecips + doc = Doc hLocal Activity + { activityId = + Just $ encodeRouteLocal $ + ProjectOutboxItemR shrRecip prjRecip obikhidAccept + , activityActor = + encodeRouteLocal $ ProjectR shrRecip prjRecip + , activitySummary = Just summary + , activityAudience = Audience recips [] [] [] [] [] + , activitySpecific = AcceptActivity Accept + { acceptObject = + ObjURI + (objUriAuthority $ remoteAuthorURI author) + luCreate + , acceptResult = Nothing + } + } + update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return + ( obiidAccept + , doc + , makeRecipientSet localRecipsA localRecipsC + , [(objUriAuthority $ remoteAuthorURI author, remoteRecipsA)] + , objUriAuthority $ remoteAuthorURI author + ) + + insertTicket jid luTicket published ractidCreate obiidAccept = do + tid <- insert Ticket + { ticketNumber = Nothing + , ticketCreated = published + , ticketTitle = unTextHtml $ AP.ticketSummary ticket + , ticketSource = unTextPandocMarkdown $ AP.ticketSource ticket + , ticketDescription = unTextHtml $ AP.ticketContent ticket + , ticketAssignee = Nothing + , ticketStatus = TSNew + , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 + , ticketCloser = Nothing + } + tplid <- insert TicketProjectLocal + { ticketProjectLocalTicket = tid + , ticketProjectLocalProject = jid + , ticketProjectLocalAccept = obiidAccept + } + mtarid <- insertUnique TicketAuthorRemote + { ticketAuthorRemoteTicket = tplid + , ticketAuthorRemoteAuthor = remoteAuthorId author + , ticketAuthorRemoteOpen = ractidCreate + } + case mtarid of + Nothing -> do + delete tplid + delete tid + return $ Left False + Just tarid -> do + roid <- either entityKey id <$> insertBy' RemoteObject + { remoteObjectInstance = remoteAuthorInstance author + , remoteObjectIdent = luTicket + } + mrtid <- insertUnique RemoteTicket + { remoteTicketTicket = tarid + , remoteTicketIdent = roid + } + case mrtid of + Nothing -> do + delete tarid + delete tplid + delete tid + return $ Left True + Just _rtid -> return $ Right () diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index a5a256d..81c74a8 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -1511,6 +1511,8 @@ changes hLocal ctx = , addEntities model_2020_02_22 -- 235 , addEntities model_2020_04_07 + -- 236 + , addEntities model_2020_04_09 ] migrateDB diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 5cc28c4..152228f 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -182,6 +182,7 @@ module Vervis.Migration.Model , RemoteMessage227Generic (..) , model_2020_02_22 , model_2020_04_07 + , model_2020_04_09 ) where @@ -359,3 +360,6 @@ model_2020_02_22 = $(schema "2020_02_22_tpr") model_2020_04_07 :: [Entity SqlBackend] model_2020_04_07 = $(schema "2020_04_07_tpra") + +model_2020_04_09 :: [Entity SqlBackend] +model_2020_04_09 = $(schema "2020_04_09_rt")