Publish Accept activity when creating a new ticket from the Offer

config/models

@@ -304,10 +304,12 @@ Ticket
     closer      PersonId      Maybe
     discuss     DiscussionId
     followers   FollowerSetId
+    accept      OutboxItemId
 
     UniqueTicket project number
     UniqueTicketDiscussion discuss
     UniqueTicketFollowers followers
+    UniqueTicketAccept accept
 
 TicketAuthorLocal
     ticket TicketId

migrations/2019_06_24.model

@@ -0,0 +1,92 @@
+Sharer
+    ident   ShrIdent
+    name    Text     Maybe
+    created UTCTime
+
+    UniqueSharer ident
+
+Person
+    ident               SharerId
+    login               Text
+    passphraseHash      ByteString
+    email               Text
+    verified            Bool
+    verifiedKey         Text
+    verifiedKeyCreated  UTCTime
+    resetPassKey        Text
+    resetPassKeyCreated UTCTime
+    about               Text
+    inbox               InboxId
+    outbox              OutboxId
+
+    UniquePersonIdent ident
+    UniquePersonLogin login
+    UniquePersonEmail email
+    UniquePersonInbox inbox
+    UniquePersonOutbox outbox
+
+Outbox
+
+OutboxItem
+    outbox    OutboxId
+    activity  PersistActivity
+    published UTCTime
+
+Inbox
+
+InboxItem
+    unread Bool
+
+InboxItemLocal
+    inbox    InboxId
+    activity OutboxItemId
+    item     InboxItemId
+
+    UniqueInboxItemLocal inbox activity
+    UniqueInboxItemLocalItem item
+
+Project
+    ident      PrjIdent
+    sharer     SharerId
+    name       Text          Maybe
+    desc       Text          Maybe
+    workflow   Int64
+    nextTicket Int
+    wiki       Int64         Maybe
+    collabUser Int64         Maybe
+    collabAnon Int64         Maybe
+    inbox      InboxId
+    outbox     OutboxId
+    followers  Int64
+
+    UniqueProject ident sharer
+    UniqueProjectInbox inbox
+    UniqueProjectOutbox outbox
+    UniqueProjectFollowers followers
+
+Ticket
+    project     ProjectId
+    number      Int
+    created     UTCTime
+    title       Text                -- HTML
+    source      Text                -- Pandoc Markdown
+    description Text                -- HTML
+    assignee    PersonId      Maybe
+    status      Text
+    closed      UTCTime
+    closer      PersonId      Maybe
+    discuss     Int64
+    followers   Int64
+    accept      OutboxItemId
+
+    UniqueTicket project number
+    UniqueTicketDiscussion discuss
+    UniqueTicketFollowers followers
+
+TicketAuthorLocal
+    ticket TicketId
+    author PersonId
+    offer  OutboxItemId
+
+    UniqueTicketAuthorLocal ticket
+    UniqueTicketAuthorLocalOffer offer

src/Vervis/API.hs

@@ -53,6 +53,7 @@ import Network.HTTP.Client
 import Network.HTTP.Types.Header
 import Network.HTTP.Types.URI
 import Network.TLS hiding (SHA256)
+import Text.Blaze.Html (preEscapedToHtml)
 import Text.Blaze.Html.Renderer.Text
 import UnliftIO.Exception (try)
 import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
@@ -468,9 +469,9 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
             if targetIsLocal
                 then Just <$> getProjectAndDeps shrProject prjProject deps
                 else return Nothing
-        (obiid, doc) <- lift $ insertToOutbox now obidAuthor
+        (obiid, doc, luOffer) <- lift $ insertToOutbox now obidAuthor
         moreRemotes <-
-            lift $ deliverLocal shrProject prjProject now pidAuthor mprojAndDeps obiid localRecips
+            lift $ deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer localRecips
         unless (federation || null moreRemotes) $
             throwE "Federation disabled but remote collection members found"
         remotesHttp <- lift $ deliverRemoteDB' hProject obiid remoteRecips moreRemotes
