Merge pull request #5 from unisoncomputing/cp/definition-diffs

Definition Diffs

Author: ChrisPenner

.github/workflows/ci.yaml

@@ -179,7 +179,7 @@ jobs:
       # This step generates an artifact attestation for the image, which is an unforgeable statement about where and how it was built. It increases supply chain security for people who consume the image. For more information, see "[AUTOTITLE](/actions/security-guides/using-artifact-attestations-to-establish-provenance-for-builds)."
       - name: Generate artifact attestation
         uses: actions/[email protected]
-        if: ${{ env.is_published_build }}
+        if: ${{ github.event_name == 'push' && (github.ref == 'refs/heads/main' || github.ref == 'refs/heads/staging') }}
         with:
           subject-name: ${{ env.container_registry }}/${{ env.docker_image_name}}
           subject-digest: ${{ steps.push.outputs.digest }}

package.yaml

@@ -46,6 +46,7 @@ dependencies:
 - cookie
 - cryptonite
 - data-default
+- Diff
 - either
 - extra
 - share-utils

share-api.cabal

@@ -182,7 +182,8 @@ library
       ImportQualifiedPost
   ghc-options: -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info -O2 -funbox-strict-fields
   build-depends:
-      MonadRandom
+      Diff
+    , MonadRandom
     , aeson
     , async
     , base >=4.7 && <5
@@ -321,7 +322,8 @@ executable share-api
       ImportQualifiedPost
   ghc-options: -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info -O2 -funbox-strict-fields -threaded -rtsopts "-with-rtsopts=-N -A32m -qn2 -T"
   build-depends:
-      MonadRandom
+      Diff
+    , MonadRandom
     , aeson
     , async
     , base >=4.7 && <5

src/Share/Backend.hs

@@ -17,7 +17,9 @@ module Share.Backend
     Backend.bestNameForTerm,
     Backend.bestNameForType,
     Backend.termsToSyntax,
+    Backend.termsToSyntaxOf,
     Backend.typesToSyntax,
+    Backend.typesToSyntaxOf,
     Backend.definitionResultsDependencies,
     Backend.DefinitionResults (..),
     Backend.IncludeCycles (..),

src/Share/Postgres/NameLookups/Ops.hs

@@ -32,7 +32,6 @@ import U.Codebase.Referent (ConstructorType, Referent)
 import Unison.Codebase.Path (Path)
 import Unison.Codebase.Path qualified as Path
 import Unison.Debug qualified as Debug
-import Unison.HashQualified qualified as HQ
 import Unison.Name (Name)
 import Unison.Name qualified as Name
 import Unison.NameSegment (NameSegment (..))
@@ -91,10 +90,10 @@ namesPerspectiveForRootAndPath rootBranchHashId namespace = do
 --
 -- A name root is either a project root or a dependency root.
 -- E.g. @.myproject.some.namespace -> .myproject@ or @.myproject.lib.base.List -> .myproject.lib.base@
-relocateToNameRoot :: PG.QueryM m => Path -> HQ.HashQualified Name -> BranchHashId -> m (NamesPerspective, HQ.HashQualified Name)
+relocateToNameRoot :: (PG.QueryM m, Traversable hq) => Path -> hq Name -> BranchHashId -> m (NamesPerspective, hq Name)
 relocateToNameRoot perspective query rootBh = do
   -- The namespace containing the name path
-  let nameLocation = case HQ.toName query of
+  let nameLocation = case getFirst query of
         Just name ->
           name
             & Name.segments

src/Share/Prelude.hs

@@ -9,6 +9,7 @@ module Share.Prelude
     readMaybe,
     eitherToMaybe,
     maybeToEither,
+    getFirst,
     unifyEither,
     fromMaybeT,
     guardM,
@@ -80,10 +81,10 @@ import Data.Traversable as X
 import Data.Typeable (Typeable)
 import Data.Void as X
 import Data.Word as X (Word64)
-import Share.Prelude.Orphans ()
-import Share.Utils.Show (tShow)
 import GHC.Generics (Generic)
 import GHC.Stack (HasCallStack)
+import Share.Prelude.Orphans ()
+import Share.Utils.Show (tShow)
 import Text.Read (readMaybe)
 import Unison.Util.Monoid (foldMapM)
 import UnliftIO as X (Exception (..), MonadUnliftIO, bracket, bracket_, throwIO, try)
@@ -92,6 +93,9 @@ import Witch.Utility as X (as)
 import Witherable as X hiding (filter)
 import Prelude as X hiding (log)
 
+getFirst :: (Foldable f) => f a -> Maybe a
+getFirst = listToMaybe . toList
+
 -- | Throws an error with the provided message and applicable callstack.
 todo :: (HasCallStack) => String -> a
 todo = error

