Merge pull request #17 from unisoncomputing/cp/fix-diff-caching

Fix caching for project and contribution diffs

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))

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)

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)

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

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)

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