@@ -535,8 +536,8 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
         let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
             doc = activity $ Just luAct
         update obiid [OutboxItemActivity =. PersistJSON doc]
-        return (obiid, doc)
+        return (obiid, doc, luAct)
-    deliverLocal shrProject prjProject now pidAuthor mprojAndDeps obiid recips = do
+    deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer recips = do
         (pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer projects) -> do
             (pids, remotes) <-
                 traverseCollect (uncurry $ deliverLocalProject shr) projects
@@ -571,7 +572,12 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
                       prj == prjProject &&
                       localRecipProject project -> do
                         insertToInbox ibid
-                        insertTicket jid tids
+                        num <-
+                            ((subtract 1) . projectNextTicket) <$>
+                                updateGet jid [ProjectNextTicket +=. 1]
+                        (obiidAccept, docAccept) <- insertAccept pidAuthor sid jid fsid luOffer num
+                        insertTicket jid tids num obiidAccept
+                        publishAccept pidAuthor sid jid fsid luOffer num obiidAccept docAccept
                         (pidsTeam, remotesTeam) <-
                             if localRecipProjectTeam project
                                 then getProjectTeam sid
@@ -589,10 +595,59 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
             insertToInbox ibid = do
                 ibiid <- insert $ InboxItem False
                 insert_ $ InboxItemLocal ibid obiid ibiid
-            insertTicket jid tidsDeps = do
+            insertAccept pidAuthor sid jid fsid luOffer num = do
-                next <-
+                now <- liftIO getCurrentTime
-                    ((subtract 1) . projectNextTicket) <$>
+                obid <- projectOutbox <$> getJust jid
-                        updateGet jid [ProjectNextTicket +=. 1]
+                insertToOutbox now obid
+                where
+                insertToOutbox now obid = do
+                    summary <-
+                        TextHtml . TL.toStrict . renderHtml <$>
+                            withUrlRenderer
+                                [hamlet|
+                                    <p>
+                                      <a href=@{SharerR shrUser}>
+                                        #{shr2text shrUser}
+                                      's ticket accepted by project #
+                                      <a href=@{ProjectR shrProject prjProject}>
+                                        ./s/#{shr2text shrProject}/p/#{prj2text prjProject}
+                                      : #
+                                      <a href=@{TicketR shrProject prjProject num}>
+                                        #{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}.
+                                |]
+                    hLocal <- asksSite siteInstanceHost
+                    encodeRouteLocal <- getEncodeRouteLocal
+                    encodeRouteHome <- getEncodeRouteHome
+                    let recips =
+                            map encodeRouteHome
+                                [ SharerR shrUser
+                                , ProjectTeamR shrProject prjProject
+                                , ProjectFollowersR shrProject prjProject
+                                ]
+                        accept luAct = Doc hLocal Activity
+                            { activityId       = luAct
+                            , activityActor    =
+                                encodeRouteLocal $ ProjectR shrProject prjProject
+                            , activitySummary  = Just summary
+                            , activityAudience = Audience recips [] [] [] [] []
+                            , activitySpecific = AcceptActivity Accept
+                                { acceptObject = l2f hLocal luOffer
+                                , acceptResult =
+                                    encodeRouteLocal $ TicketR shrProject prjProject num
+                                }
+                            }
+                    obiid <- insert OutboxItem
+                        { outboxItemOutbox    = obid
+                        , outboxItemActivity  = PersistJSON $ accept Nothing
+                        , outboxItemPublished = now
+                        }
+                    encodeRouteLocal <- getEncodeRouteLocal
+                    obikhid <- encodeKeyHashid obiid
+                    let luAct = encodeRouteLocal $ ProjectOutboxItemR shrProject prjProject obikhid
+                        doc = accept $ Just luAct
+                    update obiid [OutboxItemActivity =. PersistJSON doc]
+                    return (obiid, doc)
+            insertTicket jid tidsDeps next obiidAccept = do
                 did <- insert Discussion
                 fsid <- insert FollowerSet
                 tid <- insert Ticket