src/Share/Web/Share/Projects/API.hs

@@ -3,6 +3,7 @@
 
 module Share.Web.Share.Projects.API where
 
+import Servant
 import Share.IDs
 import Share.OAuth.Session (MaybeAuthenticatedSession)
 import Share.Utils.Caching (Cached)
@@ -14,7 +15,7 @@ import Share.Web.Share.Projects.Types
 import Share.Web.Share.Releases.API
 import Share.Web.Share.Tickets.API (TicketsByProjectAPI)
 import Share.Web.Share.Types
-import Servant
+import Unison.Name (Name)
 
 type ProjectsAPI =
   ( ListProjectsForUserEndpoint
@@ -27,7 +28,12 @@ type ProjectResourceAPI =
       :<|> ("releases" :> ProjectReleasesAPI)
       :<|> ("contributions" :> ContributionsByProjectAPI)
       :<|> ("tickets" :> TicketsByProjectAPI)
-      :<|> ("diff" :> "namespaces" :> ProjectDiffNamespaceEndpoint)
+      :<|> ( "diff"
+               :> ( "namespaces" :> ProjectDiffNamespacesEndpoint
+                      :<|> "terms" :> ProjectDiffTermsEndpoint
+                      :<|> "types" :> ProjectDiffTypesEndpoint
+                  )
+           )
       :<|> CreateProjectEndpoint
       :<|> UpdateProjectEndpoint
       :<|> DeleteProjectEndpoint
@@ -37,11 +43,25 @@ type ProjectResourceAPI =
       :<|> "maintainers" :> MaintainersResourceAPI
   )
 
-type ProjectDiffNamespaceEndpoint =
+type ProjectDiffNamespacesEndpoint =
   RequiredQueryParam "old" BranchOrReleaseShortHand
     :> RequiredQueryParam "new" BranchOrReleaseShortHand
     :> Get '[JSON] (Cached JSON ShareNamespaceDiffResponse)
 
+type ProjectDiffTermsEndpoint =
+  RequiredQueryParam "oldBranchRef" BranchOrReleaseShortHand
+    :> RequiredQueryParam "newBranchRef" BranchOrReleaseShortHand
+    :> RequiredQueryParam "oldTerm" Name
+    :> RequiredQueryParam "newTerm" Name
+    :> Get '[JSON] ShareTermDiffResponse
+
+type ProjectDiffTypesEndpoint =
+  RequiredQueryParam "oldBranchRef" BranchOrReleaseShortHand
+    :> RequiredQueryParam "newBranchRef" BranchOrReleaseShortHand
+    :> RequiredQueryParam "oldType" Name
+    :> RequiredQueryParam "newType" Name
+    :> Get '[JSON] ShareTypeDiffResponse
+
 type CreateProjectEndpoint =
   ReqBody '[JSON] CreateProjectRequest
     :> Post '[JSON] CreateProjectResponse

src/Share/Web/Share/Projects/Impl.hs

@@ -11,20 +11,25 @@ import Data.ByteString.Lazy qualified as BL
 import Data.Map qualified as Map
 import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
-import Share.Branch (Branch (..), defaultBranchShorthand)
+import Servant
+import Share.Branch (defaultBranchShorthand)
+import Share.Branch qualified as Branch
+import Share.Codebase (CodebaseEnv)
+import Share.Codebase qualified as Codebase
 import Share.IDs (PrefixedHash (..), ProjectSlug (..), UserHandle, UserId)
 import Share.IDs qualified as IDs
 import Share.OAuth.Session
 import Share.Postgres qualified as PG
 import Share.Postgres.Causal.Queries qualified as CausalQ
-import Share.Postgres.IDs (CausalId)
+import Share.Postgres.IDs (BranchHashId, CausalId)
+import Share.Postgres.NameLookups.Ops qualified as NameLookupOps
 import Share.Postgres.Ops qualified as PGO
 import Share.Postgres.Projects.Queries qualified as ProjectsQ
 import Share.Postgres.Queries qualified as Q
 import Share.Postgres.Users.Queries qualified as UsersQ
 import Share.Prelude
 import Share.Project (Project (..))
-import Share.Release (Release (..))
+import Share.Release qualified as Release
 import Share.User (User (..))
 import Share.Utils.API ((:++) (..))
 import Share.Utils.Caching (Cached)
@@ -43,7 +48,17 @@ import Share.Web.Share.Projects.Types
 import Share.Web.Share.Releases.Impl (getProjectReleaseReadmeEndpoint, releasesServer)
 import Share.Web.Share.Tickets.Impl (ticketsByProjectServer)
 import Share.Web.Share.Types
