S2S: Write Create/Ticket project inbox handler: list ticket & do inbox fwding

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

migrations/2020_04_09_rt.model

@@ -0,0 +1,6 @@
+RemoteTicket
+    ticket  TicketAuthorRemoteId
+    ident   RemoteObjectId
+
+    UniqueRemoteTicket      ticket
+    UniqueRemoteTicketIdent ident

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]

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

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|
+                        <p>
+                          <a href="#{renderObjURI uAuthor}">
+                            $maybe name <- remoteActorName ra
+                              #{name}
+                            $nothing
+                              #{renderAuthority hAuthor}#{localUriPath luAuthor}
+                          \'s ticket accepted and listed by project #
+                          <a href=@{ProjectR shrRecip prjRecip}>
+                            ./s/#{shr2text shrRecip}/p/#{prj2text prjRecip}
+                          \: #
+                          <a href="#{renderObjURI $ ObjURI hAuthor $ AP.ticketId tlocal}">
+                            #{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 ()

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

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")