forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Implement C2S Create{Ticket}, available in PublishR and in postTicketsR

Browse source 
IMPORTANT: Since a lot of ticket code still doesn't use TicketUnderProject,
creating tickets now appears to be failing. Usage of this patch as is, is at
your own risk ^_^ the next patches will update the ticket handlers to fix this
problem.
This commit is contained in:
fr33domlover 2020-02-22 19:45:27 +00:00
parent e0300ba0fa
commit a00c45a444
13 changed files with 521 additions and 83 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
config/models
View file

@ -372,6 +372,13 @@ TicketProjectLocal
UniqueTicketProjectLocal ticket
UniqueTicketProjectLocalAccept accept
TicketProjectRemote
ticket TicketAuthorLocalId
tracker RemoteActorId
project RemoteObjectId Maybe -- specify if not same as tracker
UniqueTicketProjectRemote ticket
TicketAuthorLocal
ticket LocalTicketId
author PersonId

6
migrations/2020_02_22_tpr.model Normal file
View file

@ -0,0 +1,6 @@
TicketProjectRemote
ticket TicketAuthorLocalId
tracker RemoteActorId
project RemoteObjectId Maybe
UniqueTicketProjectRemote ticket

271
src/Vervis/API.hs
View file

@ -15,6 +15,7 @@
module Vervis.API
( createNoteC
, createTicketC
, followC
, offerTicketC
, undoC
@ -398,7 +399,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
-> OutboxItemId
-> [ShrIdent]
-> Maybe (SharerId, FollowerSetId, InboxId, FollowerSetId)
-> ExceptT Text AppDB [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
-> ExceptT Text AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
deliverLocal pidAuthor obid recips mticket = do
recipPids <- traverse getPersonId $ nub recips
when (pidAuthor `elem` recipPids) $
@ -450,6 +451,272 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
Right _gid -> throwE "Local Note addresses a local group"
-}
-- | Handle a Ticket submitted by a local user to their outbox. The ticket's
-- context project may be local or remote. Return an error message if the
-- Ticket is rejected, otherwise the new 'TicketAuthorLocalId'.
createTicketC
:: Entity Person
-> Sharer
-> TextHtml
-> Audience URIMode
-> AP.Ticket URIMode
-> Maybe FedURI
-> Handler (Either Text TicketAuthorLocalId)
createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muTarget = runExceptT $ do
let shrUser = sharerIdent sharerUser
ticketData@(uContext, title, desc, source, uTarget) <- checkTicket shrUser ticket muTarget
context <- parseTicketContext uContext
(localRecips, remoteRecips) <- do
mrecips <- parseAudience audience
fromMaybeE mrecips "Create Ticket with no recipients"
checkFederation remoteRecips
verifyProjectRecip context localRecips
tracker <- fetchTracker context uTarget
now <- liftIO getCurrentTime
(talid, obiidCreate, docCreate, remotesHttpCreate, maybeAccept) <- runDBExcept $ do
obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
project <- prepareProject now tracker
talid <- lift $ insertTicket now pidUser title desc source obiidCreate project
docCreate <- lift $ insertCreateToOutbox shrUser ticketData now obiidCreate talid
remoteRecipsHttpCreate <- do
let sieve =
case tracker of
Left (shr, prj) ->
makeRecipientSet
[ LocalActorProject shr prj
]
[ LocalPersonCollectionSharerFollowers shrUser
, LocalPersonCollectionProjectTeam shr prj
, LocalPersonCollectionProjectFollowers shr prj
]
Right _ ->
makeRecipientSet
[]
[LocalPersonCollectionSharerFollowers shrUser]
moreRemoteRecips <- lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $ localRecipSieve sieve False localRecips
checkFederation moreRemoteRecips
lift $ deliverRemoteDB' (objUriAuthority uTarget) obiidCreate remoteRecips moreRemoteRecips
maccept <-
case project of
Left proj@(shr, Entity _ j, obiidAccept) -> Just <$> do
let prj = projectIdent j
recipsA =
[ LocalActorSharer shrUser
]
recipsC =
[ LocalPersonCollectionProjectTeam shr prj
, LocalPersonCollectionProjectFollowers shr prj
, LocalPersonCollectionSharerFollowers shrUser
]
doc <- lift $ insertAcceptToOutbox proj shrUser obiidCreate talid recipsA recipsC
recips <- lift $ deliverLocal' True (LocalActorProject shr prj) (projectInbox j) obiidAccept $ makeRecipientSet recipsA recipsC
checkFederation recips
lift $ (obiidAccept,doc,) <$> deliverRemoteDB' dont obiidAccept [] recips
Right _ -> return Nothing
return (talid, obiidCreate, docCreate, remoteRecipsHttpCreate, maccept)
lift $ do
forkWorker "createTicketC: async HTTP Create delivery" $ deliverRemoteHttp (objUriAuthority uTarget) obiidCreate docCreate remotesHttpCreate
for_ maybeAccept $ \ (obiidAccept, docAccept, remotesHttpAccept) ->
forkWorker "createTicketC: async HTTP Accept delivery" $ deliverRemoteHttp dont obiidAccept docAccept remotesHttpAccept
return talid
where
checkTicket shr (AP.Ticket mlocal luAttrib mpublished mupdated mcontext summary content source massigned resolved) mtarget = do
verifyNothingE mlocal "Ticket with 'id'"
encodeRouteLocal <- getEncodeRouteLocal
unless (encodeRouteLocal (SharerR shr) == luAttrib) $
throwE "Ticket attributed to someone else"
verifyNothingE mpublished "Ticket with 'published'"
verifyNothingE mupdated "Ticket with 'updated'"
context <- fromMaybeE mcontext "Ticket without 'context'"
verifyNothingE massigned "Ticket with 'assignedTo'"
when resolved $ throwE "Ticket resolved"
target <- fromMaybeE mtarget "Create Ticket without 'target'"
return (context, summary, content, source, target)
parseTicketContext :: (MonadSite m, SiteEnv m ~ App) => FedURI -> ExceptT Text m (Either (ShrIdent, PrjIdent) FedURI)
parseTicketContext u@(ObjURI h lu) = do
hl <- hostIsLocal h
if hl
then Left <$> do
route <- fromMaybeE (decodeRouteLocal lu) "Ticket context isn't a valid route"
case route of
ProjectR shr prj -> return (shr, prj)
_ -> throwE "Ticket context isn't a project route"
else return $ Right u
checkFederation remoteRecips = do
federation <- asksSite $ appFederation . appSettings
unless (federation || null remoteRecips) $
throwE "Federation disabled, but remote recipients found"
verifyProjectRecip (Right _) _ = return ()
verifyProjectRecip (Left (shr, prj)) localRecips =
fromMaybeE verify "Local context project isn't listed as a recipient"
where
verify = do
sharerSet <- lookup shr localRecips
projectSet <- lookup prj $ localRecipProjectRelated sharerSet
guard $ localRecipProject $ localRecipProjectDirect projectSet
fetchTracker c u@(ObjURI h lu) = do
hl <- hostIsLocal h
case (hl, c) of
(True, Left (shr, prj)) -> Left <$> do
encodeRouteLocal <- getEncodeRouteLocal
unless (encodeRouteLocal (ProjectR shr prj) == lu) $
throwE "Local context and target mismatch"
return (shr, prj)
(True, Right _) -> throwE "context and target different host"
(False, Left _) -> throwE "context and target different host"
(False, Right (ObjURI h' lu')) -> Right <$> do
unless (h == h') $ throwE "context and target different host"
(iid, era) <- do
iid <- lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
result <- lift $ fetchRemoteActor iid h lu
case result of
Left e -> throwE $ T.pack $ displayException e
Right (Left e) -> throwE $ T.pack $ show e
Right (Right mera) -> do
era <- fromMaybeE mera "target found to be a collection, not an actor"
return (iid, era)
return (iid, era, if lu == lu' then Nothing else Just lu')
insertEmptyOutboxItem obid now = do
h <- asksSite siteInstanceHost
insert OutboxItem
{ outboxItemOutbox = obid
, outboxItemActivity = persistJSONObjectFromDoc $ Doc h emptyActivity
, outboxItemPublished = now
}
prepareProject now (Left (shr, prj)) = Left <$> do
mej <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getBy $ UniqueProject prj sid
ej@(Entity _ j) <- fromMaybeE mej "Local context: no such project"
obiidAccept <- lift $ insertEmptyOutboxItem (projectOutbox j) now
return (shr, ej, obiidAccept)
prepareProject _ (Right (iid, era, mlu)) = lift $ Right <$> do
mroid <- for mlu $ \ lu -> either entityKey id <$> insertBy' (RemoteObject iid lu)
return (era, mroid)
insertTicket now pidUser title desc source obiidCreate project = do
did <- insert Discussion
fsid <- insert FollowerSet
tid <- insert Ticket
{ ticketNumber = Nothing
, ticketCreated = now
, ticketTitle = unTextHtml title
, ticketSource = unTextPandocMarkdown source
, ticketDescription = unTextHtml desc
, ticketAssignee = Nothing
, ticketStatus = TSNew
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0
, ticketCloser = Nothing
}
ltid <- insert LocalTicket
{ localTicketTicket = tid
, localTicketDiscuss = did
, localTicketFollowers = fsid
}
talid <- insert TicketAuthorLocal
{ ticketAuthorLocalTicket = ltid
, ticketAuthorLocalAuthor = pidUser
, ticketAuthorLocalOpen = obiidCreate
}
case project of
Left (_shr, Entity jid _j, obiidAccept) ->
insert_ TicketProjectLocal
{ ticketProjectLocalTicket = tid
, ticketProjectLocalProject = jid
, ticketProjectLocalAccept = obiidAccept
}
Right (Entity raid _ra, mroid) ->
insert_ TicketProjectRemote
{ ticketProjectRemoteTicket = talid
, ticketProjectRemoteTracker = raid
, ticketProjectRemoteProject = mroid
}
return talid
insertCreateToOutbox shrUser (uContext, title, desc, source, uTarget) now obiidCreate talid = do
encodeRouteLocal <- getEncodeRouteLocal
hLocal <- asksSite siteInstanceHost
talkhid <- encodeKeyHashid talid
obikhid <- encodeKeyHashid obiidCreate
let luAttrib = encodeRouteLocal $ SharerR shrUser
tlocal = TicketLocal
{ ticketId = encodeRouteLocal $ SharerTicketR shrUser talkhid
, ticketReplies = encodeRouteLocal $ SharerTicketDiscussionR shrUser talkhid
, ticketParticipants = encodeRouteLocal $ SharerTicketFollowersR shrUser talkhid
, ticketTeam = encodeRouteLocal $ SharerTicketTeamR shrUser talkhid
, ticketEvents = encodeRouteLocal $ SharerTicketEventsR shrUser talkhid
, ticketDeps = encodeRouteLocal $ SharerTicketDepsR shrUser talkhid
, ticketReverseDeps = encodeRouteLocal $ SharerTicketReverseDepsR shrUser talkhid
}
create = Doc hLocal Activity
{ activityId = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
, activityActor = luAttrib
, activitySummary = Just summary
, activityAudience = audience
, activitySpecific = CreateActivity Create
{ createObject = CreateTicket AP.Ticket
{ AP.ticketLocal = Just (hLocal, tlocal)
, AP.ticketAttributedTo = luAttrib
, AP.ticketPublished = Just now
, AP.ticketUpdated = Nothing
, AP.ticketContext = Just uContext
, AP.ticketSummary = title
, AP.ticketContent = desc
, AP.ticketSource = source
, AP.ticketAssignedTo = Nothing
, AP.ticketIsResolved = False
}
, createTarget = Just uTarget
}
}
update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create]
return create
insertAcceptToOutbox (shrJ, Entity _ j, obiidAccept) shrU obiidCreate talid actors colls = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
hLocal <- asksSite siteInstanceHost
obikhidAccept <- encodeKeyHashid obiidAccept
obikhidCreate <- encodeKeyHashid obiidCreate
talkhid <- encodeKeyHashid talid
let prjJ = projectIdent j
summary <-
TextHtml . TL.toStrict . renderHtml <$>
withUrlRenderer
[hamlet|
<p>
Project #
<a href=@{ProjectR shrJ prjJ}>
#{prj2text prjJ}
\ accepted #
<a href=@{SharerTicketR shrU talkhid}>
ticket
\ by #
<a href=@{SharerR shrU}>
#{shr2text shrU}
|]
let recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalPersonCollection colls
accept = Doc hLocal Activity
{ activityId = Just $ encodeRouteLocal $ ProjectOutboxItemR shrJ prjJ obikhidAccept
, activityActor = encodeRouteLocal $ ProjectR shrJ prjJ
, activitySummary = Just summary
, activityAudience = Audience recips [] [] [] [] []
, activitySpecific = AcceptActivity Accept
{ acceptObject = encodeRouteHome $ SharerOutboxItemR shrU obikhidCreate
, acceptResult = Nothing
}
}
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc accept]
return accept
dont = Authority "dont-do.any-forwarding" Nothing
data Followee
= FolloweeSharer ShrIdent
| FolloweeProject ShrIdent PrjIdent
@ -1041,7 +1308,7 @@ pushCommitsC (eperson, sharer) summary push shrRepo rpRepo = runExceptT $ do
:: OutboxItemId
-> AppDB
[ ( (InstanceId, Host)
, NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)
, NonEmpty RemoteRecipient
)
]
deliverLocal obiid = do

