diff --git a/sql/2025-04-30-drop-namespace-diffs.sql b/sql/2025-04-30-drop-namespace-diffs.sql new file mode 100644 index 00000000..530e9f9b --- /dev/null +++ b/sql/2025-04-30-drop-namespace-diffs.sql @@ -0,0 +1,3 @@ +-- Delete all previously-computed namespace diffs, because the diff payload is different now (we explicitly store +-- errors). +TRUNCATE namespace_diffs; diff --git a/src/Share/Backend.hs b/src/Share/Backend.hs index 826aae1c..cf6c13af 100644 --- a/src/Share/Backend.hs +++ b/src/Share/Backend.hs @@ -231,7 +231,7 @@ displayType = \case pure (UserObject decl) evalDocRef :: - Codebase.CodebaseRuntime -> + Codebase.CodebaseRuntime IO -> V2.TermReference -> Codebase.CodebaseM e (Doc.EvaluatedDoc Symbol) evalDocRef (CodebaseRuntime {codeLookup, cachedEvalResult, unisonRuntime}) termRef = do @@ -245,6 +245,7 @@ evalDocRef (CodebaseRuntime {codeLookup, cachedEvalResult, unisonRuntime}) termR typeOf :: Referent.Referent -> Codebase.CodebaseM e (Maybe (V1.Type Symbol ())) typeOf termRef = fmap void <$> Codebase.loadTypeOfReferent (Cv.referent1to2 termRef) + eval :: V1.Term Symbol a -> Codebase.CodebaseM e (Maybe (V1.Term Symbol ())) eval (Term.amap (const mempty) -> tm) = do -- We use an empty ppe for evalutation, it's only used for adding additional context to errors. diff --git a/src/Share/BackgroundJobs/Diffs/ContributionDiffs.hs b/src/Share/BackgroundJobs/Diffs/ContributionDiffs.hs index 68f0a6e4..7bd1b829 100644 --- a/src/Share/BackgroundJobs/Diffs/ContributionDiffs.hs +++ b/src/Share/BackgroundJobs/Diffs/ContributionDiffs.hs @@ -7,13 +7,13 @@ import Share.BackgroundJobs.Diffs.Queries qualified as DQ import Share.BackgroundJobs.Errors (reportError) import Share.BackgroundJobs.Monad (Background, withTag) import Share.BackgroundJobs.Workers (newWorker) -import Share.Branch (Branch (..)) +import Share.Branch (branchCausals_) import Share.Codebase qualified as Codebase import Share.Contribution (Contribution (..)) +import Share.Env qualified as Env import Share.IDs import Share.IDs qualified as IDs import Share.Metrics qualified as Metrics -import Share.NamespaceDiffs (NamespaceDiffError (MissingEntityError)) import Share.Postgres qualified as PG import Share.Postgres.Contributions.Queries qualified as ContributionsQ import Share.Postgres.Notifications qualified as Notif @@ -23,6 +23,7 @@ import Share.Utils.Logging qualified as Logging import Share.Web.Authorization qualified as AuthZ import Share.Web.Errors (EntityMissing (..), ErrorID (..)) import Share.Web.Share.Diffs.Impl qualified as Diffs +import System.Clock qualified as Clock -- | Check every 10 minutes if we haven't heard on the notifications channel. -- Just in case we missed a notification. @@ -32,43 +33,70 @@ maxPollingIntervalSeconds = 10 * 60 worker :: Ki.Scope -> Background () worker scope = do authZReceipt <- AuthZ.backgroundJobAuthZ + badUnliftCodebaseRuntime <- Codebase.badAskUnliftCodebaseRuntime + unisonRuntime <- asks Env.sandboxedRuntime + let makeRuntime :: Codebase.CodebaseEnv -> IO (Codebase.CodebaseRuntime IO) + makeRuntime codebase = do + runtime <- Codebase.codebaseRuntimeTransaction unisonRuntime codebase + pure (badUnliftCodebaseRuntime runtime) newWorker scope "diffs:contributions" $ forever do Notif.waitOnChannel Notif.ContributionDiffChannel (maxPollingIntervalSeconds * 1000000) - processDiffs authZReceipt >>= \case - Left (contributionId, e) -> - withTag "contribution-id" (IDs.toText contributionId) $ do - reportError e - Right _ -> pure () + processDiffs authZReceipt makeRuntime -processDiffs :: AuthZ.AuthZReceipt -> Background (Either (ContributionId, NamespaceDiffError) ()) -processDiffs authZReceipt = Metrics.recordContributionDiffDuration . runExceptT $ do - mayContributionId <- PG.runTransaction DQ.claimContributionToDiff - for_ mayContributionId (diffContribution authZReceipt) - case mayContributionId of - Just contributionId -> do - Logging.textLog ("Recomputed contribution diff: " <> tShow contributionId) - & Logging.withTag ("contribution-id", tShow contributionId) - & Logging.withSeverity Logging.Info - & Logging.logMsg - -- Keep processing releases until we run out of them. - either throwError pure =<< lift (processDiffs authZReceipt) - Nothing -> pure () +-- Process diffs until we run out of them. We claim a diff in a transaction and compute the diff in the same +-- transaction, with a row lock on the contribution id (which is skipped by other workers). There's therefore no chance +-- that we claim a diff but fail to write the result of computing that diff back to the database. +processDiffs :: AuthZ.AuthZReceipt -> (Codebase.CodebaseEnv -> IO (Codebase.CodebaseRuntime IO)) -> Background () +processDiffs authZReceipt makeRuntime = do + let loop :: Background () + loop = do + result <- + PG.runTransactionMode PG.RepeatableRead PG.ReadWrite do + DQ.claimContributionToDiff >>= \case + Nothing -> pure Nothing + Just contributionId -> do + startTime <- PG.transactionUnsafeIO (Clock.getTime Clock.Monotonic) + result <- PG.catchTransaction (maybeComputeAndStoreCausalDiff authZReceipt makeRuntime contributionId) + pure (Just (contributionId, startTime, result)) + whenJust result \(contributionId, startTime, result) -> do + withTag "contribution-id" (IDs.toText contributionId) do + case result of + Left err -> reportError err + Right didWork -> do + when didWork do + liftIO (Metrics.recordContributionDiffDuration startTime) + Logging.textLog "Computed contribution diff" + & Logging.withSeverity Logging.Info + & Logging.logMsg + loop + loop -diffContribution :: AuthZ.AuthZReceipt -> ContributionId -> ExceptT (ContributionId, NamespaceDiffError) Background () -diffContribution authZReceipt contributionId = withExceptT (contributionId,) . mapExceptT (withTag "contribution-id" (IDs.toText contributionId)) $ do - ( bestCommonAncestorCausalId, - project, - newBranch@Branch {causal = newBranchCausalId}, - oldBranch@Branch {causal = oldBranchCausalId} - ) <- ExceptT $ PG.tryRunTransaction $ do - Contribution {bestCommonAncestorCausalId, sourceBranchId = newBranchId, targetBranchId = oldBranchId, projectId} <- ContributionsQ.contributionById contributionId - project <- Q.projectById projectId `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "project:missing") "Project not found") - newBranch <- Q.branchById newBranchId `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "branch:missing") "Source branch not found") - oldBranch <- Q.branchById oldBranchId `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "branch:missing") "Target branch not found") - pure (bestCommonAncestorCausalId, project, newBranch, oldBranch) +-- Check whether a causal diff has already been computed, and if it hasn't, compute and store it. Otherwise, do nothing. +-- Returns whether or not we did any work. +maybeComputeAndStoreCausalDiff :: + AuthZ.AuthZReceipt -> + (Codebase.CodebaseEnv -> IO (Codebase.CodebaseRuntime IO)) -> + ContributionId -> + PG.Transaction EntityMissing Bool +maybeComputeAndStoreCausalDiff authZReceipt makeRuntime contributionId = do + Contribution {bestCommonAncestorCausalId, sourceBranchId = newBranchId, targetBranchId = oldBranchId, projectId} <- + ContributionsQ.contributionById contributionId + project <- Q.projectById projectId `whenNothingM` throwError (EntityMissing (ErrorID "project:missing") "Project 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") let oldCodebase = Codebase.codebaseForProjectBranch authZReceipt project oldBranch let newCodebase = Codebase.codebaseForProjectBranch authZReceipt project newBranch - -- This method saves the diff so it'll be there when we need it, so we don't need to do anything with it. - _ <- - Diffs.diffCausals authZReceipt (oldCodebase, oldBranchCausalId) (newCodebase, newBranchCausalId) bestCommonAncestorCausalId - pure () + let oldCausal = oldBranch ^. branchCausals_ + let newCausal = newBranch ^. branchCausals_ + ContributionsQ.existsPrecomputedNamespaceDiff (oldCodebase, oldCausal) (newCodebase, newCausal) >>= \case + True -> pure False + False -> do + oldRuntime <- PG.transactionUnsafeIO (makeRuntime oldCodebase) + newRuntime <- PG.transactionUnsafeIO (makeRuntime newCodebase) + _ <- + Diffs.computeAndStoreCausalDiff + authZReceipt + (oldCodebase, oldRuntime, oldCausal) + (newCodebase, newRuntime, newCausal) + bestCommonAncestorCausalId + pure True diff --git a/src/Share/BackgroundJobs/Diffs/Queries.hs b/src/Share/BackgroundJobs/Diffs/Queries.hs index 02105741..3a4b6e7b 100644 --- a/src/Share/BackgroundJobs/Diffs/Queries.hs +++ b/src/Share/BackgroundJobs/Diffs/Queries.hs @@ -4,22 +4,20 @@ module Share.BackgroundJobs.Diffs.Queries ) where -import Data.Foldable (toList) -import Data.Set (Set) import Share.IDs import Share.Postgres import Share.Postgres.Notifications qualified as Notif +import Unison.Prelude submitContributionsToBeDiffed :: (QueryM m) => Set ContributionId -> m () submitContributionsToBeDiffed contributions = do execute_ [sql| - WITH new_contributions(contribution_id) AS ( - SELECT * FROM ^{singleColumnTable (toList contributions)} - ) - INSERT INTO contribution_diff_queue (contribution_id) - SELECT nc.contribution_id FROM new_contributions nc - ON CONFLICT DO NOTHING + WITH new_contributions(contribution_id) AS ( + SELECT * FROM ^{singleColumnTable (toList contributions)} + ) + INSERT INTO contribution_diff_queue (contribution_id) + SELECT nc.contribution_id FROM new_contributions nc |] Notif.notifyChannel Notif.ContributionDiffChannel @@ -28,16 +26,16 @@ claimContributionToDiff :: Transaction e (Maybe ContributionId) claimContributionToDiff = do query1Col [sql| - WITH chosen_contribution(contribution_id) AS ( - SELECT q.contribution_id - FROM contribution_diff_queue q - ORDER BY q.created_at ASC - LIMIT 1 - -- Skip any that are being synced by other workers. - FOR UPDATE SKIP LOCKED - ) - DELETE FROM contribution_diff_queue - USING chosen_contribution - WHERE contribution_diff_queue.contribution_id = chosen_contribution.contribution_id - RETURNING chosen_contribution.contribution_id + WITH chosen_contribution(contribution_id) AS ( + SELECT q.contribution_id + FROM contribution_diff_queue q + ORDER BY q.created_at ASC + LIMIT 1 + -- Skip any that are being synced by other workers. + FOR UPDATE SKIP LOCKED + ) + DELETE FROM contribution_diff_queue + USING chosen_contribution + WHERE contribution_diff_queue.contribution_id = chosen_contribution.contribution_id + RETURNING chosen_contribution.contribution_id |] diff --git a/src/Share/Branch.hs b/src/Share/Branch.hs index 1f469746..65678169 100644 --- a/src/Share/Branch.hs +++ b/src/Share/Branch.hs @@ -55,7 +55,7 @@ instance (Hasql.DecodeValue causal) => Hasql.DecodeRow (Branch causal) where creatorId <- PG.decodeField pure $ Branch {..} -branchCausals_ :: Traversal (Branch causal) (Branch causal') causal causal' +branchCausals_ :: Lens (Branch causal) (Branch causal') causal causal' branchCausals_ f Branch {..} = (\causal -> Branch {causal, ..}) <$> f causal branchCodebaseUser :: Branch causal -> UserId diff --git a/src/Share/Codebase.hs b/src/Share/Codebase.hs index ad33ab6f..ac178058 100644 --- a/src/Share/Codebase.hs +++ b/src/Share/Codebase.hs @@ -17,6 +17,8 @@ module Share.Codebase CodebaseRuntime (..), codebaseEnv, codebaseRuntime, + codebaseRuntimeTransaction, + badAskUnliftCodebaseRuntime, codebaseForProjectBranch, codebaseLocationForUserCodebase, codebaseLocationForProjectBranchCodebase, @@ -65,12 +67,17 @@ module Share.Codebase LCQ.ensureLooseCodeRootHash, setLooseCodeRoot, + -- * Conversions + convertTerm2to1, + -- * Utilities cachedCodebaseResponse, ) where +import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO) import Control.Lens +import Control.Monad.Morph (hoist) import Data.ByteString.Lazy.Char8 qualified as BL import Data.Map qualified as Map import Data.Set qualified as Set @@ -107,16 +114,21 @@ import U.Codebase.Causal qualified as Causal import U.Codebase.Decl qualified as V2 import U.Codebase.Reference qualified as V2 import U.Codebase.Referent qualified as V2 +import U.Codebase.Sqlite.Symbol qualified as V2 +import U.Codebase.Term qualified as V2.Term import Unison.Builtin qualified as Builtin import Unison.Builtin qualified as Builtins import Unison.Codebase.CodeLookup qualified as CL +import Unison.Codebase.Runtime (Runtime) import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.ConstructorType qualified as CT import Unison.DataDeclaration qualified as DD import Unison.DataDeclaration qualified as V1 +import Unison.Hash (Hash) import Unison.Parser.Ann import Unison.Parser.Ann qualified as Ann import Unison.Prelude (askUnliftIO) +import Unison.Reference (TermReferenceId) import Unison.Reference qualified as Reference import Unison.Reference qualified as V1 import Unison.Referent qualified as V1 @@ -174,14 +186,40 @@ codebaseEnv !_authZReceipt codebaseLoc = do -- | Construct a Runtime linked to a specific codebase. -- Don't use the runtime for one codebase with another codebase. -codebaseRuntime :: (MonadReader (Env.Env x) m, MonadUnliftIO m) => CodebaseEnv -> m CodebaseRuntime -codebaseRuntime CodebaseEnv {codebaseOwner} = do +codebaseRuntime :: (MonadReader (Env.Env x) m, MonadUnliftIO m) => CodebaseEnv -> m (CodebaseRuntime IO) +codebaseRuntime codebase = do unisonRuntime <- asks Env.sandboxedRuntime - codeLookup <- codeLookupForUser codebaseOwner - toIO <- UnliftIO.askRunInIO - let codebaseRt = CodebaseRuntime {codeLookup, cachedEvalResult, unisonRuntime} - cachedEvalResult r = (fmap . fmap) Term.unannotate . toIO . PG.runTransaction . loadCachedEvalResult codebaseOwner $ r - pure codebaseRt + rt <- liftIO (codebaseRuntimeTransaction unisonRuntime codebase) + unlift <- badAskUnliftCodebaseRuntime + pure (unlift rt) + +-- | Ideally, we'd use this – a runtime with lookup actions in transaction, not IO. But that will require refactoring to +-- the runtime interface in ucm, so we can't use it for now. That's bad: we end up unsafely running separate +-- transactions for inner calls to 'codeLookup' / 'cachedEvalResult', which can lead to deadlock due to a starved +-- connection pool. +codebaseRuntimeTransaction :: Runtime Symbol -> CodebaseEnv -> IO (CodebaseRuntime (PG.Transaction e)) +codebaseRuntimeTransaction unisonRuntime CodebaseEnv {codebaseOwner} = do + cacheVar <- newTVarIO (CodeLookupCache mempty mempty) + pure + CodebaseRuntime + { codeLookup = codeLookupForUser cacheVar codebaseOwner, + cachedEvalResult = (fmap . fmap) Term.unannotate . loadCachedEvalResult codebaseOwner, + unisonRuntime + } + +-- Why bad: see above comment on `codebaseRuntimeTransaction`. We don't want to use a `CodebaseRuntime IO`, because it +-- will run every lookup in a separate transaction. But we can't use a `CodebaseRuntime Transaction` because we call +-- back into UCM library code that expects a `CodebaseRuntime IO`. +badAskUnliftCodebaseRuntime :: + (MonadReader (Env.Env x) m, MonadUnliftIO m) => + m (CodebaseRuntime (PG.Transaction Void) -> CodebaseRuntime IO) +badAskUnliftCodebaseRuntime = do + UnliftIO.UnliftIO toIO <- askUnliftIO + pure \rt@CodebaseRuntime {codeLookup, cachedEvalResult} -> + rt + { codeLookup = hoist (toIO . PG.runTransaction) codeLookup, + cachedEvalResult = toIO . PG.runTransaction . cachedEvalResult + } runCodebaseTransaction :: (MonadReader (Env.Env x) m, MonadIO m) => CodebaseEnv -> CodebaseM Void a -> m a runCodebaseTransaction codebaseEnv m = do @@ -233,20 +271,24 @@ cachedCodebaseResponse authzReceipt codebaseOwner endpointName providedCachePara codebaseViewCacheKey = IDs.toText (codebaseOwnerUserId codebaseOwner) -- | Load a term and its type. -loadTerm :: Reference.Id -> CodebaseM e (Maybe (V1.Term Symbol Ann, V1.Type Symbol Ann)) +loadTerm :: TermReferenceId -> CodebaseM e (Maybe (V1.Term Symbol Ann, V1.Type Symbol Ann)) loadTerm refId = do codebaseUser <- asks codebaseOwner lift $ loadTermForCodeLookup codebaseUser refId -- | Load a term and its type. -loadTermForCodeLookup :: UserId -> Reference.Id -> PG.Transaction e (Maybe (V1.Term Symbol Ann, V1.Type Symbol Ann)) +loadTermForCodeLookup :: UserId -> TermReferenceId -> PG.Transaction e (Maybe (V1.Term Symbol Ann, V1.Type Symbol Ann)) loadTermForCodeLookup codebaseUser refId@(Reference.Id h _) = runMaybeT $ do (v2Term, v2Type) <- MaybeT $ DefnQ.loadTerm codebaseUser refId - v1Term <- Cv.term2to1 h (lift . expectDeclKind) v2Term + convertTerm2to1 h v2Term v2Type + +convertTerm2to1 :: (PG.QueryM m) => Hash -> V2.Term.Term V2.Symbol -> V2.Term.Type V2.Symbol -> m (V1.Term Symbol Ann, V1.Type Symbol Ann) +convertTerm2to1 h v2Term v2Type = do + v1Term <- Cv.term2to1 h expectDeclKind v2Term let v1Type = Cv.ttype2to1 v2Type pure (v1Term, v1Type) -expectTerm :: Reference.Id -> CodebaseM e (V1.Term Symbol Ann, V1.Type Symbol Ann) +expectTerm :: TermReferenceId -> CodebaseM e (V1.Term Symbol Ann, V1.Type Symbol Ann) expectTerm refId = loadTerm refId `whenNothingM` lift (unrecoverableError (MissingTerm refId)) -- | Load the type of a term. @@ -280,7 +322,7 @@ expectTypeOfReferents trav s = do s & trav %%~ expectTypeOfReferent expectDeclKind :: (PG.QueryM m) => Reference.TypeReference -> m CT.ConstructorType -expectDeclKind r = loadDeclKind r `whenNothingM` (unrecoverableError (InternalServerError "missing-decl-kind" $ "Couldn't find the decl kind of " <> tShow r)) +expectDeclKind r = loadDeclKind r `whenNothingM` unrecoverableError (DefnQ.missingDeclKindError r) expectDeclKindsOf :: (PG.QueryM m) => Traversal s t Reference.TypeReference CT.ConstructorType -> s -> m t expectDeclKindsOf trav s = do @@ -288,7 +330,7 @@ expectDeclKindsOf trav s = do & unsafePartsOf trav %%~ \refs -> do results <- loadDeclKindsOf traversed refs for (zip refs results) \case - (r, Nothing) -> unrecoverableError (InternalServerError "missing-decl-kind" $ "Couldn't find the decl kind of " <> tShow r) + (r, Nothing) -> unrecoverableError (DefnQ.missingDeclKindError r) (_, Just ct) -> pure ct loadDeclKind :: (PG.QueryM m) => V2.TypeReference -> m (Maybe CT.ConstructorType) @@ -376,43 +418,41 @@ data CodeLookupCache = CodeLookupCache typeCache :: Map Reference.Id (V1.Decl Symbol Ann) } -codeLookupForUser :: (MonadUnliftIO m, MonadReader (Env.Env ctx) m) => UserId -> m (CL.CodeLookup Symbol IO Ann) -codeLookupForUser codebaseOwner = do - -- A simple append-only cache that lives for the duration of the request. - cacheVar <- UnliftIO.newTVarIO (CodeLookupCache mempty mempty) - unlift <- askUnliftIO - let getTermAndType :: Reference.Id -> IO (Maybe (V1.Term Symbol Ann, V1.Type Symbol Ann)) - getTermAndType r = do - let UnliftIO.UnliftIO toIO = unlift - CodeLookupCache {termCache} <- UnliftIO.atomically $ UnliftIO.readTVar cacheVar - case Map.lookup r termCache of - Just termAndType -> pure (Just termAndType) - Nothing -> do - mayTermAndType <- toIO . PG.runTransaction $ loadTermForCodeLookup codebaseOwner r - case mayTermAndType of - Just termAndType -> do - UnliftIO.atomically $ UnliftIO.modifyTVar cacheVar $ \CodeLookupCache {termCache, ..} -> +codeLookupForUser :: TVar CodeLookupCache -> UserId -> CL.CodeLookup Symbol (PG.Transaction e) Ann +codeLookupForUser cacheVar codebaseOwner = do + CL.CodeLookup (fmap (fmap fst) . getTermAndType) (fmap (fmap snd) . getTermAndType) getTypeDecl + <> Builtin.codeLookup + <> IOSource.codeLookupM + where + getTermAndType :: + Reference.Id -> + PG.Transaction e (Maybe (V1.Term Symbol Ann, V1.Type Symbol Ann)) + getTermAndType r = do + CodeLookupCache {termCache} <- PG.transactionUnsafeIO (readTVarIO cacheVar) + case Map.lookup r termCache of + Just termAndType -> pure (Just termAndType) + Nothing -> do + maybeTermAndType <- loadTermForCodeLookup codebaseOwner r + whenJust maybeTermAndType \termAndType -> do + PG.transactionUnsafeIO do + atomically do + modifyTVar' cacheVar \CodeLookupCache {termCache, ..} -> CodeLookupCache {termCache = Map.insert r termAndType termCache, ..} - pure (Just termAndType) - Nothing -> pure Nothing - - let getTypeDecl r = do - let UnliftIO.UnliftIO toIO = unlift - CodeLookupCache {typeCache} <- UnliftIO.atomically $ UnliftIO.readTVar cacheVar - case Map.lookup r typeCache of - Just typ -> pure (Just typ) - Nothing -> do - mayTypeDecl <- toIO . PG.runTransaction $ loadTypeDeclarationForCodeLookup codebaseOwner r - case mayTypeDecl of - Just typ -> do - UnliftIO.atomically $ UnliftIO.modifyTVar cacheVar $ \CodeLookupCache {typeCache, ..} -> + pure maybeTermAndType + + getTypeDecl :: Reference.Id -> PG.Transaction e (Maybe (V1.Decl Symbol Ann)) + getTypeDecl r = do + CodeLookupCache {typeCache} <- PG.transactionUnsafeIO (readTVarIO cacheVar) + case Map.lookup r typeCache of + Just typ -> pure (Just typ) + Nothing -> do + maybeType <- loadTypeDeclarationForCodeLookup codebaseOwner r + whenJust maybeType \typ -> + PG.transactionUnsafeIO do + atomically do + modifyTVar' cacheVar \CodeLookupCache {typeCache, ..} -> CodeLookupCache {typeCache = Map.insert r typ typeCache, ..} - pure (Just typ) - Nothing -> pure Nothing - pure $ - CL.CodeLookup (\r -> fmap fst <$> getTermAndType r) (\r -> fmap snd <$> getTermAndType r) getTypeDecl - <> Builtin.codeLookup - <> IOSource.codeLookupM + pure maybeType -- | Look up the result of evaluating a term if we have it cached. -- diff --git a/src/Share/Codebase/Types.hs b/src/Share/Codebase/Types.hs index 791dacb7..ecddfd8e 100644 --- a/src/Share/Codebase/Types.hs +++ b/src/Share/Codebase/Types.hs @@ -29,10 +29,10 @@ data CodebaseEnv = CodebaseEnv { codebaseOwner :: UserId } -data CodebaseRuntime = CodebaseRuntime - { codeLookup :: CL.CodeLookup Symbol IO Ann, +data CodebaseRuntime m = CodebaseRuntime + { codeLookup :: CL.CodeLookup Symbol m Ann, -- Function to look up cached evaluation results for the runtime. - cachedEvalResult :: Reference.Id -> IO (Maybe (Rt.Term Symbol)), + cachedEvalResult :: Reference.Id -> m (Maybe (Rt.Term Symbol)), unisonRuntime :: Rt.Runtime Symbol } diff --git a/src/Share/Metrics.hs b/src/Share/Metrics.hs index 9747b64a..2745f89a 100644 --- a/src/Share/Metrics.hs +++ b/src/Share/Metrics.hs @@ -99,12 +99,11 @@ requestMetricsMiddleware api app req handleResponse = do let path = Text.intercalate "/" <$> normalizePath api (Wai.pathInfo req) let status = Just $ Text.pack (show (HTTP.statusCode (Wai.responseStatus resp))) result <- handleResponse resp - let latency :: Double - latency = fromRational (toNanoSecs (end `diffTimeSpec` start) % 1000000000) - Prom.withLabel + recordLatency requestLatency (tShow Deployment.deployment, service, fromMaybe "" method, fromMaybe "" status, fromMaybe "unknown-path" path) - (flip Prom.observe latency) + start + end pure result else app req handleResponse where @@ -426,14 +425,17 @@ webhookSendingDurationSeconds = timeActionIntoHistogram :: (Prom.Label l, MonadUnliftIO m) => (Prom.Vector l Prom.Histogram) -> l -> m c -> m c timeActionIntoHistogram histogram l m = do - UnliftIO.bracket start end \_ -> m - where - start = UnliftIO.liftIO $ Clock.getTime Monotonic - end startTime = UnliftIO.liftIO $ do - end <- Clock.getTime Monotonic - let latency :: Double - latency = fromRational (toNanoSecs (end `diffTimeSpec` startTime) % 1000000000) - Prom.withLabel histogram l (flip Prom.observe latency) + startTime <- liftIO $ Clock.getTime Monotonic + m `UnliftIO.finally` do + liftIO do + endTime <- Clock.getTime Monotonic + recordLatency histogram l startTime endTime + +recordLatency :: (Prom.Label l) => (Prom.Vector l Prom.Histogram) -> l -> Clock.TimeSpec -> Clock.TimeSpec -> IO () +recordLatency histogram l startTime endTime = do + let latency :: Double + latency = fromRational (toNanoSecs (endTime `diffTimeSpec` startTime) % 1000000000) + Prom.withLabel histogram l (flip Prom.observe latency) -- | Record the duration of a background import. recordBackgroundImportDuration :: (MonadUnliftIO m) => m r -> m r @@ -443,8 +445,10 @@ recordBackgroundImportDuration = timeActionIntoHistogram backgroundImportDuratio recordDefinitionSearchIndexDuration :: (MonadUnliftIO m) => m r -> m r recordDefinitionSearchIndexDuration = timeActionIntoHistogram definitionSearchIndexDurationSeconds (deployment, service) -recordContributionDiffDuration :: (MonadUnliftIO m) => m r -> m r -recordContributionDiffDuration = timeActionIntoHistogram contributionDiffDurationSeconds (deployment, service) +recordContributionDiffDuration :: Clock.TimeSpec -> IO () +recordContributionDiffDuration startTime = do + endTime <- Clock.getTime Monotonic + recordLatency contributionDiffDurationSeconds (deployment, service) startTime endTime -- | Record the duration of sending a webhook. recordWebhookSendingDuration :: (MonadUnliftIO m) => m r -> m r diff --git a/src/Share/NamespaceDiffs.hs b/src/Share/NamespaceDiffs.hs index 7e940dc0..79827671 100644 --- a/src/Share/NamespaceDiffs.hs +++ b/src/Share/NamespaceDiffs.hs @@ -1,7 +1,8 @@ -- | Logic for computing the differerences between two namespaces, -- typically used when showing the differences caused by a contribution. module Share.NamespaceDiffs - ( NamespaceAndLibdepsDiff, + ( NamespaceDiffResult (..), + NamespaceAndLibdepsDiff, GNamespaceAndLibdepsDiff (..), NamespaceTreeDiff, GNamespaceTreeDiff, @@ -35,8 +36,11 @@ where import Control.Comonad.Cofree (Cofree) import Control.Comonad.Cofree qualified as Cofree -import Control.Lens hiding ((:<)) +import Control.Lens hiding ((.=), (:<)) import Control.Monad.Except +import Data.Aeson (ToJSON, (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Types (ToJSON (..)) import Data.Align (Semialign (..)) import Data.Either (partitionEithers) import Data.Foldable qualified as Foldable @@ -47,9 +51,11 @@ import Data.Set.NonEmpty (NESet) import Data.Set.NonEmpty qualified as NESet import Servant (err400, err404, err500) import Share.Codebase qualified as Codebase +import Share.IDs (UserId) import Share.Names.Postgres qualified as PGNames import Share.Postgres qualified as PG -import Share.Postgres.IDs (BranchHashId) +import Share.Postgres.Definitions.Queries qualified as DefnsQ +import Share.Postgres.IDs (BranchHash, BranchHashId) import Share.Postgres.NameLookups.Ops qualified as NL import Share.Postgres.NameLookups.Types (NameLookupReceipt) import Share.Postgres.NameLookups.Types qualified as NL @@ -58,11 +64,12 @@ import Share.Utils.Logging qualified as Logging import Share.Web.Errors import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path +import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.DataDeclaration (Decl) import Unison.LabeledDependency (LabeledDependency) -import Unison.Merge (DiffOp, EitherWay, Mergeblob0, Mergeblob1, ThreeWay (..), TwoOrThreeWay (..), TwoWay (..)) +import Unison.Merge (DiffOp, EitherWay, IncoherentDeclReason (..), Mergeblob0, Mergeblob1, ThreeWay (..), TwoOrThreeWay (..), TwoWay (..)) import Unison.Merge qualified as Merge -import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason) +import Unison.Merge.EitherWay qualified as EitherWay import Unison.Merge.HumanDiffOp (HumanDiffOp (..)) import Unison.Merge.Mergeblob1 qualified as Mergeblob1 import Unison.Merge.ThreeWay qualified as ThreeWay @@ -77,6 +84,8 @@ import Unison.Reference (Reference, TermReferenceId, TypeReference, TypeReferenc import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent +import Unison.Server.Types (DisplayObjectDiff (..), TermDefinition, TermDefinitionDiff (..), TermTag, TypeDefinition, TypeDefinitionDiff (..), TypeTag) +import Unison.ShortHash (ShortHash) import Unison.Symbol (Symbol) import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Term (Term) @@ -219,6 +228,183 @@ definitionDiffKindRendered_ f = \case RenamedTo r old rendered -> RenamedTo r old <$> f rendered RenamedFrom r old rendered -> RenamedFrom r old <$> f rendered +data NamespaceDiffResult + = NamespaceDiffResult'Ok + ( NamespaceAndLibdepsDiff + (TermTag, ShortHash) + (TypeTag, ShortHash) + TermDefinition + TypeDefinition + TermDefinitionDiff + TypeDefinitionDiff + BranchHash + ) + | NamespaceDiffResult'Err NamespaceDiffError + +instance ToJSON NamespaceDiffResult where + toJSON = \case + NamespaceDiffResult'Ok diff -> + Aeson.object + [ "defns" .= namespaceTreeDiffJSON diff.defns, + "libdeps" .= libdepsDiffJSON diff.libdeps, + "tag" .= ("ok" :: Text) + ] + NamespaceDiffResult'Err err -> + Aeson.object + [ "error" .= errValue, + "tag" .= ("error" :: Text) + ] + where + errValue = + case err of + ImpossibleError _ -> + Aeson.object + [ "tag" .= ("impossibleError" :: Text) + ] + IncoherentDecl reason -> + let f :: Text -> IncoherentDeclReason -> Aeson.Value + f which reason = + Aeson.object + ( "oldOrNewBranch" .= which + : case reason of + IncoherentDeclReason'ConstructorAlias typeName constructorName1 constructorName2 -> + [ "tag" .= ("constructorAlias" :: Text), + "typeName" .= typeName, + "constructorName1" .= constructorName1, + "constructorName2" .= constructorName2 + ] + IncoherentDeclReason'MissingConstructorName typeName -> + [ "tag" .= ("missingConstructorName" :: Text), + "typeName" .= typeName + ] + IncoherentDeclReason'NestedDeclAlias constructorName1 constructorName2 -> + [ "tag" .= ("constructorAlias" :: Text), + "constructorName1" .= constructorName1, + "constructorName2" .= constructorName2 + ] + IncoherentDeclReason'StrayConstructor _ constructorName -> + [ "tag" .= ("strayConstructor" :: Text), + "constructorName" .= constructorName + ] + ) + in case reason of + EitherWay.Alice reason -> f "old" reason + EitherWay.Bob reason -> f "new" reason + LibFoundAtUnexpectedPath _ -> + Aeson.object + [ "tag" .= ("libFoundAtUnexpectedPath" :: Text) + ] + MissingEntityError _ -> + Aeson.object + [ "tag" .= ("missingEntityError" :: Text) + ] + where + text :: Text -> Text + text t = t + hqNameJSON :: Name -> NameSegment -> ShortHash -> Aeson.Value -> Aeson.Value + hqNameJSON fqn name sh rendered = Aeson.object ["hash" .= sh, "shortName" .= name, "fullName" .= fqn, "rendered" .= rendered] + -- The preferred frontend format is a bit clunky to calculate here: + diffDataJSON :: (ToJSON tag) => NameSegment -> DefinitionDiff (tag, ShortHash) Aeson.Value Aeson.Value -> (tag, Aeson.Value) + diffDataJSON shortName (DefinitionDiff {fqn, kind}) = case kind of + Added (defnTag, r) rendered -> (defnTag, Aeson.object ["tag" .= text "Added", "contents" .= hqNameJSON fqn shortName r rendered]) + NewAlias (defnTag, r) existingNames rendered -> + let contents = Aeson.object ["hash" .= r, "aliasShortName" .= shortName, "aliasFullName" .= fqn, "otherNames" .= toList existingNames, "rendered" .= rendered] + in (defnTag, Aeson.object ["tag" .= text "Aliased", "contents" .= contents]) + Removed (defnTag, r) rendered -> (defnTag, Aeson.object ["tag" .= text "Removed", "contents" .= hqNameJSON fqn shortName r rendered]) + Updated (oldTag, oldRef) (newTag, newRef) diffVal -> + let contents = Aeson.object ["oldHash" .= oldRef, "newHash" .= newRef, "shortName" .= shortName, "fullName" .= fqn, "oldTag" .= oldTag, "newTag" .= newTag, "diff" .= diffVal] + in (newTag, Aeson.object ["tag" .= text "Updated", "contents" .= contents]) + Propagated (oldTag, oldRef) (newTag, newRef) diffVal -> + let contents = Aeson.object ["oldHash" .= oldRef, "newHash" .= newRef, "shortName" .= shortName, "fullName" .= fqn, "oldTag" .= oldTag, "newTag" .= newTag, "diff" .= diffVal] + in (newTag, Aeson.object ["tag" .= text "Propagated", "contents" .= contents]) + RenamedTo (defnTag, r) newNames rendered -> + let contents = Aeson.object ["oldShortName" .= shortName, "oldFullName" .= fqn, "newNames" .= newNames, "hash" .= r, "rendered" .= rendered] + in (defnTag, Aeson.object ["tag" .= text "RenamedTo", "contents" .= contents]) + RenamedFrom (defnTag, r) oldNames rendered -> + let contents = Aeson.object ["oldNames" .= oldNames, "newShortName" .= shortName, "newFullName" .= fqn, "hash" .= r, "rendered" .= rendered] + in (defnTag, Aeson.object ["tag" .= text "RenamedFrom", "contents" .= contents]) + displayObjectDiffToJSON :: DisplayObjectDiff -> Aeson.Value + displayObjectDiffToJSON = \case + DisplayObjectDiff dispDiff -> + Aeson.object ["diff" .= dispDiff, "diffKind" .= ("diff" :: Text)] + MismatchedDisplayObjects {} -> + Aeson.object ["diffKind" .= ("mismatched" :: Text)] + + termDefinitionDiffToJSON :: TermDefinitionDiff -> Aeson.Value + termDefinitionDiffToJSON (TermDefinitionDiff {left, right, diff}) = Aeson.object ["left" .= left, "right" .= right, "diff" .= displayObjectDiffToJSON diff] + + typeDefinitionDiffToJSON :: TypeDefinitionDiff -> Aeson.Value + typeDefinitionDiffToJSON (TypeDefinitionDiff {left, right, diff}) = Aeson.object ["left" .= left, "right" .= right, "diff" .= displayObjectDiffToJSON diff] + + namespaceTreeDiffJSON :: + NamespaceTreeDiff + (TermTag, ShortHash) + (TypeTag, ShortHash) + TermDefinition + TypeDefinition + TermDefinitionDiff + TypeDefinitionDiff -> + Aeson.Value + namespaceTreeDiffJSON (diffs Cofree.:< children) = + let changesJSON = + diffs + & Map.toList + & foldMap + ( \(name, DiffAtPath {termDiffsAtPath, typeDiffsAtPath}) -> + ( Foldable.toList termDiffsAtPath + <&> over definitionDiffDiffs_ termDefinitionDiffToJSON + <&> over definitionDiffRendered_ toJSON + & fmap (diffDataJSON name) + & fmap (\(tag, dJSON) -> Aeson.object ["tag" .= tag, "contents" .= dJSON]) + ) + <> ( Foldable.toList typeDiffsAtPath + <&> over definitionDiffDiffs_ typeDefinitionDiffToJSON + <&> over definitionDiffRendered_ toJSON + & fmap (diffDataJSON name) + & fmap (\(tag, dJSON) -> Aeson.object ["tag" .= tag, "contents" .= dJSON]) + ) + ) + & toJSON @[Aeson.Value] + childrenJSON = + children + & Map.toList + & fmap + ( \(path, childNode) -> + Aeson.object ["path" .= path, "contents" .= namespaceTreeDiffJSON childNode] + ) + in Aeson.object + [ "changes" .= changesJSON, + "children" .= childrenJSON + ] + + libdepsDiffJSON :: Map NameSegment (DiffOp BranchHash) -> Aeson.Value + libdepsDiffJSON = + Map.toList + >>> map + ( \(name, op) -> + case op of + Merge.DiffOp'Add hash -> + Aeson.object + [ "hash" .= hash, + "name" .= name, + "tag" .= ("Added" :: Text) + ] + Merge.DiffOp'Delete hash -> + Aeson.object + [ "hash" .= hash, + "name" .= name, + "tag" .= ("Removed" :: Text) + ] + Merge.DiffOp'Update Merge.Updated {old, new} -> + Aeson.object + [ "name" .= name, + "newHash" .= new, + "oldHash" .= old, + "tag" .= ("Updated" :: Text) + ] + ) + >>> toJSON @[Aeson.Value] + type NamespaceAndLibdepsDiff referent reference renderedTerm renderedType termDiff typeDiff libdep = GNamespaceAndLibdepsDiff Path referent reference renderedTerm renderedType termDiff typeDiff libdep @@ -623,22 +809,37 @@ computeThreeWayNamespaceDiff codebaseEnvs2 branchHashIds3 nameLookupReceipts3 = (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) (TypeReferenceId, Decl Symbol Ann) ) <- do - let hydrateTerm :: - Codebase.CodebaseEnv -> - TermReferenceId -> - PG.Transaction e (TermReferenceId, (Term Symbol Ann, Type Symbol Ann)) - hydrateTerm codebaseEnv ref = - Codebase.codebaseMToTransaction codebaseEnv do - term <- Codebase.expectTerm ref - pure (ref, term) - hydrateType :: - Codebase.CodebaseEnv -> - TypeReferenceId -> - PG.Transaction e (TypeReferenceId, Decl Symbol Ann) - hydrateType codebaseEnv ref = - Codebase.codebaseMToTransaction codebaseEnv do - type_ <- Codebase.expectTypeDeclaration ref - pure (ref, type_) + let hydrateTerms :: + UserId -> + BiMultimap Referent Name -> + PG.Transaction e (Map Name (TermReferenceId, (Term Symbol Ann, Type Symbol Ann))) + hydrateTerms codebaseUser termReferents = do + let termReferenceIds = Map.mapMaybe Referent.toTermReferenceId (BiMultimap.range termReferents) + termIds <- + PG.pFor termReferenceIds \refId -> + (refId,) <$> DefnsQ.expectTermId refId + v2Terms <- + PG.pFor termIds \(refId, termId) -> + (refId,) <$> DefnsQ.expectTermById codebaseUser refId termId + v1Terms <- + for v2Terms \(refId, (term, typ)) -> + (refId,) <$> Codebase.convertTerm2to1 (Reference.idToHash refId) term typ + pure v1Terms + hydrateTypes :: + UserId -> + BiMultimap TypeReference Name -> + PG.Transaction e (Map Name (TypeReferenceId, Decl Symbol Ann)) + hydrateTypes codebaseUser typeReferences = do + let typeReferenceIds = Map.mapMaybe Reference.toId (BiMultimap.range typeReferences) + typeIds <- + PG.pFor typeReferenceIds \refId -> + (refId,) <$> DefnsQ.expectTypeComponentElementAndTypeId codebaseUser refId + v1Decls <- + PG.pFor typeIds \(refId, typeId) -> + DefnsQ.loadDeclByTypeComponentElementAndTypeId typeId <&> \v2Decl -> + let v1Decl = Cv.decl2to1 (Reference.idToHash refId) v2Decl + in (refId, v1Decl) + pure v1Decls f :: Codebase.CodebaseEnv -> Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> @@ -650,9 +851,8 @@ computeThreeWayNamespaceDiff codebaseEnvs2 branchHashIds3 nameLookupReceipts3 = (TypeReferenceId, Decl Symbol Ann) ) f codebaseEnv = - bitraverse - (traverse (hydrateTerm codebaseEnv) . Map.mapMaybe Referent.toTermReferenceId . BiMultimap.range) - (traverse (hydrateType codebaseEnv) . Map.mapMaybe Reference.toId . BiMultimap.range) + let codebaseUser = Codebase.codebaseOwner codebaseEnv + in bitraverse (hydrateTerms codebaseUser) (hydrateTypes codebaseUser) let -- Here we assume that the LCA is in the same codebase as Alice. codebaseEnvs3 :: ThreeWay Codebase.CodebaseEnv diff --git a/src/Share/Postgres.hs b/src/Share/Postgres.hs index 3f691355..8e9eefe9 100644 --- a/src/Share/Postgres.hs +++ b/src/Share/Postgres.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE LiberalTypeSynonyms #-} @@ -35,6 +36,7 @@ module Share.Postgres catchTransaction, unliftTransaction, runTransactionOrRespondError, + transaction, runSession, tryRunSession, runSessionOrRespondError, @@ -43,6 +45,7 @@ module Share.Postgres unliftSession, defaultIsolationLevel, pipelined, + pEitherMap, pFor, pFor_, @@ -128,6 +131,14 @@ newtype Pipeline e a = Pipeline {unPipeline :: Hasql.Pipeline.Pipeline (Either ( pipelined :: Pipeline e a -> Transaction e a pipelined p = Transaction (Hasql.pipeline (unPipeline p)) +-- | Like fmap, but the provided function can throw a recoverable error by returning 'Left'. +pEitherMap :: (a -> Either e b) -> Pipeline e a -> Pipeline e b +pEitherMap f (Pipeline p) = + Pipeline $ + p <&> \case + Right x -> mapLeft Err (f x) + Left e -> Left e + pFor :: (Traversable f) => f a -> (a -> Pipeline e b) -> Transaction e (f b) pFor f p = pipelined $ for f p @@ -327,6 +338,17 @@ class (Applicative m) => QueryA m where -- | Fail the transaction and whole request with an unrecoverable server error. unrecoverableError :: (HasCallStack, ToServerError e, Loggable e, Show e) => e -> m a + -- | Map an either-returning function over the result of an action; if it returns Left, throw an unrecoverable error. + -- This is a trivial combinator for any monad, hence the default signature, but it can be implemented by our + -- Pipeline applicative, too. + unrecoverableEitherMap :: (HasCallStack, Loggable e, Show e, ToServerError e) => (a -> Either e b) -> m a -> m b + default unrecoverableEitherMap :: (HasCallStack, Loggable e, Show e, ToServerError e, Monad m) => (a -> Either e b) -> m a -> m b + unrecoverableEitherMap f m = do + x <- m + case f x of + Right y -> pure y + Left e -> unrecoverableError e + class (Monad m, QueryA m) => QueryM m where -- | Allow running IO actions in a transaction. These actions may be run multiple times if -- the transaction is retried. @@ -357,6 +379,12 @@ instance QueryA (Pipeline e) where unrecoverableError e = Pipeline $ pure (Left (Unrecoverable (someServerError e))) + unrecoverableEitherMap f (Pipeline p) = + Pipeline $ + p <&> \case + Right x -> mapLeft (Unrecoverable . someServerError) (f x) + Left e -> Left e + instance (QueryM m) => QueryA (ReaderT e m) where statement q s = lift $ statement q s diff --git a/src/Share/Postgres/Causal/Queries.hs b/src/Share/Postgres/Causal/Queries.hs index 6157ebbd..8cac1104 100644 --- a/src/Share/Postgres/Causal/Queries.hs +++ b/src/Share/Postgres/Causal/Queries.hs @@ -976,7 +976,7 @@ importAccessibleCausals causalHashes = do pure results -- | Find the best common ancestor between two causals for diffs or merges. -bestCommonAncestor :: (QueryM m) => CausalId -> CausalId -> m (Maybe CausalId) +bestCommonAncestor :: (QueryA m) => CausalId -> CausalId -> m (Maybe CausalId) bestCommonAncestor a b = do query1Col [sql| SELECT best_common_causal_ancestor(#{a}, #{b}) as causal_id diff --git a/src/Share/Postgres/Contributions/Queries.hs b/src/Share/Postgres/Contributions/Queries.hs index 433054e7..e60afbc0 100644 --- a/src/Share/Postgres/Contributions/Queries.hs +++ b/src/Share/Postgres/Contributions/Queries.hs @@ -17,6 +17,7 @@ module Share.Postgres.Contributions.Queries performMergesAndBCAUpdatesFromBranchPush, rebaseContributionsFromMergedBranches, contributionStateTokenById, + existsPrecomputedNamespaceDiff, getPrecomputedNamespaceDiff, savePrecomputedNamespaceDiff, contributionsRelatedToBranches, @@ -539,13 +540,31 @@ contributionStateTokenById contributionId = do WHERE contribution.id = #{contributionId} |] +-- | Get whether a precomputed namespace diff exists. +existsPrecomputedNamespaceDiff :: (CodebaseEnv, CausalId) -> (CodebaseEnv, CausalId) -> PG.Transaction e Bool +existsPrecomputedNamespaceDiff + (CodebaseEnv {codebaseOwner = leftCodebaseUser}, leftCausalId) + (CodebaseEnv {codebaseOwner = rightCodebaseUser}, rightCausalId) = do + PG.queryExpect1Col @Bool + [PG.sql| + SELECT EXISTS ( + SELECT + FROM namespace_diffs + WHERE left_causal_id = #{leftCausalId} + AND right_causal_id = #{rightCausalId} + AND left_codebase_owner_user_id = #{leftCodebaseUser} + AND right_codebase_owner_user_id = #{rightCodebaseUser} + ) + |] + getPrecomputedNamespaceDiff :: + (PG.QueryA m) => (CodebaseEnv, CausalId) -> (CodebaseEnv, CausalId) -> - PG.Transaction e (Maybe Text) + m (Maybe Text) getPrecomputedNamespaceDiff (CodebaseEnv {codebaseOwner = leftCodebaseUser}, leftCausalId) - (CodebaseEnv {codebaseOwner = rightCodebaseUser}, rightCausalId) = do + (CodebaseEnv {codebaseOwner = rightCodebaseUser}, rightCausalId) = PG.query1Col @Text [PG.sql| SELECT (diff :: text) diff --git a/src/Share/Postgres/Definitions/Queries.hs b/src/Share/Postgres/Definitions/Queries.hs index ef3666c6..ae9254ee 100644 --- a/src/Share/Postgres/Definitions/Queries.hs +++ b/src/Share/Postgres/Definitions/Queries.hs @@ -3,6 +3,8 @@ module Share.Postgres.Definitions.Queries ( loadTerm, expectTerm, + expectTermId, + expectTermById, saveTermComponent, saveEncodedTermComponent, loadTermComponent, @@ -17,6 +19,8 @@ module Share.Postgres.Definitions.Queries loadDeclKindsOf, loadDecl, expectDecl, + loadDeclByTypeComponentElementAndTypeId, + expectTypeComponentElementAndTypeId, loadCachedEvalResult, saveCachedEvalResult, termReferencesByPrefix, @@ -31,6 +35,11 @@ module Share.Postgres.Definitions.Queries -- * For Migrations saveSerializedComponent, + + -- * Errors + expectedTermError, + expectedTypeError, + missingDeclKindError, ) where @@ -41,7 +50,6 @@ import Data.List.NonEmpty qualified as NE import Data.List.NonEmpty qualified as NonEmpty import Data.Set qualified as Set import Data.Text qualified as Text -import Data.Vector (Vector) import Data.Vector qualified as Vector import Servant (err500) import Share.Codebase.Types (CodebaseEnv (..), CodebaseM) @@ -81,7 +89,7 @@ import Unison.ConstructorType qualified as CT import Unison.Hash (Hash) import Unison.Hash32 (Hash32) import Unison.Hash32 qualified as Hash32 -import Unison.Reference (Reference, TypeReference) +import Unison.Reference (Reference, TermReferenceId, TypeReference, TypeReferenceId) import Unison.Reference qualified as Reference import Unison.Reference qualified as V1Reference import Unison.Referent qualified as V1Referent @@ -99,9 +107,9 @@ type PgLocalIds = LocalIds.LocalIds' TextId ComponentHashId type ComponentRef = These ComponentHash ComponentHashId data DefinitionQueryError - = ExpectedTermNotFound Reference.Id + = ExpectedTermNotFound TermReferenceId | ExpectedTermComponentNotFound ComponentRef - | ExpectedTypeNotFound Reference.Id + | ExpectedTypeNotFound TypeReferenceId | ExpectedTypeComponentNotFound ComponentRef deriving stock (Show) @@ -129,26 +137,37 @@ instance Logging.Loggable DefinitionQueryError where -- | This isn't in CodebaseM so that we can run it in a normal transaction to build the Code -- Lookup. -loadTerm :: UserId -> Reference.Id -> PG.Transaction e (Maybe (V2.Term Symbol, V2.Type Symbol)) -loadTerm userId (Reference.Id compHash (pgComponentIndex -> compIndex)) = runMaybeT $ do - termId <- - MaybeT $ - query1Col - [sql| - SELECT term.id - FROM terms term - JOIN component_hashes ON term.component_hash_id = component_hashes.id - WHERE component_hashes.base32 = #{compHash} - AND term.component_index = #{compIndex} - |] +loadTerm :: UserId -> TermReferenceId -> PG.Transaction e (Maybe (V2.Term Symbol, V2.Type Symbol)) +loadTerm userId refId = runMaybeT do + termId <- MaybeT $ loadTermId refId MaybeT $ loadTermById userId termId +loadTermId :: (QueryA m) => TermReferenceId -> m (Maybe TermId) +loadTermId (Reference.Id compHash (pgComponentIndex -> compIndex)) = + query1Col + [sql| + SELECT term.id + FROM terms term + JOIN component_hashes ON term.component_hash_id = component_hashes.id + WHERE component_hashes.base32 = #{compHash} + AND term.component_index = #{compIndex} + |] + +expectTermId :: QueryA m => TermReferenceId -> m TermId +expectTermId refId = + unrecoverableEitherMap + ( \case + Nothing -> Left (expectedTermError refId) + Just termId -> Right termId + ) + (loadTermId refId) + expectTerm :: UserId -> Reference.Id -> PG.Transaction e (V2.Term Symbol, V2.Type Symbol) expectTerm userId refId = do mayTerm <- loadTerm userId refId case mayTerm of Just term -> pure term - Nothing -> unrecoverableError $ InternalServerError "expected-term" (ExpectedTermNotFound refId) + Nothing -> unrecoverableError $ expectedTermError refId resolveComponentHash :: ComponentRef -> CodebaseM e (ComponentHash, ComponentHashId) resolveComponentHash = \case @@ -230,10 +249,8 @@ expectShareTermComponent componentHashId = do ) `whenNothingM` do lift . unrecoverableError $ InternalServerError "expected-term-component" (ExpectedTermComponentNotFound (That componentHashId)) - second (Hash32.fromHash . unComponentHash) . Share.TermComponent . toList <$> for componentElements \(termId, LocalTermBytes bytes) -> do - textLookup <- lift $ termLocalTextReferences termId - defnLookup <- lift $ termLocalComponentReferences termId - pure (Share.LocalIds {texts = textLookup, hashes = defnLookup}, bytes) + second (Hash32.fromHash . unComponentHash) . Share.TermComponent . toList <$> for componentElements \(termId, LocalTermBytes bytes) -> + (,bytes) <$> termLocalReferences termId where checkElements :: [(TermId, Maybe LocalTermBytes)] -> Maybe (NonEmpty (TermId, LocalTermBytes)) checkElements rows = @@ -260,10 +277,8 @@ expectShareTypeComponent componentHashId = do ) `whenNothingM` do lift . unrecoverableError $ InternalServerError "expected-type-component" (ExpectedTypeComponentNotFound (That componentHashId)) - second (Hash32.fromHash . unComponentHash) . Share.DeclComponent . toList <$> for componentElements \(typeId, LocalTypeBytes bytes) -> do - textLookup <- lift $ typeLocalTextReferences typeId - defnLookup <- lift $ typeLocalComponentReferences typeId - pure (Share.LocalIds {texts = Vector.toList textLookup, hashes = Vector.toList defnLookup}, bytes) + second (Hash32.fromHash . unComponentHash) . Share.DeclComponent . toList <$> for componentElements \(typeId, LocalTypeBytes bytes) -> + (,bytes) <$> typeLocalReferences typeId where checkElements :: [(TypeId, Maybe LocalTypeBytes)] -> Maybe (NonEmpty (TypeId, LocalTypeBytes)) checkElements rows = @@ -279,25 +294,49 @@ expectTypeComponent componentRef = do -- | This isn't in CodebaseM so that we can run it in a normal transaction to build the Code -- Lookup. -loadTermById :: (QueryM m) => UserId -> TermId -> m (Maybe (V2.Term Symbol, V2.Type Symbol)) -loadTermById codebaseUser termId = runMaybeT $ do - (TermComponentElement trm typ) <- - MaybeT $ - query1Col - [sql| - SELECT bytes.bytes - FROM sandboxed_terms sandboxed - JOIN bytes ON sandboxed.bytes_id = bytes.id - WHERE sandboxed.user_id = #{codebaseUser} - AND sandboxed.term_id = #{termId} - |] - textLookup <- lift $ termLocalTextReferences termId - defnLookup <- lift $ termLocalComponentReferences termId - let localIds :: ResolvedLocalIds - localIds = LocalIds.LocalIds {textLookup = Vector.fromList textLookup, defnLookup = Vector.fromList defnLookup} - pure $ s2cTermWithType (localIds, trm, typ) +loadTermById :: (QueryA m) => UserId -> TermId -> m (Maybe (V2.Term Symbol, V2.Type Symbol)) +loadTermById codebaseUser termId = do + ( \maybeTermComponentElement Share.LocalIds {texts, hashes} -> + maybeTermComponentElement <&> \(TermComponentElement trm typ) -> + s2cTermWithType + ( LocalIds.LocalIds + { textLookup = Vector.fromList texts, + defnLookup = Vector.fromList hashes + }, + trm, + typ + ) + ) + <$> loadTermComponentElementByTermId codebaseUser termId + <*> termLocalReferences termId + +expectTermById :: QueryA m => UserId -> TermReferenceId -> TermId -> m (V2.Term Symbol, V2.Type Symbol) +expectTermById userId refId termId = + unrecoverableEitherMap + ( \case + Nothing -> Left (expectedTermError refId) + Just term -> Right term + ) + (loadTermById userId termId) + +loadTermComponentElementByTermId :: (QueryA m) => UserId -> TermId -> m (Maybe TermComponentElement) +loadTermComponentElementByTermId codebaseUser termId = + query1Col + [sql| + SELECT bytes.bytes + FROM sandboxed_terms sandboxed + JOIN bytes ON sandboxed.bytes_id = bytes.id + WHERE sandboxed.user_id = #{codebaseUser} + AND sandboxed.term_id = #{termId} + |] + +termLocalReferences :: (QueryA m) => TermId -> m (Share.LocalIds Text ComponentHash) +termLocalReferences termId = + Share.LocalIds + <$> termLocalTextReferences termId + <*> termLocalComponentReferences termId -termLocalTextReferences :: (QueryM m) => TermId -> m [Text] +termLocalTextReferences :: (QueryA m) => TermId -> m [Text] termLocalTextReferences termId = queryListCol [sql| @@ -308,7 +347,7 @@ termLocalTextReferences termId = ORDER BY local_index ASC |] -termLocalComponentReferences :: (QueryM m) => TermId -> m [ComponentHash] +termLocalComponentReferences :: (QueryA m) => TermId -> m [ComponentHash] termLocalComponentReferences termId = queryListCol [sql| @@ -351,10 +390,10 @@ resolveConstructorTypeLocalIds (LocalIds.LocalIds {textLookup, defnLookup}) = substText i = textLookup ^?! ix (fromIntegral i) substHash i = unComponentHash $ (defnLookup ^?! ix (fromIntegral i)) -loadDeclKind :: (PG.QueryM m) => Reference.Id -> m (Maybe CT.ConstructorType) +loadDeclKind :: (PG.QueryA m) => TypeReferenceId -> m (Maybe CT.ConstructorType) loadDeclKind = loadDeclKindsOf id -loadDeclKindsOf :: (PG.QueryM m) => Traversal s t Reference.Id (Maybe CT.ConstructorType) -> s -> m t +loadDeclKindsOf :: (PG.QueryA m) => Traversal s t TypeReferenceId (Maybe CT.ConstructorType) -> s -> m t loadDeclKindsOf trav s = s & unsafePartsOf trav %%~ \refIds -> do @@ -377,50 +416,52 @@ loadDeclKindsOf trav s = -- | This isn't in CodebaseM so that we can run it in a normal transaction to build the Code -- Lookup. -loadDecl :: UserId -> Reference.Id -> PG.Transaction e (Maybe (V2.Decl Symbol)) -loadDecl codebaseUser (Reference.Id compHash (pgComponentIndex -> compIndex)) = runMaybeT $ do - (TypeComponentElement decl, typeId :: TypeId) <- - MaybeT $ - query1Row - [sql| - SELECT bytes.bytes, typ.id - FROM types typ - JOIN component_hashes ON typ.component_hash_id = component_hashes.id - JOIN sandboxed_types sandboxed ON typ.id = sandboxed.type_id - JOIN bytes ON sandboxed.bytes_id = bytes.id - WHERE sandboxed.user_id = #{codebaseUser} - AND component_hashes.base32 = #{compHash} - AND typ.component_index = #{compIndex} - |] - textLookup <- - Vector.fromList - <$> queryListCol - [sql| - SELECT text.text - FROM type_local_text_references - JOIN text ON type_local_text_references.text_id = text.id - WHERE type_id = #{typeId} - ORDER BY local_index ASC - |] - defnLookup <- - Vector.fromList - <$> queryListCol - [sql| - SELECT component_hashes.base32 - FROM type_local_component_references - JOIN component_hashes ON type_local_component_references.component_hash_id = component_hashes.id - WHERE type_id = #{typeId} - ORDER BY local_index ASC - |] - let localIds :: ResolvedLocalIds - localIds = LocalIds.LocalIds {textLookup, defnLookup} +loadDecl :: (QueryM m) => UserId -> TypeReferenceId -> m (Maybe (V2.Decl Symbol)) +loadDecl codebaseUser refId = runMaybeT $ do + (TypeComponentElement decl, typeId :: TypeId) <- MaybeT (loadTypeComponentElementAndTypeId codebaseUser refId) + Share.LocalIds {texts, hashes} <- typeLocalReferences typeId + let localIds = LocalIds.LocalIds {textLookup = Vector.fromList texts, defnLookup = Vector.fromList hashes} pure $ s2cDecl localIds decl -typeLocalTextReferences :: TypeId -> Transaction e (Vector Text) +loadDeclByTypeComponentElementAndTypeId :: QueryA m => (TypeComponentElement, TypeId) -> m (V2.Decl Symbol) +loadDeclByTypeComponentElementAndTypeId (TypeComponentElement decl, typeId) = + typeLocalReferences typeId <&> \Share.LocalIds {texts, hashes} -> + let localIds = LocalIds.LocalIds {textLookup = Vector.fromList texts, defnLookup = Vector.fromList hashes} + in s2cDecl localIds decl + +loadTypeComponentElementAndTypeId :: (QueryA m) => UserId -> TypeReferenceId -> m (Maybe (TypeComponentElement, TypeId)) +loadTypeComponentElementAndTypeId codebaseUser (Reference.Id compHash (pgComponentIndex -> compIndex)) = do + query1Row + [sql| + SELECT bytes.bytes, typ.id + FROM types typ + JOIN component_hashes ON typ.component_hash_id = component_hashes.id + JOIN sandboxed_types sandboxed ON typ.id = sandboxed.type_id + JOIN bytes ON sandboxed.bytes_id = bytes.id + WHERE sandboxed.user_id = #{codebaseUser} + AND component_hashes.base32 = #{compHash} + AND typ.component_index = #{compIndex} + |] + +expectTypeComponentElementAndTypeId :: QueryA m => UserId -> TermReferenceId -> m (TypeComponentElement, TypeId) +expectTypeComponentElementAndTypeId codebaseUser refId = + unrecoverableEitherMap + ( \case + Nothing -> Left (expectedTypeError refId) + Just decl -> Right decl + ) + (loadTypeComponentElementAndTypeId codebaseUser refId) + +typeLocalReferences :: (QueryA m) => TypeId -> m (Share.LocalIds Text ComponentHash) +typeLocalReferences typeId = + Share.LocalIds + <$> typeLocalTextReferences typeId + <*> typeLocalComponentReferences typeId + +typeLocalTextReferences :: (QueryA m) => TypeId -> m [Text] typeLocalTextReferences typeId = - Vector.fromList - <$> queryListCol - [sql| + queryListCol + [sql| SELECT text.text FROM type_local_text_references JOIN text ON type_local_text_references.text_id = text.id @@ -428,11 +469,10 @@ typeLocalTextReferences typeId = ORDER BY local_index ASC |] -typeLocalComponentReferences :: TypeId -> Transaction e (Vector ComponentHash) +typeLocalComponentReferences :: (QueryA m) => TypeId -> m [ComponentHash] typeLocalComponentReferences typeId = - Vector.fromList - <$> queryListCol - [sql| + queryListCol + [sql| SELECT component_hashes.base32 FROM type_local_component_references JOIN component_hashes ON type_local_component_references.component_hash_id = component_hashes.id @@ -1167,3 +1207,15 @@ saveSerializedComponent chId (CBORBytes bytes) = do VALUES (#{codebaseOwnerUserId}, #{chId}, #{bytesId}) ON CONFLICT DO NOTHING |] + +expectedTermError :: TermReferenceId -> InternalServerError DefinitionQueryError +expectedTermError refId = + InternalServerError "expected-term" (ExpectedTermNotFound refId) + +expectedTypeError :: TypeReferenceId -> InternalServerError DefinitionQueryError +expectedTypeError refId = + InternalServerError "expected-type" (ExpectedTypeNotFound refId) + +missingDeclKindError :: TypeReference -> InternalServerError Text +missingDeclKindError r = + InternalServerError "missing-decl-kind" $ "Couldn't find the decl kind of " <> tShow r diff --git a/src/Share/Postgres/Hashes/Queries.hs b/src/Share/Postgres/Hashes/Queries.hs index 34409a04..6d422a0a 100644 --- a/src/Share/Postgres/Hashes/Queries.hs +++ b/src/Share/Postgres/Hashes/Queries.hs @@ -236,30 +236,27 @@ addKnownCausalHashMismatch providedHash actualHash = do |] -- | Generic helper which fetches both branch hashes and causal hashes -expectCausalHashesOfG :: (HasCallStack, QueryM m) => ((BranchHash, CausalHash) -> h) -> Traversal s t CausalId h -> s -> m t +expectCausalHashesOfG :: (HasCallStack, QueryA m) => ((BranchHash, CausalHash) -> h) -> Traversal s t CausalId h -> s -> m t expectCausalHashesOfG project trav = do unsafePartsOf trav %%~ \hashIds -> do let numberedHashIds = zip [0 :: Int32 ..] hashIds - results :: [(BranchHash, CausalHash)] <- - queryListRows + (\results -> if length results /= length hashIds then error "expectCausalHashesOf: Missing expected causal hash" else (project <$> results)) + <$> queryListRows [sql| - WITH causal_ids(ord, id) AS ( - SELECT * FROM ^{toTable numberedHashIds} - ) - SELECT bh.base32, causal.hash - FROM causal_ids - JOIN causals causal ON causal.id = causal_ids.id - JOIN branch_hashes bh ON causal.namespace_hash_id = bh.id - ORDER BY causal_ids.ord ASC - |] - if length results /= length hashIds - then error "expectCausalHashesOf: Missing expected causal hash" - else pure (project <$> results) + WITH causal_ids(ord, id) AS ( + SELECT * FROM ^{toTable numberedHashIds} + ) + SELECT bh.base32, causal.hash + FROM causal_ids + JOIN causals causal ON causal.id = causal_ids.id + JOIN branch_hashes bh ON causal.namespace_hash_id = bh.id + ORDER BY causal_ids.ord ASC + |] -expectCausalAndBranchHashesOf :: (HasCallStack, QueryM m) => Traversal s t CausalId (BranchHash, CausalHash) -> s -> m t +expectCausalAndBranchHashesOf :: (HasCallStack, QueryA m) => Traversal s t CausalId (BranchHash, CausalHash) -> s -> m t expectCausalAndBranchHashesOf = expectCausalHashesOfG id -expectCausalHashesByIdsOf :: (HasCallStack, QueryM m) => Traversal s t CausalId CausalHash -> s -> m t +expectCausalHashesByIdsOf :: (HasCallStack, QueryA m) => Traversal s t CausalId CausalHash -> s -> m t expectCausalHashesByIdsOf = expectCausalHashesOfG snd expectCausalIdsOf :: (HasCallStack) => Traversal s t CausalHash (BranchHashId, CausalId) -> s -> CodebaseM e t diff --git a/src/Share/Postgres/NameLookups/Ops.hs b/src/Share/Postgres/NameLookups/Ops.hs index 953236c2..4f7dfa6c 100644 --- a/src/Share/Postgres/NameLookups/Ops.hs +++ b/src/Share/Postgres/NameLookups/Ops.hs @@ -20,7 +20,7 @@ import Control.Lens import Control.Monad.Trans.Maybe import Data.List.NonEmpty qualified as NonEmpty import Data.Set qualified as Set -import Share.Postgres (QueryM) +import Share.Postgres (QueryA, QueryM) import Share.Postgres qualified as PG import Share.Postgres.Cursors qualified as Cursor import Share.Postgres.Hashes.Queries qualified as HashQ @@ -188,10 +188,10 @@ deleteNameLookupsExceptFor reachable = do bhIds <- for (Set.toList reachable) HashQ.ensureBranchHashId Q.deleteNameLookupsExceptFor bhIds -ensureNameLookupForBranchId :: (QueryM m) => BranchHashId -> m NameLookupReceipt -ensureNameLookupForBranchId branchHashId = do - PG.execute_ [PG.sql| SELECT ensure_name_lookup(#{branchHashId}) |] - pure $ UnsafeNameLookupReceipt +ensureNameLookupForBranchId :: (QueryA m) => BranchHashId -> m NameLookupReceipt +ensureNameLookupForBranchId branchHashId = + UnsafeNameLookupReceipt + <$ PG.execute_ [PG.sql| SELECT ensure_name_lookup(#{branchHashId}) |] -- | Build a 'Names' for all definitions within the given root, without any dependencies. -- Note: This loads everything into memory at once, so avoid this and prefer streaming when possible. diff --git a/src/Share/Postgres/Notifications.hs b/src/Share/Postgres/Notifications.hs index 5e409d73..17bc91a4 100644 --- a/src/Share/Postgres/Notifications.hs +++ b/src/Share/Postgres/Notifications.hs @@ -30,8 +30,10 @@ data NotificationError deriving stock (Show) deriving (Logging.Loggable) via (Logging.ShowLoggable Logging.Error NotificationError) +-- Initialize the set of channel kinds to check with every channel kind, so that on server startup, workers do any +-- outstanding work. notifs :: TVar (Set ChannelKind) -notifs = unsafePerformIO $ STM.newTVarIO mempty +notifs = unsafePerformIO $ STM.newTVarIO allChannels {-# NOINLINE notifs #-} -- | Initializes the notification worker, which listens for notifications from the database. @@ -39,10 +41,10 @@ notifs = unsafePerformIO $ STM.newTVarIO mempty initialize :: Ki.Scope -> -- The scope of the server Background () -initialize scope = void $ Ki.fork scope $ forever do +initialize scope = Ki.fork_ scope $ forever do result <- UnliftIO.try $ do PG.runSession $ do - for_ [minBound .. maxBound] \kind -> do + for_ allChannels \kind -> do PG.statement () $ Hasql.listen (Hasql.Identifier . Text.encodeUtf8 $ toChannelText kind) -- Wait for notifications let loop = do @@ -79,6 +81,10 @@ fromChannelText = \case "webhooks" -> Just WebhooksChannel _ -> Nothing +allChannels :: Set ChannelKind +allChannels = + Set.fromList [minBound .. maxBound] + -- | Block waiting on a channel until either we get a notification OR until the max polling time has been reached -- -- The channel notifications can help ensure we process items as they come in, but they're not diff --git a/src/Share/Utils/Caching.hs b/src/Share/Utils/Caching.hs index 5aad05df..eef64a20 100644 --- a/src/Share/Utils/Caching.hs +++ b/src/Share/Utils/Caching.hs @@ -6,6 +6,7 @@ module Share.Utils.Caching ( cachedResponse, + conditionallyCachedResponse, causalIdCacheKey, branchIdCacheKey, Cached, @@ -54,7 +55,22 @@ cachedResponse :: -- | How to generate the response if it's not in the cache. WebApp a -> WebApp (Cached ct a) -cachedResponse authzReceipt endpointName cacheParams action = do +cachedResponse authzReceipt endpointName cacheParams action = + conditionallyCachedResponse authzReceipt endpointName cacheParams ((,True) <$> action) + +-- | Like 'cachedResponse', but only cache (True, x) values. +conditionallyCachedResponse :: + forall ct a. + (Servant.MimeRender ct a) => + AuthZ.AuthZReceipt -> + -- | The name of the endpoint we're caching. Must be unique. + Text -> + -- | Cache Keys: All parameters which affect the response + [Text] -> + -- | How to generate the response if it's not in the cache. True means cache, false means don't cache. + WebApp (a, Bool) -> + WebApp (Cached ct a) +conditionallyCachedResponse authzReceipt endpointName cacheParams action = do requestIsCacheable <- shouldUseCaching let mayCachingToken = AuthZ.getCacheability authzReceipt let shouldUseCaching = requestIsCacheable && isJust mayCachingToken @@ -65,14 +81,13 @@ cachedResponse authzReceipt endpointName cacheParams action = do case mayCachedResponse of Just cachedResponse -> pure cachedResponse Nothing -> do - a <- action + (a, cache) <- action let cachedResponse :: Cached ct a cachedResponse = Cached . BL.toStrict $ Servant.mimeRender (Proxy @ct) a - -- Only actually cache the response if it's valid to do so. - case mayCachingToken of - Just ct | shouldUseCaching -> do - cacheResponse ct endpointName cacheParams $ cachedResponse - _ -> pure () + when (shouldUseCaching && cache) do + -- Only actually cache the response if it's valid to do so. + whenJust mayCachingToken \ct -> + cacheResponse ct endpointName cacheParams cachedResponse pure cachedResponse -- | Cached responses expire if not accessed in 7 days. diff --git a/src/Share/Web/Share/Contributions/Impl.hs b/src/Share/Web/Share/Contributions/Impl.hs index 04ac72b7..84b088c2 100644 --- a/src/Share/Web/Share/Contributions/Impl.hs +++ b/src/Share/Web/Share/Contributions/Impl.hs @@ -14,7 +14,9 @@ module Share.Web.Share.Contributions.Impl where import Control.Lens hiding ((.=)) +import Data.ByteString.Lazy qualified as ByteString.Lazy import Data.Set qualified as Set +import Data.Text.Encoding qualified as Text import Servant import Servant.Server.Generic (AsServerT) import Share.BackgroundJobs.Diffs.Queries qualified as DiffsQ @@ -38,6 +40,7 @@ import Share.Prelude import Share.Project import Share.User qualified as User import Share.Utils.API +import Share.Utils.Aeson (PreEncoded (..)) import Share.Utils.Caching (Cached) import Share.Utils.Caching qualified as Caching import Share.Web.App @@ -52,7 +55,7 @@ import Share.Web.Share.Contributions.API qualified as API import Share.Web.Share.Contributions.MergeDetection qualified as MergeDetection import Share.Web.Share.Contributions.Types import Share.Web.Share.Diffs.Impl qualified as Diffs -import Share.Web.Share.Diffs.Types (ShareNamespaceDiffResponse (..), ShareTermDiffResponse (..), ShareTypeDiffResponse (..)) +import Share.Web.Share.Diffs.Types (ShareNamespaceDiffResponse (..), ShareNamespaceDiffStatus (..), ShareTermDiffResponse (..), ShareTypeDiffResponse (..)) import Share.Web.Share.DisplayInfo (UserDisplayInfo (..)) import Unison.Name (Name) import Unison.Server.Types @@ -261,7 +264,7 @@ contributionDiffEndpoint :: WebApp (Cached JSON ShareNamespaceDiffResponse) contributionDiffEndpoint (AuthN.MaybeAuthedUserID mayCallerUserId) userHandle projectSlug contributionNumber = do ( project@Project {projectId}, - Contribution {contributionId, bestCommonAncestorCausalId}, + Contribution {contributionId}, oldBranch@Branch {causal = oldBranchCausalId, branchId = oldBranchId}, newBranch@Branch {causal = newBranchCausalId, branchId = newBranchId} ) <- PG.runTransactionOrRespondError $ do @@ -279,21 +282,28 @@ contributionDiffEndpoint (AuthN.MaybeAuthedUserID mayCallerUserId) userHandle pr 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] - Caching.cachedResponse authZReceipt "contribution-diff" cacheKeys do - namespaceDiff <- respondExceptT (Diffs.diffCausals authZReceipt (oldCodebase, oldBranchCausalId) (newCodebase, newBranchCausalId) bestCommonAncestorCausalId) - (newBranchCausalHash, oldBranchCausalHash) <- PG.runTransaction do - newBranchCausalHash <- CausalQ.expectCausalHashesByIdsOf id newBranchCausalId - oldBranchCausalHash <- CausalQ.expectCausalHashesByIdsOf id oldBranchCausalId - pure (newBranchCausalHash, oldBranchCausalHash) - pure $ - ShareNamespaceDiffResponse - { project = projectShorthand, - newRef = IDs.IsBranchShortHand $ IDs.projectBranchShortHandToBranchShortHand newPBSH, - newRefHash = Just $ PrefixedHash newBranchCausalHash, - oldRef = IDs.IsBranchShortHand $ IDs.projectBranchShortHandToBranchShortHand oldPBSH, - oldRefHash = Just $ PrefixedHash oldBranchCausalHash, - diff = namespaceDiff - } + Caching.conditionallyCachedResponse authZReceipt "contribution-diff" cacheKeys do + (oldBranchCausalHash, newBranchCausalHash, maybeNamespaceDiff) <- + PG.runTransaction do + PG.pipelined do + (,,) + <$> CausalQ.expectCausalHashesByIdsOf id oldBranchCausalId + <*> CausalQ.expectCausalHashesByIdsOf id newBranchCausalId + <*> ContributionsQ.getPrecomputedNamespaceDiff (oldCodebase, oldBranchCausalId) (newCodebase, newBranchCausalId) + let response = + ShareNamespaceDiffResponse + { project = projectShorthand, + newRef = IDs.IsBranchShortHand $ IDs.projectBranchShortHandToBranchShortHand newPBSH, + newRefHash = Just $ PrefixedHash newBranchCausalHash, + oldRef = IDs.IsBranchShortHand $ IDs.projectBranchShortHandToBranchShortHand oldPBSH, + oldRefHash = Just $ PrefixedHash oldBranchCausalHash, + diff = + case maybeNamespaceDiff of + Just diff -> ShareNamespaceDiffStatus'Done (PreEncoded (ByteString.Lazy.fromStrict (Text.encodeUtf8 diff))) + Nothing -> ShareNamespaceDiffStatus'StillComputing + } + let shouldCache = isJust maybeNamespaceDiff + pure (response, shouldCache) where projectShorthand = IDs.ProjectShortHand {userHandle, projectSlug} @@ -327,11 +337,21 @@ contributionDiffTermsEndpoint (AuthN.MaybeAuthedUserID mayCallerUserId) userHand 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) - termDiff <- - respondExceptT (Diffs.diffTerms authZReceipt (oldCodebase, oldBranchHashId, oldTermName) (newCodebase, newBranchHashId, newTermName)) + oldRuntime <- Codebase.codebaseRuntime oldCodebase + newRuntime <- Codebase.codebaseRuntime newCodebase + termDiff <- do + result <- + PG.tryRunTransaction do + (oldBranchHashId, newBranchHashId) <- CausalQ.expectNamespaceIdsByCausalIdsOf both (oldCausalId, newBranchCausalId) + Diffs.diffTerms + authZReceipt + (oldCodebase, oldRuntime, oldBranchHashId, oldTermName) + (newCodebase, newRuntime, newBranchHashId, newTermName) + case result of + Left err -> respondError err -- Not exactly a "term not found" - one or both term names is a constructor - but probably ok for now - `whenNothingM` respondError (EntityMissing (ErrorID "term:missing") "Term not found") + Right Nothing -> respondError (EntityMissing (ErrorID "term:missing") "Term not found") + Right (Just diff) -> pure diff pure ShareTermDiffResponse { project = projectShorthand, @@ -375,8 +395,13 @@ contributionDiffTypesEndpoint (AuthN.MaybeAuthedUserID mayCallerUserId) userHand 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) - typeDiff <- respondExceptT (Diffs.diffTypes authZReceipt (oldCodebase, oldBranchHashId, oldTypeName) (newCodebase, newBranchHashId, newTypeName)) + oldRuntime <- Codebase.codebaseRuntime oldCodebase + newRuntime <- Codebase.codebaseRuntime newCodebase + typeDiff <- + (either respondError pure =<<) do + PG.tryRunTransaction do + (oldBranchHashId, newBranchHashId) <- CausalQ.expectNamespaceIdsByCausalIdsOf both (oldCausalId, newBranchCausalId) + Diffs.diffTypes authZReceipt (oldCodebase, oldRuntime, oldBranchHashId, oldTypeName) (newCodebase, newRuntime, newBranchHashId, newTypeName) pure $ ShareTypeDiffResponse { project = projectShorthand, diff --git a/src/Share/Web/Share/Diffs/Impl.hs b/src/Share/Web/Share/Diffs/Impl.hs index e2908b3f..3f961631 100644 --- a/src/Share/Web/Share/Diffs/Impl.hs +++ b/src/Share/Web/Share/Diffs/Impl.hs @@ -1,24 +1,17 @@ module Share.Web.Share.Diffs.Impl - ( diffCausals, + ( computeAndStoreCausalDiff, diffTerms, diffTypes, ) where -import Control.Comonad.Cofree qualified as Cofree import Control.Lens hiding ((.=)) import Control.Monad.Except -import Control.Monad.Trans.Except (except) -import Data.Aeson (ToJSON (..), Value, (.=)) import Data.Aeson qualified as Aeson -import Data.Aeson.Types (object) -import Data.Foldable qualified as Foldable -import Data.Map qualified as Map import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding qualified as TL -import Share.App (AppM) import Share.Codebase qualified as Codebase -import Share.NamespaceDiffs (DefinitionDiff (..), DefinitionDiffKind (..), DiffAtPath (..), GNamespaceAndLibdepsDiff, GNamespaceTreeDiff, NamespaceAndLibdepsDiff, NamespaceDiffError (..), NamespaceTreeDiff) +import Share.NamespaceDiffs (DefinitionDiffKind (..), GNamespaceTreeDiff, NamespaceDiffError (..)) import Share.NamespaceDiffs qualified as NamespaceDiffs import Share.Postgres qualified as PG import Share.Postgres.Causal.Queries qualified as CausalQ @@ -36,13 +29,10 @@ import Share.Web.Errors import U.Codebase.Reference qualified as V2Reference import Unison.Codebase.SqliteCodebase.Conversions (referent1to2) import Unison.ConstructorReference (ConstructorReference) -import Unison.Merge (DiffOp (..), TwoOrThreeWay (..), TwoWay (..)) -import Unison.Merge qualified as Merge +import Unison.Merge (TwoOrThreeWay (..), TwoWay (..)) import Unison.Name (Name) import Unison.NameSegment (NameSegment) import Unison.PrettyPrintEnvDecl qualified as PPED -import Unison.Reference (TypeReference) -import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Server.Backend.DefinitionDiff qualified as DefinitionDiff import Unison.Server.NameSearch.Postgres qualified as PGNameSearch @@ -51,153 +41,116 @@ import Unison.Server.Types import Unison.ShortHash (ShortHash) import Unison.Syntax.Name qualified as Name import Unison.Util.Pretty (Width) -import UnliftIO qualified -diffCausals :: +-- | Diff two causals and store the diff in the database. +computeAndStoreCausalDiff :: AuthZReceipt -> - (Codebase.CodebaseEnv, CausalId) -> - (Codebase.CodebaseEnv, CausalId) -> + (Codebase.CodebaseEnv, Codebase.CodebaseRuntime IO, CausalId) -> + (Codebase.CodebaseEnv, Codebase.CodebaseRuntime IO, CausalId) -> Maybe CausalId -> - ExceptT - NamespaceDiffs.NamespaceDiffError - (AppM r) - ( PreEncoded - ( NamespaceDiffs.NamespaceAndLibdepsDiff - (TermTag, ShortHash) - (TypeTag, ShortHash) - TermDefinition - TypeDefinition - TermDefinitionDiff - TypeDefinitionDiff - BranchHash - ) + PG.Transaction e (PreEncoded NamespaceDiffs.NamespaceDiffResult) +computeAndStoreCausalDiff authZReceipt old@(oldCodebase, _, oldCausalId) new@(newCodebase, _, newCausalId) lca = do + result <- + PG.catchTransaction (tryComputeCausalDiff authZReceipt old new lca) <&> \case + Right diff -> NamespaceDiffs.NamespaceDiffResult'Ok diff + Left err -> NamespaceDiffs.NamespaceDiffResult'Err err + let encoded = Aeson.encode result + ContributionQ.savePrecomputedNamespaceDiff + (oldCodebase, oldCausalId) + (newCodebase, newCausalId) + (TL.toStrict $ TL.decodeUtf8 encoded) + pure (PreEncoded encoded) + +tryComputeCausalDiff :: + AuthZReceipt -> + (Codebase.CodebaseEnv, Codebase.CodebaseRuntime IO, CausalId) -> + (Codebase.CodebaseEnv, Codebase.CodebaseRuntime IO, CausalId) -> + Maybe CausalId -> + PG.Transaction + NamespaceDiffError + ( NamespaceDiffs.NamespaceAndLibdepsDiff + (TermTag, ShortHash) + (TypeTag, ShortHash) + TermDefinition + TypeDefinition + TermDefinitionDiff + TypeDefinitionDiff + BranchHash ) -diffCausals !authZReceipt (oldCodebase, oldCausalId) (newCodebase, newCausalId) maybeLcaCausalId = do +tryComputeCausalDiff !authZReceipt (oldCodebase, oldRuntime, oldCausalId) (newCodebase, newRuntime, newCausalId) maybeLcaCausalId = do -- Ensure name lookups for the things we're diffing. - -- We do this in separate transactions to ensure we can still make progress even if we need to build name lookups. - let getBranch :: CausalId -> ExceptT NamespaceDiffs.NamespaceDiffError (AppM r) (BranchHashId, NameLookupReceipt) - getBranch causalId = - PG.runTransaction do - branchHashId <- CausalQ.expectNamespaceIdsByCausalIdsOf id causalId - nameLookupReceipt <- NLOps.ensureNameLookupForBranchId branchHashId - pure (branchHashId, nameLookupReceipt) - (((oldBranchHashId, oldBranchNLReceipt), (newBranchHashId, newBranchNLReceipt))) <- - getBranch oldCausalId `concurrentExceptT` getBranch newCausalId - PG.runTransaction (ContributionQ.getPrecomputedNamespaceDiff (oldCodebase, oldCausalId) (newCodebase, newCausalId)) >>= \case - Just diff -> pure $ PreEncoded $ TL.encodeUtf8 $ TL.fromStrict diff - Nothing -> do - (maybeLcaBranchHashId, maybeLcaBranchNLReceipt) <- - case maybeLcaCausalId of - Just lcaCausalId -> do - (lcaBranchHashId, lcaBranchNLReceipt) <- getBranch lcaCausalId - pure (Just lcaBranchHashId, Just lcaBranchNLReceipt) - Nothing -> pure (Nothing, Nothing) - diff0 <- - ExceptT do - PG.tryRunTransaction do - -- Do the initial 3-way namespace diff - diff :: - GNamespaceAndLibdepsDiff - NameSegment - Referent - TypeReference - Name - Name - Name - Name - BranchHashId <- - NamespaceDiffs.computeThreeWayNamespaceDiff - TwoWay {alice = oldCodebase, bob = newCodebase} - TwoOrThreeWay {alice = oldBranchHashId, bob = newBranchHashId, lca = maybeLcaBranchHashId} - TwoOrThreeWay {alice = oldBranchNLReceipt, bob = newBranchNLReceipt, lca = maybeLcaBranchNLReceipt} - -- Resolve the term referents to tag + hash - diff1 :: - GNamespaceAndLibdepsDiff - NameSegment - (TermTag, ShortHash) - TypeReference - Name - Name - Name - Name - BranchHashId <- - diff - & unsafePartsOf (NamespaceDiffs.namespaceAndLibdepsDiffDefns_ . NamespaceDiffs.namespaceTreeDiffReferents_) - %%~ \refs -> do - termTags <- Codebase.termTagsByReferentsOf (\f -> traverse (f . referent1to2)) refs - pure $ zip termTags (refs <&> Referent.toShortHash) - -- Resolve the type references to tag + hash - diff2 :: - GNamespaceAndLibdepsDiff - NameSegment - (TermTag, ShortHash) - (TypeTag, ShortHash) - Name - Name - Name - Name - BranchHashId <- - diff1 - & unsafePartsOf (NamespaceDiffs.namespaceAndLibdepsDiffDefns_ . NamespaceDiffs.namespaceTreeDiffReferences_) - %%~ \refs -> do - typeTags <- Codebase.typeTagsByReferencesOf traversed refs - pure $ zip typeTags (refs <&> V2Reference.toShortHash) - -- Resolve libdeps branch hash ids to branch hashes - diff3 :: - GNamespaceAndLibdepsDiff - NameSegment - (TermTag, ShortHash) - (TypeTag, ShortHash) - Name - Name - Name - Name - BranchHash <- - HashQ.expectNamespaceHashesByNamespaceHashIdsOf - (NamespaceDiffs.namespaceAndLibdepsDiffLibdeps_ . traversed . traversed) - diff2 - pure diff3 - -- Resolve the actual term/type definitions. Use the LCA as the "old" (because that's what we're rendering the - -- diff relative to, unless there isn't an LCA (unlikely), in which case we fall back on the other branch (we - -- won't have anything classified as an "update" in this case so it doesn't really matter). - diff1 <- - diff0 - & NamespaceDiffs.namespaceAndLibdepsDiffDefns_ - %%~ computeUpdatedDefinitionDiffs - authZReceipt - (oldCodebase, fromMaybe oldBranchHashId maybeLcaBranchHashId) - (newCodebase, newBranchHashId) - let encoded = Aeson.encode (RenderedNamespaceAndLibdepsDiff diff1) - PG.runTransaction $ - ContributionQ.savePrecomputedNamespaceDiff - (oldCodebase, oldCausalId) - (newCodebase, newCausalId) - (TL.toStrict $ TL.decodeUtf8 encoded) - pure $ PreEncoded encoded + let getBranch :: CausalId -> PG.Transaction NamespaceDiffError (BranchHashId, NameLookupReceipt) + getBranch causalId = do + branchHashId <- CausalQ.expectNamespaceIdsByCausalIdsOf id causalId + nameLookupReceipt <- NLOps.ensureNameLookupForBranchId branchHashId + pure (branchHashId, nameLookupReceipt) + (oldBranchHashId, oldBranchNLReceipt) <- getBranch oldCausalId + (newBranchHashId, newBranchNLReceipt) <- getBranch newCausalId + (maybeLcaBranchHashId, maybeLcaBranchNLReceipt) <- + case maybeLcaCausalId of + Just lcaCausalId -> do + (lcaBranchHashId, lcaBranchNLReceipt) <- getBranch lcaCausalId + pure (Just lcaBranchHashId, Just lcaBranchNLReceipt) + Nothing -> pure (Nothing, Nothing) + -- Do the initial 3-way namespace diff + diff0 <- + NamespaceDiffs.computeThreeWayNamespaceDiff + TwoWay {alice = oldCodebase, bob = newCodebase} + TwoOrThreeWay {alice = oldBranchHashId, bob = newBranchHashId, lca = maybeLcaBranchHashId} + TwoOrThreeWay {alice = oldBranchNLReceipt, bob = newBranchNLReceipt, lca = maybeLcaBranchNLReceipt} + -- Resolve the term referents to tag + hash + diff1 <- + diff0 + & unsafePartsOf (NamespaceDiffs.namespaceAndLibdepsDiffDefns_ . NamespaceDiffs.namespaceTreeDiffReferents_) + %%~ \refs -> do + termTags <- Codebase.termTagsByReferentsOf (\f -> traverse (f . referent1to2)) refs + pure $ zip termTags (refs <&> Referent.toShortHash) + -- Resolve the type references to tag + hash + diff2 <- + diff1 + & unsafePartsOf (NamespaceDiffs.namespaceAndLibdepsDiffDefns_ . NamespaceDiffs.namespaceTreeDiffReferences_) + %%~ \refs -> do + typeTags <- Codebase.typeTagsByReferencesOf traversed refs + pure $ zip typeTags (refs <&> V2Reference.toShortHash) + -- Resolve libdeps branch hash ids to branch hashes + diff3 <- + HashQ.expectNamespaceHashesByNamespaceHashIdsOf + (NamespaceDiffs.namespaceAndLibdepsDiffLibdeps_ . traversed . traversed) + diff2 + -- Resolve the actual term/type definitions. Use the LCA as the "old" (because that's what we're rendering the + -- diff relative to, unless there isn't an LCA (unlikely), in which case we fall back on the other branch (we + -- won't have anything classified as an "update" in this case so it doesn't really matter). + diff4 <- + diff3 + & NamespaceDiffs.namespaceAndLibdepsDiffDefns_ + %%~ computeUpdatedDefinitionDiffs + authZReceipt + (oldCodebase, oldRuntime, fromMaybe oldBranchHashId maybeLcaBranchHashId) + (newCodebase, newRuntime, newBranchHashId) + pure diff4 computeUpdatedDefinitionDiffs :: - forall a b r. + forall a b. (Ord a, Ord b) => AuthZReceipt -> - (Codebase.CodebaseEnv, BranchHashId) -> - (Codebase.CodebaseEnv, BranchHashId) -> + (Codebase.CodebaseEnv, Codebase.CodebaseRuntime IO, BranchHashId) -> + (Codebase.CodebaseEnv, Codebase.CodebaseRuntime IO, BranchHashId) -> GNamespaceTreeDiff NameSegment a b Name Name Name Name -> - ExceptT + PG.Transaction NamespaceDiffError - (AppM r) (NamespaceDiffs.NamespaceTreeDiff a b TermDefinition TypeDefinition TermDefinitionDiff TypeDefinitionDiff) -computeUpdatedDefinitionDiffs !authZReceipt (fromCodebase, fromBHId) (toCodebase, toBHId) diff0 = do +computeUpdatedDefinitionDiffs !authZReceipt (fromCodebase, fromRuntime, fromBHId) (toCodebase, toRuntime, toBHId) diff0 = do diff1 <- NamespaceDiffs.witherNamespaceTreeDiffTermDiffs - (\name -> diffTerms authZReceipt (fromCodebase, fromBHId, name) (toCodebase, toBHId, name)) + (\name -> diffTerms authZReceipt (fromCodebase, fromRuntime, fromBHId, name) (toCodebase, toRuntime, toBHId, name)) diff0 diff2 <- NamespaceDiffs.witherNamespaceTreeTermDiffKinds - (throwAwayConstructorDiffs . renderDiffKind (ExceptT . fmap sequence . getTermDefinition)) + (fmap throwAwayConstructorDiffs . renderDiffKind getTermDefinition) diff1 diff3 <- NamespaceDiffs.namespaceTreeDiffTypeDiffs_ - (\name -> diffTypes authZReceipt (fromCodebase, fromBHId, name) (toCodebase, toBHId, name)) + (\name -> diffTypes authZReceipt (fromCodebase, fromRuntime, fromBHId, name) (toCodebase, toRuntime, toBHId, name)) diff2 diff4 <- NamespaceDiffs.namespaceTreeTypeDiffKinds_ @@ -208,44 +161,45 @@ computeUpdatedDefinitionDiffs !authZReceipt (fromCodebase, fromBHId) (toCodebase notFound name t = MissingEntityError $ EntityMissing (ErrorID "definition-not-found") (t <> ": Definition not found: " <> Name.toText name) renderDiffKind :: - forall diff m r x. - (Monad m) => - ((Codebase.CodebaseEnv, BranchHashId, Name) -> m (Maybe x)) -> + forall diff r x. + ((Codebase.CodebaseEnv, Codebase.CodebaseRuntime IO, BranchHashId, Name) -> PG.Transaction NamespaceDiffError (Maybe x)) -> DefinitionDiffKind r Name diff -> - ExceptT NamespaceDiffError m (DefinitionDiffKind r x diff) + PG.Transaction NamespaceDiffError (DefinitionDiffKind r x diff) renderDiffKind getter = \case - Added r name -> Added r <$> (lift (getter (toCodebase, toBHId, name)) `whenNothingM` throwError (notFound name "Added")) - NewAlias r existingNames name -> NewAlias r existingNames <$> (lift (getter (toCodebase, toBHId, name)) `whenNothingM` throwError (notFound name "NewAlias")) - Removed r name -> Removed r <$> (lift (getter (fromCodebase, fromBHId, name)) `whenNothingM` throwError (notFound name "Removed")) + Added r name -> Added r <$> (getter (toCodebase, toRuntime, toBHId, name) `whenNothingM` throwError (notFound name "Added")) + NewAlias r existingNames name -> NewAlias r existingNames <$> (getter (toCodebase, toRuntime, toBHId, name) `whenNothingM` throwError (notFound name "NewAlias")) + Removed r name -> Removed r <$> (getter (fromCodebase, fromRuntime, fromBHId, name) `whenNothingM` throwError (notFound name "Removed")) Updated oldRef newRef diff -> pure $ Updated oldRef newRef diff Propagated oldRef newRef diff -> pure $ Propagated oldRef newRef diff - RenamedTo r names name -> RenamedTo r names <$> (lift (getter (fromCodebase, fromBHId, name)) `whenNothingM` throwError (notFound name "RenamedTo")) - RenamedFrom r names name -> RenamedFrom r names <$> (lift (getter (toCodebase, toBHId, name)) `whenNothingM` throwError (notFound name "RenamedFrom")) + RenamedTo r names name -> RenamedTo r names <$> (getter (fromCodebase, fromRuntime, fromBHId, name) `whenNothingM` throwError (notFound name "RenamedTo")) + RenamedFrom r names name -> RenamedFrom r names <$> (getter (toCodebase, toRuntime, toBHId, name) `whenNothingM` throwError (notFound name "RenamedFrom")) throwAwayConstructorDiffs :: - ExceptT - NamespaceDiffError - (ExceptT ConstructorReference (AppM r)) - (DefinitionDiffKind a TermDefinition TermDefinitionDiff) -> - ExceptT - NamespaceDiffError - (AppM r) - (Maybe (DefinitionDiffKind a TermDefinition TermDefinitionDiff)) - throwAwayConstructorDiffs m = - lift (runExceptT (runExceptT m)) >>= \case - Left _ref -> pure Nothing - Right (Left err) -> throwError err - Right (Right diff) -> pure (Just diff) + DefinitionDiffKind a (Either ConstructorReference TermDefinition) diff -> Maybe (DefinitionDiffKind a TermDefinition diff) + throwAwayConstructorDiffs = \case + Added ref (Right term) -> Just (Added ref term) + NewAlias ref names (Right term) -> Just (NewAlias ref names term) + Removed ref (Right term) -> Just (Removed ref term) + Updated old new diff -> Just (Updated old new diff) + Propagated old new diff -> Just (Propagated old new diff) + RenamedTo ref names (Right term) -> Just (RenamedTo ref names term) + RenamedFrom ref names (Right term) -> Just (RenamedFrom ref names term) + -- + Added _ (Left _) -> Nothing + NewAlias _ _ (Left _) -> Nothing + Removed _ (Left _) -> Nothing + RenamedFrom _ _ (Left _) -> Nothing + RenamedTo _ _ (Left _) -> Nothing diffTerms :: AuthZReceipt -> - (Codebase.CodebaseEnv, BranchHashId, Name) -> - (Codebase.CodebaseEnv, BranchHashId, Name) -> - ExceptT NamespaceDiffError (AppM r) (Maybe TermDefinitionDiff) -diffTerms !_authZReceipt old@(_, _, oldName) new@(_, _, newName) = do - let getOldTerm = lift (getTermDefinition old) `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "term-not-found") ("'From' term not found: " <> Name.toText oldName)) - let getNewTerm = lift (getTermDefinition new) `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "term-not-found") ("'To' term not found: " <> Name.toText newName)) - (getOldTerm `concurrentExceptT` getNewTerm) >>= \case + (Codebase.CodebaseEnv, Codebase.CodebaseRuntime IO, BranchHashId, Name) -> + (Codebase.CodebaseEnv, Codebase.CodebaseRuntime IO, BranchHashId, Name) -> + PG.Transaction NamespaceDiffError (Maybe TermDefinitionDiff) +diffTerms !_authZReceipt old@(_, _, _, oldName) new@(_, _, _, newName) = do + oldTerm <- getTermDefinition old `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "term-not-found") ("'From' term not found: " <> Name.toText oldName)) + newTerm <- getTermDefinition new `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "term-not-found") ("'To' term not found: " <> Name.toText newName)) + case (oldTerm, newTerm) of (Right oldTerm, Right newTerm) -> do let termDiffDisplayObject = DefinitionDiff.diffDisplayObjects (termDefinition oldTerm) (termDefinition newTerm) pure (Just TermDefinitionDiff {left = oldTerm, right = newTerm, diff = termDiffDisplayObject}) @@ -253,14 +207,13 @@ diffTerms !_authZReceipt old@(_, _, oldName) new@(_, _, newName) = do -- Just dropping them from the diff for now _ -> pure Nothing -getTermDefinition :: (Codebase.CodebaseEnv, BranchHashId, Name) -> AppM r (Maybe (Either ConstructorReference TermDefinition)) -getTermDefinition (codebase, bhId, name) = do +getTermDefinition :: (Codebase.CodebaseEnv, Codebase.CodebaseRuntime IO, BranchHashId, Name) -> PG.Transaction e (Maybe (Either ConstructorReference TermDefinition)) +getTermDefinition (codebase, rt, bhId, name) = do let perspective = mempty - (namesPerspective, Identity relocatedName) <- PG.runTransaction $ NameLookupOps.relocateToNameRoot perspective (Identity name) bhId - let ppedBuilder deps = (PPED.biasTo [name]) <$> lift (PPEPostgres.ppedForReferences namesPerspective deps) + (namesPerspective, Identity relocatedName) <- NameLookupOps.relocateToNameRoot perspective (Identity name) bhId + let ppedBuilder deps = PPED.biasTo [name] <$> PPEPostgres.ppedForReferences namesPerspective deps let nameSearch = PGNameSearch.nameSearchForPerspective namesPerspective - rt <- Codebase.codebaseRuntime codebase - Codebase.runCodebaseTransaction codebase do + Codebase.codebaseMToTransaction codebase do Definitions.termDefinitionByName ppedBuilder nameSearch renderWidth rt relocatedName where renderWidth :: Width @@ -268,153 +221,27 @@ getTermDefinition (codebase, bhId, name) = do diffTypes :: AuthZReceipt -> - (Codebase.CodebaseEnv, BranchHashId, Name) -> - (Codebase.CodebaseEnv, BranchHashId, Name) -> - ExceptT NamespaceDiffError (AppM r) TypeDefinitionDiff -diffTypes !_authZReceipt old@(_, _, oldTypeName) new@(_, _, newTypeName) = do - let getOldType = - lift (getTypeDefinition old) - `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "type-not-found") ("'From' Type not found: " <> Name.toText oldTypeName)) - let getNewType = - lift (getTypeDefinition new) - `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "type-not-found") ("'To' Type not found: " <> Name.toText newTypeName)) - (sourceType, newType) <- getOldType `concurrentExceptT` getNewType - let typeDiffDisplayObject = DefinitionDiff.diffDisplayObjects (typeDefinition sourceType) (typeDefinition newType) - pure $ TypeDefinitionDiff {left = sourceType, right = newType, diff = typeDiffDisplayObject} - -getTypeDefinition :: (Codebase.CodebaseEnv, BranchHashId, Name) -> AppM r (Maybe TypeDefinition) -getTypeDefinition (codebase, bhId, name) = do + (Codebase.CodebaseEnv, Codebase.CodebaseRuntime IO, BranchHashId, Name) -> + (Codebase.CodebaseEnv, Codebase.CodebaseRuntime IO, BranchHashId, Name) -> + PG.Transaction NamespaceDiffError TypeDefinitionDiff +diffTypes !_authZReceipt old@(_, _, _, oldTypeName) new@(_, _, _, newTypeName) = do + oldType <- + getTypeDefinition old + `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "type-not-found") ("'From' Type not found: " <> Name.toText oldTypeName)) + newType <- + getTypeDefinition new + `whenNothingM` throwError (MissingEntityError $ EntityMissing (ErrorID "type-not-found") ("'To' Type not found: " <> Name.toText newTypeName)) + let typeDiffDisplayObject = DefinitionDiff.diffDisplayObjects (typeDefinition oldType) (typeDefinition newType) + pure $ TypeDefinitionDiff {left = oldType, right = newType, diff = typeDiffDisplayObject} + +getTypeDefinition :: (Codebase.CodebaseEnv, Codebase.CodebaseRuntime IO, BranchHashId, Name) -> PG.Transaction e (Maybe TypeDefinition) +getTypeDefinition (codebase, rt, bhId, name) = do let perspective = mempty - (namesPerspective, Identity relocatedName) <- PG.runTransaction $ NameLookupOps.relocateToNameRoot perspective (Identity name) bhId + (namesPerspective, Identity relocatedName) <- 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 + Codebase.codebaseMToTransaction codebase do Definitions.typeDefinitionByName ppedBuilder nameSearch renderWidth rt relocatedName where renderWidth :: Width renderWidth = 80 - -newtype RenderedNamespaceAndLibdepsDiff - = RenderedNamespaceAndLibdepsDiff - (NamespaceAndLibdepsDiff (TermTag, ShortHash) (TypeTag, ShortHash) TermDefinition TypeDefinition TermDefinitionDiff TypeDefinitionDiff BranchHash) - -instance ToJSON RenderedNamespaceAndLibdepsDiff where - toJSON (RenderedNamespaceAndLibdepsDiff diff) = - object - [ "defns" .= namespaceTreeDiffJSON diff.defns, - "libdeps" .= libdepsDiffJSON diff.libdeps - ] - where - text :: Text -> Text - text t = t - hqNameJSON :: Name -> NameSegment -> ShortHash -> Value -> Value - hqNameJSON fqn name sh rendered = object ["hash" .= sh, "shortName" .= name, "fullName" .= fqn, "rendered" .= rendered] - -- The preferred frontend format is a bit clunky to calculate here: - diffDataJSON :: (ToJSON tag) => NameSegment -> DefinitionDiff (tag, ShortHash) Value Value -> (tag, Value) - diffDataJSON shortName (DefinitionDiff {fqn, kind}) = case kind of - Added (defnTag, r) rendered -> (defnTag, object ["tag" .= text "Added", "contents" .= hqNameJSON fqn shortName r rendered]) - NewAlias (defnTag, r) existingNames rendered -> - let contents = object ["hash" .= r, "aliasShortName" .= shortName, "aliasFullName" .= fqn, "otherNames" .= toList existingNames, "rendered" .= rendered] - in (defnTag, object ["tag" .= text "Aliased", "contents" .= contents]) - Removed (defnTag, r) rendered -> (defnTag, object ["tag" .= text "Removed", "contents" .= hqNameJSON fqn shortName r rendered]) - Updated (oldTag, oldRef) (newTag, newRef) diffVal -> - let contents = object ["oldHash" .= oldRef, "newHash" .= newRef, "shortName" .= shortName, "fullName" .= fqn, "oldTag" .= oldTag, "newTag" .= newTag, "diff" .= diffVal] - in (newTag, object ["tag" .= text "Updated", "contents" .= contents]) - Propagated (oldTag, oldRef) (newTag, newRef) diffVal -> - let contents = object ["oldHash" .= oldRef, "newHash" .= newRef, "shortName" .= shortName, "fullName" .= fqn, "oldTag" .= oldTag, "newTag" .= newTag, "diff" .= diffVal] - in (newTag, object ["tag" .= text "Propagated", "contents" .= contents]) - RenamedTo (defnTag, r) newNames rendered -> - let contents = object ["oldShortName" .= shortName, "oldFullName" .= fqn, "newNames" .= newNames, "hash" .= r, "rendered" .= rendered] - in (defnTag, object ["tag" .= text "RenamedTo", "contents" .= contents]) - RenamedFrom (defnTag, r) oldNames rendered -> - let contents = object ["oldNames" .= oldNames, "newShortName" .= shortName, "newFullName" .= fqn, "hash" .= r, "rendered" .= rendered] - in (defnTag, object ["tag" .= text "RenamedFrom", "contents" .= contents]) - displayObjectDiffToJSON :: DisplayObjectDiff -> Value - displayObjectDiffToJSON = \case - DisplayObjectDiff dispDiff -> - object ["diff" .= dispDiff, "diffKind" .= ("diff" :: Text)] - MismatchedDisplayObjects {} -> - object ["diffKind" .= ("mismatched" :: Text)] - - termDefinitionDiffToJSON :: TermDefinitionDiff -> Value - termDefinitionDiffToJSON (TermDefinitionDiff {left, right, diff}) = object ["left" .= left, "right" .= right, "diff" .= displayObjectDiffToJSON diff] - - typeDefinitionDiffToJSON :: TypeDefinitionDiff -> Value - typeDefinitionDiffToJSON (TypeDefinitionDiff {left, right, diff}) = object ["left" .= left, "right" .= right, "diff" .= displayObjectDiffToJSON diff] - - namespaceTreeDiffJSON :: - NamespaceTreeDiff - (TermTag, ShortHash) - (TypeTag, ShortHash) - TermDefinition - TypeDefinition - TermDefinitionDiff - TypeDefinitionDiff -> - Value - namespaceTreeDiffJSON (diffs Cofree.:< children) = - let changesJSON = - diffs - & Map.toList - & foldMap - ( \(name, DiffAtPath {termDiffsAtPath, typeDiffsAtPath}) -> - ( Foldable.toList termDiffsAtPath - <&> over NamespaceDiffs.definitionDiffDiffs_ termDefinitionDiffToJSON - <&> over NamespaceDiffs.definitionDiffRendered_ toJSON - & fmap (diffDataJSON name) - & fmap (\(tag, dJSON) -> object ["tag" .= tag, "contents" .= dJSON]) - ) - <> ( Foldable.toList typeDiffsAtPath - <&> over NamespaceDiffs.definitionDiffDiffs_ typeDefinitionDiffToJSON - <&> over NamespaceDiffs.definitionDiffRendered_ toJSON - & fmap (diffDataJSON name) - & fmap (\(tag, dJSON) -> object ["tag" .= tag, "contents" .= dJSON]) - ) - ) - & toJSON @[Value] - childrenJSON = - children - & Map.toList - & fmap - ( \(path, childNode) -> - object ["path" .= path, "contents" .= namespaceTreeDiffJSON childNode] - ) - in object - [ "changes" .= changesJSON, - "children" .= childrenJSON - ] - - libdepsDiffJSON :: Map NameSegment (DiffOp BranchHash) -> Value - libdepsDiffJSON = - Map.toList - >>> map - ( \(name, op) -> - case op of - DiffOp'Add hash -> - object - [ "hash" .= hash, - "name" .= name, - "tag" .= ("Added" :: Text) - ] - DiffOp'Delete hash -> - object - [ "hash" .= hash, - "name" .= name, - "tag" .= ("Removed" :: Text) - ] - DiffOp'Update Merge.Updated {old, new} -> - object - [ "name" .= name, - "newHash" .= new, - "oldHash" .= old, - "tag" .= ("Updated" :: Text) - ] - ) - >>> toJSON @[Value] - -concurrentExceptT :: (MonadUnliftIO m) => ExceptT e m a -> ExceptT e m b -> ExceptT e m (a, b) -concurrentExceptT a b = do - (ea, eb) <- lift $ UnliftIO.concurrently (runExceptT a) (runExceptT b) - ra <- except ea - rb <- except eb - pure (ra, rb) diff --git a/src/Share/Web/Share/Diffs/Types.hs b/src/Share/Web/Share/Diffs/Types.hs index 3ac48952..47c36507 100644 --- a/src/Share/Web/Share/Diffs/Types.hs +++ b/src/Share/Web/Share/Diffs/Types.hs @@ -4,36 +4,58 @@ module Share.Web.Share.Diffs.Types where import Data.Aeson import Share.IDs -import Share.NamespaceDiffs (NamespaceAndLibdepsDiff) +import Share.NamespaceDiffs (NamespaceAndLibdepsDiff, NamespaceDiffResult) import Share.Postgres.IDs (BranchHash, CausalHash) import Share.Prelude import Share.Utils.Aeson (PreEncoded) -import Unison.Server.Types (DisplayObjectDiff (..), TermDefinition, TermDefinitionDiff (..), TermTag, TypeDefinition, TypeDefinitionDiff (..), TypeTag) +import Unison.Server.Types + ( DisplayObjectDiff (..), + TermDefinition, + TermDefinitionDiff (..), + TermTag, + TypeDefinition, + TypeDefinitionDiff (..), + TypeTag, + ) import Unison.ShortHash (ShortHash) type ShareNamespaceDiff = NamespaceAndLibdepsDiff (TermTag, ShortHash) (TypeTag, ShortHash) TermDefinition TypeDefinition TermDefinitionDiff TypeDefinitionDiff BranchHash +data ShareNamespaceDiffStatus + = ShareNamespaceDiffStatus'Done (PreEncoded NamespaceDiffResult) + | ShareNamespaceDiffStatus'StillComputing + data ShareNamespaceDiffResponse = ShareNamespaceDiffResponse { project :: ProjectShortHand, oldRef :: BranchOrReleaseShortHand, oldRefHash :: Maybe (PrefixedHash "#" CausalHash), newRef :: BranchOrReleaseShortHand, newRefHash :: Maybe (PrefixedHash "#" CausalHash), - diff :: PreEncoded ShareNamespaceDiff + diff :: ShareNamespaceDiffStatus } instance ToJSON ShareNamespaceDiffResponse where toJSON (ShareNamespaceDiffResponse {diff, project, oldRef, newRef, oldRefHash, newRefHash}) = - object - [ "diff" .= diff, - "project" .= project, - "oldRef" .= oldRef, - "oldRefHash" .= oldRefHash, - "newRef" .= newRef, - "newRefHash" .= newRefHash - ] + object $ + diffPairs ++ + [ "project" .= toJSON project, + "oldRef" .= oldRef, + "oldRefHash" .= oldRefHash, + "newRef" .= newRef, + "newRefHash" .= newRefHash + ] where + diffPairs :: [(Key, Value)] + diffPairs = + case diff of + ShareNamespaceDiffStatus'Done diff -> + [ "diff" .= toJSON diff + , "tag" .= ("done" :: Text) + ] + ShareNamespaceDiffStatus'StillComputing -> + [ "tag" .= ("computing" :: Text) + ] data ShareTermDiffResponse = ShareTermDiffResponse { project :: ProjectShortHand, diff --git a/src/Share/Web/Share/Projects/Impl.hs b/src/Share/Web/Share/Projects/Impl.hs index d75eac36..1df6fe37 100644 --- a/src/Share/Web/Share/Projects/Impl.hs +++ b/src/Share/Web/Share/Projects/Impl.hs @@ -8,6 +8,7 @@ module Share.Web.Share.Projects.Impl where import Control.Lens import Control.Monad.Except import Data.ByteString.Lazy qualified as BL +import Data.ByteString.Lazy qualified as ByteString.Lazy import Data.Map qualified as Map import Data.Text qualified as Text import Data.Text.Encoding qualified as Text @@ -16,12 +17,14 @@ import Share.Branch (defaultBranchShorthand) import Share.Branch qualified as Branch import Share.Codebase (CodebaseEnv) import Share.Codebase qualified as Codebase +import Share.Env qualified as Env 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.Authorization.Queries qualified as AuthZQ import Share.Postgres.Causal.Queries qualified as CausalQ +import Share.Postgres.Contributions.Queries qualified as ContributionsQ import Share.Postgres.IDs (BranchHashId, CausalId) import Share.Postgres.Ops qualified as PGO import Share.Postgres.Projects.Queries qualified as ProjectsQ @@ -32,6 +35,7 @@ import Share.Project (Project (..)) import Share.Release qualified as Release import Share.User (User (..)) import Share.Utils.API ((:++) (..)) +import Share.Utils.Aeson (PreEncoded (..)) import Share.Utils.Caching (Cached) import Share.Utils.Caching qualified as Caching import Share.Utils.Logging qualified as Logging @@ -43,7 +47,7 @@ import Share.Web.Errors import Share.Web.Share.Branches.Impl (branchesServer, getProjectBranchReadmeEndpoint) import Share.Web.Share.Contributions.Impl (contributionsByProjectServer) import Share.Web.Share.Diffs.Impl qualified as Diffs -import Share.Web.Share.Diffs.Types (ShareNamespaceDiffResponse (..), ShareTermDiffResponse (..), ShareTypeDiffResponse (..)) +import Share.Web.Share.Diffs.Types (ShareNamespaceDiffResponse (..), ShareNamespaceDiffStatus (..), ShareTermDiffResponse (..), ShareTypeDiffResponse (..)) import Share.Web.Share.Projects.API qualified as API import Share.Web.Share.Projects.Types import Share.Web.Share.Releases.Impl (getProjectReleaseReadmeEndpoint, releasesServer) @@ -161,12 +165,30 @@ diffNamespacesEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHandle project 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 - (oldCausalHash, newCausalHash, maybeLcaCausalId) <- + ((oldCausalHash, newCausalHash), maybeLcaCausalId) <- PG.runTransaction do - (oldCausalHash, newCausalHash) <- CausalQ.expectCausalHashesByIdsOf each (oldCausalId, newCausalId) - maybeLcaCausalId <- CausalQ.bestCommonAncestor oldCausalId newCausalId - pure (oldCausalHash, newCausalHash, maybeLcaCausalId) - namespaceDiff <- respondExceptT (Diffs.diffCausals authZReceipt (oldCodebase, oldCausalId) (newCodebase, newCausalId) maybeLcaCausalId) + PG.pipelined do + (,) + <$> CausalQ.expectCausalHashesByIdsOf each (oldCausalId, newCausalId) + <*> CausalQ.bestCommonAncestor oldCausalId newCausalId + badUnliftCodebaseRuntime <- Codebase.badAskUnliftCodebaseRuntime + unisonRuntime <- asks Env.sandboxedRuntime + let makeRuntime :: Codebase.CodebaseEnv -> IO (Codebase.CodebaseRuntime IO) + makeRuntime codebase = do + runtime <- Codebase.codebaseRuntimeTransaction unisonRuntime codebase + pure (badUnliftCodebaseRuntime runtime) + diff <- + PG.runTransaction do + ContributionsQ.getPrecomputedNamespaceDiff (oldCodebase, oldCausalId) (newCodebase, newCausalId) >>= \case + Just diff -> pure (PreEncoded (ByteString.Lazy.fromStrict (Text.encodeUtf8 diff))) + Nothing -> do + oldRuntime <- PG.transactionUnsafeIO (makeRuntime oldCodebase) + newRuntime <- PG.transactionUnsafeIO (makeRuntime newCodebase) + Diffs.computeAndStoreCausalDiff + authZReceipt + (oldCodebase, oldRuntime, oldCausalId) + (newCodebase, newRuntime, newCausalId) + maybeLcaCausalId pure ShareNamespaceDiffResponse { project = projectShortHand, @@ -174,7 +196,7 @@ diffNamespacesEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHandle project oldRefHash = Just $ PrefixedHash oldCausalHash, newRef = newShortHand, newRefHash = Just $ PrefixedHash newCausalHash, - diff = namespaceDiff + diff = ShareNamespaceDiffStatus'Done diff } where projectShortHand = IDs.ProjectShortHand {userHandle, projectSlug} @@ -199,10 +221,14 @@ projectDiffTermsEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHandle proje let cacheKeys = [IDs.toText projectId, IDs.toText oldShortHand, IDs.toText newShortHand, Caching.branchIdCacheKey oldBhId, Caching.branchIdCacheKey newBhId, Name.toText oldTermName, Name.toText newTermName] Caching.cachedResponse authZReceipt "project-diff-terms" cacheKeys do + oldRuntime <- Codebase.codebaseRuntime oldCodebase + newRuntime <- Codebase.codebaseRuntime newCodebase termDiff <- - respondExceptT (Diffs.diffTerms authZReceipt (oldCodebase, oldBhId, oldTermName) (newCodebase, newBhId, newTermName)) + PG.tryRunTransaction (Diffs.diffTerms authZReceipt (oldCodebase, oldRuntime, oldBhId, oldTermName) (newCodebase, newRuntime, newBhId, newTermName)) >>= \case + Left err -> respondError err -- Not exactly a "term not found" - one or both term names is a constructor - but probably ok for now - `whenNothingM` respondError (EntityMissing (ErrorID "term:missing") "Term not found") + Right Nothing -> respondError (EntityMissing (ErrorID "term:missing") "Term not found") + Right (Just diff) -> pure diff pure $ ShareTermDiffResponse { project = projectShortHand, @@ -236,7 +262,15 @@ projectDiffTypesEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHandle proje let cacheKeys = [IDs.toText projectId, IDs.toText oldShortHand, IDs.toText newShortHand, Caching.branchIdCacheKey oldBhId, Caching.branchIdCacheKey newBhId, Name.toText oldTypeName, Name.toText newTypeName] Caching.cachedResponse authZReceipt "project-diff-types" cacheKeys do - typeDiff <- respondExceptT (Diffs.diffTypes authZReceipt (oldCodebase, oldBhId, oldTypeName) (newCodebase, newBhId, newTypeName)) + oldRuntime <- Codebase.codebaseRuntime oldCodebase + newRuntime <- Codebase.codebaseRuntime newCodebase + typeDiff <- + (either respondError pure =<<) do + PG.tryRunTransaction do + Diffs.diffTypes + authZReceipt + (oldCodebase, oldRuntime, oldBhId, oldTypeName) + (newCodebase, newRuntime, newBhId, newTypeName) pure $ ShareTypeDiffResponse { project = projectShortHand, diff --git a/src/Unison/Server/Share/Definitions.hs b/src/Unison/Server/Share/Definitions.hs index d51d671c..b0a547bf 100644 --- a/src/Unison/Server/Share/Definitions.hs +++ b/src/Unison/Server/Share/Definitions.hs @@ -77,7 +77,7 @@ definitionForHQName :: -- | Whether to suffixify bindings in the rendered syntax Suffixify -> -- | Runtime used to evaluate docs. This should be sandboxed if run on the server. - CodebaseRuntime -> + CodebaseRuntime IO -> -- | The name, hash, or both, of the definition to display. HQ.HashQualified Name -> Codebase.CodebaseM e DefinitionDisplayResults @@ -143,7 +143,7 @@ definitionForHQName perspective rootCausalId renderWidth suffixifyBindings rt pe renderDocRefs :: PPEDBuilder (Codebase.CodebaseM e) -> Width -> - CodebaseRuntime -> + CodebaseRuntime IO -> [TermReference] -> Codebase.CodebaseM e [(HashQualifiedName, UnisonHash, Doc.Doc)] renderDocRefs _ppedBuilder _width _rt [] = pure [] @@ -207,7 +207,7 @@ termDefinitionByName :: PPEDBuilder (Codebase.CodebaseM e) -> NameSearch (PG.Transaction e) -> Width -> - CodebaseRuntime -> + CodebaseRuntime IO -> Name -> Codebase.CodebaseM e (Maybe (Either ConstructorReference TermDefinition)) termDefinitionByName ppedBuilder nameSearch width rt name = runMaybeT do @@ -241,7 +241,7 @@ typeDefinitionByName :: PPEDBuilder (Codebase.CodebaseM e) -> NameSearch (PG.Transaction e) -> Width -> - CodebaseRuntime -> + CodebaseRuntime IO -> Name -> Codebase.CodebaseM e (Maybe TypeDefinition) typeDefinitionByName ppedBuilder nameSearch width rt name = runMaybeT $ do diff --git a/src/Unison/Server/Share/NamespaceDetails.hs b/src/Unison/Server/Share/NamespaceDetails.hs index 406bf197..bb1e1c1b 100644 --- a/src/Unison/Server/Share/NamespaceDetails.hs +++ b/src/Unison/Server/Share/NamespaceDetails.hs @@ -17,7 +17,7 @@ import Unison.Server.Types import Unison.Util.Pretty (Width) namespaceDetails :: - CodebaseRuntime -> + CodebaseRuntime IO -> Path.Path -> CausalId -> Maybe Width -> diff --git a/src/Unison/Server/Share/RenderDoc.hs b/src/Unison/Server/Share/RenderDoc.hs index 1246dac8..4df2fd45 100644 --- a/src/Unison/Server/Share/RenderDoc.hs +++ b/src/Unison/Server/Share/RenderDoc.hs @@ -37,7 +37,7 @@ import Unison.Util.Pretty (Width) -- Requires Name Lookups, currently only usable on Share. findAndRenderDoc :: Set NameSegment -> - CodebaseRuntime -> + CodebaseRuntime IO -> Path.Path -> CausalId -> Maybe Width -> diff --git a/transcripts/share-apis/contribution-diffs/contribution-diff.json b/transcripts/share-apis/contribution-diffs/contribution-diff.json index db781a63..fea19a85 100644 --- a/transcripts/share-apis/contribution-diffs/contribution-diff.json +++ b/transcripts/share-apis/contribution-diffs/contribution-diff.json @@ -2689,13 +2689,15 @@ } ] }, - "libdeps": [] + "libdeps": [], + "tag": "ok" }, "newRef": "diff-end", "newRefHash": "#f2bjgi4tm53bf6dcfcukt5a6as3ktlrbiacnqq81nco8i4g7dg6pt14vmc1b7ulsb7rt683qjt2rvg9u92uo5mk1gaqgo8cl30umep8", "oldRef": "diff-start", "oldRefHash": "#f8nji6tc2vaorc7gl8kjdmj8ucrht674blmb586iptgsa8v1pm8ovjplc4an2voirvlip91ick9g5mjkncsmr8sadaqqf8810eskbig", - "project": "@transcripts/contribution-diff" + "project": "@transcripts/contribution-diff", + "tag": "done" }, "status": [ { diff --git a/transcripts/share-apis/contribution-diffs/namespace-diff.json b/transcripts/share-apis/contribution-diffs/namespace-diff.json index db781a63..fea19a85 100644 --- a/transcripts/share-apis/contribution-diffs/namespace-diff.json +++ b/transcripts/share-apis/contribution-diffs/namespace-diff.json @@ -2689,13 +2689,15 @@ } ] }, - "libdeps": [] + "libdeps": [], + "tag": "ok" }, "newRef": "diff-end", "newRefHash": "#f2bjgi4tm53bf6dcfcukt5a6as3ktlrbiacnqq81nco8i4g7dg6pt14vmc1b7ulsb7rt683qjt2rvg9u92uo5mk1gaqgo8cl30umep8", "oldRef": "diff-start", "oldRefHash": "#f8nji6tc2vaorc7gl8kjdmj8ucrht674blmb586iptgsa8v1pm8ovjplc4an2voirvlip91ick9g5mjkncsmr8sadaqqf8810eskbig", - "project": "@transcripts/contribution-diff" + "project": "@transcripts/contribution-diff", + "tag": "done" }, "status": [ { diff --git a/transcripts/share-apis/contributions/merged-contribution-diff.json b/transcripts/share-apis/contributions/merged-contribution-diff.json index c0422147..39b241d9 100644 --- a/transcripts/share-apis/contributions/merged-contribution-diff.json +++ b/transcripts/share-apis/contributions/merged-contribution-diff.json @@ -248,13 +248,15 @@ ], "children": [] }, - "libdeps": [] + "libdeps": [], + "tag": "ok" }, "newRef": "feature-one", "newRefHash": "#7shvkj0gn9mfne1pemp3oudmo23vio4d8ualvbah6avr7m5471rssu9cd4o6i4pn91bgc62vgnm0oper0itgtmopqmff7c0b40ui1s0", "oldRef": "main", "oldRefHash": "#7shvkj0gn9mfne1pemp3oudmo23vio4d8ualvbah6avr7m5471rssu9cd4o6i4pn91bgc62vgnm0oper0itgtmopqmff7c0b40ui1s0", - "project": "@transcripts/bca-updates" + "project": "@transcripts/bca-updates", + "tag": "done" }, "status": [ { diff --git a/transcripts/share-apis/contributions/run.zsh b/transcripts/share-apis/contributions/run.zsh index ac848333..4ab2135f 100755 --- a/transcripts/share-apis/contributions/run.zsh +++ b/transcripts/share-apis/contributions/run.zsh @@ -118,6 +118,17 @@ transcript_ucm transcript merge-contribution-branches.md # Fetch the contribution to see that it's been marked as merged. fetch "$transcripts_user" GET merged-contribution '/users/transcripts/projects/bca-updates/contributions/1' +# Hacky, but since namespace diffs are computed asynchronously, we just block here until there are 5 (the number this +# test creates). Don't wait more than 10 seconds, just in case. +expectedNumberOfNamespaceDiffs=5 +for i in {1..5}; do + if [[ $(pg_sql "select count(*) from namespace_diffs;") -lt $expectedNumberOfNamespaceDiffs ]]; then + sleep 1 + else + break + fi +done + # BCA of contribution diff should still be frozen at it's pre-merge hash. The bca and source hash should be different (or else we'd see no diff!) fetch "$transcripts_user" GET merged-contribution-diff '/users/transcripts/projects/bca-updates/contributions/1/diff' diff --git a/transcripts/share-apis/contributions/transitive-contribution-diff.json b/transcripts/share-apis/contributions/transitive-contribution-diff.json index e96edaba..34bedd9e 100644 --- a/transcripts/share-apis/contributions/transitive-contribution-diff.json +++ b/transcripts/share-apis/contributions/transitive-contribution-diff.json @@ -248,13 +248,15 @@ ], "children": [] }, - "libdeps": [] + "libdeps": [], + "tag": "ok" }, "newRef": "feature-two", "newRefHash": "#ktjspqi8s5ngg129a6lt7i9kd488isfoq8hqmsv54f327de28dq9u0n1dp1vlbgs8jdc6bqss3h46ep9241405ml19nr0gekel56pig", "oldRef": "main", "oldRefHash": "#7shvkj0gn9mfne1pemp3oudmo23vio4d8ualvbah6avr7m5471rssu9cd4o6i4pn91bgc62vgnm0oper0itgtmopqmff7c0b40ui1s0", - "project": "@transcripts/bca-updates" + "project": "@transcripts/bca-updates", + "tag": "done" }, "status": [ {