diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index eedcb26..f4bc1f9 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -62,7 +62,6 @@ import Network.HTTP.Client import System.Directory import System.Exit import System.FilePath -import System.IO.Temp import System.Process.Typed import Text.Blaze.Html.Renderer.Text import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) @@ -103,6 +102,7 @@ import Vervis.Data.Collab import Vervis.Data.Ticket import Vervis.Delivery import Vervis.FedURI +import Vervis.Fetch import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident @@ -118,6 +118,7 @@ import Vervis.Settings import Vervis.Query import Vervis.Ticket import Vervis.WorkItem +import Vervis.Web.Repo verifyResourceAddressed :: (MonadSite m, YesodHashids (SiteEnv m)) @@ -2242,13 +2243,6 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje ibiid <- insert $ InboxItem True now insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid -data Result - = ResultSomeException SomeException - | ResultIdMismatch - | ResultGetError APGetError - | ResultNotActor - deriving Show - inviteC :: Entity Person -> Actor @@ -2774,66 +2768,6 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t where - fetchRepoE h lu = do - manager <- asksSite getHttpManager - let apRepoId = AP.actorId . AP.actorLocal . AP.repoActor - ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$> - fetchAPID' manager apRepoId h lu - - insertRemoteActor h lu (AP.Actor local detail) = do - iid <- either entityKey id <$> insertBy' (Instance h) - roid <- either entityKey id <$> insertBy' (RemoteObject iid lu) - let ra = RemoteActor - { remoteActorIdent = roid - , remoteActorName = - AP.actorName detail <|> AP.actorUsername detail - , remoteActorInbox = AP.actorInbox local - , remoteActorFollowers = AP.actorFollowers local - , remoteActorErrorSince = Nothing - } - either entityKey id <$> insertBy' ra - - httpGetRemoteTip - :: FedURI - -> ExceptT Result Handler - ( VersionControlSystem - , RemoteActorId - , FedURI - , Maybe (LocalURI, Text) - ) - httpGetRemoteTip (ObjURI host localURI) = do - repoOrBranch <- fetchTipE host localURI - case repoOrBranch of - Left repo -> do - remoteActorID <- - lift $ runSiteDB $ - 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 $ runSiteDB $ - 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 <- asksSite getHttpManager - ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$> - fetchTip manager h lu - - httpGetRemoteRepo - :: FedURI - -> ExceptT Result Handler (VersionControlSystem, RemoteActorId, FedURI) - httpGetRemoteRepo (ObjURI host localURI) = do - repo <- fetchRepoE host localURI - remoteActorID <- - lift $ runSiteDB $ - insertRemoteActor host localURI $ AP.repoActor repo - let uClone = ObjURI host $ NE.head $ AP.repoClone repo - return (AP.repoVcs repo, remoteActorID, uClone) - insertOfferToOutbox senderHash blinded offerID = do encodeRouteLocal <- getEncodeRouteLocal hLocal <- asksSite siteInstanceHost @@ -2943,79 +2877,6 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc] return doc - runProcessE name spec = do - exitCode <- runProcess spec - case exitCode of - ExitFailure n -> - throwE $ - T.concat - [ "`", name, "` failed with exit code " - , T.pack (show n) - ] - ExitSuccess -> return () - - readProcessE name spec = do - (exitCode, out) <- readProcessStdout spec - case exitCode of - ExitFailure n -> - throwE $ - T.concat - [ "`", name, "` failed with exit code " - , T.pack (show n) - ] - ExitSuccess -> return $ TU.decodeStrict $ BL.toStrict out - - generateGitPatches :: FilePath -> String -> String -> String -> FilePath -> ExceptT Text IO (NonEmpty Text) - generateGitPatches targetRepoPath targetBranch originRepoURI originBranch tempDir = do - runProcessE "git clone" $ proc "git" ["clone", "--bare", "--verbose", "--origin", "target", "--single-branch", "--branch", targetBranch, "--", targetRepoPath, tempDir] - runProcessE "git remote add" $ proc "git" ["-C", tempDir, "remote", "--verbose", "add", "-t", originBranch, "real-origin", originRepoURI] - runProcessE "git fetch" $ proc "git" ["-C", tempDir, "fetch", "real-origin", originBranch] - runProcessE "git merge-base --is-ancestor" $ proc "git" ["-C", tempDir, "merge-base", "--is-ancestor", targetBranch, "real-origin/" ++ originBranch] - patchFileNames <- do - names <- T.lines <$> readProcessE "git format-patch" (proc "git" ["-C", tempDir, "format-patch", targetBranch ++ "..real-origin/" ++ originBranch]) - fromMaybeE (NE.nonEmpty names) "No new patches found in origin branch" - for patchFileNames $ \ name -> do - b <- lift $ B.readFile $ tempDir T.unpack name - case TE.decodeUtf8' b of - Left e -> throwE $ T.concat - [ "UTF-8 decoding error while reading Git patch file " - , name, ": " , T.pack $ displayException e - ] - Right t -> return t - - generatePatches - :: ( TicketLoomId - , RepoId - , Bool - , Either - (Text, (Either RepoId FedURI, Text)) - (Either RepoId FedURI) - ) - -> ExceptT Text Handler () - 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 - liftIO $ makeAbsolute repoDir - originURI <- - case originRepo of - Left repoID -> do - repoHash <- encodeKeyHashid repoID - repoDir <- 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 $ runDB $ do - bundleID <- insert $ Bundle clothID True - insertMany_ $ NE.toList $ NE.map (Patch bundleID now PatchMediaTypeGit) $ NE.reverse patches - {- verifyHosterRecip _ _ (Right _) = return () verifyHosterRecip localRecips name (Left wi) = diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index a6542fb..73be9f9 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -16,7 +16,7 @@ module Vervis.Federation.Ticket ( --personOfferTicketF deckOfferTicketF - --, repoOfferTicketF + , loomOfferTicketF --, repoAddBundleF @@ -40,6 +40,8 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Data.Aeson +import Data.Align +import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) @@ -50,6 +52,7 @@ import Data.List (nub, union) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Data.Text (Text) +import Data.These import Data.Time.Calendar import Data.Time.Clock import Data.Traversable @@ -94,9 +97,10 @@ import Vervis.Cloth import Vervis.Data.Ticket import Vervis.Darcs import Vervis.Delivery -import Vervis.FedURI import Vervis.Federation.Auth import Vervis.Federation.Util +import Vervis.FedURI +import Vervis.Fetch import Vervis.Foundation import Vervis.Git import Vervis.Model @@ -106,6 +110,7 @@ import Vervis.Path import Vervis.Query import Vervis.Recipient import Vervis.Ticket +import Vervis.Web.Repo import Vervis.WorkItem {- @@ -494,6 +499,365 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, recipientSet, remoteActors, fwdHosts) +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 + + -- 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 + maybeAlreadyInInbox <- runMaybeT $ do + instanceID <- MaybeT $ getKeyBy $ UniqueInstance $ objUriAuthority $ remoteAuthorURI author + remoteObjectID <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID luOffer + remoteActivityID <- MaybeT $ getKeyBy $ UniqueRemoteActivity remoteObjectID + MaybeT $ getBy $ UniqueInboxItemRemote (actorInbox actor) remoteActivityID + + return (recipLoomRepoID, recipLoomActor, isJust maybeAlreadyInInbox) + + 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 <- lift $ runSiteDB $ do + + -- Insert the Offer to loom's inbox + mractid <- 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 <- for mfwd $ \ (localRecips, sig) -> do + let sieve = + makeRecipientSet + [] + [LocalStageLoomFollowers recipLoomHash] + remoteRecips <- + insertRemoteActivityToLocalInboxes False offerID $ + localRecipSieve' sieve False False localRecips + remoteRecipsHttp <- + deliverRemoteDB_L + (actbBL body) offerID recipLoomID sig remoteRecips + return $ + deliverRemoteHTTP_L + now recipLoomHash (actbBL body) sig remoteRecipsHttp + + -- Insert the new ticket to our DB + acceptID <- insertEmptyOutboxItem (actorOutbox recipLoomActor) now + ticketID <- insertTicket now title desc source offerID acceptID + clothID <- 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 + (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + insertAcceptToOutbox clothID acceptID + + -- Deliver the Accept to local recipients, and schedule delivery + -- for unavailable remote recipients + knownRemoteRecipsAccept <- + deliverLocal' + False (LocalActorLoom recipLoomHash) recipLoomActorID + acceptID localRecipsAccept + remoteRecipsHttpAccept <- + deliverRemoteDB'' + fwdHostsAccept acceptID remoteRecipsAccept + knownRemoteRecipsAccept + + -- 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 + , deliverRemoteHttp' + fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept + , 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 + , ticketStatus = TSNew + , 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 + + insertAcceptToOutbox + :: TicketLoomId + -> OutboxItemId + -> WorkerDB + ( AP.Doc AP.Activity URIMode + , RecipientRoutes + , [(Host, NonEmpty LocalURI)] + , [Host] + ) + insertAcceptToOutbox clothID acceptID = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hLocal <- asksSite siteInstanceHost + + clothHash <- encodeKeyHashid clothID + acceptHash <- encodeKeyHashid acceptID + + 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 + doc = AP.Doc hLocal AP.Activity + { AP.activityId = + Just $ encodeRouteLocal $ + LoomOutboxItemR recipLoomHash acceptHash + , AP.activityActor = + encodeRouteLocal $ LoomR recipLoomHash + , AP.activityCapability = Nothing + , AP.activitySummary = Nothing + , AP.activityAudience = AP.Audience recips [] [] [] [] [] + , AP.activityFulfills = [] + , AP.activitySpecific = AP.AcceptActivity AP.Accept + { acceptObject = ObjURI hAuthor luOffer + , acceptResult = + Just $ encodeRouteLocal $ + ClothR recipLoomHash clothHash + } + } + + update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (doc, recipientSet, remoteActors, fwdHosts) + repoOfferTicketF :: UTCTime -> KeyHashid Repo diff --git a/src/Vervis/Fetch.hs b/src/Vervis/Fetch.hs new file mode 100644 index 0000000..1be62d6 --- /dev/null +++ b/src/Vervis/Fetch.hs @@ -0,0 +1,181 @@ +{- This file is part of Vervis. + - + - Written in 2022 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Fetch + ( Result (..) + , httpGetRemoteTip + , httpGetRemoteRepo + ) +where + +import Control.Applicative +import Control.Exception.Base +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Data.Align +import Data.Barbie +import Data.Bifunctor +import Data.Bifoldable +import Data.Bitraversable +import Data.Foldable +import Data.Functor +import Data.Functor.Identity +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 hiding (deleteBy) +import Database.Persist.Sql hiding (deleteBy) +import Network.HTTP.Client +import System.Directory +import System.Exit +import System.FilePath +import System.IO.Temp +import System.Process.Typed +import Text.Blaze.Html.Renderer.Text +import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) +import Yesod.Persist.Core + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL + +import Database.Persist.JSON +import Development.PatchMediaType +import Network.FedURI +import Web.ActivityPub hiding (Patch, Ticket, Follow, Repo (..), ActorLocal (..), ActorDetail (..), Actor (..)) +import Web.Text +import Yesod.ActivityPub +import Yesod.FedURI +import Yesod.Hashids +import Yesod.MonadSite + +import qualified Web.ActivityPub as AP + +import Control.Monad.Trans.Except.Local +import Data.Either.Local +import Database.Persist.Local + +import qualified Data.Git.Local as G (createRepo) +import qualified Data.Text.UTF8.Local as TU +import qualified Darcs.Local.Repository as D (createRepo) + +import Vervis.Access +import Vervis.ActivityPub +import Vervis.Cloth +import Vervis.Data.Actor +import Vervis.Data.Collab +import Vervis.Data.Ticket +import Vervis.Delivery +import Vervis.FedURI +import Vervis.Foundation +import Vervis.Model +import Vervis.Model.Ident +import Vervis.Model.Role +import Vervis.Model.Workflow +import Vervis.Model.Ticket +import Vervis.Path +import Vervis.Persist.Actor +import Vervis.Persist.Collab +import Vervis.Recipient +import Vervis.RemoteActorStore +import Vervis.Settings +import Vervis.Query +import Vervis.Ticket +import Vervis.WorkItem + +data Result + = ResultSomeException SomeException + | ResultIdMismatch + | ResultGetError APGetError + | ResultNotActor + deriving Show + +fetchRepoE :: (MonadSite m, SiteEnv m ~ App) => Host -> LocalURI -> ExceptT Result m (AP.Repo URIMode) +fetchRepoE h lu = do + manager <- asksSite getHttpManager + let apRepoId = AP.actorId . AP.actorLocal . AP.repoActor + ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$> + fetchAPID' manager apRepoId h lu + +insertRemoteActor + :: MonadIO m + => Host + -> LocalURI + -> AP.Actor URIMode + -> ReaderT SqlBackend m RemoteActorId +insertRemoteActor h lu (AP.Actor local detail) = do + iid <- either entityKey id <$> insertBy' (Instance h) + roid <- either entityKey id <$> insertBy' (RemoteObject iid lu) + let ra = RemoteActor + { remoteActorIdent = roid + , remoteActorName = + AP.actorName detail <|> AP.actorUsername detail + , remoteActorInbox = AP.actorInbox local + , remoteActorFollowers = AP.actorFollowers local + , remoteActorErrorSince = Nothing + } + either entityKey id <$> insertBy' ra + +httpGetRemoteTip + :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App) + => FedURI + -> ExceptT Result m + ( VersionControlSystem + , RemoteActorId + , FedURI + , Maybe (LocalURI, Text) + ) +httpGetRemoteTip (ObjURI host localURI) = do + repoOrBranch <- fetchTipE host localURI + case repoOrBranch of + Left repo -> do + remoteActorID <- + lift $ runSiteDB $ + 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 $ runSiteDB $ + 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 <- asksSite getHttpManager + ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$> + fetchTip manager h lu + +httpGetRemoteRepo + :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App) + => FedURI + -> ExceptT Result m (VersionControlSystem, RemoteActorId, FedURI) +httpGetRemoteRepo (ObjURI host localURI) = do + repo <- fetchRepoE host localURI + remoteActorID <- + lift $ runSiteDB $ + 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/Git.hs b/src/Vervis/Git.hs index 7adec50..9951e36 100644 --- a/src/Vervis/Git.hs +++ b/src/Vervis/Git.hs @@ -21,11 +21,13 @@ module Vervis.Git , readPatch --, lastCommitTime , writePostReceiveHooks + , generateGitPatches --, applyGitPatches ) where import Control.Arrow ((***)) +import Control.Exception.Base import Control.Monad (join) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) @@ -55,12 +57,13 @@ import Data.Traversable (for) import Data.Word (Word32) import Database.Persist import System.Exit +import System.FilePath import System.Hourglass (timeCurrent) import System.Process.Typed import Text.Email.Validate (emailAddress) import Time.Types (Elapsed (..), Seconds (..)) -import qualified Data.ByteString as B (intercalate) +import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.DList as D (DList, empty, snoc, toList) import qualified Data.Git as G @@ -77,6 +80,7 @@ import Yesod.ActivityPub import Yesod.Hashids import Yesod.MonadSite +import Control.Monad.Trans.Except.Local import Data.ByteString.Char8.Local (takeLine) import Data.DList.Local import Data.EventTime.Local @@ -355,6 +359,59 @@ writePostReceiveHooks = do path <- askRepoDir repoHash liftIO $ writeHookFile path hook authority (keyHashidText repoHash) +-- | Given a temporary directory to use freely for this operation, generate +-- patches from the difference between the origin branch and the target branch +-- (origin branch must be an ancestor of target branch) +-- +-- Target repo must be local, origin repo may be remote on the network +generateGitPatches + :: FilePath -- ^ Absolute path to target repo + -> String -- ^ Target branch + -> String -- ^ Absolute path or HTTP URI of origin repo + -> String -- ^ Origin branch + -> FilePath -- ^ Temporary directory to use for the operation + -> ExceptT Text IO (NonEmpty Text) +generateGitPatches targetRepoPath targetBranch originRepoURI originBranch tempDir = do + runProcessE "git clone" $ proc "git" ["clone", "--bare", "--verbose", "--origin", "target", "--single-branch", "--branch", targetBranch, "--", targetRepoPath, tempDir] + runProcessE "git remote add" $ proc "git" ["-C", tempDir, "remote", "--verbose", "add", "-t", originBranch, "real-origin", originRepoURI] + runProcessE "git fetch" $ proc "git" ["-C", tempDir, "fetch", "real-origin", originBranch] + runProcessE "git merge-base --is-ancestor" $ proc "git" ["-C", tempDir, "merge-base", "--is-ancestor", targetBranch, "real-origin/" ++ originBranch] + patchFileNames <- do + names <- T.lines <$> readProcessE "git format-patch" (proc "git" ["-C", tempDir, "format-patch", targetBranch ++ "..real-origin/" ++ originBranch]) + fromMaybeE (NE.nonEmpty names) "No new patches found in origin branch" + for patchFileNames $ \ name -> do + b <- lift $ B.readFile $ tempDir T.unpack name + case TE.decodeUtf8' b of + Left e -> throwE $ T.concat + [ "UTF-8 decoding error while reading Git patch file " + , name, ": " , T.pack $ displayException e + ] + Right t -> return t + + where + + runProcessE name spec = do + exitCode <- runProcess spec + case exitCode of + ExitFailure n -> + throwE $ + T.concat + [ "`", name, "` failed with exit code " + , T.pack (show n) + ] + ExitSuccess -> return () + + readProcessE name spec = do + (exitCode, out) <- readProcessStdout spec + case exitCode of + ExitFailure n -> + throwE $ + T.concat + [ "`", name, "` failed with exit code " + , T.pack (show n) + ] + ExitSuccess -> return $ TU.decodeStrict $ BL.toStrict out + {- applyGitPatches shr rp branch patches = do path <- askRepoDir shr rp diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index 9fa3618..f9fa200 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -73,6 +73,7 @@ import Vervis.Access import Vervis.API import Vervis.Federation.Auth import Vervis.Federation.Collab +import Vervis.Federation.Ticket import Vervis.FedURI import Vervis.Form.Project import Vervis.Form.Ticket @@ -143,6 +144,11 @@ postLoomInboxR recipLoomHash = loomAcceptF now recipLoomHash author body mfwd luActivity accept AP.InviteActivity invite -> topicInviteF now (GrantResourceLoom recipLoomHash) author body mfwd luActivity invite + AP.OfferActivity (AP.Offer obj target) -> + case obj of + AP.OfferTicket ticket -> + loomOfferTicketF now recipLoomHash author body mfwd luActivity ticket target + _ -> return ("Unsupported offer object type for looms", Nothing) _ -> return ("Unsupported activity type for looms", Nothing) getLoomOutboxR :: KeyHashid Loom -> Handler TypedContent diff --git a/src/Vervis/Web/Repo.hs b/src/Vervis/Web/Repo.hs index 0460128..d67fdfd 100644 --- a/src/Vervis/Web/Repo.hs +++ b/src/Vervis/Web/Repo.hs @@ -15,22 +15,31 @@ module Vervis.Web.Repo ( serveCommit + , generatePatches ) where +import Control.Monad +import Control.Monad.Trans.Except import Data.Text (Text) import Data.Text.Encoding +import Data.Time.Clock import Data.Traversable import Database.Persist +import System.Directory +import System.IO.Temp import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) import Yesod.Persist.Core +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T -import Web.ActivityPub hiding (Author (..), Ticket, Repo, ActorLocal (..)) +import Development.PatchMediaType +import Network.FedURI import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids +import Yesod.MonadSite import qualified Web.ActivityPub as AP @@ -38,8 +47,11 @@ import Data.Patch.Local hiding (Patch) import qualified Data.Patch.Local as P +import Vervis.FedURI import Vervis.Foundation +import Vervis.Git import Vervis.Model +import Vervis.Path import Vervis.Settings import Vervis.Time import Vervis.Widget.Person @@ -62,20 +74,20 @@ serveCommit repoHash ref patch parents = do mcommitter = patchCommitted patch makeAuthor' = makeAuthor hashPerson encodeRouteHome patchAP = AP.Commit - { commitId = encodeRouteLocal $ RepoCommitR repoHash ref - , commitRepository = encodeRouteLocal $ RepoR repoHash - , commitAuthor = makeAuthor' mpersonWritten author - , commitCommitter = + { AP.commitId = encodeRouteLocal $ RepoCommitR repoHash ref + , AP.commitRepository = encodeRouteLocal $ RepoR repoHash + , AP.commitAuthor = makeAuthor' mpersonWritten author + , AP.commitCommitter = makeAuthor' mpersonCommitted . fst <$> mcommitter - , commitTitle = patchTitle patch - , commitHash = Hash $ encodeUtf8 ref - , commitDescription = + , AP.commitTitle = patchTitle patch + , AP.commitHash = AP.Hash $ encodeUtf8 ref + , AP.commitDescription = let desc = patchDescription patch in if T.null desc then Nothing else Just desc - , commitWritten = written - , commitCommitted = snd <$> patchCommitted patch + , AP.commitWritten = written + , AP.commitCommitted = snd <$> patchCommitted patch } provideHtmlAndAP patchAP $ let number = zip ([1..] :: [Int]) @@ -92,3 +104,37 @@ serveCommit repoHash ref patch parents = do } makeAuthor hashPerson encodeRouteHome (Just (Entity personID _, _)) _ = Right $ encodeRouteHome $ PersonR $ hashPerson personID + +generatePatches + :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App) + => ( TicketLoomId + , RepoId + , Bool + , Either + (Text, (Either RepoId FedURI, Text)) + (Either RepoId FedURI) + ) + -> ExceptT Text m () +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 + liftIO $ makeAbsolute repoDir + originURI <- + case originRepo of + Left repoID -> do + repoHash <- encodeKeyHashid repoID + repoDir <- 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 + bundleID <- insert $ Bundle clothID True + insertMany_ $ NE.toList $ NE.map (Patch bundleID now PatchMediaTypeGit) $ NE.reverse patches diff --git a/vervis.cabal b/vervis.cabal index 4e8b4ef..69c354d 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -154,6 +154,7 @@ library Vervis.Federation.Ticket Vervis.Federation.Util Vervis.FedURI + Vervis.Fetch -- Vervis.Field.Key Vervis.Field.Person --Vervis.Field.Project