sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 15:04:50 +09:00
Code Issues Activity

Publish Accept activity when creating a new ticket from the Offer

Browse source
This commit is contained in:
fr33domlover 2019-06-26 01:12:11 +00:00
parent 0a4c2ad817
commit 07f76d2a6f
10 changed files with 494 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
config/models
View file

@ -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

92
migrations/2019_06_24.model Normal file
View file

@ -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

92
src/Vervis/API.hs
View file

@ -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)
deliverLocal shrProject prjProject now pidAuthor mprojAndDeps obiid recips = do
return (obiid, doc, luAct)
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
next <-
((subtract 1) . projectNextTicket) <$>
updateGet jid [ProjectNextTicket +=. 1]
insertAccept pidAuthor sid jid fsid luOffer num = do
now <- liftIO getCurrentTime
obid <- projectOutbox <$> getJust jid
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

7
src/Vervis/ActivityPub.hs
View file

@ -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

4
src/Vervis/Federation.hs
View file

@ -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

191
src/Vervis/Federation/Ticket.hs
View file

@ -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
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
lift $ for_ mremotesHttp $ \ (sig, remotesHttp) -> do
let handler e = logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
forkHandler handler $
deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
lift $ do
mticket <- insertTicket luOffer jid ibid tids
for mticket $ \ (ractid, num, obiidAccept, docAccept) -> do
msr <- for msig $ \ sig -> do
remoteRecips <- deliverLocal ractid colls sid fsid
(sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips
return (num, msr, obiidAccept, docAccept)
lift $ for_ mremotesHttp $ \ (num, msr, obiidAccept, docAccept) -> do
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

1
src/Vervis/Form/Ticket.hs
View file

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

104
src/Vervis/Migration.hs
View file

@ -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

14
src/Vervis/Migration/Model.hs
View file

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

18
src/Web/ActivityPub.hs
View file

@ -679,13 +679,19 @@ instance ActivityPub Ticket where
data Accept = Accept
{ acceptObject :: FedURI
, acceptResult :: LocalURI
}
parseAccept :: Object -> Parser Accept
parseAccept o = Accept <$> o .: "object"
parseAccept :: Text -> Object -> Parser Accept
parseAccept h o =
Accept
<$> o .: "object"
<*> (withHost h $ f2l <$> o .: "result")
encodeAccept :: Accept -> Series
encodeAccept (Accept obj) = "object" .= obj
encodeAccept :: Text -> Accept -> Series
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