diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 6cda819..dea3d8e 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -26,7 +26,6 @@ module Vervis.API , createPatchTrackerC , createRepositoryC , followC - , offerTicketC --, offerDepC , resolveC , undoC @@ -1652,352 +1651,6 @@ followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re } } -offerTicketC - :: Entity Person - -> Actor - -> Maybe - (Either - (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) - FedURI - ) - -> RecipientRoutes - -> [(Host, NonEmpty LocalURI)] - -> [Host] - -> AP.Action URIMode - -> AP.Ticket URIMode - -> FedURI - -> ExceptT Text Handler OutboxItemId -offerTicketC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action ticket uTarget = do - - -- Check input - verifyNothingE maybeCap "Capability not needed" - (title, desc, source, tam) <- do - hostLocal <- asksSite siteInstanceHost - WorkItemOffer {..} <- VA2.runActE $ checkOfferTicket hostLocal ticket uTarget - unless (wioAuthor == Left senderPersonID) $ - throwE "Offering a Ticket attributed to someone else" - return (wioTitle, wioDesc, wioSource, wioRest) - - -- Verify that the target tracker is addressed by the Offer - case tam of - TAM_Task deckID -> do - deckHash <- encodeKeyHashid deckID - unless (actorIsAddressed localRecips $ LocalActorDeck deckHash) $ - throwE "Local target deck not addressed by the Offer" - TAM_Merge loomID _ -> do - loomHash <- encodeKeyHashid loomID - unless (actorIsAddressed localRecips $ LocalActorLoom loomHash) $ - throwE "Local target loom not addressed by the Offer" - TAM_Remote uTracker _ -> verifyRemoteAddressed remoteRecips uTracker - - senderHash <- encodeKeyHashid senderPersonID - now <- liftIO getCurrentTime - - -- If tracker is a local loom, and a remote origin repo is specified, fetch - -- that repo's AP object via HTTP and remember in DB - maybeLocalTracker <- - case tam of - TAM_Task deckID -> pure $ Just $ Left deckID - TAM_Merge loomID (Merge maybeOriginTip maybeBundle targetTip) -> do - maybeOrigin <- for maybeOriginTip $ \case - TipLocalRepo repoID -> pure $ Left (repoID, Nothing) - TipLocalBranch repoID branch -> pure $ Left (repoID, Just branch) - TipRemote uOrigin -> Right <$> do - (vcs, raid, uClone, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip uOrigin - return (vcs, raid, uClone, first Just <$> mb) - TipRemoteBranch uRepo branch -> Right <$> do - (vcs, raid, uClone) <- withExceptT (T.pack . show) $ httpGetRemoteRepo uRepo - return (vcs, raid, uClone, Just (Nothing, branch)) - originOrBundle <- - fromMaybeE - (align maybeOrigin maybeBundle) - "MR provides neither origin nor patches" - (targetRepoID, maybeTargetBranch) <- - case targetTip of - TipLocalRepo repoID -> pure (repoID, Nothing) - TipLocalBranch repoID branch -> pure (repoID, Just branch) - _ -> throwE "Offer target is a local loom but MR target is a remote repo (Looms serve only local repos)" - return $ Just $ Right (loomID, originOrBundle, targetRepoID, maybeTargetBranch) - TAM_Remote _ _ -> pure Nothing - - (offerID, deliverHttpOffer, maybeAcceptMaybePull) <- runDBExcept $ do - - -- If target tracker is local, find it in our DB - -- If that tracker is a loom, find and check the MR too - maybeLocalTrackerDB <- for maybeLocalTracker $ bitraverse - (\ deckID -> do - deck <- getE deckID "Offer local target no such deck in DB" - return (deckID, deckActor deck) - ) - (\ (loomID, originOrBundle, targetRepoID, maybeTargetBranch) -> do - loom <- getE loomID "Offer local target no such loom in DB" - - unless (targetRepoID == loomRepo loom) $ - throwE "MR target repo isn't the one served by the Offer target loom" - targetRepo <- getE targetRepoID "MR target local repo not found in DB" - unless (repoLoom targetRepo == Just loomID) $ - throwE "Offer target loom doesn't have repo's consent to serve it" - - for_ (justThere originOrBundle) $ \ (Material typ diffs) -> do - unless (repoVcs targetRepo == patchMediaTypeVCS typ) $ - throwE "Patch type and local target repo VCS mismatch" - case (typ, diffs) of - (PatchMediaTypeDarcs, _ :| _ : _) -> - throwE "More than one Darcs dpatch file provided" - _ -> pure () - - originOrBundle' <- - bitraverse - (\ origin -> do - (vcs, origin') <- - case origin of - Left (repoID, maybeBranch) -> do - repo <- getE repoID "MR origin local repo not found in DB" - return (repoVcs repo, Left (repoID, maybeBranch)) - Right (vcs, remoteActorID, uClone, maybeBranch) -> - pure (vcs, Right (remoteActorID, uClone, maybeBranch)) - unless (vcs == repoVcs targetRepo) $ - throwE "Origin repo VCS differs from target repo VCS" - return origin' - ) - pure - originOrBundle - - -- Verify that the VCS of target repo, origin repo and patches - -- all match, and that branches are specified for Git and - -- aren't specified for Darcs - tipInfo <- case repoVcs targetRepo of - VCSGit -> do - targetBranch <- fromMaybeE maybeTargetBranch "Local target repo is Git but no target branch specified" - maybeOrigin <- for (justHere originOrBundle') $ \case - Left (originRepoID, maybeOriginBranch) -> do - originBranch <- fromMaybeE maybeOriginBranch "Local origin repo is Git but no origin branch specified" - return (Left originRepoID, originBranch) - Right (_remoteActorID, uClone, maybeOriginBranch) -> do - (_maybeURI, originBranch) <- fromMaybeE maybeOriginBranch "Remote origin repo is Git but no origin branch specified" - return (Right uClone, originBranch) - return $ Left (targetBranch, maybeOrigin) - VCSDarcs -> do - verifyNothingE maybeTargetBranch "Local target repo is Darcs but target branch specified" - maybeOriginRepo <- for (justHere originOrBundle') $ \case - Left (originRepoID, maybeOriginBranch) -> do - verifyNothingE maybeOriginBranch "Local origin repo is Darcs but origin branch specified" - return $ Left originRepoID - Right (_remoteActorID, uClone, maybeOriginBranch) -> do - verifyNothingE maybeOriginBranch "Remote origin repo is Darcs but origin branch specified" - return $ Right uClone - return $ Right $ maybeOriginRepo - - return (loomID, loomActor loom, originOrBundle', targetRepoID, maybeTargetBranch, tipInfo) - ) - - -- Insert Offer to sender's outbox - offerID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now - luOffer <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) offerID action - - -- Deliver the Offer activity to local recipients, and schedule - -- delivery for unavailable remote recipients - deliverHttpOffer <- do - hashRepo <- getEncodeKeyHashid - let tipRepo tip = - case tip of - TipLocalRepo repoID -> Just $ hashRepo repoID - TipLocalBranch repoID _ -> Just $ hashRepo repoID - _ -> Nothing - hashDeck <- getEncodeKeyHashid - hashLoom <- getEncodeKeyHashid - let (tracker, target, origin) = - case tam of - TAM_Task deckID -> - ( Just $ Left $ hashDeck deckID - , Nothing - , Nothing - ) - TAM_Merge loomID (Merge maybeOriginTip _ targetTip) -> - ( Just $ Right $ hashLoom loomID - , tipRepo targetTip - , tipRepo =<< maybeOriginTip - ) - TAM_Remote _ maybeMerge -> - ( Nothing - , tipRepo . mergeTarget =<< maybeMerge - , tipRepo =<< mergeOrigin =<< maybeMerge - ) - sieveActors = catMaybes - [ tracker <&> \case - Left deckHash -> LocalActorDeck deckHash - Right loomHash -> LocalActorLoom loomHash - , LocalActorRepo <$> target - , LocalActorRepo <$> origin - ] - sieveStages = catMaybes - [ tracker <&> \case - Left deckHash -> LocalStageDeckFollowers deckHash - Right loomHash -> LocalStageLoomFollowers loomHash - , LocalStageRepoFollowers <$> target - , LocalStageRepoFollowers <$> origin - , Just $ LocalStagePersonFollowers senderHash - ] - sieve = makeRecipientSet sieveActors sieveStages - localRecipsFinal = localRecipSieve sieve False localRecips - deliverActivityDB - (LocalActorPerson senderHash) (personActor senderPerson) - localRecipsFinal remoteRecips fwdHosts offerID action - - -- If Offer target is a local deck/loom, verify that it has received - -- the Offer, insert a new Ticket to DB, and publish Accept - maybeAcceptMaybePull <- for maybeLocalTrackerDB $ \ tracker -> do - - -- Verify that tracker received the Offer - let trackerActorID = - case tracker of - Left (_, actorID) -> actorID - Right (_, actorID, _, _, _, _) -> actorID - verifyActorHasItem trackerActorID offerID "Local tracker didn't receive the Offer" - - -- Insert ticket/MR to DB - acceptID <- lift $ do - trackerActor <- getJust trackerActorID - insertEmptyOutboxItem (actorOutbox trackerActor) now - (ticketRoute, maybePull) <- lift $ do - ticketID <- insertTicket now title desc source offerID acceptID - case tracker of - Left (deckID, _) -> - (,Nothing) <$> insertTask deckID ticketID - Right (loomID, _, originOrBundle, targetRepoID, maybeTargetBranch, tipInfo) -> do - (clothID, route) <- insertMerge now loomID ticketID maybeTargetBranch originOrBundle - let maybeTipInfo = - case tipInfo of - Left (b, mo) -> Left . (b,) <$> mo - Right mo -> Right <$> mo - hasBundle = isJust $ justThere originOrBundle - pull = (clothID, targetRepoID, hasBundle,) <$> maybeTipInfo - return (route, pull) - - -- Insert an Accept activity to tracker's outbox - hashDeck <- getEncodeKeyHashid - hashLoom <- getEncodeKeyHashid - let acceptRecipActors = [LocalActorPerson senderHash] - acceptRecipStages = - [ case tracker of - Left (deckID, _) -> - LocalStageDeckFollowers $ hashDeck deckID - Right (loomID, _, _, _, _, _) -> - LocalStageLoomFollowers $ hashLoom loomID - , LocalStagePersonFollowers senderHash - ] - actionAccept <- prepareAccept ticketRoute luOffer acceptRecipActors acceptRecipStages - let trackerByKey = - case tracker of - Left (deckID, _) -> LocalActorDeck deckID - Right (loomID, _, _, _, _, _) -> LocalActorLoom loomID - _luAccept <- lift $ updateOutboxItem trackerByKey acceptID actionAccept - - -- Deliver the Accept activity to local recipients, and schedule - -- delivery for unavailable remote recipients - deliverHttpAccept <- do - let trackerLocalActor = - case tracker of - Left (deckID, _) -> - LocalActorDeck $ hashDeck deckID - Right (loomID, _, _, _, _, _) -> - LocalActorLoom $ hashLoom loomID - localRecipsAccept = - makeRecipientSet acceptRecipActors acceptRecipStages - deliverActivityDB - trackerLocalActor trackerActorID localRecipsAccept [] [] - acceptID actionAccept - - -- Return instructions for HTTP delivery to remote recipients, and - -- info for pulling origin branch to generate patches - return (deliverHttpAccept, maybePull) - - -- Return instructions for HTTP delivery to remote recipients, and info - -- for pulling origin branch to generate patches - return (offerID, deliverHttpOffer, maybeAcceptMaybePull) - - -- Launch asynchronous HTTP delivery of Offer and Accept, and generate - -- patches if we opened a local MR that mentions just an origin - lift $ forkWorker "offerTicketC: async HTTP Offer delivery" deliverHttpOffer - for_ maybeAcceptMaybePull $ \ (deliverHttpAccept, maybePull) -> do - lift $ forkWorker "offerTicketC: async HTTP Accept delivery" deliverHttpAccept - VA2.runActE $ traverse generatePatches maybePull - - return offerID - - where - - insertTicket now title desc source offerID acceptID = do - did <- insert Discussion - fsid <- insert FollowerSet - tid <- insert Ticket - { ticketNumber = Nothing - , ticketCreated = now - , ticketTitle = title - , ticketSource = source - , ticketDescription = desc - , ticketDiscuss = did - , ticketFollowers = fsid - , ticketAccept = acceptID - } - insert_ TicketAuthorLocal - { ticketAuthorLocalTicket = tid - , ticketAuthorLocalAuthor = senderPersonID - , ticketAuthorLocalOpen = offerID - } - return tid - - insertTask deckID ticketID = do - ticketDeckID <- insert $ TicketDeck ticketID deckID - TicketR <$> encodeKeyHashid deckID <*> encodeKeyHashid ticketDeckID - - insertMerge - :: UTCTime - -> LoomId - -> TicketId - -> Maybe Text - -> These - (Either - (RepoId, Maybe Text) - (RemoteActorId, FedURI, Maybe (Maybe LocalURI, Text)) - ) - Material - -> AppDB (TicketLoomId, Route App) - insertMerge now loomID ticketID maybeBranch originOrBundle = do - clothID <- insert $ TicketLoom ticketID loomID maybeBranch - for_ (justHere originOrBundle) $ \case - Left (repoID, maybeOriginBranch) -> - insert_ $ MergeOriginLocal clothID repoID maybeOriginBranch - Right (remoteActorID, _uClone, maybeOriginBranch) -> do - originID <- insert $ MergeOriginRemote clothID remoteActorID - for_ maybeOriginBranch $ \ (mlu, b) -> - insert_ $ MergeOriginRemoteBranch originID mlu b - for_ (justThere originOrBundle) $ \ (Material typ diffs) -> do - bundleID <- insert $ Bundle clothID False - insertMany_ $ NE.toList $ NE.reverse $ - NE.map (Patch bundleID now typ) diffs - route <- ClothR <$> encodeKeyHashid loomID <*> encodeKeyHashid clothID - return (clothID, route) - - prepareAccept ticketRoute luOffer actors stages = do - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost - let recips = - map encodeRouteHome $ - map renderLocalActor actors ++ - map renderLocalStage stages - return Action - { actionCapability = Nothing - , actionSummary = Nothing - , actionAudience = Audience recips [] [] [] [] [] - , actionFulfills = [] - , actionSpecific = AcceptActivity Accept - { acceptObject = ObjURI hLocal luOffer - , acceptResult = Just $ encodeRouteLocal ticketRoute - } - } - {- verifyHosterRecip _ _ (Right _) = return () verifyHosterRecip localRecips name (Left wi) = diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 4b605f4..ebc524c 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -689,7 +689,7 @@ postPublishR = do <|> ResultCreateMR <$> result7 <|> ResultOfferMR <$> result8 - ep@(Entity _ p) <- requireVerifiedAuth + ep@(Entity pid p) <- requireVerifiedAuth s <- runDB $ getJust $ personIdent p let shrAuthor = sharerIdent s @@ -1063,7 +1063,8 @@ postPublishOfferMergeR = do omgOriginRepo (Just omgOriginBranch) (localRecips, remoteRecips, fwdHosts, action) <- makeServerInput Nothing summary audience $ AP.OfferActivity $ AP.Offer (AP.OfferTicket ticket) omgTracker - offerID <- offerTicketC ep a Nothing localRecips remoteRecips fwdHosts action ticket omgTracker + offerID <- + handleViaActor pid Nothing localRecips remoteRecips fwdHosts action if trackerLocal then nameExceptT "Offer published but" $ runDBExcept $ do ticketID <- do diff --git a/src/Vervis/Handler/Cloth.hs b/src/Vervis/Handler/Cloth.hs index ff9bd55..14a2b1f 100644 --- a/src/Vervis/Handler/Cloth.hs +++ b/src/Vervis/Handler/Cloth.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2020, 2022 by fr33domlover . + - Written in 2020, 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -684,9 +684,7 @@ postClothNewR loomHash = do lift $ C.makeServerInput Nothing maybeSummary audience $ AP.OfferActivity $ AP.Offer (AP.OfferTicket ticket) uLoom offerID <- - offerTicketC - person senderActor Nothing localRecips remoteRecips fwdHosts action - ticket uLoom + handleViaActor pid Nothing localRecips remoteRecips fwdHosts action runDBExcept $ do mtal <- lift $ getValBy $ UniqueTicketAuthorLocalOpen offerID tal <- fromMaybeE mtal "Offer processed bu no ticket created" diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index add1e07..79f5ce8 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -460,17 +460,22 @@ postTicketNewR deckHash = do lift $ C.makeServerInput Nothing maybeSummary audience $ AP.OfferActivity $ AP.Offer (AP.OfferTicket ticket) uDeck offerID <- - offerTicketC - person actor Nothing localRecips remoteRecips fwdHosts action - ticket uDeck + handleViaActor pid Nothing localRecips remoteRecips fwdHosts action + {- runDBExcept $ do mtal <- lift $ getValBy $ UniqueTicketAuthorLocalOpen offerID tal <- fromMaybeE mtal "Offer processed bu no ticket created" return $ ticketAuthorLocalTicket tal + -} + return () case errorOrTicket of Left e -> do setMessage $ toHtml e redirect $ TicketNewR deckHash + Right () -> do + setMessage "Offer activity sent" + redirect $ DeckTicketsR deckHash + {- Right ticketID -> do taskID <- do maybeTaskID <- runDB $ getKeyBy $ UniqueTicketDeck ticketID @@ -480,6 +485,7 @@ postTicketNewR deckHash = do taskHash <- encodeKeyHashid taskID setMessage "Ticket created" redirect $ TicketR deckHash taskHash + -} postTicketFollowR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler () postTicketFollowR _ = error "Temporarily disabled"