-import Servant
+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.Orphans ()
+import Unison.Server.Share.Definitions qualified as Definitions
+import Unison.Server.Types (TermDefinition (..), TypeDefinition (..))
+import Unison.Syntax.Name qualified as Name
+import Unison.Util.Pretty (Width)
 
 data ProjectErrors
   = MaintainersAlreadyExist [UserId]
@@ -91,7 +106,10 @@ projectServer session handle =
                      :<|> releasesServer session handle slug
                      :<|> contributionsByProjectServer session handle slug
                      :<|> ticketsByProjectServer session handle slug
-                     :<|> diffNamespacesEndpoint session handle slug
+                     :<|> ( diffNamespacesEndpoint session handle slug
+                              :<|> diffTermsEndpoint session handle slug
+                              :<|> diffTypesEndpoint session handle slug
+                          )
                      :<|> createProjectEndpoint session handle slug
                      :<|> updateProjectEndpoint session handle slug
                      :<|> deleteProjectEndpoint session handle slug
@@ -142,8 +160,8 @@ diffNamespacesEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHandle project
   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
-  oldCausalId <- resolveBranchOrRelease projectId oldShortHand
-  newCausalId <- resolveBranchOrRelease projectId newShortHand
+  (_, oldCausalId, _oldBranchId) <- namespaceHashForBranchOrRelease authZReceipt project oldShortHand
+  (_, newCausalId, _newBranchId) <- namespaceHashForBranchOrRelease authZReceipt project newShortHand
 
   let cacheKeys = [IDs.toText projectId, IDs.toText oldShortHand, IDs.toText newShortHand, Caching.causalIdCacheKey oldCausalId, Caching.causalIdCacheKey newCausalId]
   Caching.cachedResponse authZReceipt "project-diff-namespaces" cacheKeys do
@@ -163,16 +181,113 @@ diffNamespacesEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHandle project
         }
   where
     projectShortHand = IDs.ProjectShortHand {userHandle, projectSlug}