@@ -609,6 +664,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
                     , ticketCloser      = Nothing
                     , ticketDiscuss     = did
                     , ticketFollowers   = fsid
+                    , ticketAccept      = obiidAccept
                     }
                 insert TicketAuthorLocal
                     { ticketAuthorLocalTicket = tid
@@ -616,6 +672,24 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
                     , ticketAuthorLocalOffer  = obiid
                     }
                 insertMany_ $ map (TicketDependency tid) tidsDeps
+            publishAccept pidAuthor sid jid fsid luOffer num obiid doc = do
+                now <- liftIO getCurrentTime
+                remotesHttp <- do
+                    moreRemotes <- deliverLocal now sid fsid obiid
+                    deliverRemoteDB' "dont-do.any-forwarding" obiid [] moreRemotes
+                site <- askSite
+                liftIO $ runWorker (deliverRemoteHttp "dont-do.any-forwarding" obiid doc remotesHttp) site
+                where
+                deliverLocal now sid fsid obiid = do
+                    (pidsTeam, remotesTeam) <- getProjectTeam sid
+                    (pidsFollowers, remotesFollowers) <- getFollowers fsid
+                    let pids = LO.insertSet pidAuthor $ LO.union pidsTeam pidsFollowers
+                        remotes = unionRemotes remotesTeam remotesFollowers
+                    for_ pids $ \ pid -> do
+                        ibid <- personInbox <$> getJust pid
+                        ibiid <- insert $ InboxItem True
+                        insert_ $ InboxItemLocal ibid obiid ibiid
+                    return remotes
 
 getFollowersCollection
     :: Route App -> AppDB FollowerSetId -> Handler TypedContent

src/Vervis/ActivityPub.hs

@@ -67,7 +67,10 @@ import Database.Persist
 import Database.Persist.Sql
 import Network.HTTP.Client
 import Network.TLS -- hiding (SHA256)
+import Text.Blaze.Html (preEscapedToHtml)
+import Text.Blaze.Html.Renderer.Text
 import UnliftIO.Exception (try)
+import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
 import Yesod.Core.Handler
 import Yesod.Persist.Core
 
@@ -76,10 +79,12 @@ import qualified Data.CaseInsensitive as CI
 import qualified Data.List.NonEmpty as NE
 import qualified Data.List.Ordered as LO
 import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
 import qualified Database.Esqueleto as E
 
 import Yesod.HttpSignature
 
+import Database.Persist.JSON
 import Network.FedURI
 import Network.HTTP.Digest
 import Web.ActivityPub
@@ -88,6 +93,8 @@ import Yesod.MonadSite
 import Yesod.FedURI
 import Yesod.Hashids
 
+import qualified Web.ActivityPub as AP
+
 import Control.Monad.Trans.Except.Local
 import Data.Either.Local
 import Data.List.NonEmpty.Local

src/Vervis/Federation.hs

@@ -217,10 +217,14 @@ handleSharerInbox _now shrRecip (ActivityAuthLocalProject jidAuthor) body = do
                     return $ "Activity inserted to inbox of /s/" <> recip
 handleSharerInbox now shrRecip (ActivityAuthRemote author) body =
     case activitySpecific $ actbActivity body of
+        AcceptActivity accept ->
+            sharerAcceptOfferTicketF now shrRecip author body accept
         CreateActivity (Create note) ->
             sharerCreateNoteF now shrRecip author body note
         OfferActivity offer ->
             sharerOfferTicketF now shrRecip author body offer
+        RejectActivity reject ->
+            sharerRejectOfferTicketF now shrRecip author body reject
         _ -> return "Unsupported activity type"
 
 handleProjectInbox

src/Vervis/Federation/Ticket.hs

@@ -15,6 +15,8 @@
 
 module Vervis.Federation.Ticket
     ( sharerOfferTicketF
+    , sharerAcceptOfferTicketF
+    , sharerRejectOfferTicketF
     , projectOfferTicketF
     )
 where
