Skip to content

Commit 0aeb41d

Browse files
ChrisPennerChrisPenner
authored
Merge pull request #15 from unisoncomputing/cp/contribution-defn-diffs
Contribution defn diffs
2 parents 25a5510 + b995556 commit 0aeb41d

File tree

17 files changed

+713
-186
lines changed

17 files changed

+713
-186
lines changed

‎src/Share/Postgres/Causal/Queries.hs

Lines changed: 0 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -14,8 +14,6 @@ module Share.Postgres.Causal.Queries
1414
expectPgNamespace,
1515
savePgNamespace,
1616
saveCausal,
17-
loadNamespaceIdForCausal,
18-
expectNamespaceIdForCausal,
1917
tryGetCachedSquashResult,
2018
saveSquashResult,
2119
saveV2BranchShallow,
@@ -385,20 +383,6 @@ expectPgNamespace branchHashId = do
385383
(nameSegmentId, (branchHashId, causalId))
386384
pure $ Map.fromList childList
387385

388-
loadNamespaceIdForCausal :: (QueryM m) => CausalId -> m (Maybe BranchHashId)
389-
loadNamespaceIdForCausal causalId = runMaybeT do
390-
MaybeT $
391-
query1Col
392-
[sql| SELECT namespace_hash_id
393-
FROM causals
394-
WHERE causals.id = #{causalId}
395-
|]
396-
397-
expectNamespaceIdForCausal :: (HasCallStack, QueryM m) => CausalId -> m BranchHashId
398-
expectNamespaceIdForCausal c = do
399-
loadNamespaceIdForCausal c
400-
`whenNothingM` unrecoverableError (MissingExpectedEntity $ "Expected namespace id for causal: " <> tShow c)
401-
402386
-- | Crawls the namespace tree to find the causal id mounted at a given path from the provided
403387
-- root causal.
404388
-- 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

Lines changed: 19 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -9,10 +9,12 @@ import Share.Contribution (ContributionStatus)
99
import Share.IDs
1010
import Share.Utils.API
1111
import Share.Utils.Caching (Cached)
12+
import Share.Utils.Servant (RequiredQueryParam)
1213
import Share.Web.Share.Comments.API qualified as Comments
1314
import Share.Web.Share.Contributions.Types
14-
import Share.Web.Share.Diffs.Types (ShareNamespaceDiffResponse)
15+
import Share.Web.Share.Diffs.Types (ShareNamespaceDiffResponse, ShareTermDiffResponse, ShareTypeDiffResponse)
1516
import Share.Web.Share.Types (UserDisplayInfo)
17+
import Unison.Name (Name)
1618

1719
type ContributionsByUserAPI = ListContributionsByUserEndpoint
1820

