bb6785de75
This is the first step preparing for patches and merge requests. The work-item aspect of MRs will reuse the Ticket related tables, except MRs will live under repos. So, the context of tickets will no longer be just projects, but will also be repos. So, TicketProjectLocal turns into TicketContextLocal, and there are 2 new tables that refer to it: TicketProjectLocal and TicketRepoLocal. Tickets will have the former, MRs will have the latter.
737 lines
32 KiB
Haskell
737 lines
32 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
|
|
-
|
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
|
-
|
|
- The author(s) have dedicated all copyright and related and neighboring
|
|
- rights to this software to the public domain worldwide. This software is
|
|
- distributed without any warranty.
|
|
-
|
|
- You should have received a copy of the CC0 Public Domain Dedication along
|
|
- with this software. If not, see
|
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|
-}
|
|
|
|
module Vervis.Federation.Ticket
|
|
( sharerOfferTicketF
|
|
, projectOfferTicketF
|
|
|
|
, sharerCreateTicketF
|
|
, projectCreateTicketF
|
|
)
|
|
where
|
|
|
|
import Control.Exception hiding (Handler)
|
|
import Control.Monad
|
|
import Control.Monad.Logger.CallStack
|
|
import Control.Monad.Trans.Class
|
|
import Control.Monad.Trans.Except
|
|
import Control.Monad.Trans.Maybe
|
|
import Data.Aeson
|
|
import Data.Bifunctor
|
|
import Data.Foldable
|
|
import Data.Function
|
|
import Data.List (nub, union)
|
|
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 Web.ActivityPub as AP
|
|
|
|
import Control.Monad.Trans.Except.Local
|
|
import Data.Tuple.Local
|
|
import Database.Persist.Local
|
|
import Yesod.Persist.Local
|
|
|
|
import Vervis.ActivityPub
|
|
import Vervis.ActivityPub.Recipient
|
|
import Vervis.FedURI
|
|
import Vervis.Federation.Auth
|
|
import Vervis.Foundation
|
|
import Vervis.Model
|
|
import Vervis.Model.Ident
|
|
import Vervis.Model.Ticket
|
|
|
|
checkOffer
|
|
:: AP.Ticket URIMode
|
|
-> Host
|
|
-> ShrIdent
|
|
-> PrjIdent
|
|
-> ExceptT Text Handler ()
|
|
checkOffer ticket hProject shrProject prjProject = do
|
|
verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'"
|
|
verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'"
|
|
verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'"
|
|
-- verifyNothingE (AP.ticketName ticket) "Ticket with 'name'"
|
|
verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'"
|
|
when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved"
|
|
|
|
sharerOfferTicketF
|
|
:: UTCTime
|
|
-> ShrIdent
|
|
-> RemoteAuthor
|
|
-> ActivityBody
|
|
-> Offer URIMode
|
|
-> ExceptT Text Handler Text
|
|
sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
|
|
(hProject, shrProject, prjProject) <- parseTarget uTarget
|
|
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
|
|
{-deps <- -}
|
|
checkOffer ticket hProject shrProject prjProject
|
|
local <- hostIsLocal hProject
|
|
runDBExcept $ do
|
|
ibidRecip <- lift $ do
|
|
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
|
p <- getValBy404 $ UniquePersonIdent sid
|
|
return $ personInbox p
|
|
when local $ checkTargetAndDeps shrProject prjProject {-deps-}
|
|
lift $ insertToInbox luOffer ibidRecip
|
|
where
|
|
checkTargetAndDeps shrProject prjProject {-deps-} = do
|
|
msid <- lift $ getKeyBy $ UniqueSharer shrProject
|
|
sid <- fromMaybeE msid "Offer target: no such local sharer"
|
|
mjid <- lift $ getKeyBy $ UniqueProject prjProject sid
|
|
jid <- fromMaybeE mjid "Offer target: no such local project"
|
|
return ()
|
|
{-
|
|
for_ deps $ \ dep -> do
|
|
mt <- lift $ getBy $ UniqueTicket jid dep
|
|
unless (isJust mt) $
|
|
throwE "Local dep: No such ticket number in DB"
|
|
-}
|
|
insertToInbox luOffer ibidRecip = do
|
|
let iidAuthor = remoteAuthorInstance author
|
|
roid <-
|
|
either entityKey id <$> insertBy' (RemoteObject iidAuthor luOffer)
|
|
let jsonObj = persistJSONFromBL $ actbBL body
|
|
ract = RemoteActivity roid 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
|
|
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
|
|
-> PrjIdent
|
|
-> RemoteAuthor
|
|
-> ActivityBody
|
|
-> Offer URIMode
|
|
-> ExceptT Text Handler Text
|
|
projectOfferTicketF
|
|
now shrRecip prjRecip author body (Offer ticket uTarget) = do
|
|
targetIsUs <- lift $ runExceptT checkTarget
|
|
case targetIsUs of
|
|
Left t -> do
|
|
logWarn $ T.concat
|
|
[ recip, " got Offer Ticket with target "
|
|
, renderObjURI uTarget
|
|
]
|
|
return t
|
|
Right () -> do
|
|
luOffer <-
|
|
fromMaybeE
|
|
(activityId $ actbActivity body)
|
|
"Offer without 'id'"
|
|
hLocal <- getsYesod siteInstanceHost
|
|
{-deps <- -}
|
|
checkOffer ticket hLocal shrRecip prjRecip
|
|
msig <- checkForward $ LocalActorProject shrRecip prjRecip
|
|
let colls =
|
|
findRelevantCollections shrRecip prjRecip hLocal $
|
|
activityAudience $ actbActivity body
|
|
mremotesHttp <- runDBExcept $ do
|
|
(sid, jid, ibid, fsid{-, tids-}) <-
|
|
getProjectAndDeps shrRecip prjRecip {-deps-}
|
|
lift $ do
|
|
mticket <- do
|
|
ra <- getJust $ remoteAuthorId author
|
|
insertTicket ra luOffer jid ibid {-tids-}
|
|
for mticket $ \ (ractid, obiidAccept, docAccept) -> do
|
|
msr <- for msig $ \ sig -> do
|
|
remoteRecips <- deliverFwdLocal ractid colls sid fsid
|
|
(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
|
|
return (msr, obiidAccept, docAccept)
|
|
lift $ for_ mremotesHttp $ \ (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_J now shrRecip prjRecip (actbBL body) sig remotesHttp
|
|
forkHandler handler $ publishAccept luOffer obiidAccept docAccept
|
|
return $ recip <> " inserted new ticket"
|
|
where
|
|
recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
|
|
checkTarget = do
|
|
let ObjURI h lu = uTarget
|
|
local <- hostIsLocal h
|
|
unless local $
|
|
throwE $ recip <> " not using; target has different host"
|
|
route <-
|
|
case decodeRouteLocal lu of
|
|
Nothing ->
|
|
throwE $
|
|
recip <> " not using; local target isn't a valid route"
|
|
Just r -> return r
|
|
(shrTarget, prjTarget) <-
|
|
case route of
|
|
ProjectR shr prj -> return (shr, prj)
|
|
_ -> throwE $
|
|
recip <>
|
|
" not using; local target isn't a project route"
|
|
unless (shrTarget == shrRecip && prjTarget == prjRecip) $
|
|
throwE $ recip <> " not using; local target is a different project"
|
|
insertTicket ra luOffer jid ibid {-deps-} = do
|
|
let iidAuthor = remoteAuthorInstance author
|
|
roid <-
|
|
either entityKey id <$> insertBy' (RemoteObject iidAuthor luOffer)
|
|
let raidAuthor = remoteAuthorId author
|
|
ractid <- either entityKey id <$> insertBy' RemoteActivity
|
|
{ remoteActivityIdent = roid
|
|
, remoteActivityContent = persistJSONFromBL $ actbBL body
|
|
, remoteActivityReceived = now
|
|
}
|
|
ibiid <- insert $ InboxItem False
|
|
mibirid <- insertUnique $ InboxItemRemote ibid ractid ibiid
|
|
case mibirid of
|
|
Nothing -> do
|
|
delete ibiid
|
|
return Nothing
|
|
Just _ibirid -> do
|
|
{-
|
|
next <-
|
|
((subtract 1) . projectNextTicket) <$>
|
|
updateGet jid [ProjectNextTicket +=. 1]
|
|
-}
|
|
did <- insert Discussion
|
|
fsid <- insert FollowerSet
|
|
|
|
obiidAccept <- do
|
|
obidProject <- do
|
|
sid <- fromJust <$> getKeyBy (UniqueSharer shrRecip)
|
|
j <- fromJust <$> getValBy (UniqueProject prjRecip sid)
|
|
return $ projectOutbox j
|
|
hLocal <- asksSite siteInstanceHost
|
|
now <- liftIO getCurrentTime
|
|
insert OutboxItem
|
|
{ outboxItemOutbox = obidProject
|
|
, outboxItemActivity = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
|
|
, outboxItemPublished = now
|
|
}
|
|
|
|
tid <- insert Ticket
|
|
{ ticketNumber = Nothing
|
|
, ticketCreated = now
|
|
, 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
|
|
}
|
|
ltid <- insert LocalTicket
|
|
{ localTicketTicket = tid
|
|
, localTicketDiscuss = did
|
|
, localTicketFollowers = fsid
|
|
}
|
|
tclid <- insert TicketContextLocal
|
|
{ ticketContextLocalTicket = tid
|
|
, ticketContextLocalAccept = obiidAccept
|
|
}
|
|
insert_ TicketProjectLocal
|
|
{ ticketProjectLocalContext = tclid
|
|
, ticketProjectLocalProject = jid
|
|
}
|
|
insert_ TicketAuthorRemote
|
|
{ ticketAuthorRemoteTicket = tclid
|
|
, ticketAuthorRemoteAuthor = raidAuthor
|
|
, ticketAuthorRemoteOpen = ractid
|
|
}
|
|
docAccept <- insertAccept ra luOffer ltid obiidAccept
|
|
-- insertMany_ $ map (TicketDependency tid) deps
|
|
--insert_ $ RemoteFollow raidAuthor fsid False True
|
|
return $ Just (ractid, obiidAccept, docAccept)
|
|
|
|
insertAccept ra luOffer ltid obiid = do
|
|
let uAuthor@(ObjURI hAuthor luAuthor) = remoteAuthorURI author
|
|
ltkhid <- encodeKeyHashid ltid
|
|
summary <-
|
|
TextHtml . TL.toStrict . renderHtml <$>
|
|
withUrlRenderer
|
|
[hamlet|
|
|
<p>
|
|
<a href="#{renderObjURI uAuthor}">
|
|
$maybe name <- remoteActorName ra
|
|
#{name}
|
|
$nothing
|
|
#{renderAuthority hAuthor}#{localUriPath luAuthor}
|
|
\'s ticket accepted by project #
|
|
<a href=@{ProjectR shrRecip prjRecip}>
|
|
./s/#{shr2text shrRecip}/p/#{prj2text prjRecip}
|
|
\: #
|
|
<a href=@{ProjectTicketR shrRecip prjRecip ltkhid}>
|
|
#{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}.
|
|
|]
|
|
hLocal <- asksSite siteInstanceHost
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
obikhid <- encodeKeyHashid obiid
|
|
let recips =
|
|
remoteAuthorURI author :
|
|
map encodeRouteHome
|
|
[ ProjectTeamR shrRecip prjRecip
|
|
, ProjectFollowersR shrRecip prjRecip
|
|
]
|
|
doc = Doc hLocal Activity
|
|
{ activityId =
|
|
Just $ encodeRouteLocal $
|
|
ProjectOutboxItemR shrRecip prjRecip obikhid
|
|
, activityActor =
|
|
encodeRouteLocal $ ProjectR shrRecip prjRecip
|
|
, activitySummary = Just summary
|
|
, activityAudience = Audience recips [] [] [] [] []
|
|
, activitySpecific = AcceptActivity Accept
|
|
{ acceptObject =
|
|
ObjURI
|
|
(objUriAuthority $ remoteAuthorURI author)
|
|
luOffer
|
|
, acceptResult =
|
|
Just $ encodeRouteLocal $
|
|
ProjectTicketR shrRecip prjRecip ltkhid
|
|
}
|
|
}
|
|
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
|
return doc
|
|
|
|
publishAccept luOffer obiid doc = do
|
|
now <- liftIO getCurrentTime
|
|
let dont = Authority "dont-do.any-forwarding" Nothing
|
|
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
|
|
ro <- getJust $ remoteActorIdent ra
|
|
let raInfo = RemoteRecipient raidAuthor (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra)
|
|
iidAuthor = remoteAuthorInstance author
|
|
hAuthor = objUriAuthority $ remoteAuthorURI author
|
|
hostSection = ((iidAuthor, hAuthor), raInfo :| [])
|
|
remotes = unionRemotes [hostSection] moreRemotes
|
|
deliverRemoteDB' dont obiid [] remotes
|
|
site <- askSite
|
|
liftIO $ runWorker (deliverRemoteHttp dont 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
|
|
|
|
checkCreateTicket
|
|
:: RemoteAuthor
|
|
-> AP.Ticket URIMode
|
|
-> Maybe FedURI
|
|
-> 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, ticketData, published) <- checkTicket ticket
|
|
(, ticketData, published) <$> checkTargetAndContext mtarget context
|
|
where
|
|
checkTracker name u@(ObjURI h lu) = do
|
|
hl <- hostIsLocal h
|
|
if hl
|
|
then Left <$> do
|
|
route <-
|
|
fromMaybeE
|
|
(decodeRouteLocal lu)
|
|
(name <> " is local but isn't a valid route")
|
|
case route of
|
|
ProjectR shr prj -> return (shr, prj)
|
|
_ ->
|
|
throwE $
|
|
name <>
|
|
" is a valid local route, but isn't a project \
|
|
\route"
|
|
else return $ Right u
|
|
|
|
checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext _summary
|
|
_content _source muAssigned resolved) = do
|
|
(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)) $
|
|
throwE "Author created ticket hosted elsewhere"
|
|
unless (attrib == objUriLocal (remoteAuthorURI author)) $
|
|
throwE "Author created ticket attibuted to someone else"
|
|
uContext <- fromMaybeE muContext "Ticket without 'context'"
|
|
context <- checkTracker "Ticket context" uContext
|
|
|
|
pub <- fromMaybeE mpublished "Ticket without 'published'"
|
|
verifyNothingE mupdated "Ticket has 'updated'"
|
|
verifyNothingE muAssigned "Ticket has 'assignedTo'"
|
|
when resolved $ throwE "Ticket is resolved"
|
|
|
|
return (context, tlocal, pub)
|
|
|
|
checkTargetAndContext Nothing context =
|
|
return $
|
|
case context of
|
|
Left (shr, prj) -> Left (False, shr, prj)
|
|
Right (ObjURI h lu) -> Right (h, Nothing, lu)
|
|
checkTargetAndContext (Just target) context =
|
|
case (target, context) of
|
|
(Left _, Right _) ->
|
|
throwE "Create target is local but ticket context is remote"
|
|
(Right _, Left _) ->
|
|
throwE "Create target is remote but ticket context is local"
|
|
(Right (ObjURI hTarget luTarget), Right (ObjURI hContext luContext)) ->
|
|
if hTarget == hContext
|
|
then return $ Right (hTarget, Just luTarget, luContext)
|
|
else throwE "Create target and ticket context on \
|
|
\different remote hosts"
|
|
(Left (shr, prj), Left (shr', prj')) ->
|
|
if shr == shr' && prj == prj'
|
|
then return $ Left (True, shr, prj)
|
|
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
|
|
MaybeT $ getBy $ UniqueProject prj sid
|
|
unless (isJust mj) $ throwE "Local context: No such project"
|
|
checkTargetAndContextDB (Right _) = return ()
|
|
|
|
insertToInbox luAct ibidRecip = do
|
|
let iidAuthor = remoteAuthorInstance author
|
|
roid <-
|
|
either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct)
|
|
let jsonObj = persistJSONFromBL $ actbBL body
|
|
ract = RemoteActivity roid 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
|
|
|
|
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 $ LocalActorProject 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_J (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_J 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
|
|
ra <- getJust $ remoteAuthorId author
|
|
summary <- do
|
|
let uAuthor@(ObjURI hAuthor luAuthor) = remoteAuthorURI 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 = catMaybes
|
|
[ remoteActorFollowers ra
|
|
, Just $ AP.ticketParticipants tlocal
|
|
, Just $ 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
|
|
}
|
|
tclid <- insert TicketContextLocal
|
|
{ ticketContextLocalTicket = tid
|
|
, ticketContextLocalAccept = obiidAccept
|
|
}
|
|
tplid <- insert TicketProjectLocal
|
|
{ ticketProjectLocalContext = tclid
|
|
, ticketProjectLocalProject = jid
|
|
}
|
|
mtarid <- insertUnique TicketAuthorRemote
|
|
{ ticketAuthorRemoteTicket = tclid
|
|
, ticketAuthorRemoteAuthor = remoteAuthorId author
|
|
, ticketAuthorRemoteOpen = ractidCreate
|
|
}
|
|
case mtarid of
|
|
Nothing -> do
|
|
delete tplid
|
|
delete tclid
|
|
delete tid
|
|
return $ Left False
|
|
Just tarid -> do
|
|
roid <- either entityKey id <$> insertBy' RemoteObject
|
|
{ remoteObjectInstance = remoteAuthorInstance author
|
|
, remoteObjectIdent = luTicket
|
|
}
|
|
did <- insert Discussion
|
|
(rdid, rdnew) <- idAndNew <$> insertBy' RemoteDiscussion
|
|
{ remoteDiscussionIdent = roid
|
|
, remoteDiscussionDiscuss = did
|
|
}
|
|
unless rdnew $ delete did
|
|
mrtid <- insertUnique RemoteTicket
|
|
{ remoteTicketTicket = tarid
|
|
, remoteTicketIdent = roid
|
|
, remoteTicketDiscuss = rdid
|
|
}
|
|
case mrtid of
|
|
Nothing -> do
|
|
delete tarid
|
|
delete tplid
|
|
delete tclid
|
|
delete tid
|
|
return $ Left True
|
|
Just _rtid -> return $ Right ()
|