@@ -29,24 +31,32 @@ import Data.Bifunctor
 import Data.Foldable
 import Data.Function
 import Data.List (nub, union)
-import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe
 import Data.Text (Text)
 import Data.Time.Calendar
 import Data.Time.Clock
 import Data.Traversable
 import Database.Persist
+import Text.Blaze.Html (preEscapedToHtml)
+import Text.Blaze.Html.Renderer.Text
+import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
 import Yesod.Core.Handler
 import Yesod.Persist.Core
 
+import qualified Data.List.NonEmpty as NE
+import qualified Data.List.Ordered as LO
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+
 import Database.Persist.JSON
 import Network.FedURI
 import Web.ActivityPub hiding (Ticket (..))
 import Yesod.ActivityPub
 import Yesod.FedURI
+import Yesod.Hashids
+import Yesod.MonadSite
 
-import qualified Data.List.NonEmpty as NE
-import qualified Data.Text as T
 import qualified Web.ActivityPub as AP
 
 import Control.Monad.Trans.Except.Local
@@ -119,6 +129,68 @@ sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
                 return $ "Activity already exists in inbox of /s/" <> recip
             Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
 
+sharerAcceptOfferTicketF
+    :: UTCTime
+    -> ShrIdent
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Accept
+    -> ExceptT Text Handler Text
+sharerAcceptOfferTicketF now shrRecip author body (Accept _uOffer _luTicket) = do
+    luAccept <-
+        fromMaybeE (activityId $ actbActivity body) "Accept without 'id'"
+    lift $ runDB $ do
+        ibidRecip <- do
+            sid <- getKeyBy404 $ UniqueSharer shrRecip
+            p <- getValBy404 $ UniquePersonIdent sid
+            return $ personInbox p
+        insertToInbox luAccept ibidRecip
+    where
+    insertToInbox luAccept ibidRecip = do
+        let iidAuthor = remoteAuthorInstance author
+            jsonObj = PersistJSON $ actbObject body
+            ract = RemoteActivity iidAuthor luAccept jsonObj now
+        ractid <- either entityKey id <$> insertBy' ract
+        ibiid <- insert $ InboxItem True
+        mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
+        let recip = shr2text shrRecip
+        case mibrid of
+            Nothing -> do
+                delete ibiid
+                return $ "Activity already exists in inbox of /s/" <> recip
+            Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
+
+sharerRejectOfferTicketF
+    :: UTCTime
+    -> ShrIdent
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Reject
+    -> ExceptT Text Handler Text
+sharerRejectOfferTicketF now shrRecip author body (Reject _uOffer) = do
+    luReject <-
+        fromMaybeE (activityId $ actbActivity body) "Reject without 'id'"
+    lift $ runDB $ do
+        ibidRecip <- do
+            sid <- getKeyBy404 $ UniqueSharer shrRecip
+            p <- getValBy404 $ UniquePersonIdent sid
+            return $ personInbox p
+        insertToInbox luReject ibidRecip
+    where
+    insertToInbox luReject ibidRecip = do
+        let iidAuthor = remoteAuthorInstance author
+            jsonObj = PersistJSON $ actbObject body
+            ract = RemoteActivity iidAuthor luReject jsonObj now
+        ractid <- either entityKey id <$> insertBy' ract
+        ibiid <- insert $ InboxItem True
+        mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
+        let recip = shr2text shrRecip
+        case mibrid of
+            Nothing -> do
+                delete ibiid
+                return $ "Activity already exists in inbox of /s/" <> recip
+            Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
+
 data OfferTicketRecipColl
     = OfferTicketRecipProjectFollowers
     | OfferTicketRecipProjectTeam
@@ -156,15 +228,19 @@ projectOfferTicketF
                 mremotesHttp <- runDBExcept $ do
                     (sid, jid, ibid, fsid, tids) <-
                         getProjectAndDeps shrRecip prjRecip deps
