Skip to content

Contribution defn diffs #15

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 3 commits into from
Jul 29, 2024
Merged

Contribution defn diffs #15

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
4b7f79e
Refactor definition diffs for more sharing
ChrisPenner Jul 29, 2024
7342c56
Implement new contribution term & type diff endpoints
ChrisPenner Jul 29, 2024
b995556
New contribution transcripts
ChrisPenner Jul 29, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
16 changes: 0 additions & 16 deletions src/Share/Postgres/Causal/Queries.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -14,8 +14,6 @@ module Share.Postgres.Causal.Queries
expectPgNamespace,
savePgNamespace,
saveCausal,
loadNamespaceIdForCausal,
expectNamespaceIdForCausal,
Comment on lines -17 to -18
Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

These don't fit the new traversal loader pattern, and already had a replacement, so I replaced all usages of these.

tryGetCachedSquashResult,
saveSquashResult,
saveV2BranchShallow,
Expand Down Expand Up @@ -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)
Expand Down
21 changes: 19 additions & 2 deletions src/Share/Web/Share/Contributions/API.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand All @@ -24,7 +26,12 @@ type ContributionsByProjectAPI =
type ContributionResourceServer =
( GetContributionByNumber
:<|> UpdateContributionByNumber
:<|> ("diff" :> ContributionDiffEndpoint)
:<|> ( "diff"
:> ( ("terms" :> ContributionDiffTermsEndpoint)
:<|> ("types" :> ContributionDiffTypesEndpoint)
:<|> ContributionDiffEndpoint
)
)
:<|> ("merge" :> MergeContribution)
:<|> ( "timeline"
:> ( GetContributionTimeline
Expand All @@ -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 =
Expand Down
103 changes: 99 additions & 4 deletions src/Share/Web/Share/Contributions/Impl.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand All @@ -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
Expand Down Expand Up @@ -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]
Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I altered the caching key to use the BCA so the cache will blow less often (but will still be correct)

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
Expand All @@ -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 ->
Expand Down
67 changes: 64 additions & 3 deletions src/Share/Web/Share/Diffs/Impl.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,6 +1,8 @@
module Share.Web.Share.Diffs.Impl
( diffNamespaces,
diffCausals,
diffTerms,
diffTypes,
)
where

Expand All @@ -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 ->
Expand Down Expand Up @@ -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)

Expand All @@ -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
Loading
Loading