Merge pull request #15 from unisoncomputing/cp/contribution-defn-diffs

Contribution defn diffs

src/Share/Postgres/Causal/Queries.hs

@@ -14,8 +14,6 @@ module Share.Postgres.Causal.Queries
     expectPgNamespace,
     savePgNamespace,
     saveCausal,
-    loadNamespaceIdForCausal,
-    expectNamespaceIdForCausal,
     tryGetCachedSquashResult,
     saveSquashResult,
     saveV2BranchShallow,
@@ -385,20 +383,6 @@ expectPgNamespace branchHashId = do
             (nameSegmentId, (branchHashId, causalId))
       pure $ Map.fromList childList
 
-loadNamespaceIdForCausal :: (QueryM m) => CausalId -> m (Maybe BranchHashId)
-loadNamespaceIdForCausal causalId = runMaybeT do
-  MaybeT $
-    query1Col
-      [sql| SELECT namespace_hash_id
-            FROM causals
-              WHERE causals.id = #{causalId}
-    |]
-
-expectNamespaceIdForCausal :: (HasCallStack, QueryM m) => CausalId -> m BranchHashId
-expectNamespaceIdForCausal c = do
-  loadNamespaceIdForCausal c
-    `whenNothingM` unrecoverableError (MissingExpectedEntity $ "Expected namespace id for causal: " <> tShow c)
-
 -- | Crawls the namespace tree to find the causal id mounted at a given path from the provided
 -- root causal.
 -- Returns Nothing if there's no causal at the provided path (or if the root causal doesn't exist)

src/Share/Web/Share/Contributions/API.hs

@@ -9,10 +9,12 @@ import Share.Contribution (ContributionStatus)
 import Share.IDs
 import Share.Utils.API
 import Share.Utils.Caching (Cached)
+import Share.Utils.Servant (RequiredQueryParam)
 import Share.Web.Share.Comments.API qualified as Comments
 import Share.Web.Share.Contributions.Types
-import Share.Web.Share.Diffs.Types (ShareNamespaceDiffResponse)
+import Share.Web.Share.Diffs.Types (ShareNamespaceDiffResponse, ShareTermDiffResponse, ShareTypeDiffResponse)
 import Share.Web.Share.Types (UserDisplayInfo)
+import Unison.Name (Name)
 
 type ContributionsByUserAPI = ListContributionsByUserEndpoint
 
