From a00c45a444ed5da6bea4ffa90f9f0efd9dbbf6d7 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sat, 22 Feb 2020 19:45:27 +0000 Subject: [PATCH] Implement C2S Create{Ticket}, available in PublishR and in postTicketsR 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. --- config/models | 7 + migrations/2020_02_22_tpr.model | 6 + src/Vervis/API.hs | 271 +++++++++++++++++++++++++++- src/Vervis/ActivityPub.hs | 57 +++--- src/Vervis/ActivityPub/Recipient.hs | 26 +++ src/Vervis/Client.hs | 62 +++++++ src/Vervis/Federation/Discussion.hs | 2 +- src/Vervis/Federation/Offer.hs | 2 +- src/Vervis/Federation/Ticket.hs | 4 +- src/Vervis/Form/Ticket.hs | 2 + src/Vervis/Handler/Client.hs | 159 +++++++++++----- src/Vervis/Migration.hs | 2 + src/Vervis/Migration/Model.hs | 4 + 13 files changed, 521 insertions(+), 83 deletions(-) create mode 100644 migrations/2020_02_22_tpr.model diff --git a/config/models b/config/models index 248b517..45015a6 100644 --- a/config/models +++ b/config/models @@ -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 diff --git a/migrations/2020_02_22_tpr.model b/migrations/2020_02_22_tpr.model new file mode 100644 index 0000000..8d3f84f --- /dev/null +++ b/migrations/2020_02_22_tpr.model @@ -0,0 +1,6 @@ +TicketProjectRemote + ticket TicketAuthorLocalId + tracker RemoteActorId + project RemoteObjectId Maybe + + UniqueTicketProjectRemote ticket diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 17bcdb7..ebd01a4 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -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| +

+ Project # + + #{prj2text prjJ} + \ accepted # + + ticket + \ by # + + #{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 diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 102842e..cfe6502 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -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] [] diff --git a/src/Vervis/ActivityPub/Recipient.hs b/src/Vervis/ActivityPub/Recipient.hs index 0b564f6..08e44ff 100644 --- a/src/Vervis/ActivityPub/Recipient.hs +++ b/src/Vervis/ActivityPub/Recipient.hs @@ -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 diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 80b770b..59db032 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -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| +

+ + #{shr2text shrAuthor} + \ opened a ticket on project # + + #{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 diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index 8db25c9..30c98e8 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -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 diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index 2700e00..85db130 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -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 :| []) diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 471f098..16fe31a 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -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 :| []) diff --git a/src/Vervis/Form/Ticket.hs b/src/Vervis/Form/Ticket.hs index 9002193..f10886b 100644 --- a/src/Vervis/Form/Ticket.hs +++ b/src/Vervis/Form/Ticket.hs @@ -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 diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index a1af941..4873202 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -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| -

Publish a ticket comment -
- ^{widget1} - +activityWidget + widget1 enctype1 widget2 enctype2 widget3 enctype3 widget4 enctype4 = + [whamlet| +

Publish a ticket comment + + ^{widget1} + -

Open a new ticket - - ^{widget2} - +

Open a new ticket (via Create) + + ^{widget2} + -

Follow a person, a projet or a repo - - ^{widget3} - - |] +

Open a new ticket (via Offer) + + ^{widget3} + + +

Follow a person, a projet or a repo + + ^{widget4} + + |] 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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 0e1e0ec..84f71c2 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -1507,6 +1507,8 @@ changes hLocal ctx = , removeField "RemoteMessage" "ident" -- 233 , renameField "RemoteMessage" "identNew" "ident" + -- 234 + , addEntities model_2020_02_22 ] migrateDB diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 751e4a3..33d755c 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -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")