-                    lift $ join <$> do
+                    lift $ do
-                        mractid <- insertTicket luOffer jid ibid tids
+                        mticket <- insertTicket luOffer jid ibid tids
-                        for mractid $ \ ractid -> for msig $ \ sig -> do
+                        for mticket $ \ (ractid, num, obiidAccept, docAccept) -> do
-                            remoteRecips <- deliverLocal ractid colls sid fsid
+                            msr <- for msig $ \ sig -> do
-                            (sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips
+                                remoteRecips <- deliverLocal ractid colls sid fsid
-                lift $ for_ mremotesHttp $ \ (sig, remotesHttp) -> do
+                                (sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips
-                    let handler e = logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
+                            return (num, msr, obiidAccept, docAccept)
-                    forkHandler handler $
+                lift $ for_ mremotesHttp $ \ (num, msr, obiidAccept, docAccept) -> do
-                        deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
+                    let handler e = logError $ "Project Accept sender: delivery failed! " <> T.pack (displayException e)
+                    for msr $ \ (sig, remotesHttp) -> do
+                        forkHandler handler $
+                            deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
+                    forkHandler handler $ publishAccept luOffer num obiidAccept docAccept
                 return $ recip <> " inserted new ticket"
     where
     recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
@@ -222,6 +298,7 @@ projectOfferTicketF
                         updateGet jid [ProjectNextTicket +=. 1]
                 did <- insert Discussion
                 fsid <- insert FollowerSet
+                (obiidAccept, docAccept) <- insertAccept luOffer next
                 tid <- insert Ticket
                     { ticketProject     = jid
                     , ticketNumber      = next
@@ -236,6 +313,7 @@ projectOfferTicketF
                     , ticketCloser      = Nothing
                     , ticketDiscuss     = did
                     , ticketFollowers   = fsid
+                    , ticketAccept      = obiidAccept
                     }
                 insert_ TicketAuthorRemote
                     { ticketAuthorRemoteTicket = tid
@@ -243,7 +321,7 @@ projectOfferTicketF
                     , ticketAuthorRemoteOffer  = ractid
                     }
                 insertMany_ $ map (TicketDependency tid) deps
-                return $ Just ractid
+                return $ Just (ractid, next, obiidAccept, docAccept)
 
     deliverLocal
         :: RemoteActivityId
@@ -269,3 +347,90 @@ projectOfferTicketF
             when (isNothing mibrid) $
                 delete ibiid
         return remotes
+
+    insertAccept luOffer num = do
+        now <- liftIO getCurrentTime
+        (sid, project) <- do
+            sid <- fromJust <$> getKeyBy (UniqueSharer shrRecip)
+            j <- fromJust <$> getValBy (UniqueProject prjRecip sid)
+            return (sid, j)
+        insertToOutbox now $ projectOutbox project
+        where
+        insertToOutbox now obid = do
+            summary <-
+                TextHtml . TL.toStrict . renderHtml <$>
+                    withUrlRenderer
+                        [hamlet|
+                            <p>
+                              <a href="#{renderFedURI $ remoteAuthorURI author}">
+                                (?)
+                              's ticket accepted by project #
+                              <a href=@{ProjectR shrRecip prjRecip}>
+                                ./s/#{shr2text shrRecip}/p/#{prj2text prjRecip}
+                              : #
+                              <a href=@{TicketR shrRecip prjRecip num}>
+                                #{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}.
+                        |]
+            hLocal <- asksSite siteInstanceHost
+            encodeRouteLocal <- getEncodeRouteLocal
+            encodeRouteHome <- getEncodeRouteHome
+            let recips =
+                    remoteAuthorURI author :
+                    map encodeRouteHome
+                        [ ProjectTeamR shrRecip prjRecip
+                        , ProjectFollowersR shrRecip prjRecip
+                        ]
+                accept luAct = Doc hLocal Activity
+                    { activityId       = luAct
+                    , activityActor    =
+                        encodeRouteLocal $ ProjectR shrRecip prjRecip
+                    , activitySummary  = Just summary
+                    , activityAudience = Audience recips [] [] [] [] []
+                    , activitySpecific = AcceptActivity Accept
+                        { acceptObject =
+                            l2f (furiHost $ remoteAuthorURI author) luOffer
+                        , acceptResult =
+                            encodeRouteLocal $ TicketR shrRecip prjRecip num
+                        }
+                    }
+            obiid <- insert OutboxItem
+                { outboxItemOutbox    = obid
+                , outboxItemActivity  = PersistJSON $ accept Nothing
+                , outboxItemPublished = now
+                }
+            encodeRouteLocal <- getEncodeRouteLocal
+            obikhid <- encodeKeyHashid obiid
+            let luAct = encodeRouteLocal $ ProjectOutboxItemR shrRecip prjRecip obikhid
+                doc = accept $ Just luAct
+            update obiid [OutboxItemActivity =. PersistJSON doc]
+            return (obiid, doc)
+
+    publishAccept luOffer num obiid doc = do
+        now <- liftIO getCurrentTime
+        remotesHttp <- runDB $ do
+            (sid, project) <- do
+                sid <- fromJust <$> getKeyBy (UniqueSharer shrRecip)
+                j <- fromJust <$> getValBy (UniqueProject prjRecip sid)
+                return (sid, j)
+            moreRemotes <- deliverLocal now sid (projectFollowers project) obiid
+            let raidAuthor = remoteAuthorId author
+            ra <- getJust raidAuthor
+            let raInfo = (raidAuthor, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra)
+                iidAuthor = remoteAuthorInstance author
+                hAuthor = furiHost $ remoteAuthorURI author
+                hostSection = ((iidAuthor, hAuthor), raInfo :| [])
+                remotes = unionRemotes [hostSection] moreRemotes
+            deliverRemoteDB' "dont-do.any-forwarding" obiid [] remotes
+        site <- askSite
+        liftIO $ runWorker (deliverRemoteHttp "dont-do.any-forwarding" obiid doc remotesHttp) site
+        where
+        deliverLocal now sid fsid obiid = do
+            (pidsTeam, remotesTeam) <- getProjectTeam sid
+            (pidsFollowers, remotesFollowers) <- getFollowers fsid
+            let pids = LO.union pidsTeam pidsFollowers
+                remotes = unionRemotes remotesTeam remotesFollowers
+            for_ pids $ \ pid -> do
+                ibid <- personInbox <$> getJust pid
+                ibiid <- insert $ InboxItem True
+                insert_ $ InboxItemLocal ibid obiid ibiid
+            return remotes

src/Vervis/Form/Ticket.hs

@@ -140,6 +140,7 @@ editTicketContentAForm ticket = Ticket
     <*> pure (ticketCloser ticket)
     <*> pure (ticketDiscuss ticket)
     <*> pure (ticketFollowers ticket)
+    <*> pure (ticketAccept ticket)
 
 tEditField
     :: TicketTextParam

src/Vervis/Migration.hs

@@ -44,7 +44,7 @@ import Database.Persist.Schema (SchemaT, Migration)
 import Database.Persist.Schema.Types hiding (Entity)
 import Database.Persist.Schema.PostgreSQL (schemaBackend)
 import Database.Persist.Sql (SqlBackend, toSqlKey)
-import Text.Blaze.Html (toHtml)
+import Text.Blaze.Html (toHtml, preEscapedToHtml)
 import Text.Blaze.Html.Renderer.Text
 --import Text.Email.QuasiQuotation (email
 import Text.Email.Validate (unsafeEmailAddress)
@@ -321,7 +321,7 @@ changes hLocal ctx =
                     , activityActor    = localUri
                     , activitySummary  = Nothing
                     , activityAudience = Audience [] [] [] [] [] []
-                    , activitySpecific = AcceptActivity $ Accept fedUri
+                    , activitySpecific = RejectActivity $ Reject fedUri
                     }
             insertEntity $ OutboxItem201905 pid (PersistJSON doc) defaultTime
         )
@@ -688,7 +688,7 @@ changes hLocal ctx =
                     , activityActor    = localUri
                     , activitySummary  = Nothing
                     , activityAudience = Audience [] [] [] [] [] []
-                    , activitySpecific = AcceptActivity $ Accept fedUri
+                    , activitySpecific = RejectActivity $ Reject fedUri
                     }
             insertEntity $ OutboxItem20190612 pid (PersistJSON doc) defaultTime
         )