57
src/Vervis/ActivityPub.hs
View file

@ -41,6 +41,8 @@ module Vervis.ActivityPub
, deliverRemoteHttp
, serveCommit
, deliverLocal
, RemoteRecipient (..)
, deliverLocal'
)
where
@ -200,7 +202,7 @@ getPersonOrGroupId sid = do
"Found sharer that is neither person nor group"
"Found sharer that is both person and group"
getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty RemoteRecipient)])
getTicketTeam sid = do
id_ <- getPersonOrGroupId sid
(,[]) <$> case id_ of
@ -213,7 +215,7 @@ getProjectTeam = getTicketTeam
getRepoTeam = getTicketTeam
getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty RemoteRecipient)])
getFollowers fsid = do
local <- selectList [FollowTarget ==. fsid] [Asc FollowPerson]
remote <- E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
@ -239,16 +241,16 @@ getFollowers fsid = do
remote
)
where
groupRemotes :: [(InstanceId, Host, RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)] -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
groupRemotes :: [(InstanceId, Host, RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)] -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
where
toTuples (iid, h, raid, luA, luI, ms) = ((iid, h), (raid, luA, luI, ms))
toTuples (iid, h, raid, luA, luI, ms) = ((iid, h), RemoteRecipient raid luA luI ms)
unionRemotes
:: [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
unionRemotes = unionGroupsOrdWith fst fst4
:: [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
unionRemotes = unionGroupsOrdWith fst remoteRecipientActor
insertMany' mk xs = zip' xs <$> insertMany (NE.toList $ mk <$> xs)
where
@ -303,21 +305,21 @@ deliverRemoteDB
-> RemoteActivityId
-> ProjectId
-> ByteString
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
deliverRemoteDB body ractid jid sig recips = do
let body' = BL.toStrict body
deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
fetchedDeliv <- for recips $ \ (i, rs) ->
(i,) <$> insertMany' (\ (raid, _, _, msince) -> deliv raid msince) rs
(i,) <$> insertMany' (\ (RemoteRecipient raid _ _ msince) -> deliv raid msince) rs
return $ takeNoError4 fetchedDeliv
where
takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
takeNoError4 = takeNoError noError
where
noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
noError ((_ , _ , _ , Just _ ), _ ) = Nothing
noError (RemoteRecipient ak luA luI Nothing , dlk) = Just (ak, luA, luI, dlk)
noError (RemoteRecipient _ _ _ (Just _), _ ) = Nothing
deliverRemoteHTTP
:: UTCTime
@ -449,7 +451,7 @@ deliverRemoteDB'
:: Host
-> OutboxItemId
-> [(Host, NonEmpty LocalURI)]
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB
( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
, [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
@ -474,7 +476,7 @@ deliverRemoteDB' hContext obid recips known = do
Nothing -> Just $ Left lu
Just (ro, r) ->
case r of
RecipRA (Entity raid ra) -> Just $ Right $ Left (raid, remoteObjectIdent ro, remoteActorInbox ra, remoteActorErrorSince ra)
RecipRA (Entity raid ra) -> Just $ Right $ Left $ RemoteRecipient raid (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra)
RecipURA (Entity uraid ura) -> Just $ Right $ Right (uraid, remoteObjectIdent ro, unfetchedRemoteActorSince ura)
RecipRC _ -> Nothing
let (unknown, newKnown) = partitionEithers $ catMaybes $ NE.toList es
@ -486,7 +488,7 @@ deliverRemoteDB' hContext obid recips known = do
allFetched = unionRemotes known moreKnown
fetchedDeliv <- for allFetched $ \ (i, rs) ->
let fwd = snd i == hContext
in (i,) <$> insertMany' (\ (raid, _, _, msince) -> Delivery raid obid fwd $ isNothing msince) rs
in (i,) <$> insertMany' (\ (RemoteRecipient raid _ _ msince) -> Delivery raid obid fwd $ isNothing msince) rs
unfetchedDeliv <- for unfetched $ \ (i, rs) ->
let fwd = snd i == hContext
in (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid fwd $ isNothing msince) rs
@ -511,8 +513,8 @@ deliverRemoteDB' hContext obid recips known = do
noError ((_ , _ , Just _ ), _ ) = Nothing
takeNoError4 = takeNoError noError
where
noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
noError ((_ , _ , _ , Just _ ), _ ) = Nothing
noError (RemoteRecipient ak luA luI Nothing , dlk) = Just (ak, luA, luI, dlk)
noError (RemoteRecipient _ _ _ (Just _), _ ) = Nothing
deliverRemoteHttp
:: Host
@ -712,13 +714,12 @@ deliverLocal
-> LocalRecipientSet
-> AppDB
[ ( (InstanceId, Host)
, NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)
, NonEmpty RemoteRecipient
)
]
deliverLocal shrAuthor ibidAuthor _fsidAuthor obiid = fmap (map $ second $ NE.map fromRR) . deliverLocal' True shrAuthor ibidAuthor obiid . localRecipSieve sieve True
deliverLocal shrAuthor ibidAuthor _fsidAuthor obiid = deliverLocal' True (LocalActorSharer shrAuthor) ibidAuthor obiid . localRecipSieve sieve True
where
sieve = [(shrAuthor, LocalSharerRelatedSet (LocalSharerDirectSet False True) [] [])]
fromRR (RemoteRecipient raid luA luI msince) = (raid, luA, luI, msince)
data RemoteRecipient = RemoteRecipient
{ remoteRecipientActor :: RemoteActorId
@ -735,12 +736,12 @@ data RemoteRecipient = RemoteRecipient
-- the remote members
deliverLocal'
:: Bool -- ^ Whether to deliver to collection only if owner actor is addressed
-> ShrIdent
-> LocalActor
-> InboxId
-> OutboxItemId
-> LocalRecipientSet
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
deliverLocal' requireOwner author ibidAuthor obiid recips = do
ibidsSharer <- L.delete ibidAuthor <$> getSharerInboxes recips
ibidsOther <- concat <$> traverse getOtherInboxes recips
@ -799,7 +800,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
[shr | (shr, s) <- sharers
, let d = localRecipSharerDirect s
in localRecipSharerFollowers d &&
(localRecipSharer d || not requireOwner || shr == shrAuthor)
(localRecipSharer d || not requireOwner || LocalActorSharer shr == author)
]
sids <- selectKeysList [SharerIdent <-. shrs] []
map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] []
@ -819,7 +820,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
[prj | (prj, j) <- projects
, let d = localRecipProjectDirect j
in localRecipProjectFollowers d &&
(localRecipProject d || not requireOwner)
(localRecipProject d || not requireOwner || LocalActorProject shr prj == author)
]
fsidsJ <-
map (projectFollowers . entityVal) <$>
@ -829,7 +830,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
then
[ (prj, localRecipTicketRelated j)
| (prj, j) <- projects
, localRecipProject $ localRecipProjectDirect j
, localRecipProject (localRecipProjectDirect j) || LocalActorProject shr prj == author
]
else
map (second localRecipTicketRelated) projects
@ -863,7 +864,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
[rp | (rp, r) <- repos
, let d = localRecipRepoDirect r
in localRecipRepoFollowers d &&
(localRecipRepo d || not requireOwner)
(localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author)
]
in map (repoFollowers . entityVal) <$>
selectList [RepoSharer ==. sid, RepoIdent <-. rps] []
@ -911,7 +912,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
getProjectTeams sid projects = do
let prjs =
[prj | (prj, LocalProjectRelatedSet d ts) <- projects
, (localRecipProject d || not requireOwner) &&
, (localRecipProject d || not requireOwner || LocalActorProject shr prj == author) &&
(localRecipProjectTeam d || any (localRecipTicketTeam . snd) ts)
]
jids <- selectKeysList [ProjectSharer ==. sid, ProjectIdent <-. prjs] []
@ -922,7 +923,7 @@ deliverLocal' requireOwner shrAuthor ibidAuthor obiid recips = do
[rp | (rp, r) <- repos
, let d = localRecipRepoDirect r
in localRecipRepoTeam d &&
(localRecipRepo d || not requireOwner)
(localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author)
]
rids <- selectKeysList [RepoSharer ==. sid, RepoIdent <-. rps] []
pids <- map (repoCollabPerson . entityVal) <$> selectList [RepoCollabRepo <-. rids] []

26
src/Vervis/ActivityPub/Recipient.hs
View file

@ -15,6 +15,7 @@
module Vervis.ActivityPub.Recipient
( LocalActor (..)
, LocalPersonCollection (..)
, LocalTicketDirectSet (..)
, LocalProjectDirectSet (..)
, LocalProjectRelatedSet (..)
@ -25,6 +26,9 @@ module Vervis.ActivityPub.Recipient
, LocalRecipientSet
, concatRecipients
, parseLocalActor
, renderLocalActor
, renderLocalPersonCollection
, makeRecipientSet
, parseAudience
, actorRecips
, localRecipSieve
@ -78,6 +82,7 @@ data LocalActor
= LocalActorSharer ShrIdent
| LocalActorProject ShrIdent PrjIdent
| LocalActorRepo ShrIdent RpIdent
deriving Eq
parseLocalActor :: Route App -> Maybe LocalActor
parseLocalActor (SharerR shr) = Just $ LocalActorSharer shr
@ -85,6 +90,11 @@ parseLocalActor (ProjectR shr prj) = Just $ LocalActorProject shr prj
parseLocalActor (RepoR shr rp) = Just $ LocalActorRepo shr rp
parseLocalActor _ = Nothing
renderLocalActor :: LocalActor -> Route App
renderLocalActor (LocalActorSharer shr) = SharerR shr
renderLocalActor (LocalActorProject shr prj) = ProjectR shr prj
renderLocalActor (LocalActorRepo shr rp) = RepoR shr rp
data LocalPersonCollection
= LocalPersonCollectionSharerFollowers ShrIdent
| LocalPersonCollectionProjectTeam ShrIdent PrjIdent
@ -93,6 +103,7 @@ data LocalPersonCollection
| LocalPersonCollectionTicketFollowers ShrIdent PrjIdent (KeyHashid LocalTicket)
| LocalPersonCollectionRepoTeam ShrIdent RpIdent
| LocalPersonCollectionRepoFollowers ShrIdent RpIdent
deriving Eq
parseLocalPersonCollection
:: Route App -> Maybe LocalPersonCollection
@ -112,6 +123,15 @@ parseLocalPersonCollection (RepoFollowersR shr rp) =
Just $ LocalPersonCollectionRepoFollowers shr rp
parseLocalPersonCollection _ = Nothing
renderLocalPersonCollection :: LocalPersonCollection -> Route App
renderLocalPersonCollection (LocalPersonCollectionSharerFollowers shr) = SharerFollowersR shr
renderLocalPersonCollection (LocalPersonCollectionProjectTeam shr prj) = ProjectTeamR shr prj
renderLocalPersonCollection (LocalPersonCollectionProjectFollowers shr prj) = ProjectFollowersR shr prj
renderLocalPersonCollection (LocalPersonCollectionTicketTeam shr prj ltkhid) = TicketTeamR shr prj ltkhid
renderLocalPersonCollection (LocalPersonCollectionTicketFollowers shr prj ltkhid) = TicketParticipantsR shr prj ltkhid
renderLocalPersonCollection (LocalPersonCollectionRepoTeam shr rp) = RepoTeamR shr rp
renderLocalPersonCollection (LocalPersonCollectionRepoFollowers shr rp) = RepoFollowersR shr rp
parseLocalRecipient
:: Route App -> Maybe (Either LocalActor LocalPersonCollection)
parseLocalRecipient r =
@ -321,6 +341,12 @@ groupLocalRecipients
-- Parse URIs into a grouped recipient set
-------------------------------------------------------------------------------
makeRecipientSet :: [LocalActor] -> [LocalPersonCollection] -> LocalRecipientSet
makeRecipientSet actors collections =
groupLocalRecipients $
map groupedRecipientFromActor actors ++
map groupedRecipientFromCollection collections
parseRecipients
:: (MonadSite m, SiteEnv m ~ App)
=> NonEmpty FedURI

62
src/Vervis/Client.hs
View file

@ -22,6 +22,7 @@ module Vervis.Client
, followTicket
, followRepo
, offerTicket
, createTicket
, undoFollowSharer
, undoFollowProject
, undoFollowTicket
@ -233,6 +234,7 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx
, AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
, AP.ticketPublished = Nothing
, AP.ticketUpdated = Nothing
, AP.ticketContext = Nothing
-- , AP.ticketName = Nothing
, AP.ticketSummary = TextHtml title
, AP.ticketContent = TextHtml descHtml
@ -254,6 +256,66 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx
}
return (summary, audience, offer)
createTicket
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
=> ShrIdent
-> TextHtml
-> TextPandocMarkdown
-> FedURI
-> FedURI
-> m (Either Text (TextHtml, Audience URIMode, Create URIMode))
createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) target context = runExceptT $ do
summary <-
TextHtml . TL.toStrict . renderHtml <$>
withUrlRenderer
[hamlet|
<p>
<a href=@{SharerR shrAuthor}>
#{shr2text shrAuthor}
\ opened a ticket on project #
<a href="#{renderObjURI context}"}>
#{renderObjURI context}
: #{preEscapedToHtml title}.
|]
encodeRouteHome <- getEncodeRouteHome
let recipsA = [target]
recipsC =
let ObjURI h (LocalURI lu) = context
in [ ObjURI h $ LocalURI $ lu <> "/followers"
, ObjURI h $ LocalURI $ lu <> "/team"
, encodeRouteHome $ SharerFollowersR shrAuthor
]
audience = Audience
{ audienceTo = recipsA ++ recipsC
, audienceBto = []
, audienceCc = []
, audienceBcc = []
, audienceGeneral = []
, audienceNonActors = recipsC
}
encodeRouteLocal <- getEncodeRouteLocal
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
let ticket = AP.Ticket
{ AP.ticketLocal = Nothing
, AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
, AP.ticketPublished = Nothing
, AP.ticketUpdated = Nothing
, AP.ticketContext = Just context
, AP.ticketSummary = TextHtml title
, AP.ticketContent = TextHtml descHtml
, AP.ticketSource = TextPandocMarkdown desc
, AP.ticketAssignedTo = Nothing
, AP.ticketIsResolved = False
}
create = Create
{ createObject = CreateTicket ticket
, createTarget = Just target
}
return (summary, audience, create)
undoFollow
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
=> ShrIdent

2
src/Vervis/Federation/Discussion.hs
View file

@ -347,7 +347,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
-> SharerId
-> FollowerSetId
-> FollowerSetId
-> AppDB [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
deliverLocal ractid recips sid fsidProject fsidTicket = do
(teamPids, teamRemotes) <-
if CreateNoteRecipTicketTeam `elem` recips

2
src/Vervis/Federation/Offer.hs
View file

@ -256,7 +256,7 @@ followF
newFollow <- insertFollow ractid obiid $ recipFollowers recip
if newFollow
then Right <$> do
let raInfo = (raidAuthor, remoteObjectIdent ro, remoteActorInbox ra, remoteActorErrorSince ra)
let raInfo = RemoteRecipient raidAuthor (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra)
iidAuthor = remoteAuthorInstance author
hAuthor = objUriAuthority $ remoteAuthorURI author
hostSection = ((iidAuthor, hAuthor), raInfo :| [])

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

@ -298,7 +298,7 @@ projectOfferTicketF
-> [OfferTicketRecipColl]
-> SharerId
-> FollowerSetId
-> AppDB [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
deliverLocal ractid recips sid fsid = do
(teamPids, teamRemotes) <-
if OfferTicketRecipProjectTeam `elem` recips
@ -381,7 +381,7 @@ projectOfferTicketF
let raidAuthor = remoteAuthorId author
ra <- getJust raidAuthor
ro <- getJust $ remoteActorIdent ra
let raInfo = (raidAuthor, remoteObjectIdent ro, remoteActorInbox ra, remoteActorErrorSince ra)
let raInfo = RemoteRecipient raidAuthor (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra)
iidAuthor = remoteAuthorInstance author
hAuthor = objUriAuthority $ remoteAuthorURI author
hostSection = ((iidAuthor, hAuthor), raInfo :| [])

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

@ -55,6 +55,7 @@ data NewTicket = NewTicket
, ntTParams :: [(WorkflowFieldId, Text)]
, ntEParams :: [(WorkflowFieldId, WorkflowEnumCtorId)]
, ntCParams :: [WorkflowFieldId]
, ntOffer :: Bool
}
fieldSettings :: Text -> Bool -> FieldSettings App
@ -135,6 +136,7 @@ newTicketForm wid html = do
<*> (catMaybes <$> traverse tfield tfs)
<*> (fmap catMaybes $ sequenceA $ mapMaybe efield efs)
<*> (catMaybes <$> traverse cfield cfs)
<*> areq checkBoxField "Offer" Nothing
editTicketContentAForm :: Ticket -> AForm Handler Ticket
editTicketContentAForm ticket = Ticket

159
src/Vervis/Handler/Client.hs
View file

@ -167,9 +167,23 @@ publishCommentForm html = do
defp = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/m/2f1a7"
defmsg = "Hi! I'm testing federation. Can you see my message? :)"
openTicketForm
createTicketForm :: Form (FedURI, FedURI, TextHtml, TextPandocMarkdown)
createTicketForm = renderDivs $ (,,,)
<$> areq fedUriField "Tracker" (Just defaultProject)
<*> areq fedUriField "Context" (Just defaultProject)
<*> (TextHtml . sanitizeBalance <$> areq textField "Title" Nothing)
<*> (TextPandocMarkdown . T.filter (/= '\r') . unTextarea <$>
areq textareaField "Description" Nothing
)
where
defaultProject =
ObjURI
(Authority "forge.angeley.es" Nothing)
(LocalURI "/s/fr33/p/sandbox")
offerTicketForm
:: Form ((Host, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown)
openTicketForm html = do
offerTicketForm html = do
enc <- getEncodeRouteLocal
flip renderDivs html $ (,,)
<$> areq (projectField enc) "Project" (Just defj)
@ -195,24 +209,31 @@ activityWidget
:: Widget -> Enctype
-> Widget -> Enctype
-> Widget -> Enctype
-> Widget -> Enctype
-> Widget
activityWidget widget1 enctype1 widget2 enctype2 widget3 enctype3 =
[whamlet|
<h1>Publish a ticket comment
<form method=POST action=@{PublishR} enctype=#{enctype1}>
^{widget1}
<input type=submit>
activityWidget
widget1 enctype1 widget2 enctype2 widget3 enctype3 widget4 enctype4 =
[whamlet|
<h1>Publish a ticket comment
<form method=POST action=@{PublishR} enctype=#{enctype1}>
^{widget1}
<input type=submit>
<h1>Open a new ticket
<form method=POST action=@{PublishR} enctype=#{enctype2}>
^{widget2}
<input type=submit>
<h1>Open a new ticket (via Create)
<form method=POST action=@{PublishR} enctype=#{enctype2}>
^{widget2}
<input type=submit>
<h1>Follow a person, a projet or a repo
<form method=POST action=@{PublishR} enctype=#{enctype3}>
^{widget3}
<input type=submit>
|]
<h1>Open a new ticket (via Offer)
<form method=POST action=@{PublishR} enctype=#{enctype3}>
^{widget3}
<input type=submit>
<h1>Follow a person, a projet or a repo
<form method=POST action=@{PublishR} enctype=#{enctype4}>
^{widget4}
<input type=submit>
|]
getUser :: Handler (ShrIdent, PersonId)
getUser = do
@ -228,11 +249,14 @@ getPublishR = do
((_result1, widget1), enctype1) <-
runFormPost $ identifyForm "f1" publishCommentForm
((_result2, widget2), enctype2) <-
runFormPost $ identifyForm "f2" openTicketForm
runFormPost $ identifyForm "f2" createTicketForm
((_result3, widget3), enctype3) <-
runFormPost $ identifyForm "f3" followForm
runFormPost $ identifyForm "f3" offerTicketForm
((_result4, widget4), enctype4) <-
runFormPost $ identifyForm "f4" followForm
defaultLayout $
activityWidget widget1 enctype1 widget2 enctype2 widget3 enctype3
activityWidget
widget1 enctype1 widget2 enctype2 widget3 enctype3 widget4 enctype4
postSharerOutboxR :: ShrIdent -> Handler Html
postSharerOutboxR _shrAuthor = do
@ -240,8 +264,8 @@ postSharerOutboxR _shrAuthor = do
unless federation badMethod
error
"ActivityPub C2S outbox POST not implemented yet, but you can public \
\activities via the /publish page"
"ActivityPub C2S outbox POST not implemented yet, but you can post \
\public activities via the /publish page"
postPublishR :: Handler Html
postPublishR = do
@ -251,15 +275,20 @@ postPublishR = do
((result1, widget1), enctype1) <-
runFormPost $ identifyForm "f1" publishCommentForm
((result2, widget2), enctype2) <-
runFormPost $ identifyForm "f2" openTicketForm
runFormPost $ identifyForm "f2" createTicketForm
((result3, widget3), enctype3) <-
runFormPost $ identifyForm "f3" followForm
runFormPost $ identifyForm "f3" offerTicketForm
((result4, widget4), enctype4) <-
runFormPost $ identifyForm "f4" followForm
let result
= Left <$> result1
<|> Right . Left <$> result2
<|> Right . Right <$> result3
= Left . Left <$> result1
<|> Left . Right <$> result2
<|> Right . Left <$> result3
<|> Right . Right <$> result4
shrAuthor <- getUserShrIdent
ep@(Entity _ p) <- requireVerifiedAuth
s <- runDB $ getJust $ personIdent p
let shrAuthor = sharerIdent s
eid <- runExceptT $ do
input <-
@ -267,16 +296,21 @@ postPublishR = do
FormMissing -> throwE "Field(s) missing"
FormFailure _l -> throwE "Invalid input, see below"
FormSuccess r -> return r
bitraverse (publishComment shrAuthor) (bitraverse (openTicket shrAuthor) (follow shrAuthor)) input
bitraverse (bitraverse (publishComment shrAuthor) (publishTicket ep s)) (bitraverse (openTicket shrAuthor) (follow shrAuthor)) input
case eid of
Left err -> setMessage $ toHtml err
Right id_ ->
case id_ of
Left lmid -> do
Left (Left lmid) -> do
lmkhid <- encodeKeyHashid lmid
renderUrl <- getUrlRender
let u = renderUrl $ MessageR shrAuthor lmkhid
setMessage $ toHtml $ "Message created! ID: " <> u
Left (Right talid) -> do
talkhid <- encodeKeyHashid talid
renderUrl <- getUrlRender
let u = renderUrl $ SharerTicketR shrAuthor talkhid
setMessage $ toHtml $ "Ticket created! ID: " <> u
Right (Left _obiid) ->
setMessage "Ticket offer published!"
Right (Right _obiid) ->
@ -286,6 +320,7 @@ postPublishR = do
widget1 enctype1
widget2 enctype2
widget3 enctype3
widget4 enctype4
where
publishComment shrAuthor ((hTicket, shrTicket, prj, num), muParent, msg) = do
encodeRouteFed <- getEncodeRouteHome
@ -319,6 +354,15 @@ postPublishR = do
, noteContent = contentHtml
}
ExceptT $ createNoteC hLocal note
publishTicket eperson sharer (target, context, title, desc) = do
(summary, audience, create) <-
ExceptT $ C.createTicket (sharerIdent sharer) title desc target context
let ticket =
case createObject create of
CreateTicket t -> t
_ -> error "Create object isn't a ticket"
target = createTarget create
ExceptT $ createTicketC eperson sharer summary audience ticket target
openTicket shrAuthor ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteFed <- getEncodeRouteFed
@ -664,12 +708,14 @@ postTicketsR shr prj = do
return $ projectWorkflow j
((result, widget), enctype) <- runFormPost $ newTicketForm wid
shrAuthor <- do
Entity _ p <- requireVerifiedAuth
runDB $ sharerIdent <$> getJust (personIdent p)
(eperson, sharer) <- do
ep@(Entity _ p) <- requireVerifiedAuth
s <- runDB $ getJust $ personIdent p
return (ep, s)
let shrAuthor = sharerIdent sharer
eltid <- runExceptT $ do
NewTicket title desc tparams eparams cparams <-
eid <- runExceptT $ do
NewTicket title desc tparams eparams cparams offer <-
case result of
FormMissing -> throwE "Field(s) missing."
FormFailure _l ->
@ -691,23 +737,38 @@ postTicketsR shr prj = do
}
insertMany_ $ map mkeparam $ ntEParams nt
-}
(summary, audience, offer) <-
ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj
obiid <- ExceptT $ offerTicketC shrAuthor summary audience offer
ExceptT $ runDB $ do
mtal <- getValBy $ UniqueTicketAuthorLocalOpen obiid
return $
case mtal of
Nothing ->
Left
"Offer processed successfully but no ticket \
\created"
Just tal -> Right $ ticketAuthorLocalTicket tal
case eltid of
if offer
then Right <$> do
(summary, audience, offer) <-
ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj
obiid <- ExceptT $ offerTicketC shrAuthor summary audience offer
ExceptT $ runDB $ do
mtal <- getValBy $ UniqueTicketAuthorLocalOpen obiid
return $
case mtal of
Nothing ->
Left
"Offer processed successfully but no ticket \
\created"
Just tal -> Right $ ticketAuthorLocalTicket tal
else Left <$> do
(summary, audience, Create obj mtarget) <- do
encodeRouteHome <- getEncodeRouteHome
let project = encodeRouteHome $ ProjectR shr prj
ExceptT $ createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) project project
let ticket =
case obj of
CreateTicket t -> t
_ -> error "Create object isn't a ticket"
ExceptT $ createTicketC eperson sharer summary audience ticket mtarget
case eid of
Left e -> do
setMessage $ toHtml e
defaultLayout $(widgetFile "ticket/new")
Right ltid -> do
Right (Left talid) -> do
talkhid <- encodeKeyHashid talid
redirect $ SharerTicketR shr talkhid
Right (Right ltid) -> do
ltkhid <- encodeKeyHashid ltid
eobiidFollow <- runExceptT $ do
(summary, audience, follow) <- followTicket shrAuthor shr prj ltkhid False

2
src/Vervis/Migration.hs
View file

@ -1507,6 +1507,8 @@ changes hLocal ctx =
, removeField "RemoteMessage" "ident"
-- 233
, renameField "RemoteMessage" "identNew" "ident"
-- 234
, addEntities model_2020_02_22
]
migrateDB

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

@ -180,6 +180,7 @@ module Vervis.Migration.Model
, RemoteObject227Generic (..)
, RemoteMessage227
, RemoteMessage227Generic (..)
, model_2020_02_22
)
where
@ -350,3 +351,6 @@ makeEntitiesMigration "223"
makeEntitiesMigration "227"
$(modelFile "migrations/2020_02_10_rm_point_to_ro.model")
model_2020_02_22 :: [Entity SqlBackend]
model_2020_02_22 = $(schema "2020_02_22_tpr")