@@ -24,7 +26,12 @@ type ContributionsByProjectAPI =
 type ContributionResourceServer =
   ( GetContributionByNumber
       :<|> UpdateContributionByNumber
-      :<|> ("diff" :> ContributionDiffEndpoint)
+      :<|> ( "diff"
+               :> ( ("terms" :> ContributionDiffTermsEndpoint)
+                      :<|> ("types" :> ContributionDiffTypesEndpoint)
+                      :<|> ContributionDiffEndpoint
+                  )
+           )
       :<|> ("merge" :> MergeContribution)
       :<|> ( "timeline"
                :> ( GetContributionTimeline
@@ -36,6 +43,16 @@ type ContributionResourceServer =
 type ContributionDiffEndpoint =
   Get '[JSON] (Cached JSON ShareNamespaceDiffResponse)
 
+type ContributionDiffTermsEndpoint =
+  RequiredQueryParam "oldTerm" Name
+    :> RequiredQueryParam "newTerm" Name
+    :> Get '[JSON] (Cached JSON ShareTermDiffResponse)
+
+type ContributionDiffTypesEndpoint =
+  RequiredQueryParam "oldType" Name
+    :> RequiredQueryParam "newType" Name
+    :> Get '[JSON] (Cached JSON ShareTypeDiffResponse)
+
 type ListContributionsCursor = (UTCTime, ContributionId)
 
 type ListContributionsByProjectEndpoint =

src/Share/Web/Share/Contributions/Impl.hs

@@ -42,8 +42,10 @@ import Share.Web.Share.Contributions.API
 import Share.Web.Share.Contributions.API qualified as API
 import Share.Web.Share.Contributions.Types
 import Share.Web.Share.Diffs.Impl qualified as Diffs
-import Share.Web.Share.Diffs.Types (ShareNamespaceDiffResponse (..))
+import Share.Web.Share.Diffs.Types (ShareNamespaceDiffResponse (..), ShareTermDiffResponse (..), ShareTypeDiffResponse (..))
 import Share.Web.Share.Types (UserDisplayInfo)
+import Unison.Name (Name)
+import Unison.Syntax.Name qualified as Name
 
 contributionsByProjectServer :: Maybe Session -> UserHandle -> ProjectSlug -> ServerT API.ContributionsByProjectAPI WebApp
 contributionsByProjectServer session handle projectSlug =
@@ -62,7 +64,10 @@ contributionsByProjectServer session handle projectSlug =
         addServerTag (Proxy @API.ContributionResourceServer) "contribution-number" (IDs.toText contributionNumber) $
           getContributionByNumberEndpoint session handle projectSlug contributionNumber
             :<|> updateContributionByNumberEndpoint session handle projectSlug contributionNumber
-            :<|> contributionDiffEndpoint session handle projectSlug contributionNumber
+            :<|> ( contributionDiffTermsEndpoint session handle projectSlug contributionNumber
+                     :<|> contributionDiffTypesEndpoint session handle projectSlug contributionNumber
+                     :<|> contributionDiffEndpoint session handle projectSlug contributionNumber
+                 )
             :<|> mergeContributionEndpoint session handle projectSlug contributionNumber
             :<|> timelineServer contributionNumber
    in listContributionsByProjectEndpoint session handle projectSlug
@@ -235,9 +240,9 @@ contributionDiffEndpoint (AuthN.MaybeAuthedUserID mayCallerUserId) userHandle pr
   newPBSH <- Codebase.runCodebaseTransactionOrRespondError newCodebase $ do
     lift $ Q.projectBranchShortHandByBranchId newBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Source branch not found")
 
-  let cacheKeys = [IDs.toText contributionId, IDs.toText newPBSH, IDs.toText oldPBSH, Caching.causalIdCacheKey newBranchCausalId, Caching.causalIdCacheKey oldBranchCausalId]
+  let oldCausalId = fromMaybe oldBranchCausalId bestCommonAncestorCausalId
+  let cacheKeys = [IDs.toText contributionId, IDs.toText newPBSH, IDs.toText oldPBSH, Caching.causalIdCacheKey newBranchCausalId, Caching.causalIdCacheKey oldCausalId]
   Caching.cachedResponse authZReceipt "contribution-diff" cacheKeys do
-    let oldCausalId = fromMaybe oldBranchCausalId bestCommonAncestorCausalId
     namespaceDiff <- Diffs.diffCausals authZReceipt oldCausalId newBranchCausalId
     (newBranchCausalHash, oldCausalHash) <- PG.runTransaction $ do
       newBranchCausalHash <- CausalQ.expectCausalHashesByIdsOf id newBranchCausalId
@@ -255,6 +260,96 @@ contributionDiffEndpoint (AuthN.MaybeAuthedUserID mayCallerUserId) userHandle pr
   where
     projectShorthand = IDs.ProjectShortHand {userHandle, projectSlug}
 
+contributionDiffTermsEndpoint ::
+  Maybe Session ->
+  UserHandle ->
+  ProjectSlug ->
+  IDs.ContributionNumber ->
+  Name ->
+  Name ->
+  WebApp (Cached JSON ShareTermDiffResponse)
+contributionDiffTermsEndpoint (AuthN.MaybeAuthedUserID mayCallerUserId) userHandle projectSlug contributionNumber oldTermName newTermName =
+  do
+    ( project,
+      Contribution {contributionId, bestCommonAncestorCausalId},
+      oldBranch@Branch {causal = oldBranchCausalId, branchId = oldBranchId},
+      newBranch@Branch {causal = newBranchCausalId, branchId = newBranchId}
+      ) <- PG.runTransactionOrRespondError $ do
+      project@Project {projectId} <- Q.projectByShortHand projectShorthand `whenNothingM` throwError (EntityMissing (ErrorID "project:missing") "Project not found")
+      contribution@Contribution {sourceBranchId = newBranchId, targetBranchId = oldBranchId} <- ContributionsQ.contributionByProjectIdAndNumber projectId contributionNumber `whenNothingM` throwError (EntityMissing (ErrorID "contribution:missing") "Contribution not found")
+      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
+    let oldCodebase = Codebase.codebaseForProjectBranch authZReceipt project oldBranch
+    let newCodebase = Codebase.codebaseForProjectBranch authZReceipt project newBranch
+    oldPBSH <- Codebase.runCodebaseTransactionOrRespondError oldCodebase $ do
+      lift $ Q.projectBranchShortHandByBranchId oldBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Target branch not found")
+    newPBSH <- Codebase.runCodebaseTransactionOrRespondError newCodebase $ do
+      lift $ Q.projectBranchShortHandByBranchId newBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Source branch not found")
+    let oldCausalId = fromMaybe oldBranchCausalId bestCommonAncestorCausalId
+    let cacheKeys = [IDs.toText contributionId, IDs.toText newPBSH, IDs.toText oldPBSH, Caching.causalIdCacheKey newBranchCausalId, Caching.causalIdCacheKey oldCausalId, Name.toText oldTermName, Name.toText newTermName]
+    Caching.cachedResponse authZReceipt "contribution-diff-terms" cacheKeys do
+      (oldBranchHashId, newBranchHashId) <- PG.runTransaction $ CausalQ.expectNamespaceIdsByCausalIdsOf both (oldCausalId, newBranchCausalId)
+      (oldTerm, newTerm, displayObjDiff) <- Diffs.diffTerms authZReceipt (oldCodebase, oldBranchHashId, oldTermName) (newCodebase, newBranchHashId, newTermName)
+      pure $
+        ShareTermDiffResponse
+          { project = projectShorthand,
+            oldBranch = IDs.IsBranchShortHand $ IDs.projectBranchShortHandToBranchShortHand oldPBSH,
+            newBranch = IDs.IsBranchShortHand $ IDs.projectBranchShortHandToBranchShortHand newPBSH,
+            oldTerm = oldTerm,
+            newTerm = newTerm,
+            diff = displayObjDiff
+          }
+  where
+    projectShorthand :: IDs.ProjectShortHand
+    projectShorthand = IDs.ProjectShortHand {userHandle, projectSlug}
+
+contributionDiffTypesEndpoint ::
+  Maybe Session ->
+  UserHandle ->
+  ProjectSlug ->
+  IDs.ContributionNumber ->
+  Name ->
+  Name ->
+  WebApp (Cached JSON ShareTypeDiffResponse)
+contributionDiffTypesEndpoint (AuthN.MaybeAuthedUserID mayCallerUserId) userHandle projectSlug contributionNumber oldTypeName newTypeName =
+  do
+    ( project,
+      Contribution {contributionId, bestCommonAncestorCausalId},
+      oldBranch@Branch {causal = oldBranchCausalId, branchId = oldBranchId},
+      newBranch@Branch {causal = newBranchCausalId, branchId = newBranchId}
+      ) <- PG.runTransactionOrRespondError $ do
+      project@Project {projectId} <- Q.projectByShortHand projectShorthand `whenNothingM` throwError (EntityMissing (ErrorID "project:missing") "Project not found")
+      contribution@Contribution {sourceBranchId = newBranchId, targetBranchId = oldBranchId} <- ContributionsQ.contributionByProjectIdAndNumber projectId contributionNumber `whenNothingM` throwError (EntityMissing (ErrorID "contribution:missing") "Contribution not found")
+      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
+    let oldCodebase = Codebase.codebaseForProjectBranch authZReceipt project oldBranch
+    let newCodebase = Codebase.codebaseForProjectBranch authZReceipt project newBranch
+    oldPBSH <- Codebase.runCodebaseTransactionOrRespondError oldCodebase $ do
+      lift $ Q.projectBranchShortHandByBranchId oldBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Target branch not found")
+    newPBSH <- Codebase.runCodebaseTransactionOrRespondError newCodebase $ do
+      lift $ Q.projectBranchShortHandByBranchId newBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Source branch not found")
+    let oldCausalId = fromMaybe oldBranchCausalId bestCommonAncestorCausalId
+    let cacheKeys = [IDs.toText contributionId, IDs.toText newPBSH, IDs.toText oldPBSH, Caching.causalIdCacheKey newBranchCausalId, Caching.causalIdCacheKey oldCausalId, Name.toText oldTypeName, Name.toText newTypeName]
+    Caching.cachedResponse authZReceipt "contribution-diff-types" cacheKeys do
+      (oldBranchHashId, newBranchHashId) <- PG.runTransaction $ CausalQ.expectNamespaceIdsByCausalIdsOf both (oldCausalId, newBranchCausalId)
+      (oldType, newType, displayObjDiff) <- Diffs.diffTypes authZReceipt (oldCodebase, oldBranchHashId, oldTypeName) (newCodebase, newBranchHashId, newTypeName)
+      pure $
+        ShareTypeDiffResponse
+          { project = projectShorthand,
+            oldBranch = IDs.IsBranchShortHand $ IDs.projectBranchShortHandToBranchShortHand oldPBSH,
+            newBranch = IDs.IsBranchShortHand $ IDs.projectBranchShortHandToBranchShortHand newPBSH,
+            oldType = oldType,
+            newType = newType,
+            diff = displayObjDiff
+          }
+  where
+    projectShorthand :: IDs.ProjectShortHand
+    projectShorthand = IDs.ProjectShortHand {userHandle, projectSlug}
+
 mergeContributionEndpoint ::
   Maybe Session ->
   UserHandle ->

src/Share/Web/Share/Diffs/Impl.hs

@@ -1,6 +1,8 @@
 module Share.Web.Share.Diffs.Impl
   ( diffNamespaces,
     diffCausals,
+    diffTerms,
+    diffTypes,
   )
 where
 
@@ -12,14 +14,25 @@ import Share.Postgres qualified as PG
 import Share.Postgres.Causal.Queries qualified as CausalQ
 import Share.Postgres.IDs (BranchHashId, CausalId)
 import Share.Postgres.NameLookups.Ops qualified as NLOps
+import Share.Postgres.NameLookups.Ops qualified as NameLookupOps
 import Share.Postgres.NameLookups.Types (NameLookupReceipt)
 import Share.Prelude
 import Share.Web.App
 import Share.Web.Authorization (AuthZReceipt)
+import Share.Web.Errors (EntityMissing (..), ErrorID (..), respondError)
 import U.Codebase.Reference qualified as V2Reference
 import U.Codebase.Referent qualified as V2Referent
-import Unison.Server.Types (TermTag, TypeTag)
+import Unison.Codebase.Path qualified as Path
+import Unison.Name (Name)
+import Unison.PrettyPrintEnvDecl qualified as PPED
+import Unison.PrettyPrintEnvDecl.Postgres qualified as PPEPostgres
+import Unison.Server.Backend.DefinitionDiff qualified as DefinitionDiff
+import Unison.Server.NameSearch.Postgres qualified as PGNameSearch
+import Unison.Server.Share.Definitions qualified as Definitions
+import Unison.Server.Types (DisplayObjectDiff, TermDefinition (..), TermTag, TypeDefinition (..), TypeTag)
 import Unison.ShortHash (ShortHash)
+import Unison.Syntax.Name qualified as Name
+import Unison.Util.Pretty (Width)
 
 diffNamespaces ::
   AuthZReceipt ->
@@ -54,12 +67,12 @@ 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.expectNamespaceIdForCausal oldCausalId
+    oldBranchHashId <- CausalQ.expectNamespaceIdsByCausalIdsOf id oldCausalId
     oldBranchNLReceipt <- NLOps.ensureNameLookupForBranchId oldBranchHashId
     pure (oldBranchHashId, oldBranchNLReceipt)
 
   (newBranchHashId, newNLReceipt) <- PG.runTransaction $ do
-    newBranchHashId <- CausalQ.expectNamespaceIdForCausal newCausalId
+    newBranchHashId <- CausalQ.expectNamespaceIdsByCausalIdsOf id newCausalId
     newNLReceipt <- NLOps.ensureNameLookupForBranchId newBranchHashId
     pure (newBranchHashId, newNLReceipt)
 
@@ -81,3 +94,51 @@ diffCausals !_authZReceipt oldCausalId newCausalId = do
                   pure $ zip typeTags (refs <&> V2Reference.toShortHash)
               )
     pure diffWithTags
+
+diffTerms ::
+  AuthZReceipt ->
+  (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)
+  where
+    renderWidth :: Width
+    renderWidth = 80
+    getTermDefinition :: (Codebase.CodebaseEnv, BranchHashId, Name) -> WebApp (Maybe TermDefinition)
+    getTermDefinition (codebase, bhId, name) = do
+      let perspective = Path.empty
+      (namesPerspective, Identity relocatedName) <- PG.runTransaction $ NameLookupOps.relocateToNameRoot perspective (Identity name) bhId
+      let ppedBuilder deps = (PPED.biasTo [name]) <$> lift (PPEPostgres.ppedForReferences namesPerspective deps)
+      let nameSearch = PGNameSearch.nameSearchForPerspective namesPerspective
+      rt <- Codebase.codebaseRuntime codebase
+      Codebase.runCodebaseTransaction codebase do
+        Definitions.termDefinitionByName ppedBuilder nameSearch renderWidth rt relocatedName
+
+diffTypes ::
+  AuthZReceipt ->
+  (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)
+  where
+    renderWidth :: Width
+    renderWidth = 80
+    getTypeDefinition :: (Codebase.CodebaseEnv, BranchHashId, Name) -> WebApp (Maybe TypeDefinition)
+    getTypeDefinition (codebase, bhId, name) = do
+      let perspective = Path.empty
+      (namesPerspective, Identity relocatedName) <- PG.runTransaction $ NameLookupOps.relocateToNameRoot perspective (Identity name) bhId
+      let ppedBuilder deps = (PPED.biasTo [name]) <$> lift (PPEPostgres.ppedForReferences namesPerspective deps)
+      let nameSearch = PGNameSearch.nameSearchForPerspective namesPerspective
+      rt <- Codebase.codebaseRuntime codebase
+      Codebase.runCodebaseTransaction codebase do
+        Definitions.typeDefinitionByName ppedBuilder nameSearch renderWidth rt relocatedName