From a06003c3616e421b3e6ba8db9870a77c0f5ff671 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Fri, 3 Nov 2023 14:18:41 +0200 Subject: [PATCH] S2S: Loom: Port Offer{MR} handler from old federation code This is to allow getting rid of the old C2S offerTicketC and write a C2S Offer handler in the new actor system. And that is to allow ticket opening and closing to work, so that it can use delegated OCAPs too, as a first demo of delegated OCAPs in action. --- src/Vervis/API.hs | 7 +- src/Vervis/Actor/Loom.hs | 362 +++++++++++++++++++++++++++++++- src/Vervis/Federation/Ticket.hs | 333 +---------------------------- src/Vervis/Fetch.hs | 54 ++++- src/Vervis/Handler/Person.hs | 6 +- src/Vervis/Path.hs | 13 +- src/Vervis/Web/Repo.hs | 20 +- 7 files changed, 444 insertions(+), 351 deletions(-) diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 5b8ffab..6cda819 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -18,7 +18,7 @@ module Vervis.API ( handleViaActor - , acceptC + --, acceptC --, addBundleC , applyC --, noteC @@ -188,6 +188,7 @@ verifyRemoteAddressed remoteRecips u = lus <- lookup h remoteRecips guard $ lu `elem` lus +{- acceptC :: Entity Person -> Actor @@ -203,8 +204,6 @@ acceptC -> AP.Accept URIMode -> ExceptT Text Handler OutboxItemId acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action accept = do - error "acceptC temporarily disabled due to actor refactoring" -{- -- Check input verifyNothingE maybeCap "Capability not needed" acceptee <- parseAccept accept @@ -1922,7 +1921,7 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor maybeCap localReci lift $ forkWorker "offerTicketC: async HTTP Offer delivery" deliverHttpOffer for_ maybeAcceptMaybePull $ \ (deliverHttpAccept, maybePull) -> do lift $ forkWorker "offerTicketC: async HTTP Accept delivery" deliverHttpAccept - traverse generatePatches maybePull + VA2.runActE $ traverse generatePatches maybePull return offerID diff --git a/src/Vervis/Actor/Loom.hs b/src/Vervis/Actor/Loom.hs index cceb9a3..837515c 100644 --- a/src/Vervis/Actor/Loom.hs +++ b/src/Vervis/Actor/Loom.hs @@ -18,23 +18,40 @@ module Vervis.Actor.Loom ) where +import Control.Applicative +import Control.Exception.Base import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger.CallStack import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Data.Align +import Data.Bifunctor +import Data.Bitraversable import Data.ByteString (ByteString) import Data.Foldable +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe import Data.Text (Text) +import Data.These import Data.Time.Clock +import Data.Traversable import Database.Persist +import Database.Persist.Sql +import Optics.Core import Yesod.Persist.Core +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T +import qualified Database.Esqueleto as E import Control.Concurrent.Actor +import Development.PatchMediaType import Network.FedURI +import Web.Actor +import Web.Actor.Persist import Yesod.MonadSite import qualified Web.ActivityPub as AP @@ -42,19 +59,360 @@ import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local import Database.Persist.Local +import Vervis.Access +import Vervis.ActivityPub import Vervis.Actor +import Vervis.Actor.Common +import Vervis.Actor2 import Vervis.Cloth +import Vervis.Data.Actor +import Vervis.Data.Collab import Vervis.Data.Discussion +import Vervis.Data.Ticket import Vervis.FedURI import Vervis.Federation.Util +import Vervis.Fetch import Vervis.Foundation -import Vervis.Model +import Vervis.Model hiding (deckCreate) +import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers) +import Vervis.Persist.Actor +import Vervis.Persist.Collab import Vervis.Persist.Discussion +import Vervis.RemoteActorStore import Vervis.Ticket +import Vervis.Web.Repo + +-- Meaning: An actor A is offering a ticket or a ticket dependency +-- Behavior: +-- * Verify I'm the target +-- * Insert the Offer to my inbox +-- * Create the new ticket in my DB +-- * Forward the Offer to my followers +-- * Publish an Accept to: +-- - My followers +-- - Offer sender+followers +loomOffer + :: UTCTime + -> LoomId + -> Verse + -> AP.Offer URIMode + -> ActE (Text, Act (), Next) +loomOffer now loomID (Verse authorIdMsig body) (AP.Offer object uTarget) = do + + -- Check input + (title, desc, source, originTipOrBundle, targetRepoID, maybeTargetBranch) <- do + ticket <- + case object of + AP.OfferTicket t -> pure t + _ -> throwE "Unsupported Offer.object type" + ObjURI hAuthor _ <- lift $ getActorURI authorIdMsig + let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig + WorkItemOffer {..} <- checkOfferTicket hAuthor ticket uTarget + unless (bimap LocalActorPerson id wioAuthor == author) $ + throwE "Offering a Ticket attributed to someone else" + Merge maybeOriginTip maybeBundle targetTip <- case wioRest of + TAM_Task _ -> + throwE + "Offer target is some local deck, so I have no use for \ + \this Offer. Was I supposed to receive it?" + TAM_Merge loomID' merge -> + if loomID' == loomID + then return merge + else throwE + "Offer target is some other local loom, so I have \ + \no use for this Offer. Was I supposed to receive \ + \it?" + TAM_Remote _ _ -> + throwE + "Offer target is some remote tracker, so I have no use \ + \for this Offer. Was I supposed to receive it?" + originTipOrBundle <- + fromMaybeE + (align maybeOriginTip 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 "MR target is a remote repo (this tracker serves only local repos)" + return (wioTitle, wioDesc, wioSource, originTipOrBundle, targetRepoID, maybeTargetBranch) + + -- Verify the capability URI, if provided, is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + maybeCapability <- + for (AP.activityCapability $ actbActivity body) $ \ uCap -> + nameExceptT "Offer.capability" $ + first (\ (actor, _, item) -> (actor, item)) <$> + parseActivityURI' uCap + + -- If origin repo is remote, HTTP GET its AP representation and + -- remember it in our DB + -- + -- Why do we need to HTTP GET it? Because: + -- * No support for providing a signed repo object directly in the + -- Offer activity + -- * It may be nice to make sure a remote origin repo's VCS type + -- matches the target repo's VCS, even if patches are provided too + -- + However there's no support for caching VCS type when + -- remembering remote repo in our DB, so we'd have to check this + -- every time + -- * If origin is remote and no patches are provided, we'll need to + -- know the clone URL to generate the patches ourselves + -- + However the code here, for some simplicity, doesn't have a + -- way to skip that and do the whole handler synchronously in + -- case patches are provided or the origin is a local repo + -- + And no support for caching the clone URI in DB when + -- remembering the remote repo, so we'd need to do this every + -- time + let originTipOrBundle' = + bimap + (\case + TipLocalRepo repoID -> Left (repoID, Nothing) + TipLocalBranch repoID branch -> Left (repoID, Just branch) + TipRemote uOrigin -> Right (uOrigin, Nothing) + TipRemoteBranch uRepo branch -> Right (uRepo, Just branch) + ) + id + originTipOrBundle + originTipOrBundle'' <- + bitraverse + (bitraverse + pure + (\ (uOrigin, maybeOriginBranch) -> do + case maybeOriginBranch of + Nothing -> do + (vcs, raid, uClone, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip' uOrigin + return (vcs, (raid, uClone, first Just <$> mb)) + Just branch -> do + (vcs, raid, uClone) <- withExceptT (T.pack . show) $ httpGetRemoteRepo' uOrigin + return (vcs, (raid, uClone, Just (Nothing, branch))) + ) + ) + pure + originTipOrBundle' + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (loomRecip, actorRecip) <- lift $ do + d <- getJust loomID + (d,) <$> getJust (loomActor d) + + -- Grab loom's repo from DB and verify that it consents to be served by + -- the loom, otherwise this loom doesn't accept tickets + let recipLoomRepoID = loomRepo loomRecip + unless (targetRepoID == recipLoomRepoID) $ + throwE "MR target repo isn't the one served by the Offer target loom" + targetRepo <- lift $ getJust targetRepoID + unless (repoLoom targetRepo == Just loomID) $ + throwE "Offer target loom doesn't have repo's consent to serve it" + + -- Verify VCS type match between patch bundle and target repo + let targetRepoVCS = repoVcs targetRepo + for_ (justThere originTipOrBundle) $ \ (Material typ diffs) -> do + unless (targetRepoVCS == 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 () + + -- If origin repo is local, find it in our DB. + -- + -- Verify the (local or remote) origin repo's VCS type matches the + -- target repo. + originOrBundle' <- + bitraverse + (bitraverse + (\ origin@(repoID, maybeBranch) -> do + repo <- getE repoID "MR origin local repo not found in DB" + unless (repoVcs repo == targetRepoVCS) $ + throwE "Local origin repo VCS differs from target repo VCS" + return origin + ) + (\ (vcs, origin) -> do + unless (vcs == targetRepoVCS) $ + throwE "Remote origin repo VCS differs from target repo VCS" + return origin + ) + ) + pure + originTipOrBundle'' + + -- Verify that branches are specified for Git and aren't specified for + -- Darcs + -- Also, produce a data structure separating by VCS rather than by + -- local/remote origin, which we'll need for generating patches + tipInfo <- case targetRepoVCS 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 + + -- Insert the Offer to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + for mractid $ \ offerDB -> do + + -- If a capability is provided, check it + for_ maybeCapability $ \ cap -> do + lcap <- + case cap of + Left c -> pure c + Right _ -> throwE "Capability is a remote URI, i.e. not authored by me" + verifyCapability' + lcap + authorIdMsig + (GrantResourceLoom loomID) + AP.RoleReport + + -- Prepare forwarding the Offer to my followers + let recipByID = grantResourceLocalActor $ GrantResourceLoom loomID + recipByHash <- hashLocalActor recipByID + let sieve = makeRecipientSet [] [localActorFollowers recipByHash] + + -- Insert the new ticket to our DB + acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now + offerDB' <- + bitraverse + (traverseOf _1 $ \case + LocalActorPerson personID -> pure personID + _ -> throwE "Local non-Person ticket authors not allowed" + ) + pure + offerDB + ticketID <- lift $ insertTask title desc source offerDB' acceptID + clothID <- lift $ insertMerge loomID ticketID maybeTargetBranch originOrBundle' + let maybePull = + let maybeTipInfo = + case tipInfo of + Left (b, mo) -> Left . (b,) <$> mo + Right mo -> Right <$> mo + hasBundle = isJust $ justThere originOrBundle' + in (clothID, targetRepoID, hasBundle,) <$> maybeTipInfo + + -- Prepare an Accept activity and insert to my outbox + accept@(actionAccept, _, _, _) <- lift $ prepareAccept clothID + let recipByKey = LocalActorLoom loomID + _luAccept <- lift $ updateOutboxItem' recipByKey acceptID actionAccept + + return (loomActor loomRecip, sieve, acceptID, accept, maybePull) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (loomActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), maybePull) -> do + traverse_ generatePatches maybePull + forwardActivity + authorIdMsig body (LocalActorLoom loomID) loomActorID sieve + lift $ sendActivity + (LocalActorLoom loomID) loomActorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + done "Opened a MR and forwarded the Offer" + + where + + insertTask title desc source offerDB 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 + } + case offerDB of + Left (personID, _, offerID) -> + insert_ TicketAuthorLocal + { ticketAuthorLocalTicket = tid + , ticketAuthorLocalAuthor = personID + , ticketAuthorLocalOpen = offerID + } + Right (author, _, offerID) -> + insert_ TicketAuthorRemote + { ticketAuthorRemoteTicket = tid + , ticketAuthorRemoteAuthor = remoteAuthorId author + , ticketAuthorRemoteOpen = offerID + } + return tid + + insertMerge + :: LoomId + -> TicketId + -> Maybe Text + -> These + (Either + (RepoId, Maybe Text) + (RemoteActorId, FedURI, Maybe (Maybe LocalURI, Text)) + ) + Material + -> ActDB TicketLoomId + insertMerge loomID ticketID maybeTargetBranch originOrBundle = do + clothID <- insert $ TicketLoom ticketID loomID maybeTargetBranch + 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 + return clothID + + prepareAccept clothID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + audSender <- makeAudSenderWithFollowers authorIdMsig + loomHash <- encodeKeyHashid loomID + clothHash <- encodeKeyHashid clothID + let audLoom = AudLocal [] [LocalStageLoomFollowers loomHash] + uOffer <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audSender, audLoom] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uOffer] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uOffer + , AP.acceptResult = + Just $ encodeRouteLocal $ ClothR loomHash clothHash + } + } + + return (action, recipientSet, remoteActors, fwdHosts) loomBehavior :: UTCTime -> LoomId -> VerseExt -> ActE (Text, Act (), Next) -loomBehavior now loomID (Left _verse@(Verse _authorIdMsig body)) = +loomBehavior now loomID (Left verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of + AP.OfferActivity offer -> loomOffer now loomID verse offer _ -> throwE "Unsupported activity type for Loom" loomBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Loom" diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index d51af5b..7963d6a 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -18,11 +18,10 @@ module Vervis.Federation.Ticket ( --personOfferTicketF - loomOfferTicketF --, repoAddBundleF - , loomApplyF + loomApplyF --, deckOfferDepF --, repoOfferDepF @@ -328,336 +327,6 @@ activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do remoteActivityID <- MaybeT $ getKeyBy $ UniqueRemoteActivity remoteObjectID MaybeT $ getBy $ UniqueInboxItemRemote inboxID remoteActivityID -loomOfferTicketF - :: UTCTime - -> KeyHashid Loom - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.Ticket URIMode - -> FedURI - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do - error "loomOfferTicketF disabled for refactoring" -{- - -- Check input - recipLoomID <- decodeKeyHashid404 recipLoomHash - (title, desc, source, originTipOrBundle, targetRepoID, maybeTargetBranch) <- do - let uAuthor@(ObjURI hAuthor _) = remoteAuthorURI author - WorkItemOffer {..} <- checkOfferTicket hAuthor ticket uTarget - unless (wioAuthor == Right (remoteAuthorURI author)) $ - throwE "Offering a Ticket attributed to someone else" - Merge maybeOriginTip maybeBundle targetTip <- case wioRest of - TAM_Task _ -> - throwE - "Offer target is some local deck, so I have no use for \ - \this Offer. Was I supposed to receive it?" - TAM_Merge loomID merge -> - if loomID == recipLoomID - then return merge - else throwE - "Offer target is some other local loom, so I have \ - \no use for this Offer. Was I supposed to receive \ - \it?" - TAM_Remote _ _ -> - throwE - "Offer target is some remote tracker, so I have no use \ - \for this Offer. Was I supposed to receive it?" - originTipOrBundle <- - fromMaybeE - (align maybeOriginTip 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 "MR target is a remote repo (this tracker serves only local repos)" - return (wioTitle, wioDesc, wioSource, originTipOrBundle, targetRepoID, maybeTargetBranch) - - -- Soon we're going to proceed asynchronously to be able to HTTP GET the - -- origin repo AP object, because: - -- - -- * No support for providing a signed repo object directly in the - -- Offer activity - -- * It may be nice to make sure a remote origin repo's VCS type - -- matches the target repo's VCS, even if patches are provided too - -- + However there's no support for caching VCS type when - -- remembering remote repo in our DB, so we'd have to check this - -- every time - -- * If origin is remote and no patches are provided, we'll need to - -- know the clone URL to generate the patches ourselves - -- + However the code here, for some simplicity, doesn't have a - -- way to skip that and do the whole handler synchronously in - -- case patches are provided or the origin is a local repo - -- + And no support for caching the clone URI in DB when - -- remembering the remote repo, so we'd need to do this every - -- time - -- - -- So first let's do some checks using the DB, on the loom, on the target - -- repo (which is always local), and on the origin repo if it's local - (recipLoomRepoID, Entity recipLoomActorID recipLoomActor, alreadyInInbox) <- lift $ runDB $ do - - -- Find recipient loom in DB, returning 404 if doesn't exist because - -- we're in the loom's inbox post handler - (recipLoomRepoID, recipLoomActor@(Entity _ actor)) <- do - loom <- get404 recipLoomID - let actorID = loomActor loom - (loomRepo loom,) . Entity actorID <$> getJust actorID - - -- Has the loom already received this activity to its inbox? If yes, we - -- won't process it again - alreadyInInbox <- do - let hOffer = objUriAuthority $ remoteAuthorURI author - activityAlreadyInInbox hOffer luOffer (actorInbox actor) - - return (recipLoomRepoID, recipLoomActor, alreadyInInbox) - - if alreadyInInbox - then return ("I already have this activity in my inbox, ignoring", Nothing) - else do - (targetRepoVCS, originOrBundle) <- runDBExcept $ do - - -- Grab loom's repo from DB and verify that it consents to be served by - -- the loom, otherwise this loom doesn't accept tickets - unless (targetRepoID == recipLoomRepoID) $ - throwE "MR target repo isn't the one served by the Offer target loom" - targetRepo <- lift $ getJust targetRepoID - unless (repoLoom targetRepo == Just recipLoomID) $ - throwE "Offer target loom doesn't have repo's consent to serve it" - - -- Verify VCS type match between patch bundle and target repo - for_ (justThere originTipOrBundle) $ \ (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 () - - -- If origin repo is local, find it in our DB and verify its VCS type - -- matches the target repo - originOrBundle <- flip (bifor originTipOrBundle) pure $ \ originTip -> do - let origin = - case originTip of - TipLocalRepo repoID -> Left (repoID, Nothing) - TipLocalBranch repoID branch -> Left (repoID, Just branch) - TipRemote uOrigin -> Right (uOrigin, Nothing) - TipRemoteBranch uRepo branch -> Right (uRepo, Just branch) - bitraverse_ - (\ (repoID, maybeBranch) -> do - repo <- getE repoID "MR origin local repo not found in DB" - unless (repoVcs repo == repoVcs targetRepo) $ - throwE "Local origin repo VCS differs from target repo VCS" - ) - pure - origin - return origin - - return (repoVcs targetRepo, originOrBundle) - - return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do - - -- If origin repo is remote, HTTP GET its AP representation and - -- remember it in our DB - originOrBundle' <- - bitraverse - (bitraverse - pure - (\ (uOrigin, maybeOriginBranch) -> do - (vcs, remoteOrigin) <- - case maybeOriginBranch of - Nothing -> do - (vcs, raid, uClone, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip uOrigin - return (vcs, (raid, uClone, first Just <$> mb)) - Just branch -> do - (vcs, raid, uClone) <- withExceptT (T.pack . show) $ httpGetRemoteRepo uOrigin - return (vcs, (raid, uClone, Just (Nothing, branch))) - unless (vcs == targetRepoVCS) $ - throwE "Remote origin repo VCS differs from target repo VCS" - return remoteOrigin - ) - ) - pure - originOrBundle - - -- Verify that branches are specified for Git and aren't specified for - -- Darcs - -- Also, produce a data structure separating by VCS rather than by - -- local/remote origin, which we'll need for generating patches - tipInfo <- case targetRepoVCS 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 - - maybeHttp <- runSiteDBExcept $ do - - -- Insert the Offer to loom's inbox - mractid <- lift $ insertToInbox now author body (actorInbox recipLoomActor) luOffer False - for mractid $ \ offerID -> do - - -- Forward the Offer activity to relevant local stages, and - -- schedule delivery for unavailable remote members of them - maybeHttpFwdOffer <- lift $ for mfwd $ \ (localRecips, sig) -> do - let sieve = - makeRecipientSet - [] - [LocalStageLoomFollowers recipLoomHash] - forwardActivityDB - (actbBL body) localRecips sig - recipLoomActorID (LocalActorLoom recipLoomHash) - sieve offerID - - -- Insert the new ticket to our DB - acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipLoomActor) now - ticketID <- lift $ insertTicket now title desc source offerID acceptID - clothID <- lift $ insertMerge recipLoomID ticketID maybeTargetBranch originOrBundle' - let maybePull = - let maybeTipInfo = - case tipInfo of - Left (b, mo) -> Left . (b,) <$> mo - Right mo -> Right <$> mo - hasBundle = isJust $ justThere originOrBundle' - in (clothID, targetRepoID, hasBundle,) <$> maybeTipInfo - - -- Prepare an Accept activity and insert to loom's outbox - (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - lift $ prepareAccept clothID - _luAccept <- lift $ updateOutboxItem (LocalActorLoom recipLoomID) acceptID actionAccept - - -- Deliver the Accept to local recipients, and schedule delivery - -- for unavailable remote recipients - deliverHttpAccept <- - deliverActivityDB - (LocalActorLoom recipLoomHash) recipLoomActorID - localRecipsAccept remoteRecipsAccept - fwdHostsAccept acceptID actionAccept - - -- Return instructions for HTTP inbox-forwarding of the Offer - -- activity, and for HTTP delivery of the Accept activity to - -- remote recipients, and for generating patches from - -- the origin repo - return - (maybeHttpFwdOffer, deliverHttpAccept, maybePull) - - -- Launch asynchronous HTTP forwarding of the Offer activity and HTTP - -- delivery of the Accept activity, and generate patches if we opened - -- a local MR that mentions just an origin - case maybeHttp of - Nothing -> - return - "When I started serving this activity, I didn't have it in my inbox, \ - \but now suddenly it seems I already do, so ignoring" - Just (maybeHttpFwdOffer, deliverHttpAccept, maybePull) -> do - forkWorker "loomOfferTicketF Accept HTTP delivery" deliverHttpAccept - traverse generatePatches maybePull - case maybeHttpFwdOffer of - Nothing -> return "Opened a merge request, no inbox-forwarding to do" - Just forwardHttpOffer -> do - forkWorker "loomOfferTicketF inbox-forwarding" forwardHttpOffer - return "Opened a merge request and ran inbox-forwarding of the Offer" - - 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_ TicketAuthorRemote - { ticketAuthorRemoteTicket = tid - , ticketAuthorRemoteAuthor = remoteAuthorId author - , ticketAuthorRemoteOpen = offerID - } - return tid - - insertMerge - :: LoomId - -> TicketId - -> Maybe Text - -> These - (Either - (RepoId, Maybe Text) - (RemoteActorId, FedURI, Maybe (Maybe LocalURI, Text)) - ) - Material - -> WorkerDB TicketLoomId - insertMerge loomID ticketID maybeTargetBranch originOrBundle = do - clothID <- insert $ TicketLoom ticketID loomID maybeTargetBranch - 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 - return clothID - - prepareAccept clothID = do - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - - clothHash <- encodeKeyHashid clothID - - ra <- getJust $ remoteAuthorId author - - let ObjURI hAuthor luAuthor = remoteAuthorURI author - - audSender = - AudRemote hAuthor - [luAuthor] - (maybeToList $ remoteActorFollowers ra) - audTracker = AudLocal [] [LocalStageLoomFollowers recipLoomHash] - - (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience [audSender, audTracker] - - recips = map encodeRouteHome audLocal ++ audRemote - action = AP.Action - { AP.actionCapability = Nothing - , AP.actionSummary = Nothing - , AP.actionAudience = AP.Audience recips [] [] [] [] [] - , AP.actionFulfills = [] - , AP.actionSpecific = AP.AcceptActivity AP.Accept - { AP.acceptObject = ObjURI hAuthor luOffer - , AP.acceptResult = - Just $ encodeRouteLocal $ - ClothR recipLoomHash clothHash - } - } - - return (action, recipientSet, remoteActors, fwdHosts) --} - repoOfferTicketF :: UTCTime -> KeyHashid Repo diff --git a/src/Vervis/Fetch.hs b/src/Vervis/Fetch.hs index fb673ff..b2b1e7f 100644 --- a/src/Vervis/Fetch.hs +++ b/src/Vervis/Fetch.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022 by fr33domlover . + - Written in 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -16,7 +16,9 @@ module Vervis.Fetch ( Result (..) , httpGetRemoteTip + , httpGetRemoteTip' , httpGetRemoteRepo + , httpGetRemoteRepo' ) where @@ -60,6 +62,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL +import Control.Concurrent.Actor import Database.Persist.JSON import Development.PatchMediaType import Network.FedURI @@ -81,6 +84,7 @@ import qualified Data.Text.UTF8.Local as TU import qualified Darcs.Local.Repository as D (createRepo) --import Vervis.Access +import Vervis.Actor import Vervis.ActivityPub import Vervis.Cloth import Vervis.Data.Actor @@ -116,6 +120,13 @@ fetchRepoE h lu = do ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$> fetchAPID' manager apRepoId h lu +fetchRepoE' :: Host -> LocalURI -> ExceptT Result Act (AP.Repo URIMode) +fetchRepoE' h lu = do + manager <- asksEnv envHttpManager + let apRepoId = AP.actorId . AP.actorLocal . AP.repoActor + ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$> + fetchAPID' manager apRepoId h lu + insertRemoteActor :: MonadIO m => Host @@ -167,6 +178,36 @@ httpGetRemoteTip (ObjURI host localURI) = do ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$> fetchTip manager h lu +httpGetRemoteTip' + :: FedURI + -> ExceptT Result Act + ( VersionControlSystem + , RemoteActorId + , FedURI + , Maybe (LocalURI, Text) + ) +httpGetRemoteTip' (ObjURI host localURI) = do + repoOrBranch <- fetchTipE host localURI + case repoOrBranch of + Left repo -> do + remoteActorID <- + lift $ withDB $ + insertRemoteActor host localURI $ AP.repoActor repo + let uClone = ObjURI host $ NE.head $ AP.repoClone repo + return (AP.repoVcs repo, remoteActorID, uClone, Nothing) + Right (AP.Branch name _ luRepo) -> do + repo <- fetchRepoE' host luRepo + remoteActorID <- + lift $ withDB $ + insertRemoteActor host luRepo $ AP.repoActor repo + let uClone = ObjURI host $ NE.head $ AP.repoClone repo + return (AP.repoVcs repo, remoteActorID, uClone, Just (localURI, name)) + where + fetchTipE h lu = do + manager <- asksEnv envHttpManager + ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$> + fetchTip manager h lu + httpGetRemoteRepo :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App) => FedURI @@ -178,3 +219,14 @@ httpGetRemoteRepo (ObjURI host localURI) = do insertRemoteActor host localURI $ AP.repoActor repo let uClone = ObjURI host $ NE.head $ AP.repoClone repo return (AP.repoVcs repo, remoteActorID, uClone) + +httpGetRemoteRepo' + :: FedURI + -> ExceptT Result Act (VersionControlSystem, RemoteActorId, FedURI) +httpGetRemoteRepo' (ObjURI host localURI) = do + repo <- fetchRepoE' host localURI + remoteActorID <- + lift $ withDB $ + insertRemoteActor host localURI $ AP.repoActor repo + let uClone = ObjURI host $ NE.head $ AP.repoClone repo + return (AP.repoVcs repo, remoteActorID, uClone) diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index eca71e0..d04aa25 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -222,7 +222,6 @@ postPersonOutboxR personHash = do -> t run f = f eperson actorDB maybeCap localRecips remoteRecips fwdHosts action case specific of - AP.AcceptActivity accept -> run acceptC accept AP.ApplyActivity apply -> run applyC apply AP.CreateActivity (AP.Create obj mtarget) -> case obj of @@ -246,7 +245,10 @@ postPersonOutboxR personHash = do AP.FollowActivity follow -> run followC follow AP.OfferActivity (AP.Offer obj target) -> case obj of - AP.OfferTicket ticket -> run offerTicketC ticket target + AP.OfferTicket _ -> + handleViaActor + (entityKey eperson) maybeCap localRecips remoteRecips + fwdHosts action {- OfferDep dep -> offerDepC eperson sharer summary audience dep target diff --git a/src/Vervis/Path.hs b/src/Vervis/Path.hs index b959919..58b0706 100644 --- a/src/Vervis/Path.hs +++ b/src/Vervis/Path.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019, 2022 by fr33domlover . + - Written in 2016, 2019, 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -17,6 +17,7 @@ module Vervis.Path ( askRepoRootDir , repoDir , askRepoDir + , askRepoDir' ) where @@ -26,9 +27,11 @@ import System.FilePath (()) import qualified Data.CaseInsensitive as CI (foldedCase) import qualified Data.Text as T (unpack) +import Control.Concurrent.Actor import Yesod.Hashids import Yesod.MonadSite +import Vervis.Actor import Vervis.Foundation import Vervis.Model import Vervis.Settings @@ -36,6 +39,9 @@ import Vervis.Settings askRepoRootDir :: (MonadSite m, SiteEnv m ~ App) => m FilePath askRepoRootDir = asksSite $ appRepoDir . appSettings +askRepoRootDir' :: Act FilePath +askRepoRootDir' = asksEnv $ appRepoDir . envSettings + repoDir :: FilePath -> KeyHashid Repo -> FilePath repoDir root repo = root (T.unpack $ keyHashidText repo) @@ -44,3 +50,8 @@ askRepoDir askRepoDir repo = do root <- askRepoRootDir return $ repoDir root repo + +askRepoDir' :: KeyHashid Repo -> Act FilePath +askRepoDir' repo = do + root <- askRepoRootDir' + return $ repoDir root repo diff --git a/src/Vervis/Web/Repo.hs b/src/Vervis/Web/Repo.hs index 6fa70e6..3518164 100644 --- a/src/Vervis/Web/Repo.hs +++ b/src/Vervis/Web/Repo.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2021, 2022 by fr33domlover . + - Written in 2019, 2020, 2021, 2022, 2023 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -45,11 +46,13 @@ import Yesod.Hashids import Yesod.MonadSite import qualified Web.ActivityPub as AP +import qualified Web.Actor.Persist as WAP import Data.Patch.Local hiding (Patch) import qualified Data.Patch.Local as P +import Vervis.Actor import Vervis.Darcs import Vervis.FedURI import Vervis.Foundation @@ -110,36 +113,35 @@ serveCommit repoHash ref patch parents = do Right $ encodeRouteHome $ PersonR $ hashPerson personID generatePatches - :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App) - => ( TicketLoomId + :: ( TicketLoomId , RepoId , Bool , Either (Text, (Either RepoId FedURI, Text)) (Either RepoId FedURI) ) - -> ExceptT Text m () + -> ActE () generatePatches (clothID, targetRepoID, hasBundle, tipInfo) = unless hasBundle $ do patches <- case tipInfo of Right _ -> error "Auto-pulling from Darcs remote origin not supported yet" Left (targetBranch, (originRepo, originBranch)) -> do targetPath <- do - repoHash <- encodeKeyHashid targetRepoID - repoDir <- askRepoDir repoHash + repoHash <- WAP.encodeKeyHashid targetRepoID + repoDir <- lift $ askRepoDir' repoHash liftIO $ makeAbsolute repoDir originURI <- case originRepo of Left repoID -> do - repoHash <- encodeKeyHashid repoID - repoDir <- askRepoDir repoHash + repoHash <- WAP.encodeKeyHashid repoID + repoDir <- lift $ askRepoDir' repoHash liftIO $ makeAbsolute repoDir Right uClone -> pure $ T.unpack $ renderObjURI uClone ExceptT $ liftIO $ runExceptT $ withSystemTempDirectory "vervis-generatePatches" $ generateGitPatches targetPath (T.unpack targetBranch) originURI (T.unpack originBranch) now <- liftIO getCurrentTime - lift $ runSiteDB $ do + lift $ withDB $ do bundleID <- insert $ Bundle clothID True insertMany_ $ NE.toList $ NE.map (Patch bundleID now PatchMediaTypeGit) $ NE.reverse patches