@@ -842,6 +842,104 @@ changes hLocal ctx =
             let title =
                     TL.toStrict $ renderHtml $ toHtml $ ticket20190612Title t
             in  update tid [Ticket20190612Title =. title]
+      -- 124
+    , addFieldRefRequired''
+        "Ticket"
+        (do obid <- insert Outbox20190624
+            let localUri = LocalURI "/x/y" ""
+                fedUri = l2f "x.y" localUri
+                doc = Doc "x.y" Activity
+                    { activityId       = Nothing
+                    , activityActor    = localUri
+                    , activitySummary  = Nothing
+                    , activityAudience = Audience [] [] [] [] [] []
+                    , activitySpecific = RejectActivity $ Reject fedUri
+                    }
+            insertEntity $ OutboxItem20190624 obid (PersistJSON doc) defaultTime
+        )
+        (Just $ \ (Entity obiidTemp obiTemp) -> do
+            ts <- selectList ([] :: [Filter Ticket20190624]) []
+            for_ ts $ \ (Entity tid ticket) -> do
+                let num = ticket20190624Number ticket
+                j <- getJust $ ticket20190624Project ticket
+                let prj = project20190624Ident j
+                    ibidProject = project20190624Inbox j
+                    obidProject = project20190624Outbox j
+                sProject <- getJust $ project20190624Sharer j
+                let shrProject = sharer20190624Ident sProject
+
+                Entity talid tal <-
+                    fromJust <$> getBy (UniqueTicketAuthorLocal20190624 tid)
+                let pidAuthor = ticketAuthorLocal20190624Author tal
+                pAuthor <- getJust pidAuthor
+                let ibidAuthor = person20190624Inbox pAuthor
+                sAuthor <- getJust $ person20190624Ident pAuthor
+                let shrAuthor = sharer20190624Ident sAuthor
+
+                encodeRouteLocal <- getEncodeRouteLocal
+                encodeRouteHome <- getEncodeRouteHome
+                renderUrl <- askUrlRenderParams
+                offerR <- do
+                    let obiidOffer = ticketAuthorLocal20190624Offer tal
+                    obikhid <-
+                        encodeKeyHashid $ E.toSqlKey $ E.fromSqlKey obiidOffer
+                    return $ SharerOutboxItemR shrAuthor obikhid
+
+                let recips = map encodeRouteHome
+                        [ SharerR shrAuthor
+                        , ProjectTeamR shrProject prj
+                        , ProjectFollowersR shrProject prj
+                        ]
+                    author = encodeRouteLocal $ SharerR shrAuthor
+                    summary =
+                        [hamlet|
+                            <p>
+                              <a href=@{SharerR shrAuthor}>
+                                #{shr2text shrAuthor}
+                              's ticket accepted by project #
+                              <a href=@{ProjectR shrProject prj}>
+                                ./s/#{shr2text shrProject}/p/#{prj2text prj}
+                              : #
+                              <a href=@{TicketR shrProject prj num}>
+                                #{preEscapedToHtml $ ticket20190624Title ticket}.
+                        |]
+                    doc mluAct = Doc hLocal Activity
+                        { activityId       = mluAct
+                        , activityActor    = author
+                        , activitySummary  =
+                            Just $ TextHtml $ TL.toStrict $ renderHtml $
+                                summary renderUrl
+                        , activityAudience = Audience recips [] [] [] [] []
+                        , activitySpecific = AcceptActivity Accept
+                            { acceptObject = encodeRouteHome offerR
+                            , acceptResult =
+                                encodeRouteLocal $ TicketR shrProject prj num
+                            }
+                        }
+                obiidNew <- insert OutboxItem20190624
+                    { outboxItem20190624Outbox    = obidProject
+                    , outboxItem20190624Activity  = PersistJSON $ doc Nothing
+                    , outboxItem20190624Published =
+                        ticket20190624Created ticket
+                    }
+                obikhidNew <-
+                    encodeKeyHashid $ E.toSqlKey $ E.fromSqlKey obiidNew
+                let luAct =
+                        encodeRouteLocal $
+                            ProjectOutboxItemR shrProject prj obikhidNew
+                    act = doc $ Just luAct
+                update obiidNew [OutboxItem20190624Activity =. PersistJSON act]
+                update tid [Ticket20190624Accept =. obiidNew]
+                ibiid <- insert $ InboxItem20190624 True
+                insert_ $ InboxItemLocal20190624 ibidAuthor obiidNew ibiid
+
+            delete obiidTemp
+            delete $ outboxItem20190624Outbox obiTemp
+        )
+        "accept"
+        "OutboxItem"
+      -- 125
+    , addUnique "Ticket" $ Unique "UniqueTicketAccept" ["accept"]
     ]
 
 migrateDB

