From 4883fe5863770834627382e004abbc7cba7fc815 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 31 Jul 2024 09:52:50 -0700 Subject: [PATCH 1/2] Fix caching for project and contribution diffs --- src/Share/Utils/Caching.hs | 14 ++++-- src/Share/Web/Authorization.hs | 15 ++++++- src/Share/Web/Share/Contributions/Impl.hs | 6 +-- src/Share/Web/Share/Projects/API.hs | 4 +- src/Share/Web/Share/Projects/Impl.hs | 55 +++++++++++++---------- 5 files changed, 60 insertions(+), 34 deletions(-) diff --git a/src/Share/Utils/Caching.hs b/src/Share/Utils/Caching.hs index 0c970a8..0c47891 100644 --- a/src/Share/Utils/Caching.hs +++ b/src/Share/Utils/Caching.hs @@ -7,6 +7,7 @@ module Share.Utils.Caching ( cachedResponse, causalIdCacheKey, + branchIdCacheKey, Cached, ) where @@ -15,13 +16,13 @@ import Data.ByteString qualified as BS import Data.ByteString.Lazy.Char8 qualified as BL import Data.Text.Encoding qualified as Text import Database.Redis qualified as R -import Share.Postgres.IDs (CausalId (..)) -import Share.Prelude -import Share.Web.App -import Share.Web.Authorization qualified as AuthZ import Network.HTTP.Media import Network.HTTP.Types qualified as HTTP import Servant +import Share.Postgres.IDs (BranchHashId (..), CausalId (..)) +import Share.Prelude +import Share.Web.App +import Share.Web.Authorization qualified as AuthZ data Cached ct a = Cached BS.ByteString @@ -128,3 +129,8 @@ causalIdCacheKey :: CausalId -> Text causalIdCacheKey (CausalId causalIdInt) = -- Causal Ids are globally unique and never re-used. "causal-id:" <> tShow @Int32 causalIdInt + +branchIdCacheKey :: BranchHashId -> Text +branchIdCacheKey (BranchHashId branchIdInt) = + -- Branch Ids are globally unique and never re-used. + "branch-id:" <> tShow @Int32 branchIdInt diff --git a/src/Share/Web/Authorization.hs b/src/Share/Web/Authorization.hs index 4fce8ba..6923bf8 100644 --- a/src/Share/Web/Authorization.hs +++ b/src/Share/Web/Authorization.hs @@ -27,6 +27,7 @@ module Share.Web.Authorization checkContributionCreate, checkContributionUpdate, checkContributionMerge, + checkContributionDiffRead, checkContributionRead, checkContributionTimelineRead, checkCommentCreate, @@ -465,7 +466,7 @@ checkProjectBranchRead reqUserId project@Project {projectId} = checkProjectBranchDiff :: Maybe UserId -> Project -> WebApp (Either AuthZFailure AuthZReceipt) checkProjectBranchDiff reqUserId project@Project {projectId} = - mapLeft (const authzError) <$> do + bimap (const authzError) makeCacheable <$> do checkProjectGet reqUserId project where authzError = AuthZFailure $ (ProjectPermission (ProjectBranchDiff projectId)) @@ -541,6 +542,12 @@ checkContributionRead mayReqUserId project@(Project {projectId}) = where authzError = AuthZFailure $ ProjectPermission (ContributionRead projectId) +checkContributionDiffRead :: Maybe UserId -> Project -> WebApp (Either AuthZFailure AuthZReceipt) +checkContributionDiffRead mayReqUserId project@(Project {projectId}) = + bimap (const authzError) makeCacheable <$> checkProjectGet mayReqUserId project + where + authzError = AuthZFailure $ ProjectPermission (ContributionRead projectId) + checkContributionTimelineRead :: Maybe UserId -> Project -> WebApp (Either AuthZFailure AuthZReceipt) checkContributionTimelineRead mayReqUserId project@(Project {projectId}) = mapLeft (const authzError) <$> do @@ -671,3 +678,9 @@ permissionGuard m = m >>= \case Right a -> pure a Left err -> Errors.respondError err + +-- | Make an auth receipt cacheable. +-- useful when we're re-using an existing auth receipt, but know that the current endpoint is +-- cacheable for authed users even if the original isn't. +makeCacheable :: AuthZReceipt -> AuthZReceipt +makeCacheable (AuthZReceipt _) = AuthZReceipt (Just CachingToken) diff --git a/src/Share/Web/Share/Contributions/Impl.hs b/src/Share/Web/Share/Contributions/Impl.hs index 1e21779..3032657 100644 --- a/src/Share/Web/Share/Contributions/Impl.hs +++ b/src/Share/Web/Share/Contributions/Impl.hs @@ -232,7 +232,7 @@ contributionDiffEndpoint (AuthN.MaybeAuthedUserID mayCallerUserId) userHandle pr newBranch <- Q.branchById newBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Source branch not found") oldBranch <- Q.branchById oldBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Target branch not found") pure (project, contribution, oldBranch, newBranch) - authZReceipt <- AuthZ.permissionGuard $ AuthZ.checkContributionRead mayCallerUserId project + authZReceipt <- AuthZ.permissionGuard $ AuthZ.checkContributionDiffRead mayCallerUserId project let oldCodebase = Codebase.codebaseForProjectBranch authZReceipt project oldBranch let newCodebase = Codebase.codebaseForProjectBranch authZReceipt project newBranch oldPBSH <- Codebase.runCodebaseTransactionOrRespondError oldCodebase $ do @@ -280,7 +280,7 @@ contributionDiffTermsEndpoint (AuthN.MaybeAuthedUserID mayCallerUserId) userHand newBranch <- Q.branchById newBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Source branch not found") oldBranch <- Q.branchById oldBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Target branch not found") pure (project, contribution, oldBranch, newBranch) - authZReceipt <- AuthZ.permissionGuard $ AuthZ.checkContributionRead mayCallerUserId project + authZReceipt <- AuthZ.permissionGuard $ AuthZ.checkContributionDiffRead mayCallerUserId project let oldCodebase = Codebase.codebaseForProjectBranch authZReceipt project oldBranch let newCodebase = Codebase.codebaseForProjectBranch authZReceipt project newBranch oldPBSH <- Codebase.runCodebaseTransactionOrRespondError oldCodebase $ do @@ -325,7 +325,7 @@ contributionDiffTypesEndpoint (AuthN.MaybeAuthedUserID mayCallerUserId) userHand newBranch <- Q.branchById newBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Source branch not found") oldBranch <- Q.branchById oldBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Target branch not found") pure (project, contribution, oldBranch, newBranch) - authZReceipt <- AuthZ.permissionGuard $ AuthZ.checkContributionRead mayCallerUserId project + authZReceipt <- AuthZ.permissionGuard $ AuthZ.checkContributionDiffRead mayCallerUserId project let oldCodebase = Codebase.codebaseForProjectBranch authZReceipt project oldBranch let newCodebase = Codebase.codebaseForProjectBranch authZReceipt project newBranch oldPBSH <- Codebase.runCodebaseTransactionOrRespondError oldCodebase $ do diff --git a/src/Share/Web/Share/Projects/API.hs b/src/Share/Web/Share/Projects/API.hs index 527bf57..f58cae7 100644 --- a/src/Share/Web/Share/Projects/API.hs +++ b/src/Share/Web/Share/Projects/API.hs @@ -53,14 +53,14 @@ type ProjectDiffTermsEndpoint = :> RequiredQueryParam "newBranchRef" BranchOrReleaseShortHand :> RequiredQueryParam "oldTerm" Name :> RequiredQueryParam "newTerm" Name - :> Get '[JSON] ShareTermDiffResponse + :> Get '[JSON] (Cached JSON ShareTermDiffResponse) type ProjectDiffTypesEndpoint = RequiredQueryParam "oldBranchRef" BranchOrReleaseShortHand :> RequiredQueryParam "newBranchRef" BranchOrReleaseShortHand :> RequiredQueryParam "oldType" Name :> RequiredQueryParam "newType" Name - :> Get '[JSON] ShareTypeDiffResponse + :> Get '[JSON] (Cached JSON ShareTypeDiffResponse) type CreateProjectEndpoint = ReqBody '[JSON] CreateProjectRequest diff --git a/src/Share/Web/Share/Projects/Impl.hs b/src/Share/Web/Share/Projects/Impl.hs index fa3b249..f40ac64 100644 --- a/src/Share/Web/Share/Projects/Impl.hs +++ b/src/Share/Web/Share/Projects/Impl.hs @@ -49,6 +49,7 @@ import Share.Web.Share.Tickets.Impl (ticketsByProjectServer) import Share.Web.Share.Types import Unison.Name (Name) import Unison.Server.Orphans () +import Unison.Syntax.Name qualified as Name data ProjectErrors = MaintainersAlreadyExist [UserId] @@ -180,25 +181,28 @@ projectDiffTermsEndpoint :: IDs.BranchOrReleaseShortHand -> Name -> Name -> - WebApp ShareTermDiffResponse + WebApp (Cached JSON ShareTermDiffResponse) projectDiffTermsEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHandle projectSlug oldShortHand newShortHand oldTermName newTermName = do - project <- PG.runTransactionOrRespondError do + project@Project {projectId} <- PG.runTransactionOrRespondError do Q.projectByShortHand projectShortHand `whenNothingM` throwError (EntityMissing (ErrorID "project-not-found") ("Project not found: " <> IDs.toText @IDs.ProjectShortHand projectShortHand)) authZReceipt <- AuthZ.permissionGuard $ AuthZ.checkProjectBranchDiff callerUserId project (oldCodebase, _causalId, oldBhId) <- namespaceHashForBranchOrRelease authZReceipt project oldShortHand (newCodebase, _newCausalId, newBhId) <- namespaceHashForBranchOrRelease authZReceipt project newShortHand - (oldTerm, newTerm, displayObjectDiff) <- Diffs.diffTerms authZReceipt (oldCodebase, oldBhId, oldTermName) (newCodebase, newBhId, newTermName) - pure $ - ShareTermDiffResponse - { project = projectShortHand, - oldBranch = oldShortHand, - newBranch = newShortHand, - oldTerm = oldTerm, - newTerm = newTerm, - diff = displayObjectDiff - } + + let cacheKeys = [IDs.toText projectId, IDs.toText oldShortHand, IDs.toText newShortHand, Caching.branchIdCacheKey oldBhId, Caching.branchIdCacheKey newBhId, Name.toText oldTermName, Name.toText newTermName] + Caching.cachedResponse authZReceipt "project-diff-terms" cacheKeys do + (oldTerm, newTerm, displayObjectDiff) <- Diffs.diffTerms authZReceipt (oldCodebase, oldBhId, oldTermName) (newCodebase, newBhId, newTermName) + pure $ + ShareTermDiffResponse + { project = projectShortHand, + oldBranch = oldShortHand, + newBranch = newShortHand, + oldTerm = oldTerm, + newTerm = newTerm, + diff = displayObjectDiff + } where projectShortHand :: IDs.ProjectShortHand projectShortHand = IDs.ProjectShortHand {userHandle, projectSlug} @@ -211,25 +215,28 @@ projectDiffTypesEndpoint :: IDs.BranchOrReleaseShortHand -> Name -> Name -> - WebApp ShareTypeDiffResponse + WebApp (Cached JSON ShareTypeDiffResponse) projectDiffTypesEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHandle projectSlug oldShortHand newShortHand oldTypeName newTypeName = do - project <- PG.runTransactionOrRespondError do + project@Project {projectId} <- PG.runTransactionOrRespondError do Q.projectByShortHand projectShortHand `whenNothingM` throwError (EntityMissing (ErrorID "project-not-found") ("Project not found: " <> IDs.toText @IDs.ProjectShortHand projectShortHand)) authZReceipt <- AuthZ.permissionGuard $ AuthZ.checkProjectBranchDiff callerUserId project (oldCodebase, _causalId, oldBhId) <- namespaceHashForBranchOrRelease authZReceipt project oldShortHand (newCodebase, _newCausalId, newBhId) <- namespaceHashForBranchOrRelease authZReceipt project newShortHand - (oldType, newType, typeDiffDisplayObject) <- Diffs.diffTypes authZReceipt (oldCodebase, oldBhId, oldTypeName) (newCodebase, newBhId, newTypeName) - pure $ - ShareTypeDiffResponse - { project = projectShortHand, - oldBranch = oldShortHand, - newBranch = newShortHand, - oldType = oldType, - newType = newType, - diff = typeDiffDisplayObject - } + + let cacheKeys = [IDs.toText projectId, IDs.toText oldShortHand, IDs.toText newShortHand, Caching.branchIdCacheKey oldBhId, Caching.branchIdCacheKey newBhId, Name.toText oldTypeName, Name.toText newTypeName] + Caching.cachedResponse authZReceipt "project-diff-types" cacheKeys do + (oldType, newType, typeDiffDisplayObject) <- Diffs.diffTypes authZReceipt (oldCodebase, oldBhId, oldTypeName) (newCodebase, newBhId, newTypeName) + pure $ + ShareTypeDiffResponse + { project = projectShortHand, + oldBranch = oldShortHand, + newBranch = newShortHand, + oldType = oldType, + newType = newType, + diff = typeDiffDisplayObject + } where projectShortHand :: IDs.ProjectShortHand projectShortHand = IDs.ProjectShortHand {userHandle, projectSlug} From 0e8ac4be8f7f9e01145e4983d48c729a4eb01362 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 31 Jul 2024 10:13:39 -0700 Subject: [PATCH 2/2] Parallelize a bunch of diff operations --- src/Share/NamespaceDiffs.hs | 26 ++++++++------- src/Share/Postgres.hs | 2 +- src/Share/Postgres/NamespaceDiffs.hs | 47 +++++++++++++++------------- src/Share/Web/Share/Diffs/Impl.hs | 47 +++++++++++++++------------- 4 files changed, 67 insertions(+), 55 deletions(-) diff --git a/src/Share/NamespaceDiffs.hs b/src/Share/NamespaceDiffs.hs index 1796a79..3f3e29d 100644 --- a/src/Share/NamespaceDiffs.hs +++ b/src/Share/NamespaceDiffs.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ApplicativeDo #-} + -- | Logic for computing the differerences between two namespaces, -- typically used when showing the differences caused by a contribution. module Share.NamespaceDiffs @@ -23,6 +25,7 @@ import Data.Map qualified as Map import Data.Set qualified as Set import Data.Set.NonEmpty (NESet) import Data.Set.NonEmpty qualified as NESet +import Servant (err500) import Share.Postgres qualified as PG import Share.Postgres.IDs (BranchHashId) import Share.Postgres.NameLookups.Conversions qualified as Cv @@ -31,7 +34,6 @@ import Share.Postgres.NamespaceDiffs qualified as ND import Share.Prelude import Share.Utils.Logging qualified as Logging import Share.Web.Errors -import Servant (err500) import U.Codebase.Reference qualified as V2 import U.Codebase.Referent qualified as V2 import Unison.Codebase.Path (Path) @@ -82,7 +84,7 @@ data DefinitionDiffKind r RenamedFrom r (NESet Name) deriving stock (Eq, Show, Ord, Functor, Foldable, Traversable) -instance Ord r => Semigroup (DefinitionDiffs Name r) where +instance (Ord r) => Semigroup (DefinitionDiffs Name r) where d1 <> d2 = DefinitionDiffs { added = added d1 <> added d2, @@ -92,7 +94,7 @@ instance Ord r => Semigroup (DefinitionDiffs Name r) where newAliases = Map.unionWith (\(a1, b1) (a2, b2) -> (a1 <> a2, b1 <> b2)) (newAliases d1) (newAliases d2) } -instance Ord r => Monoid (DefinitionDiffs Name r) where +instance (Ord r) => Monoid (DefinitionDiffs Name r) where mempty = DefinitionDiffs { added = mempty, @@ -133,26 +135,26 @@ data DiffAtPath referent reference = DiffAtPath deriving stock (Eq, Show) -- | A traversal over all the referents in a `DiffAtPath`. -diffAtPathReferents_ :: Ord referent' => Traversal (DiffAtPath referent reference) (DiffAtPath referent' reference) referent referent' +diffAtPathReferents_ :: (Ord referent') => Traversal (DiffAtPath referent reference) (DiffAtPath referent' reference) referent referent' diffAtPathReferents_ f (DiffAtPath {termDiffsAtPath, typeDiffsAtPath}) = termDiffsAtPath & (Set.traverse . traverse) %%~ f & fmap \termDiffsAtPath -> DiffAtPath {typeDiffsAtPath, termDiffsAtPath} -- | A traversal over all the references in a `DiffAtPath`. -diffAtPathReferences_ :: Ord reference' => Traversal (DiffAtPath referent reference) (DiffAtPath referent reference') reference reference' +diffAtPathReferences_ :: (Ord reference') => Traversal (DiffAtPath referent reference) (DiffAtPath referent reference') reference reference' diffAtPathReferences_ f (DiffAtPath {termDiffsAtPath, typeDiffsAtPath}) = typeDiffsAtPath & (Set.traverse . traverse) %%~ f & fmap \typeDiffsAtPath -> DiffAtPath {typeDiffsAtPath, termDiffsAtPath} -- | Traversal over all the referents in a `NamespaceTreeDiff`. -namespaceTreeDiffReferents_ :: Ord referent' => Traversal (NamespaceTreeDiff referent reference) (NamespaceTreeDiff referent' reference) referent referent' +namespaceTreeDiffReferents_ :: (Ord referent') => Traversal (NamespaceTreeDiff referent reference) (NamespaceTreeDiff referent' reference) referent referent' namespaceTreeDiffReferents_ = traversed . traversed . diffAtPathReferents_ -- | Traversal over all the references in a `NamespaceTreeDiff`. -namespaceTreeDiffReferences_ :: Ord reference' => Traversal (NamespaceTreeDiff referent reference) (NamespaceTreeDiff referent reference') reference reference' +namespaceTreeDiffReferences_ :: (Ord reference') => Traversal (NamespaceTreeDiff referent reference) (NamespaceTreeDiff referent reference') reference reference' namespaceTreeDiffReferences_ = traversed . traversed . diffAtPathReferences_ data NamespaceDiffError = ImpossibleError Text @@ -170,8 +172,10 @@ instance Logging.Loggable NamespaceDiffError where -- Note: This ignores all dependencies in the lib namespace. diffTreeNamespaces :: (BranchHashId, NameLookupReceipt) -> (BranchHashId, NameLookupReceipt) -> (PG.Transaction e (Either NamespaceDiffError (NamespaceTreeDiff V2.Referent V2.Reference))) diffTreeNamespaces (oldBHId, oldNLReceipt) (newBHId, newNLReceipt) = do - (oldTerms, newTerms) <- ND.getRelevantTermsForDiff oldNLReceipt oldBHId newBHId - (oldTypes, newTypes) <- ND.getRelevantTypesForDiff newNLReceipt oldBHId newBHId + ((oldTerms, newTerms), (oldTypes, newTypes)) <- PG.pipelined do + terms <- ND.getRelevantTermsForDiff oldNLReceipt oldBHId newBHId + types <- ND.getRelevantTypesForDiff newNLReceipt oldBHId newBHId + pure (terms, types) case diffTreeNamespacesHelper (oldTerms, newTerms) (oldTypes, newTypes) of Left e -> pure $ Left e Right nd -> @@ -263,7 +267,7 @@ compressNameTree (diffs Cofree.:< children) = -- | Compute changes between two unstructured Name relations, determining what has changed and how -- it should be interpreted so it's meaningful to the user. computeDefinitionDiff :: - Ord ref => + (Ord ref) => Relation Name ref {- Relevant definitions from old namespace -} -> Relation Name ref {- Relevant definitions from new namespace -} -> Either NamespaceDiffError (DefinitionDiffs Name ref) @@ -326,7 +330,7 @@ computeDefinitionDiff old new = ) -- | Convert a `DefinitionDiffs` into a tree of differences. -definitionDiffsToTree :: forall ref. Ord ref => DefinitionDiffs Name ref -> Cofree (Map NameSegment) (Map NameSegment (Set (DefinitionDiff ref))) +definitionDiffsToTree :: forall ref. (Ord ref) => DefinitionDiffs Name ref -> Cofree (Map NameSegment) (Map NameSegment (Set (DefinitionDiff ref))) definitionDiffsToTree dd = let DefinitionDiffs {added, removed, updated, renamed, newAliases} = dd expandedAliases :: Map Name (Set (DefinitionDiffKind ref)) diff --git a/src/Share/Postgres.hs b/src/Share/Postgres.hs index 9be2ed9..e301a66 100644 --- a/src/Share/Postgres.hs +++ b/src/Share/Postgres.hs @@ -372,7 +372,7 @@ instance (QueryM m) => QueryM (MaybeT m) where prepareStatements :: Bool prepareStatements = True -queryListRows :: forall r m. (Interp.DecodeRow r, QueryM m) => Interp.Sql -> m [r] +queryListRows :: forall r m. (Interp.DecodeRow r, QueryA m) => Interp.Sql -> m [r] queryListRows sql = statement () (Interp.interp prepareStatements sql) query1Row :: forall r m. (QueryM m) => (Interp.DecodeRow r) => Interp.Sql -> m (Maybe r) diff --git a/src/Share/Postgres/NamespaceDiffs.hs b/src/Share/Postgres/NamespaceDiffs.hs index 619ca1e..4074f59 100644 --- a/src/Share/Postgres/NamespaceDiffs.hs +++ b/src/Share/Postgres/NamespaceDiffs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE TypeOperators #-} module Share.Postgres.NamespaceDiffs @@ -7,7 +8,6 @@ module Share.Postgres.NamespaceDiffs where import Data.Either qualified as Either -import Share.Postgres (Transaction) import Share.Postgres qualified as PG import Share.Postgres.IDs (BranchHashId) import Share.Postgres.NameLookups.Types (NameLookupReceipt, NamedRef (..), ReversedName) @@ -25,11 +25,11 @@ import Unison.Util.Relation qualified as Rel -- 3. Names that are in both namespaces, but have different refs -- 4. Refs that are in both namespaces, but have different names getRelevantTermsForDiff :: + (PG.QueryA m) => NameLookupReceipt -> BranchHashId -> BranchHashId -> - Transaction - e + m ( Relation Name PGReferent {- relevant terms in old namespace -}, Relation Name PGReferent {- relevant terms only in new namespace -} ) @@ -42,9 +42,8 @@ getRelevantTermsForDiff !_nameLookupReceipt oldBranchHashId newBranchHashId = do -- 4. Find (name, ref) pairs that are in both namespaces, but have different names -- 5. Return the results as a list of (ref, name, isNew) tuples. It's possible for the same -- (name, ref) pair to appear with both (isNew = true) and (isNew = false) in the result. - rows <- - PG.queryListRows @(NamedRef PGReferent PG.:. PG.Only Bool) - [PG.sql| + PG.queryListRows @(NamedRef PGReferent PG.:. PG.Only Bool) + [PG.sql| WITH only_in_old AS ( ( SELECT old.reversed_name, old.referent_builtin, old.referent_component_hash_id, old.referent_component_index, old.referent_constructor_index FROM scoped_term_name_lookup old @@ -107,12 +106,15 @@ getRelevantTermsForDiff !_nameLookupReceipt oldBranchHashId newBranchHashId = do SELECT new.reversed_name, new.referent_builtin, new.referent_component_hash_id, new.referent_component_index, new.referent_constructor_index, true FROM relevant_terms_in_new new |] - <&> fmap \(NamedRef {reversedSegments, ref} PG.:. PG.Only inNew) -> - if inNew - then Right (from @ReversedName @Name reversedSegments, ref) - else Left (from @ReversedName @Name reversedSegments, ref) - let (old, new) = Either.partitionEithers rows - pure $ (Rel.fromList old, Rel.fromList new) + <&> ( fmap \(NamedRef {reversedSegments, ref} PG.:. PG.Only inNew) -> + if inNew + then Right (from @ReversedName @Name reversedSegments, ref) + else + Left (from @ReversedName @Name reversedSegments, ref) + ) + <&> \rows -> + let (old, new) = Either.partitionEithers rows + in (Rel.fromList old, Rel.fromList new) -- | Gets the types relevant for computing the diff between two branches. -- Where 'relevant' is defined as: @@ -121,7 +123,7 @@ getRelevantTermsForDiff !_nameLookupReceipt oldBranchHashId newBranchHashId = do -- 2. Types that are in the new namespace but not the old namespace -- 3. Names that are in both namespaces, but have different refs -- 4. Refs that are in both namespaces, but have different names -getRelevantTypesForDiff :: NameLookupReceipt -> BranchHashId -> BranchHashId -> Transaction e (Relation Name PGReference, Relation Name PGReference) +getRelevantTypesForDiff :: (PG.QueryA m) => NameLookupReceipt -> BranchHashId -> BranchHashId -> m (Relation Name PGReference, Relation Name PGReference) getRelevantTypesForDiff !_nameLookupReceipt oldBranchHashId newBranchHashId = do -- This SQL query does the following: -- @@ -131,9 +133,8 @@ getRelevantTypesForDiff !_nameLookupReceipt oldBranchHashId newBranchHashId = do -- 4. Find (name, ref) pairs that are in both namespaces, but have different names -- 5. Return the results as a list of (ref, name, isNew) tuples. It's possible for the same -- (name, ref) pair to appear with both (isNew = true) and (isNew = false) in the result. - rows <- - PG.queryListRows @(NamedRef PGReference PG.:. PG.Only Bool) - [PG.sql| + PG.queryListRows @(NamedRef PGReference PG.:. PG.Only Bool) + [PG.sql| WITH only_in_old AS ( ( SELECT old.reversed_name, old.reference_builtin, old.reference_component_hash_id, old.reference_component_index FROM scoped_type_name_lookup old @@ -192,9 +193,11 @@ getRelevantTypesForDiff !_nameLookupReceipt oldBranchHashId newBranchHashId = do SELECT new.reversed_name, new.reference_builtin, new.reference_component_hash_id, new.reference_component_index, true FROM relevant_types_in_new new |] - <&> fmap \(NamedRef {reversedSegments, ref} PG.:. PG.Only inNew) -> - if inNew - then Right (from @ReversedName @Name reversedSegments, ref) - else Left (from @ReversedName @Name reversedSegments, ref) - let (old, new) = Either.partitionEithers rows - pure $ (Rel.fromList old, Rel.fromList new) + <&> ( fmap \(NamedRef {reversedSegments, ref} PG.:. PG.Only inNew) -> + if inNew + then Right (from @ReversedName @Name reversedSegments, ref) + else Left (from @ReversedName @Name reversedSegments, ref) + ) + <&> \rows -> + let (old, new) = Either.partitionEithers rows + in (Rel.fromList old, Rel.fromList new) diff --git a/src/Share/Web/Share/Diffs/Impl.hs b/src/Share/Web/Share/Diffs/Impl.hs index ba282e0..aef5cb0 100644 --- a/src/Share/Web/Share/Diffs/Impl.hs +++ b/src/Share/Web/Share/Diffs/Impl.hs @@ -33,6 +33,7 @@ import Unison.Server.Types (DisplayObjectDiff, TermDefinition (..), TermTag, Typ import Unison.ShortHash (ShortHash) import Unison.Syntax.Name qualified as Name import Unison.Util.Pretty (Width) +import UnliftIO qualified diffNamespaces :: AuthZReceipt -> @@ -66,16 +67,16 @@ diffCausals :: diffCausals !_authZReceipt oldCausalId newCausalId = do -- Ensure name lookups for each thing we're diffing. -- We do this in two separate transactions to ensure we can still make progress even if we need to build name lookups. - (oldBranchHashId, oldBranchNLReceipt) <- PG.runTransaction $ do - oldBranchHashId <- CausalQ.expectNamespaceIdsByCausalIdsOf id oldCausalId - oldBranchNLReceipt <- NLOps.ensureNameLookupForBranchId oldBranchHashId - pure (oldBranchHashId, oldBranchNLReceipt) - - (newBranchHashId, newNLReceipt) <- PG.runTransaction $ do - newBranchHashId <- CausalQ.expectNamespaceIdsByCausalIdsOf id newCausalId - newNLReceipt <- NLOps.ensureNameLookupForBranchId newBranchHashId - pure (newBranchHashId, newNLReceipt) + let getOldBranch = PG.runTransaction $ do + oldBranchHashId <- CausalQ.expectNamespaceIdsByCausalIdsOf id oldCausalId + oldBranchNLReceipt <- NLOps.ensureNameLookupForBranchId oldBranchHashId + pure (oldBranchHashId, oldBranchNLReceipt) + let getNewBranch = PG.runTransaction $ do + newBranchHashId <- CausalQ.expectNamespaceIdsByCausalIdsOf id newCausalId + newNLReceipt <- NLOps.ensureNameLookupForBranchId newBranchHashId + pure (newBranchHashId, newNLReceipt) + ((oldBranchHashId, oldBranchNLReceipt), (newBranchHashId, newNLReceipt)) <- getOldBranch `UnliftIO.concurrently` getNewBranch PG.runTransactionOrRespondError $ do diff <- NamespaceDiffs.diffTreeNamespaces (oldBranchHashId, oldBranchNLReceipt) (newBranchHashId, newNLReceipt) `whenLeftM` throwError withTermTags <- @@ -100,12 +101,12 @@ diffTerms :: (Codebase.CodebaseEnv, BranchHashId, Name) -> (Codebase.CodebaseEnv, BranchHashId, Name) -> WebApp (TermDefinition, TermDefinition, DisplayObjectDiff) -diffTerms !_authZReceipt old@(_, _, oldName) new@(_, _, newName) = - do - oldTerm@(TermDefinition {termDefinition = oldDisplayObj}) <- getTermDefinition old `whenNothingM` respondError (EntityMissing (ErrorID "term-not-found") ("'From' term not found: " <> Name.toText oldName)) - newTerm@(TermDefinition {termDefinition = newDisplayObj}) <- getTermDefinition new `whenNothingM` respondError (EntityMissing (ErrorID "term-not-found") ("'To' term not found: " <> Name.toText newName)) - let termDiffDisplayObject = DefinitionDiff.diffDisplayObjects oldDisplayObj newDisplayObj - pure $ (oldTerm, newTerm, termDiffDisplayObject) +diffTerms !_authZReceipt old@(_, _, oldName) new@(_, _, newName) = do + let getOldTerm = getTermDefinition old `whenNothingM` respondError (EntityMissing (ErrorID "term-not-found") ("'From' term not found: " <> Name.toText oldName)) + let getNewTerm = getTermDefinition new `whenNothingM` respondError (EntityMissing (ErrorID "term-not-found") ("'To' term not found: " <> Name.toText newName)) + (oldTerm, newTerm) <- getOldTerm `UnliftIO.concurrently` getNewTerm + let termDiffDisplayObject = DefinitionDiff.diffDisplayObjects (termDefinition oldTerm) (termDefinition newTerm) + pure $ (oldTerm, newTerm, termDiffDisplayObject) where renderWidth :: Width renderWidth = 80 @@ -124,12 +125,16 @@ diffTypes :: (Codebase.CodebaseEnv, BranchHashId, Name) -> (Codebase.CodebaseEnv, BranchHashId, Name) -> WebApp (TypeDefinition, TypeDefinition, DisplayObjectDiff) -diffTypes !_authZReceipt old@(_, _, oldTypeName) new@(_, _, newTypeName) = - do - sourceType@(TypeDefinition {typeDefinition = sourceDisplayObj}) <- getTypeDefinition old `whenNothingM` respondError (EntityMissing (ErrorID "type-not-found") ("'From' Type not found: " <> Name.toText oldTypeName)) - newType@(TypeDefinition {typeDefinition = newDisplayObj}) <- getTypeDefinition new `whenNothingM` respondError (EntityMissing (ErrorID "type-not-found") ("'To' Type not found: " <> Name.toText newTypeName)) - let typeDiffDisplayObject = DefinitionDiff.diffDisplayObjects sourceDisplayObj newDisplayObj - pure $ (sourceType, newType, typeDiffDisplayObject) +diffTypes !_authZReceipt old@(_, _, oldTypeName) new@(_, _, newTypeName) = do + let getOldType = + getTypeDefinition old + `whenNothingM` respondError (EntityMissing (ErrorID "type-not-found") ("'From' Type not found: " <> Name.toText oldTypeName)) + let getNewType = + getTypeDefinition new + `whenNothingM` respondError (EntityMissing (ErrorID "type-not-found") ("'To' Type not found: " <> Name.toText newTypeName)) + (sourceType, newType) <- getOldType `UnliftIO.concurrently` getNewType + let typeDiffDisplayObject = DefinitionDiff.diffDisplayObjects (typeDefinition sourceType) (typeDefinition newType) + pure $ (sourceType, newType, typeDiffDisplayObject) where renderWidth :: Width renderWidth = 80