a2468c52fd
To be honest, this is a huge patch that changes tons of stuff and probably should have been broken up into small changes. But I already had the codebase not building, so... just did all of this at once :P Basically this patch does the following: - DB migrations for ticket dependency related tables, e.g. allowing a remote author and a remote child - Allowing S2S handlers to provide an async continued processing function, which is executed and the result then added to the debug page - Most UI and functionality related to ticket deps is disabled, new implementation being added gradually via ActivityPub - Improvements to AP tools, e.g. allow to specify multiple hosts for approved forwarding when sending out an activity, and allow to specify audience of software-authored activities using a convenient human-friendly structure - Implementation of S2S sharerOfferDepF which creates a dependency under a sharer-hosted ticket/patch and sends back an Accept
1191 lines
55 KiB
Haskell
1191 lines
55 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
|
|
|
|
, sharerOfferDepF
|
|
)
|
|
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.Bitraversable
|
|
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.Federation.Util
|
|
import Vervis.Foundation
|
|
import Vervis.Model
|
|
import Vervis.Model.Ident
|
|
import Vervis.Model.Ticket
|
|
import Vervis.Patch
|
|
import Vervis.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"
|
|
verifyNothingE (AP.ticketAttachment ticket) "Ticket with 'attachment'"
|
|
|
|
sharerOfferTicketF
|
|
:: UTCTime
|
|
-> ShrIdent
|
|
-> RemoteAuthor
|
|
-> ActivityBody
|
|
-> AP.Ticket URIMode
|
|
-> FedURI
|
|
-> ExceptT Text Handler Text
|
|
sharerOfferTicketF now shrRecip author body 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
|
|
-> AP.Ticket URIMode
|
|
-> FedURI
|
|
-> ExceptT Text Handler Text
|
|
projectOfferTicketF
|
|
now shrRecip prjRecip author body 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 mmr) = 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"
|
|
verifyNothingE mmr "Ticket has 'attachment'"
|
|
|
|
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
|
|
, 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 ()
|
|
|
|
sharerOfferDepF
|
|
:: UTCTime
|
|
-> ShrIdent
|
|
-> RemoteAuthor
|
|
-> ActivityBody
|
|
-> AP.TicketDependency URIMode
|
|
-> FedURI
|
|
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
|
sharerOfferDepF now shrRecip author body dep uTarget = do
|
|
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
|
|
(parent, child) <- checkDepAndTarget dep uTarget
|
|
(localRecips, _remoteRecips) <- do
|
|
mrecips <- parseAudience $ activityAudience $ actbActivity body
|
|
fromMaybeE mrecips "Offer Dep with no recipients"
|
|
msig <- checkForward $ LocalActorSharer shrRecip
|
|
personRecip <- lift $ runDB $ do
|
|
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
|
getValBy404 $ UniquePersonIdent sid
|
|
return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
|
|
manager <- asksSite appHttpManager
|
|
relevantParent <-
|
|
for (parentRelevance shrRecip parent) $ \ (talid, patch) -> do
|
|
(parentLtid, parentCtx) <- runSiteDBExcept $ do
|
|
let getTcr tcr = do
|
|
let getRoid roid = do
|
|
ro <- getJust roid
|
|
i <- getJust $ remoteObjectInstance ro
|
|
return $ mkuri (i, ro)
|
|
roidT <- remoteActorIdent <$> getJust (ticketProjectRemoteTracker tcr)
|
|
let mroidJ = ticketProjectRemoteProject tcr
|
|
(,) <$> getRoid roidT <*> traverse getRoid mroidJ
|
|
if patch
|
|
then do
|
|
(_, Entity ltid _, _, context, _) <- do
|
|
mticket <- lift $ getSharerPatch shrRecip talid
|
|
fromMaybeE mticket $ "Parent" <> ": No such sharer-patch"
|
|
context' <-
|
|
lift $
|
|
bitraverse
|
|
(\ (_, Entity _ trl) -> do
|
|
r <- getJust $ ticketRepoLocalRepo trl
|
|
s <- getJust $ repoSharer r
|
|
return $ Right (sharerIdent s, repoIdent r)
|
|
)
|
|
(\ (Entity _ tcr, _) -> getTcr tcr)
|
|
context
|
|
return (ltid, context')
|
|
else do
|
|
(_, Entity ltid _, _, context) <- do
|
|
mticket <- lift $ getSharerTicket shrRecip talid
|
|
fromMaybeE mticket $ "Parent" <> ": No such sharer-ticket"
|
|
context' <-
|
|
lift $
|
|
bitraverse
|
|
(\ (_, Entity _ tpl) -> do
|
|
j <- getJust $ ticketProjectLocalProject tpl
|
|
s <- getJust $ projectSharer j
|
|
return $ Left (sharerIdent s, projectIdent j)
|
|
)
|
|
(\ (Entity _ tcr, _) -> getTcr tcr)
|
|
context
|
|
return (ltid, context')
|
|
parentCtx' <- bifor parentCtx pure $ \ (uTracker, muProject) -> do
|
|
let uProject = fromMaybe uTracker muProject
|
|
obj <- withExceptT T.pack $ AP.fetchAP manager $ Left uProject
|
|
unless (objId obj == uProject) $
|
|
throwE "Project 'id' differs from the URI we fetched"
|
|
return
|
|
(uTracker, objUriAuthority uProject, objFollowers obj, objTeam obj)
|
|
(childId, childCtx, childAuthor) <-
|
|
case child of
|
|
Left wi -> runSiteDBExcept $ do
|
|
(ltid, ctx, author) <- getWorkItem "Child" wi
|
|
return (Left (wi, ltid), second mkuri ctx, second mkuri author)
|
|
Right u -> do
|
|
Doc hAuthor t <- withExceptT T.pack $ AP.fetchAP manager $ Left u
|
|
(hTicket, tl) <- fromMaybeE (AP.ticketLocal t) "Child ticket no 'id'"
|
|
unless (ObjURI hAuthor (AP.ticketId tl) == u) $
|
|
throwE "Ticket 'id' differs from the URI we fetched"
|
|
uCtx <- fromMaybeE (AP.ticketContext t) "Ticket without 'context'"
|
|
ctx <- parseTicketContext uCtx
|
|
author <- parseTicketAuthor $ ObjURI hTicket (AP.ticketAttributedTo t)
|
|
return (Right (u, AP.ticketParticipants tl), ctx, author)
|
|
childCtx' <- bifor childCtx pure $ \ u -> do
|
|
obj <- withExceptT T.pack $ AP.fetchAP manager $ Left u
|
|
unless (objId obj == u) $
|
|
throwE "Project 'id' differs from the URI we fetched"
|
|
u' <-
|
|
case (objContext obj, objInbox obj) of
|
|
(Just c, Nothing) -> do
|
|
hl <- hostIsLocal $ objUriAuthority c
|
|
when hl $ throwE "Child remote context has a local context"
|
|
pure c
|
|
(Nothing, Just _) -> pure u
|
|
_ -> throwE "Umm context-inbox thing"
|
|
return
|
|
(u', objUriAuthority u, objFollowers obj, objTeam obj)
|
|
return (talid, patch, parentLtid, parentCtx', childId, childCtx', childAuthor)
|
|
mhttp <- lift $ runSiteDB $ do
|
|
mractid <- insertToInbox now author body (personInbox personRecip) luOffer True
|
|
for mractid $ \ ractid -> do
|
|
mremotesHttpFwd <- for msig $ \ sig -> do
|
|
relevantFollowers <- askRelevantFollowers
|
|
let sieve =
|
|
makeRecipientSet [] $ catMaybes
|
|
[ relevantFollowers shrRecip parent
|
|
, relevantFollowers shrRecip child
|
|
]
|
|
remoteRecips <-
|
|
insertRemoteActivityToLocalInboxes
|
|
False ractid $
|
|
localRecipSieve'
|
|
sieve False False localRecips
|
|
(sig,) <$> deliverRemoteDB_S (actbBL body) ractid (personIdent personRecip) sig remoteRecips
|
|
mremotesHttpAccept <- for relevantParent $ \ ticketData@(_, _, parentLtid, _, childId, _, _) -> do
|
|
obiidAccept <- insertEmptyOutboxItem (personOutbox personRecip) now
|
|
tdid <- insertDep ractid parentLtid childId obiidAccept
|
|
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
|
insertAccept luOffer obiidAccept tdid ticketData
|
|
knownRemoteRecipsAccept <-
|
|
deliverLocal'
|
|
False
|
|
(LocalActorSharer shrRecip)
|
|
(personInbox personRecip)
|
|
obiidAccept
|
|
localRecipsAccept
|
|
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
|
return (mremotesHttpFwd, mremotesHttpAccept)
|
|
case mhttp of
|
|
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
|
Just (mremotesHttpFwd, mremotesHttpAccept) -> do
|
|
for_ mremotesHttpFwd $ \ (sig, remotes) ->
|
|
forkWorker "sharerOfferDepF inbox-forwarding" $
|
|
deliverRemoteHTTP_S now shrRecip (actbBL body) sig remotes
|
|
for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) ->
|
|
forkWorker "sharerOfferDepF Accept HTTP delivery" $
|
|
deliverRemoteHttp' fwdHosts obiid doc remotes
|
|
return $
|
|
case (mremotesHttpAccept, mremotesHttpFwd) of
|
|
(Nothing, Nothing) -> "Parent not mine, just stored in inbox and no inbox-forwarding to do"
|
|
(Nothing, Just _) -> "Parent not mine, just stored in inbox and ran inbox-forwarding"
|
|
(Just _, Nothing) -> "Accepted new ticket dep, no inbox-forwarding to do"
|
|
(Just _, Just _) -> "Accepted new ticket dep and ran inbox-forwarding of the Offer"
|
|
where
|
|
checkDepAndTarget
|
|
(AP.TicketDependency id_ uParent uChild _attrib published updated) uTarget = do
|
|
verifyNothingE id_ "Dep with 'id'"
|
|
parent <- parseWorkItem "Dep parent" uParent
|
|
child <- parseWorkItem "Dep child" uChild
|
|
when (parent == child) $
|
|
throwE "Parent and child are the same work item"
|
|
verifyNothingE published "Dep with 'published'"
|
|
verifyNothingE updated "Dep with 'updated'"
|
|
target <- parseTarget uTarget
|
|
checkParentAndTarget parent target
|
|
return (parent, child)
|
|
where
|
|
parseWorkItem name u@(ObjURI h lu) = do
|
|
hl <- hostIsLocal h
|
|
if hl
|
|
then Left <$> do
|
|
route <-
|
|
fromMaybeE (decodeRouteLocal lu) $
|
|
name <> ": Not a valid route"
|
|
case route of
|
|
SharerTicketR shr talkhid -> do
|
|
talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid"
|
|
return $ WorkItemSharerTicket shr talid False
|
|
SharerPatchR shr talkhid -> do
|
|
talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid"
|
|
return $ WorkItemSharerTicket shr talid True
|
|
ProjectTicketR shr prj ltkhid -> do
|
|
ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid"
|
|
return $ WorkItemProjectTicket shr prj ltid
|
|
RepoPatchR shr rp ltkhid -> do
|
|
ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid"
|
|
return $ WorkItemRepoPatch shr rp ltid
|
|
_ -> throwE $ name <> ": not a work item route"
|
|
else return $ Right u
|
|
parseTarget u@(ObjURI h lu) = do
|
|
hl <- hostIsLocal h
|
|
if hl
|
|
then Left <$> do
|
|
route <-
|
|
fromMaybeE
|
|
(decodeRouteLocal lu)
|
|
"Offer local target isn't a valid route"
|
|
fromMaybeE
|
|
(parseLocalActor route)
|
|
"Offer local target isn't an actor route"
|
|
else return $ Right u
|
|
checkParentAndTarget (Left wi) (Left la) =
|
|
unless (workItemActor wi == la) $
|
|
throwE "Parent and target mismatch"
|
|
where
|
|
workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr
|
|
workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj
|
|
workItemActor (WorkItemRepoPatch shr rp _) = LocalActorRepo shr rp
|
|
checkParentAndTarget (Left _) (Right _) = throwE "Local parent but remote target"
|
|
checkParentAndTarget (Right _) (Left _) = throwE "Local target but remote parent"
|
|
checkParentAndTarget (Right _) (Right _) = return ()
|
|
parentRelevance shr (Left (WorkItemSharerTicket shr' talid patch))
|
|
| shr == shr' = Just (talid, patch)
|
|
parentRelevance _ _ = Nothing
|
|
{-
|
|
getWorkItem
|
|
:: MonadIO m
|
|
=> Text
|
|
-> WorkItem
|
|
-> ExceptT Text (ReaderT SqlBaclend m)
|
|
( LocalTicketId
|
|
, Either
|
|
(Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
|
|
(Instance, RemoteObject)
|
|
, Either ShrIdent (Instance, RemoteObject)
|
|
)
|
|
-}
|
|
getWorkItem name (WorkItemSharerTicket shr talid False) = do
|
|
(_, Entity ltid _, _, context) <- do
|
|
mticket <- lift $ getSharerTicket shr talid
|
|
fromMaybeE mticket $ name <> ": No such sharer-ticket"
|
|
context' <-
|
|
lift $
|
|
bitraverse
|
|
(\ (_, Entity _ tpl) -> do
|
|
j <- getJust $ ticketProjectLocalProject tpl
|
|
s <- getJust $ projectSharer j
|
|
return $ Left (sharerIdent s, projectIdent j)
|
|
)
|
|
(\ (Entity _ tcr, _) -> do
|
|
roid <-
|
|
case ticketProjectRemoteProject tcr of
|
|
Nothing ->
|
|
remoteActorIdent <$>
|
|
getJust (ticketProjectRemoteTracker tcr)
|
|
Just roid -> return roid
|
|
ro <- getJust roid
|
|
i <- getJust $ remoteObjectInstance ro
|
|
return (i, ro)
|
|
)
|
|
context
|
|
return (ltid, context', Left shr)
|
|
getWorkItem name (WorkItemSharerTicket shr talid True) = do
|
|
(_, Entity ltid _, _, context, _) <- do
|
|
mticket <- lift $ getSharerPatch shr talid
|
|
fromMaybeE mticket $ name <> ": No such sharer-patch"
|
|
context' <-
|
|
lift $
|
|
bitraverse
|
|
(\ (_, Entity _ trl) -> do
|
|
r <- getJust $ ticketRepoLocalRepo trl
|
|
s <- getJust $ repoSharer r
|
|
return $ Right (sharerIdent s, repoIdent r)
|
|
)
|
|
(\ (Entity _ tcr, _) -> do
|
|
roid <-
|
|
case ticketProjectRemoteProject tcr of
|
|
Nothing ->
|
|
remoteActorIdent <$>
|
|
getJust (ticketProjectRemoteTracker tcr)
|
|
Just roid -> return roid
|
|
ro <- getJust roid
|
|
i <- getJust $ remoteObjectInstance ro
|
|
return (i, ro)
|
|
)
|
|
context
|
|
return (ltid, context', Left shr)
|
|
getWorkItem name (WorkItemProjectTicket shr prj ltid) = do
|
|
mticket <- lift $ getProjectTicket shr prj ltid
|
|
(Entity _ s, Entity _ j, _, _, _, _, author) <-
|
|
fromMaybeE mticket $ name <> ": No such project-ticket"
|
|
author' <-
|
|
lift $
|
|
bitraverse
|
|
(\ (Entity _ tal, _) -> do
|
|
p <- getJust $ ticketAuthorLocalAuthor tal
|
|
sharerIdent <$> getJust (personIdent p)
|
|
)
|
|
(\ (Entity _ tar) -> do
|
|
ra <- getJust $ ticketAuthorRemoteAuthor tar
|
|
ro <- getJust $ remoteActorIdent ra
|
|
i <- getJust $ remoteObjectInstance ro
|
|
return (i, ro)
|
|
)
|
|
author
|
|
return (ltid, Left $ Left (sharerIdent s, projectIdent j), author')
|
|
getWorkItem name (WorkItemRepoPatch shr rp ltid) = do
|
|
mticket <- lift $ getRepoPatch shr rp ltid
|
|
(Entity _ s, Entity _ r, _, _, _, _, author, _) <-
|
|
fromMaybeE mticket $ name <> ": No such repo-patch"
|
|
author' <-
|
|
lift $
|
|
bitraverse
|
|
(\ (Entity _ tal, _) -> do
|
|
p <- getJust $ ticketAuthorLocalAuthor tal
|
|
sharerIdent <$> getJust (personIdent p)
|
|
)
|
|
(\ (Entity _ tar) -> do
|
|
ra <- getJust $ ticketAuthorRemoteAuthor tar
|
|
ro <- getJust $ remoteActorIdent ra
|
|
i <- getJust $ remoteObjectInstance ro
|
|
return (i, ro)
|
|
)
|
|
author
|
|
return (ltid, Left $ Right (sharerIdent s, repoIdent r), author')
|
|
mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro)
|
|
parseTicketContext u@(ObjURI h lu) = do
|
|
hl <- hostIsLocal h
|
|
if hl
|
|
then Left <$> do
|
|
route <- fromMaybeE (decodeRouteLocal lu) "Not a route"
|
|
case route of
|
|
ProjectR shr prj -> return $ Left (shr, prj)
|
|
RepoR shr rp -> return $ Right (shr, rp)
|
|
_ -> throwE "Not a ticket context route"
|
|
else return $ Right u
|
|
parseTicketAuthor u@(ObjURI h lu) = do
|
|
hl <- hostIsLocal h
|
|
if hl
|
|
then Left <$> do
|
|
route <- fromMaybeE (decodeRouteLocal lu) "Not a route"
|
|
case route of
|
|
SharerR shr -> return shr
|
|
_ -> throwE "Not a ticket author route"
|
|
else return $ Right u
|
|
askRelevantFollowers = do
|
|
hashTALID <- getEncodeKeyHashid
|
|
return $ \ shr wi -> followers hashTALID <$> parentRelevance shr wi
|
|
where
|
|
followers hashTALID (talid, patch) =
|
|
let coll =
|
|
if patch
|
|
then LocalPersonCollectionSharerPatchFollowers
|
|
else LocalPersonCollectionSharerTicketFollowers
|
|
in coll shrRecip (hashTALID talid)
|
|
insertDep ractidOffer ltidParent child obiidAccept = do
|
|
tdid <- insert LocalTicketDependency
|
|
{ localTicketDependencyParent = ltidParent
|
|
, localTicketDependencyCreated = now
|
|
, localTicketDependencyAccept = obiidAccept
|
|
}
|
|
case child of
|
|
Left (_wi, ltid) -> insert_ TicketDependencyChildLocal
|
|
{ ticketDependencyChildLocalDep = tdid
|
|
, ticketDependencyChildLocalChild = ltid
|
|
}
|
|
Right (ObjURI h lu, _luFollowers) -> do
|
|
iid <- either entityKey id <$> insertBy' (Instance h)
|
|
roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
|
|
insert_ TicketDependencyChildRemote
|
|
{ ticketDependencyChildRemoteDep = tdid
|
|
, ticketDependencyChildRemoteChild = roid
|
|
}
|
|
insert_ TicketDependencyAuthorRemote
|
|
{ ticketDependencyAuthorRemoteDep = tdid
|
|
, ticketDependencyAuthorRemoteAuthor = remoteAuthorId author
|
|
, ticketDependencyAuthorRemoteOpen = ractidOffer
|
|
}
|
|
return tdid
|
|
insertAccept luOffer obiidAccept tdid (talid, patch, _, parentCtx, childId, childCtx, childAuthor) = do
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
followers <- askFollowers
|
|
workItemFollowers <- askWorkItemFollowers
|
|
hLocal <- asksSite siteInstanceHost
|
|
obikhidAccept <- encodeKeyHashid obiidAccept
|
|
tdkhid <- encodeKeyHashid tdid
|
|
ra <- getJust $ remoteAuthorId author
|
|
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
|
|
|
audAuthor =
|
|
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
|
|
audParentContext = contextAudience parentCtx
|
|
audChildContext = contextAudience childCtx
|
|
audParent = AudLocal [LocalActorSharer shrRecip] [followers talid patch]
|
|
audChildAuthor =
|
|
case childAuthor of
|
|
Left shr -> AudLocal [LocalActorSharer shr] []
|
|
Right (ObjURI h lu) -> AudRemote h [lu] []
|
|
audChildFollowers =
|
|
case childId of
|
|
Left (wi, _ltid) -> AudLocal [] [workItemFollowers wi]
|
|
Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers]
|
|
|
|
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
|
collectAudience $
|
|
audAuthor :
|
|
audParent :
|
|
audChildAuthor :
|
|
audChildFollowers :
|
|
audParentContext ++ audChildContext
|
|
|
|
recips = map encodeRouteHome audLocal ++ audRemote
|
|
doc = Doc hLocal Activity
|
|
{ activityId =
|
|
Just $ encodeRouteLocal $
|
|
SharerOutboxItemR shrRecip obikhidAccept
|
|
, activityActor = encodeRouteLocal $ SharerR shrRecip
|
|
, activitySummary = Nothing
|
|
, activityAudience = Audience recips [] [] [] [] []
|
|
, activitySpecific = AcceptActivity Accept
|
|
{ acceptObject = ObjURI hAuthor luOffer
|
|
, acceptResult =
|
|
Just $ encodeRouteLocal $ TicketDepR tdkhid
|
|
}
|
|
}
|
|
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
|
return (doc, recipientSet, remoteActors, fwdHosts)
|
|
where
|
|
contextAudience ctx =
|
|
case ctx of
|
|
Left (Left (shr, prj)) ->
|
|
pure $ AudLocal
|
|
[LocalActorProject shr prj]
|
|
[ LocalPersonCollectionProjectTeam shr prj
|
|
, LocalPersonCollectionProjectFollowers shr prj
|
|
]
|
|
Left (Right (shr, rp)) ->
|
|
pure $ AudLocal
|
|
[LocalActorRepo shr rp]
|
|
[ LocalPersonCollectionRepoTeam shr rp
|
|
, LocalPersonCollectionRepoFollowers shr rp
|
|
]
|
|
Right (ObjURI hTracker luTracker, hProject, luFollowers, luTeam) ->
|
|
[ AudRemote hTracker [luTracker] []
|
|
, AudRemote hProject [] (catMaybes [luFollowers, luTeam])
|
|
]
|
|
askFollowers = do
|
|
hashTALID <- getEncodeKeyHashid
|
|
return $ \ talid patch ->
|
|
let coll =
|
|
if patch
|
|
then LocalPersonCollectionSharerPatchFollowers
|
|
else LocalPersonCollectionSharerTicketFollowers
|
|
in coll shrRecip (hashTALID talid)
|
|
askWorkItemFollowers = do
|
|
hashTALID <- getEncodeKeyHashid
|
|
hashLTID <- getEncodeKeyHashid
|
|
let workItemFollowers (WorkItemSharerTicket shr talid False) = LocalPersonCollectionSharerTicketFollowers shr $ hashTALID talid
|
|
workItemFollowers (WorkItemSharerTicket shr talid True) = LocalPersonCollectionSharerPatchFollowers shr $ hashTALID talid
|
|
workItemFollowers (WorkItemProjectTicket shr prj ltid) = LocalPersonCollectionProjectTicketFollowers shr prj $ hashLTID ltid
|
|
workItemFollowers (WorkItemRepoPatch shr rp ltid) = LocalPersonCollectionRepoPatchFollowers shr rp $ hashLTID ltid
|
|
return workItemFollowers
|