src/Vervis/Migration/Model.hs

@@ -99,6 +99,17 @@ module Vervis.Migration.Model
     , Project20190616Generic (..)
     , Project20190616
     , Outbox20190616Generic (..)
+    , Sharer20190624Generic (..)
+    , Person20190624Generic (..)
+    , Outbox20190624Generic (..)
+    , OutboxItem20190624Generic (..)
+    , Inbox20190624Generic (..)
+    , InboxItem20190624Generic (..)
+    , InboxItemLocal20190624Generic (..)
+    , Project20190624Generic (..)
+    , Ticket20190624Generic (..)
+    , Ticket20190624
+    , TicketAuthorLocal20190624Generic (..)
     )
 where
 
@@ -213,3 +224,6 @@ makeEntitiesMigration "20190615"
 
 makeEntitiesMigration "20190616"
     $(modelFile "migrations/2019_06_16.model")
+
+makeEntitiesMigration "20190624"
+    $(modelFile "migrations/2019_06_24.model")

src/Web/ActivityPub.hs

@@ -679,13 +679,19 @@ instance ActivityPub Ticket where
 
 data Accept = Accept
     { acceptObject :: FedURI
+    , acceptResult :: LocalURI
     }
 
-parseAccept :: Object -> Parser Accept
+parseAccept :: Text -> Object -> Parser Accept
-parseAccept o = Accept <$> o .: "object"
+parseAccept h o =
+    Accept
+        <$> o .: "object"
+        <*> (withHost h $ f2l <$> o .: "result")
 