-    resolveBranchOrRelease :: IDs.ProjectId -> IDs.BranchOrReleaseShortHand -> WebApp CausalId
-    resolveBranchOrRelease projectId = \case
-      IDs.IsBranchShortHand branchShortHand -> do
-        PG.runTransactionOrRespondError $ do
-          Branch {causal = branchHead} <- Q.branchByProjectIdAndShortHand projectId branchShortHand `whenNothingM` throwError (EntityMissing (ErrorID "branch-not-found") ("Branch not found: " <> IDs.toText @IDs.BranchShortHand branchShortHand))
-          pure branchHead
-      IDs.IsReleaseShortHand releaseShortHand -> do
-        PG.runTransactionOrRespondError $ do
-          Release {squashedCausal = releaseHead} <- Q.releaseByProjectIdAndReleaseShortHand projectId releaseShortHand `whenNothingM` throwError (EntityMissing (ErrorID "release-not-found") ("Release not found: " <> IDs.toText @IDs.ReleaseShortHand releaseShortHand))
-          pure releaseHead
+
+diffTermsEndpoint ::
+  Maybe Session ->
+  UserHandle ->
+  ProjectSlug ->
+  IDs.BranchOrReleaseShortHand ->
+  IDs.BranchOrReleaseShortHand ->
+  Name ->
+  Name ->
+  WebApp ShareTermDiffResponse
+diffTermsEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHandle projectSlug oldShortHand newShortHand oldTermName newTermName =
+  do
+    project <- 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
+    oldTerm@(TermDefinition {termDefinition = oldDisplayObj}) <- getTermDefinition authZReceipt project oldShortHand oldTermName `whenNothingM` respondError (EntityMissing (ErrorID "term-not-found") ("Term not found: " <> IDs.toText oldShortHand <> ":" <> Name.toText oldTermName))
+    newTerm@(TermDefinition {termDefinition = newDisplayObj}) <- getTermDefinition authZReceipt project newShortHand newTermName `whenNothingM` respondError (EntityMissing (ErrorID "term-not-found") ("Term not found: " <> IDs.toText newShortHand <> ":" <> Name.toText newTermName))
+    let termDiffDisplayObject = DefinitionDiff.diffDisplayObjects oldDisplayObj newDisplayObj
+    pure $
+      ShareTermDiffResponse
+        { project = projectShortHand,
+          oldBranch = oldShortHand,
+          newBranch = newShortHand,
+          oldTerm = oldTerm,
+          newTerm = newTerm,
+          diff = termDiffDisplayObject
+        }
+  where
+    renderWidth :: Width
+    renderWidth = 80
+    getTermDefinition :: AuthZ.AuthZReceipt -> Project -> IDs.BranchOrReleaseShortHand -> Name -> WebApp (Maybe TermDefinition)
+    getTermDefinition authZReceipt project shorthand name = do
+      (codebase, _causalId, bhId) <- namespaceHashForBranchOrRelease authZReceipt project shorthand
+      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
+
+    projectShortHand :: IDs.ProjectShortHand
+    projectShortHand = IDs.ProjectShortHand {userHandle, projectSlug}
+
+diffTypesEndpoint ::
+  Maybe Session ->
+  UserHandle ->
+  ProjectSlug ->
+  IDs.BranchOrReleaseShortHand ->
+  IDs.BranchOrReleaseShortHand ->
+  Name ->
+  Name ->
+  WebApp ShareTypeDiffResponse
+diffTypesEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHandle projectSlug oldShortHand newShortHand oldTypeName newTypeName =
+  do
+    project <- 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
+    sourceType@(TypeDefinition {typeDefinition = sourceDisplayObj}) <- getTypeDefinition authZReceipt project oldShortHand oldTypeName `whenNothingM` respondError (EntityMissing (ErrorID "type-not-found") ("Type not found: " <> IDs.toText oldShortHand <> ":" <> Name.toText oldTypeName))
+    newType@(TypeDefinition {typeDefinition = newDisplayObj}) <- getTypeDefinition authZReceipt project newShortHand newTypeName `whenNothingM` respondError (EntityMissing (ErrorID "type-not-found") ("Type not found: " <> IDs.toText newShortHand <> ":" <> Name.toText newTypeName))
+    let typeDiffDisplayObject = DefinitionDiff.diffDisplayObjects sourceDisplayObj newDisplayObj
+    pure $
+      ShareTypeDiffResponse
+        { project = projectShortHand,
+          oldBranch = oldShortHand,
+          newBranch = newShortHand,
+          oldType = sourceType,
+          newType = newType,
+          diff = typeDiffDisplayObject
+        }
+  where
+    renderWidth :: Width
+    renderWidth = 80
+    getTypeDefinition :: AuthZ.AuthZReceipt -> Project -> IDs.BranchOrReleaseShortHand -> Name -> WebApp (Maybe TypeDefinition)
+    getTypeDefinition authZReceipt project shorthand name = do
+      (codebase, _causalId, bhId) <- namespaceHashForBranchOrRelease authZReceipt project shorthand
+      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
+
+    projectShortHand :: IDs.ProjectShortHand
+    projectShortHand = IDs.ProjectShortHand {userHandle, projectSlug}
+
+namespaceHashForBranchOrRelease :: AuthZ.AuthZReceipt -> Project -> IDs.BranchOrReleaseShortHand -> WebApp (CodebaseEnv, CausalId, BranchHashId)
+namespaceHashForBranchOrRelease authZReceipt Project {projectId, ownerUserId = projectOwnerUserId} = \case
+  IDs.IsBranchShortHand branchShortHand -> do
+    PG.runTransactionOrRespondError $ do
+      branch <- Q.branchByProjectIdAndShortHand projectId branchShortHand `whenNothingM` throwError (EntityMissing (ErrorID "branch-not-found") ("Branch not found: " <> IDs.toText @IDs.BranchShortHand branchShortHand))
+      let causalId = Branch.causal branch
+      let codebaseLoc = Codebase.codebaseLocationForProjectBranchCodebase projectOwnerUserId (Branch.contributorId branch)
+      let codebase = Codebase.codebaseEnv authZReceipt codebaseLoc
+      Codebase.codebaseMToTransaction codebase do
+        branchHashId <- CausalQ.expectNamespaceIdForCausal causalId
+        pure (codebase, causalId, branchHashId)
+  IDs.IsReleaseShortHand releaseShortHand -> do
+    PG.runTransactionOrRespondError $ do
+      release <- Q.releaseByProjectIdAndReleaseShortHand projectId releaseShortHand `whenNothingM` throwError (EntityMissing (ErrorID "release-not-found") ("Release not found: " <> IDs.toText @IDs.ReleaseShortHand releaseShortHand))
+      let causalId = Release.squashedCausal release
+      let codebaseLoc = Codebase.codebaseLocationForProjectRelease projectOwnerUserId
+      let codebase = Codebase.codebaseEnv authZReceipt codebaseLoc
+      Codebase.codebaseMToTransaction codebase do
+        branchHashId <- CausalQ.expectNamespaceIdForCausal causalId
+        pure (codebase, causalId, branchHashId)
 
 createProjectEndpoint :: Maybe Session -> UserHandle -> ProjectSlug -> CreateProjectRequest -> WebApp CreateProjectResponse
 createProjectEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHandle projectSlug req = do