@@ -24,7 +26,12 @@ type ContributionsByProjectAPI =
2426
type ContributionResourceServer =
2527
( GetContributionByNumber
2628
:<|> UpdateContributionByNumber
27-
:<|> ("diff" :> ContributionDiffEndpoint)
29+
:<|> ( "diff"
30+
:> ( ("terms" :> ContributionDiffTermsEndpoint)
31+
:<|> ("types" :> ContributionDiffTypesEndpoint)
32+
:<|> ContributionDiffEndpoint
33+
)
34+
)
2835
:<|> ("merge" :> MergeContribution)
2936
:<|> ( "timeline"
3037
:> ( GetContributionTimeline
@@ -36,6 +43,16 @@ type ContributionResourceServer =
3643
type ContributionDiffEndpoint =
3744
Get '[JSON] (Cached JSON ShareNamespaceDiffResponse)
3845

46+
type ContributionDiffTermsEndpoint =
47+
RequiredQueryParam "oldTerm" Name
48+
:> RequiredQueryParam "newTerm" Name
49+
:> Get '[JSON] (Cached JSON ShareTermDiffResponse)
50+
51+
type ContributionDiffTypesEndpoint =
52+
RequiredQueryParam "oldType" Name
53+
:> RequiredQueryParam "newType" Name
54+
:> Get '[JSON] (Cached JSON ShareTypeDiffResponse)
55+
3956
type ListContributionsCursor = (UTCTime, ContributionId)
4057

4158
type ListContributionsByProjectEndpoint =

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

Lines changed: 99 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -42,8 +42,10 @@ import Share.Web.Share.Contributions.API
4242
import Share.Web.Share.Contributions.API qualified as API
4343
import Share.Web.Share.Contributions.Types
4444
import Share.Web.Share.Diffs.Impl qualified as Diffs
45-
import Share.Web.Share.Diffs.Types (ShareNamespaceDiffResponse (..))
45+
import Share.Web.Share.Diffs.Types (ShareNamespaceDiffResponse (..), ShareTermDiffResponse (..), ShareTypeDiffResponse (..))
4646
import Share.Web.Share.Types (UserDisplayInfo)
47+
import Unison.Name (Name)
48+
import Unison.Syntax.Name qualified as Name
4749

4850
contributionsByProjectServer :: Maybe Session -> UserHandle -> ProjectSlug -> ServerT API.ContributionsByProjectAPI WebApp
4951
contributionsByProjectServer session handle projectSlug =
@@ -62,7 +64,10 @@ contributionsByProjectServer session handle projectSlug =
6264
addServerTag (Proxy @API.ContributionResourceServer) "contribution-number" (IDs.toText contributionNumber) $
6365
getContributionByNumberEndpoint session handle projectSlug contributionNumber
6466
:<|> updateContributionByNumberEndpoint session handle projectSlug contributionNumber
65-
:<|> contributionDiffEndpoint session handle projectSlug contributionNumber
67+
:<|> ( contributionDiffTermsEndpoint session handle projectSlug contributionNumber
68+
:<|> contributionDiffTypesEndpoint session handle projectSlug contributionNumber
69+
:<|> contributionDiffEndpoint session handle projectSlug contributionNumber
70+
)
6671
:<|> mergeContributionEndpoint session handle projectSlug contributionNumber
6772
:<|> timelineServer contributionNumber
6873
in listContributionsByProjectEndpoint session handle projectSlug
@@ -235,9 +240,9 @@ contributionDiffEndpoint (AuthN.MaybeAuthedUserID mayCallerUserId) userHandle pr
235240
newPBSH <- Codebase.runCodebaseTransactionOrRespondError newCodebase $ do
236241
lift $ Q.projectBranchShortHandByBranchId newBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Source branch not found")
237242

238-
let cacheKeys = [IDs.toText contributionId, IDs.toText newPBSH, IDs.toText oldPBSH, Caching.causalIdCacheKey newBranchCausalId, Caching.causalIdCacheKey oldBranchCausalId]
243+
let oldCausalId = fromMaybe oldBranchCausalId bestCommonAncestorCausalId
244+
let cacheKeys = [IDs.toText contributionId, IDs.toText newPBSH, IDs.toText oldPBSH, Caching.causalIdCacheKey newBranchCausalId, Caching.causalIdCacheKey oldCausalId]
239245
Caching.cachedResponse authZReceipt "contribution-diff" cacheKeys do
240-
let oldCausalId = fromMaybe oldBranchCausalId bestCommonAncestorCausalId
241246
namespaceDiff <- Diffs.diffCausals authZReceipt oldCausalId newBranchCausalId
242247
(newBranchCausalHash, oldCausalHash) <- PG.runTransaction $ do
243248
newBranchCausalHash <- CausalQ.expectCausalHashesByIdsOf id newBranchCausalId
@@ -255,6 +260,96 @@ contributionDiffEndpoint (AuthN.MaybeAuthedUserID mayCallerUserId) userHandle pr
255260
where
256261
projectShorthand = IDs.ProjectShortHand {userHandle, projectSlug}
257262

263+
contributionDiffTermsEndpoint ::
264+
Maybe Session ->
265+
UserHandle ->
266+
ProjectSlug ->
267+
IDs.ContributionNumber ->
268+
Name ->
269+
Name ->
270+
WebApp (Cached JSON ShareTermDiffResponse)
271+
contributionDiffTermsEndpoint (AuthN.MaybeAuthedUserID mayCallerUserId) userHandle projectSlug contributionNumber oldTermName newTermName =
272+
do
273+
( project,
274+
Contribution {contributionId, bestCommonAncestorCausalId},
275+
oldBranch@Branch {causal = oldBranchCausalId, branchId = oldBranchId},
276+
newBranch@Branch {causal = newBranchCausalId, branchId = newBranchId}
277+
) <- PG.runTransactionOrRespondError $ do
278+
project@Project {projectId} <- Q.projectByShortHand projectShorthand `whenNothingM` throwError (EntityMissing (ErrorID "project:missing") "Project not found")
279+
contribution@Contribution {sourceBranchId = newBranchId, targetBranchId = oldBranchId} <- ContributionsQ.contributionByProjectIdAndNumber projectId contributionNumber `whenNothingM` throwError (EntityMissing (ErrorID "contribution:missing") "Contribution not found")
280+
newBranch <- Q.branchById newBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Source branch not found")
281+
oldBranch <- Q.branchById oldBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Target branch not found")
282+
pure (project, contribution, oldBranch, newBranch)
283+
authZReceipt <- AuthZ.permissionGuard $ AuthZ.checkContributionRead mayCallerUserId project
284+
let oldCodebase = Codebase.codebaseForProjectBranch authZReceipt project oldBranch
285+
let newCodebase = Codebase.codebaseForProjectBranch authZReceipt project newBranch
286+
oldPBSH <- Codebase.runCodebaseTransactionOrRespondError oldCodebase $ do
287+
lift $ Q.projectBranchShortHandByBranchId oldBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Target branch not found")
288+
newPBSH <- Codebase.runCodebaseTransactionOrRespondError newCodebase $ do
289+
lift $ Q.projectBranchShortHandByBranchId newBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Source branch not found")
290+
let oldCausalId = fromMaybe oldBranchCausalId bestCommonAncestorCausalId
291+
let cacheKeys = [IDs.toText contributionId, IDs.toText newPBSH, IDs.toText oldPBSH, Caching.causalIdCacheKey newBranchCausalId, Caching.causalIdCacheKey oldCausalId, Name.toText oldTermName, Name.toText newTermName]
292+
Caching.cachedResponse authZReceipt "contribution-diff-terms" cacheKeys do
293+
(oldBranchHashId, newBranchHashId) <- PG.runTransaction $ CausalQ.expectNamespaceIdsByCausalIdsOf both (oldCausalId, newBranchCausalId)
294+
(oldTerm, newTerm, displayObjDiff) <- Diffs.diffTerms authZReceipt (oldCodebase, oldBranchHashId, oldTermName) (newCodebase, newBranchHashId, newTermName)
295+
pure $
296+
ShareTermDiffResponse
297+
{ project = projectShorthand,
298+
oldBranch = IDs.IsBranchShortHand $ IDs.projectBranchShortHandToBranchShortHand oldPBSH,
299+
newBranch = IDs.IsBranchShortHand $ IDs.projectBranchShortHandToBranchShortHand newPBSH,
300+
oldTerm = oldTerm,
301+
newTerm = newTerm,
302+
diff = displayObjDiff
303+
}
304+
where
305+
projectShorthand :: IDs.ProjectShortHand
306+
projectShorthand = IDs.ProjectShortHand {userHandle, projectSlug}
307+
308+
contributionDiffTypesEndpoint ::
309+
Maybe Session ->
310+
UserHandle ->
311+
ProjectSlug ->
312+
IDs.ContributionNumber ->
313+
Name ->
314+
Name ->
315+
WebApp (Cached JSON ShareTypeDiffResponse)
316+
contributionDiffTypesEndpoint (AuthN.MaybeAuthedUserID mayCallerUserId) userHandle projectSlug contributionNumber oldTypeName newTypeName =
317+
do
318+
( project,
319+
Contribution {contributionId, bestCommonAncestorCausalId},
320+
oldBranch@Branch {causal = oldBranchCausalId, branchId = oldBranchId},
321+
newBranch@Branch {causal = newBranchCausalId, branchId = newBranchId}
322+
) <- PG.runTransactionOrRespondError $ do
323+
project@Project {projectId} <- Q.projectByShortHand projectShorthand `whenNothingM` throwError (EntityMissing (ErrorID "project:missing") "Project not found")
324+
contribution@Contribution {sourceBranchId = newBranchId, targetBranchId = oldBranchId} <- ContributionsQ.contributionByProjectIdAndNumber projectId contributionNumber `whenNothingM` throwError (EntityMissing (ErrorID "contribution:missing") "Contribution not found")
325+
newBranch <- Q.branchById newBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Source branch not found")
326+
oldBranch <- Q.branchById oldBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Target branch not found")
327+
pure (project, contribution, oldBranch, newBranch)
328+
authZReceipt <- AuthZ.permissionGuard $ AuthZ.checkContributionRead mayCallerUserId project
329+
let oldCodebase = Codebase.codebaseForProjectBranch authZReceipt project oldBranch
330+
let newCodebase = Codebase.codebaseForProjectBranch authZReceipt project newBranch
331+
oldPBSH <- Codebase.runCodebaseTransactionOrRespondError oldCodebase $ do
332+
lift $ Q.projectBranchShortHandByBranchId oldBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Target branch not found")
333+
newPBSH <- Codebase.runCodebaseTransactionOrRespondError newCodebase $ do
334+
lift $ Q.projectBranchShortHandByBranchId newBranchId `whenNothingM` throwError (EntityMissing (ErrorID "branch:missing") "Source branch not found")
335+
let oldCausalId = fromMaybe oldBranchCausalId bestCommonAncestorCausalId
336+
let cacheKeys = [IDs.toText contributionId, IDs.toText newPBSH, IDs.toText oldPBSH, Caching.causalIdCacheKey newBranchCausalId, Caching.causalIdCacheKey oldCausalId, Name.toText oldTypeName, Name.toText newTypeName]
337+
Caching.cachedResponse authZReceipt "contribution-diff-types" cacheKeys do
338+
(oldBranchHashId, newBranchHashId) <- PG.runTransaction $ CausalQ.expectNamespaceIdsByCausalIdsOf both (oldCausalId, newBranchCausalId)
339+
(oldType, newType, displayObjDiff) <- Diffs.diffTypes authZReceipt (oldCodebase, oldBranchHashId, oldTypeName) (newCodebase, newBranchHashId, newTypeName)
340+
pure $
341+
ShareTypeDiffResponse
342+
{ project = projectShorthand,
343+
oldBranch = IDs.IsBranchShortHand $ IDs.projectBranchShortHandToBranchShortHand oldPBSH,
344+
newBranch = IDs.IsBranchShortHand $ IDs.projectBranchShortHandToBranchShortHand newPBSH,
345+
oldType = oldType,
346+
newType = newType,
347+
diff = displayObjDiff
348+
}
349+
where
350+
projectShorthand :: IDs.ProjectShortHand
351+
projectShorthand = IDs.ProjectShortHand {userHandle, projectSlug}
352+
258353
mergeContributionEndpoint ::
259354
Maybe Session ->
260355
UserHandle ->

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

Lines changed: 64 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,8 @@
11
module Share.Web.Share.Diffs.Impl
22
( diffNamespaces,
33
diffCausals,
4+
diffTerms,
5+
diffTypes,
46
)
57
where
68

@@ -12,14 +14,25 @@ import Share.Postgres qualified as PG
1214
import Share.Postgres.Causal.Queries qualified as CausalQ
1315
import Share.Postgres.IDs (BranchHashId, CausalId)
1416
import Share.Postgres.NameLookups.Ops qualified as NLOps
17+
import Share.Postgres.NameLookups.Ops qualified as NameLookupOps
1518
import Share.Postgres.NameLookups.Types (NameLookupReceipt)
1619
import Share.Prelude
1720
import Share.Web.App
1821
import Share.Web.Authorization (AuthZReceipt)
22+
import Share.Web.Errors (EntityMissing (..), ErrorID (..), respondError)
1923
import U.Codebase.Reference qualified as V2Reference
2024
import U.Codebase.Referent qualified as V2Referent
21-
import Unison.Server.Types (TermTag, TypeTag)
25+
import Unison.Codebase.Path qualified as Path
26+
import Unison.Name (Name)
27+
import Unison.PrettyPrintEnvDecl qualified as PPED
28+
import Unison.PrettyPrintEnvDecl.Postgres qualified as PPEPostgres
29+
import Unison.Server.Backend.DefinitionDiff qualified as DefinitionDiff
30+
import Unison.Server.NameSearch.Postgres qualified as PGNameSearch
31+
import Unison.Server.Share.Definitions qualified as Definitions
32+
import Unison.Server.Types (DisplayObjectDiff, TermDefinition (..), TermTag, TypeDefinition (..), TypeTag)
2233
import Unison.ShortHash (ShortHash)
34+
import Unison.Syntax.Name qualified as Name
35+
import Unison.Util.Pretty (Width)
2336

2437
diffNamespaces ::
2538
AuthZReceipt ->
@@ -54,12 +67,12 @@ diffCausals !_authZReceipt oldCausalId newCausalId = do
5467
-- Ensure name lookups for each thing we're diffing.
5568
-- We do this in two separate transactions to ensure we can still make progress even if we need to build name lookups.
5669
(oldBranchHashId, oldBranchNLReceipt) <- PG.runTransaction $ do
57-
oldBranchHashId <- CausalQ.expectNamespaceIdForCausal oldCausalId
70+
oldBranchHashId <- CausalQ.expectNamespaceIdsByCausalIdsOf id oldCausalId
5871
oldBranchNLReceipt <- NLOps.ensureNameLookupForBranchId oldBranchHashId
5972
pure (oldBranchHashId, oldBranchNLReceipt)
6073

6174
(newBranchHashId, newNLReceipt) <- PG.runTransaction $ do
62-
newBranchHashId <- CausalQ.expectNamespaceIdForCausal newCausalId
75+
newBranchHashId <- CausalQ.expectNamespaceIdsByCausalIdsOf id newCausalId
6376
newNLReceipt <- NLOps.ensureNameLookupForBranchId newBranchHashId
6477
pure (newBranchHashId, newNLReceipt)
6578

@@ -81,3 +94,51 @@ diffCausals !_authZReceipt oldCausalId newCausalId = do
8194
pure $ zip typeTags (refs <&> V2Reference.toShortHash)
8295
)
8396
pure diffWithTags
97+
98+
diffTerms ::
99+
AuthZReceipt ->
100+
(Codebase.CodebaseEnv, BranchHashId, Name) ->
101+
(Codebase.CodebaseEnv, BranchHashId, Name) ->
102+
WebApp (TermDefinition, TermDefinition, DisplayObjectDiff)
103+
diffTerms !_authZReceipt old@(_, _, oldName) new@(_, _, newName) =
104+
do
105+
oldTerm@(TermDefinition {termDefinition = oldDisplayObj}) <- getTermDefinition old `whenNothingM` respondError (EntityMissing (ErrorID "term-not-found") ("'From' term not found: " <> Name.toText oldName))
106+
newTerm@(TermDefinition {termDefinition = newDisplayObj}) <- getTermDefinition new `whenNothingM` respondError (EntityMissing (ErrorID "term-not-found") ("'To' term not found: " <> Name.toText newName))
107+
let termDiffDisplayObject = DefinitionDiff.diffDisplayObjects oldDisplayObj newDisplayObj
108+
pure $ (oldTerm, newTerm, termDiffDisplayObject)
109+
where
110+
renderWidth :: Width
111+
renderWidth = 80
112+
getTermDefinition :: (Codebase.CodebaseEnv, BranchHashId, Name) -> WebApp (Maybe TermDefinition)
113+
getTermDefinition (codebase, bhId, name) = do
114+
let perspective = Path.empty
115+
(namesPerspective, Identity relocatedName) <- PG.runTransaction $ NameLookupOps.relocateToNameRoot perspective (Identity name) bhId
116+
let ppedBuilder deps = (PPED.biasTo [name]) <$> lift (PPEPostgres.ppedForReferences namesPerspective deps)
117+
let nameSearch = PGNameSearch.nameSearchForPerspective namesPerspective
118+
rt <- Codebase.codebaseRuntime codebase
119+
Codebase.runCodebaseTransaction codebase do
120+
Definitions.termDefinitionByName ppedBuilder nameSearch renderWidth rt relocatedName
121+
122+
diffTypes ::
123+
AuthZReceipt ->
124+
(Codebase.CodebaseEnv, BranchHashId, Name) ->
125+
(Codebase.CodebaseEnv, BranchHashId, Name) ->
126+
WebApp (TypeDefinition, TypeDefinition, DisplayObjectDiff)
127+
diffTypes !_authZReceipt old@(_, _, oldTypeName) new@(_, _, newTypeName) =
128+
do
129+
sourceType@(TypeDefinition {typeDefinition = sourceDisplayObj}) <- getTypeDefinition old `whenNothingM` respondError (EntityMissing (ErrorID "type-not-found") ("'From' Type not found: " <> Name.toText oldTypeName))
130+
newType@(TypeDefinition {typeDefinition = newDisplayObj}) <- getTypeDefinition new `whenNothingM` respondError (EntityMissing (ErrorID "type-not-found") ("'To' Type not found: " <> Name.toText newTypeName))
131+
let typeDiffDisplayObject = DefinitionDiff.diffDisplayObjects sourceDisplayObj newDisplayObj
132+
pure $ (sourceType, newType, typeDiffDisplayObject)
133+
where
134+
renderWidth :: Width
135+
renderWidth = 80
136+
getTypeDefinition :: (Codebase.CodebaseEnv, BranchHashId, Name) -> WebApp (Maybe TypeDefinition)
137+
getTypeDefinition (codebase, bhId, name) = do
138+
let perspective = Path.empty
139+
(namesPerspective, Identity relocatedName) <- PG.runTransaction $ NameLookupOps.relocateToNameRoot perspective (Identity name) bhId
140+
let ppedBuilder deps = (PPED.biasTo [name]) <$> lift (PPEPostgres.ppedForReferences namesPerspective deps)
141+
let nameSearch = PGNameSearch.nameSearchForPerspective namesPerspective
142+
rt <- Codebase.codebaseRuntime codebase
143+
Codebase.runCodebaseTransaction codebase do
144+
Definitions.typeDefinitionByName ppedBuilder nameSearch renderWidth rt relocatedName

0 commit comments

Comments
 (0)