-encodeAccept :: Accept -> Series
+encodeAccept :: Text -> Accept -> Series
-encodeAccept (Accept obj) = "object" .= obj
+encodeAccept host (Accept obj result)
+    =  "object" .= obj
+    <> "result" .= l2f host result
 
 data Create = Create
     { createObject :: Note
@@ -779,7 +785,7 @@ instance ActivityPub Activity where
                 <*> do
                     typ <- o .: "type"
                     case typ of
-                        "Accept" -> AcceptActivity <$> parseAccept o
+                        "Accept" -> AcceptActivity <$> parseAccept h o
                         "Create" -> CreateActivity <$> parseCreate o h actor
                         "Follow" -> FollowActivity <$> parseFollow o
                         "Offer"  -> OfferActivity  <$> parseOffer o h actor
@@ -801,7 +807,7 @@ instance ActivityPub Activity where
         activityType (FollowActivity _) = "Follow"
         activityType (OfferActivity _)  = "Offer"
         activityType (RejectActivity _) = "Reject"
-        encodeSpecific _ _ (AcceptActivity a) = encodeAccept a
+        encodeSpecific h _ (AcceptActivity a) = encodeAccept h a
         encodeSpecific h u (CreateActivity a) = encodeCreate h u a
         encodeSpecific _ _ (FollowActivity a) = encodeFollow a
         encodeSpecific h u (OfferActivity a)  = encodeOffer h u a