Attempt to not cache erroring doc evals

src/Share/Backend.hs

@@ -36,7 +36,10 @@ where
 
 import Control.Lens hiding ((??))
 import Data.List qualified as List
+import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as Map
+import Data.Sequence (Seq)
+import Data.Sequence qualified as Seq
 import Share.Codebase (CodebaseM)
 import Share.Codebase qualified as Codebase
 import Share.Codebase.Types (CodebaseRuntime (CodebaseRuntime, cachedEvalResult))
@@ -88,6 +91,8 @@ import Unison.Util.Pretty (Width)
 import Unison.Util.Pretty qualified as Pretty
 import Unison.Util.SyntaxText qualified as UST
 import Unison.Var (Var)
+import UnliftIO (TVar)
+import UnliftIO qualified
 
 mkTypeDefinition ::
   PPED.PrettyPrintEnvDecl ->
@@ -192,11 +197,11 @@ getTermTag r termType = do
     V2Referent.Con ref _ -> Just <$> Codebase.expectDeclKind ref
   pure $
     if
-        | isDoc -> Doc
-        | isTest -> Test
-        | Just CT.Effect <- constructorType -> Constructor Ability
-        | Just CT.Data <- constructorType -> Constructor Data
-        | otherwise -> Plain
+      | isDoc -> Doc
+      | isTest -> Test
+      | Just CT.Effect <- constructorType -> Constructor Ability
+      | Just CT.Data <- constructorType -> Constructor Data
+      | otherwise -> Plain
 
 getTypeTag ::
   (PG.QueryM m) =>
@@ -233,10 +238,13 @@ displayType = \case
 evalDocRef ::
   Codebase.CodebaseRuntime IO ->
   V2.TermReference ->
-  Codebase.CodebaseM e (Doc.EvaluatedDoc Symbol)
+  Codebase.CodebaseM e (Doc.EvaluatedDoc Symbol, Maybe (NonEmpty Rt.Error))
 evalDocRef (CodebaseRuntime {codeLookup, cachedEvalResult, unisonRuntime}) termRef = do
   let tm = Term.ref () termRef
-  Doc.evalDoc terms typeOf eval decls tm
+  errsVar <- PG.transactionUnsafeIO $ UnliftIO.newTVarIO Seq.empty
+  evalResult <- Doc.evalDoc terms typeOf (eval errsVar) decls tm
+  errs <- PG.transactionUnsafeIO $ UnliftIO.readTVarIO errsVar
+  pure (evalResult, NEL.nonEmpty $ toList errs)
   where
     terms :: Reference -> Codebase.CodebaseM e (Maybe (V1.Term Symbol ()))
     terms termRef@(Reference.Builtin _) = pure (Just (Term.ref () termRef))
@@ -246,19 +254,25 @@ 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
+    eval :: TVar (Seq Rt.Error) -> V1.Term Symbol a -> Codebase.CodebaseM e (Maybe (V1.Term Symbol ()))
+    eval errsVar (Term.amap (const mempty) -> tm) = do
       -- We use an empty ppe for evalutation, it's only used for adding additional context to errors.
       let evalPPE = PPE.empty
-      termRef <- fmap eitherToMaybe . lift . PG.transactionUnsafeIO . liftIO $ Rt.evaluateTerm' codeLookup cachedEvalResult evalPPE unisonRuntime tm
+      termRef <- lift . PG.transactionUnsafeIO . liftIO $ Rt.evaluateTerm' codeLookup cachedEvalResult evalPPE unisonRuntime tm
       case termRef of
         -- don't cache when there were decompile errors
-        Just (errs, tmr) | null errs -> do
-          Codebase.saveCachedEvalResult
-            (Hashing.hashClosedTerm tm)
-            (Term.amap (const mempty) tmr)
-        _ -> pure ()
-      pure $ termRef <&> Term.amap (const mempty) . snd
+        Right (errs, tmr)
+          | null errs -> do
+              Codebase.saveCachedEvalResult
+                (Hashing.hashClosedTerm tm)
+                (Term.amap (const mempty) tmr)
+          | otherwise -> do
+              PG.transactionUnsafeIO . UnliftIO.atomically $ UnliftIO.modifyTVar' errsVar (<> Seq.fromList errs)
+              pure ()
+        Left err -> do
+          PG.transactionUnsafeIO . UnliftIO.atomically $ UnliftIO.modifyTVar' errsVar (<> Seq.singleton err)
+          pure ()
+      pure $ eitherToMaybe termRef <&> Term.amap (const mempty) . snd
 
     decls :: Reference -> Codebase.CodebaseM e (Maybe (DD.Decl Symbol ()))
     decls (Reference.DerivedId typeRef) = fmap (DD.amap (const ())) <$> (Codebase.loadTypeDeclaration typeRef)

src/Share/Codebase.hs

@@ -72,6 +72,7 @@ module Share.Codebase
     convertTerm2to1,
 
     -- * Utilities
+    conditionallyCachedCodebaseResponse,
     cachedCodebaseResponse,
   )
 where
@@ -254,6 +255,29 @@ tryRunCodebaseTransaction codebaseEnv m = do
 codebaseMToTransaction :: CodebaseEnv -> CodebaseM e a -> PG.Transaction e a
 codebaseMToTransaction codebaseEnv m = runReaderT m codebaseEnv
 
+-- | Wrap a response in caching.
+-- This combinator respects the cachability stored on the provided auth receipt.
+conditionallyCachedCodebaseResponse ::
+  forall ct e a.
+  (Servant.MimeRender ct a) =>
+  AuthZ.AuthZReceipt ->
+  CodebaseLocation ->
+  -- | The name of the endpoint we're caching. Must be unique.
+  Text ->
+  -- | All parameters which affect the response
+  [Text] ->
+  -- | The root hash the cache is keyed on.
+  CausalId ->
+  -- | How to generate the response if it's not in the cache.
+  WebApp (Either e a) ->
+  WebApp (Either e (Cached ct a))
+conditionallyCachedCodebaseResponse authzReceipt codebaseOwner endpointName providedCacheParams rootCausalId action = do
+  let cacheParams = ["codebase", codebaseViewCacheKey, "root-hash", Caching.causalIdCacheKey rootCausalId] <> providedCacheParams
+  Caching.conditionallyCachedResponse authzReceipt endpointName cacheParams action
+  where
+    codebaseViewCacheKey :: Text
+    codebaseViewCacheKey = IDs.toText (codebaseOwnerUserId codebaseOwner)
+
 -- | Wrap a response in caching.
 -- This combinator respects the cachability stored on the provided auth receipt.
 cachedCodebaseResponse ::
@@ -271,11 +295,8 @@ cachedCodebaseResponse ::
   WebApp a ->
   WebApp (Cached ct a)
 cachedCodebaseResponse authzReceipt codebaseOwner endpointName providedCacheParams rootCausalId action = do
-  let cacheParams = ["codebase", codebaseViewCacheKey, "root-hash", Caching.causalIdCacheKey rootCausalId] <> providedCacheParams
-  Caching.cachedResponse authzReceipt endpointName cacheParams action
-  where
-    codebaseViewCacheKey :: Text
-    codebaseViewCacheKey = IDs.toText (codebaseOwnerUserId codebaseOwner)
+  conditionallyCachedCodebaseResponse authzReceipt codebaseOwner endpointName providedCacheParams rootCausalId (Right <$> action)
+    <&> either absurd id
 
 -- | Load a term and its type.
 loadTerm :: TermReferenceId -> CodebaseM e (Maybe (V1.Term Symbol Ann, V1.Type Symbol Ann))

src/Share/Utils/Caching.hs

@@ -9,7 +9,9 @@ module Share.Utils.Caching
     conditionallyCachedResponse,
     causalIdCacheKey,
     branchIdCacheKey,
+    toCached,
     Cached,
+    ShouldCache (..),
   )
 where
 
@@ -56,20 +58,27 @@ cachedResponse ::
   WebApp a ->
   WebApp (Cached ct a)
 cachedResponse authzReceipt endpointName cacheParams action =
-  conditionallyCachedResponse authzReceipt endpointName cacheParams ((,True) <$> action)
+  conditionallyCachedResponse authzReceipt endpointName cacheParams (Right <$> action)
+    <&> either absurd id
+
+data ShouldCache = DoCache | DontCache
+  deriving (Eq)
+
+toCached :: forall ct a. (Servant.MimeRender ct a) => a -> Cached ct a
+toCached a = Cached . BL.toStrict $ Servant.mimeRender (Proxy @ct) a
 
 -- | Like 'cachedResponse', but only cache (True, x) values.
 conditionallyCachedResponse ::
-  forall ct a.
+  forall ct e 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)
+  WebApp (Either e a) ->
+  WebApp (Either e (Cached ct a))
 conditionallyCachedResponse authzReceipt endpointName cacheParams action = do
   requestIsCacheable <- shouldUseCaching
   let mayCachingToken = AuthZ.getCacheability authzReceipt
@@ -79,16 +88,18 @@ conditionallyCachedResponse authzReceipt endpointName cacheParams action = do
       then getCachedResponse endpointName cacheParams
       else pure Nothing
   case mayCachedResponse of
-    Just cachedResponse -> pure cachedResponse
+    Just cachedResponse -> pure $ Right cachedResponse
     Nothing -> do
-      (a, cache) <- action
-      let cachedResponse :: Cached ct a
-          cachedResponse = Cached . BL.toStrict $ Servant.mimeRender (Proxy @ct) a
-      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
+      action >>= \case
+        Right a -> do
+          let cachedResponse :: Cached ct a
+              cachedResponse = toCached a
+          when (shouldUseCaching) do
+            -- Only actually cache the response if it's valid to do so.
+            whenJust mayCachingToken \ct ->
+              cacheResponse ct endpointName cacheParams cachedResponse
+          pure . Right $ cachedResponse
+        Left e -> pure $ Left e
 
 -- | Cached responses expire if not accessed in 7 days.
 -- Or, it could be evicted sooner if we run out of space.

src/Share/Utils/Caching/JSON.hs

@@ -39,19 +39,24 @@ encodeKey (CacheKey {key, rootCausalId}) =
         <&> (\(k, v) -> k <> "=" <> v)
           & T.intercalate ","
 
+-- | Use a JSON cache entry, or build it if it doesn't exist.
+--
+-- You can choose `f` to be `Maybe`, `Identity`, `Either e`, or anything else useful.
+-- It will only cache the value inside the `f` focused by foldable.
 usingJSONCache ::
-  (ToJSON v, FromJSON v, PG.QueryM m) =>
+  forall f v m.
+  (ToJSON v, FromJSON v, PG.QueryM m, Applicative f, Foldable f) =>
   CacheKey ->
   -- How to build the value if it's not in the cache.
-  m v ->
-  m v
+  m (f v) ->
+  m (f v)
 usingJSONCache ck action = do
   getJSONCacheEntry ck >>= \case
-    Just v -> pure v
+    Just v -> pure $ pure v
     Nothing -> do
-      v <- action
-      putJSONCacheEntry ck v
-      pure v
+      fv <- action
+      for_ fv \v -> putJSONCacheEntry ck v
+      pure fv
 
 data JSONCacheError
   = JSONCacheDecodingError CacheKey Text

src/Share/Web/Share/Branches/Impl.hs

@@ -29,6 +29,8 @@ import Share.Project qualified as Project
 import Share.User (User (..))
 import Share.Utils.API
 import Share.Utils.Caching
+import Share.Utils.Caching qualified as Caching
+import Share.Utils.Logging qualified as Logging
 import Share.Web.App
 import Share.Web.Authentication qualified as AuthN
 import Share.Web.Authorization qualified as AuthZ
@@ -45,6 +47,7 @@ import Unison.Codebase.Path qualified as Path
 import Unison.HashQualified qualified as HQ
 import Unison.Name (Name)
 import Unison.NameSegment.Internal (NameSegment (..))
+import Unison.PrintError qualified as Pretty
 import Unison.Reference (Reference)
 import Unison.Referent (Referent)
 import Unison.Referent qualified as Referent
@@ -269,10 +272,20 @@ projectBranchNamespacesByNameEndpoint (AuthN.MaybeAuthedUserID callerUserId) use
   let codebase = Codebase.codebaseEnv authZReceipt codebaseLoc
   causalId <- resolveRootHash codebase branchHead rootHash
   rt <- Codebase.codebaseRuntime codebase
-  Codebase.cachedCodebaseResponse authZReceipt codebaseLoc "project-branch-namespaces-by-name" cacheParams causalId $ do
-    Codebase.runCodebaseTransactionModeOrRespondError PG.ReadCommitted PG.ReadWrite codebase $ do
+  result <- Codebase.conditionallyCachedCodebaseResponse authZReceipt codebaseLoc "project-branch-namespaces-by-name" cacheParams causalId $ do
+    (nd, mayErrs) <- Codebase.runCodebaseTransactionModeOrRespondError PG.ReadCommitted PG.ReadWrite codebase $ do
       ND.namespaceDetails rt (fromMaybe mempty path) causalId renderWidth
         `whenNothingM` throwError (EntityMissing (ErrorID "namespace-not-found") "Namespace not found")
+    for_ mayErrs \errs -> do
+      errs
+        & fmap (Text.pack . Pretty.toANSI Pretty.defaultWidth)
+        & toList
+        & Text.intercalate "\n"
+        & Logging.logErrorText
+    case mayErrs of
+      Nothing -> pure $ Right nd
+      Just _errs -> pure $ Left nd
+  pure $ either Caching.toCached id result
   where
     cacheParams = [IDs.toText projectBranchShortHand, tShow path, foldMap (toUrlPiece . Pretty.widthToInt) renderWidth]
     projectBranchShortHand = ProjectBranchShortHand {userHandle, projectSlug, contributorHandle, branchName}
@@ -293,13 +306,20 @@ getProjectBranchReadmeEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHandle
   let codebase = Codebase.codebaseEnv authZReceipt codebaseLoc
   causalId <- resolveRootHash codebase branchHead rootHash
   rt <- Codebase.codebaseRuntime codebase
-  Codebase.cachedCodebaseResponse authZReceipt codebaseLoc "get-project-branch-readme" cacheParams causalId $ do
-    Codebase.runCodebaseTransactionMode PG.ReadCommitted PG.ReadWrite codebase $ do
-      mayNamespaceDetails <- ND.namespaceDetails rt rootPath causalId Nothing
-      let mayReadme = do
-            NamespaceDetails {readme} <- mayNamespaceDetails
-            readme
-      pure $ ReadmeResponse {readMe = mayReadme}
+  result <- Codebase.conditionallyCachedCodebaseResponse authZReceipt codebaseLoc "get-project-branch-readme" cacheParams causalId $ do
+    result <- Codebase.runCodebaseTransactionMode PG.ReadCommitted PG.ReadWrite codebase $ do
+      ND.namespaceDetails rt rootPath causalId Nothing
+    case result of
+      Nothing -> pure . Right $ ReadmeResponse {readMe = Nothing}
+      Just (NamespaceDetails {readme}, errs) -> do
+        for_ errs \err -> do
+          err
+            & fmap (Text.pack . Pretty.toANSI Pretty.defaultWidth)
+            & toList
+            & Text.intercalate "\n"
+            & Logging.logErrorText
+        pure . Left $ ReadmeResponse {readMe = readme}
+  pure $ either Caching.toCached id result
   where
     cacheParams = [IDs.toText projectBranchShortHand]
     projectBranchShortHand = ProjectBranchShortHand {userHandle, projectSlug, contributorHandle, branchName}
@@ -372,10 +392,20 @@ getProjectBranchDocEndpoint cacheKey docNames (AuthN.MaybeAuthedUserID callerUse
   let codebase = Codebase.codebaseEnv authZReceipt codebaseLoc
   causalId <- resolveRootHash codebase branchHead rootHash
   rt <- Codebase.codebaseRuntime codebase
-  Codebase.cachedCodebaseResponse authZReceipt codebaseLoc cacheKey cacheParams causalId $ do
-    Codebase.runCodebaseTransactionMode PG.ReadCommitted PG.ReadWrite codebase $ do
-      doc <- findAndRenderDoc docNames rt rootPath causalId Nothing
-      pure $ DocResponse {doc}
+  result <- Codebase.conditionallyCachedCodebaseResponse authZReceipt codebaseLoc cacheKey cacheParams causalId $ do
+    result <- Codebase.runCodebaseTransactionMode PG.ReadCommitted PG.ReadWrite codebase $ do
+      findAndRenderDoc docNames rt rootPath causalId Nothing
+    case result of
+      Just (doc, Just errs) -> do
+        errs
+          & fmap (Text.pack . Pretty.toANSI Pretty.defaultWidth)
+          & toList
+          & Text.intercalate "\n"
+          & Logging.logErrorText
+        pure $ Left $ DocResponse {doc = Just doc}
+      Just (doc, Nothing) -> pure $ Right $ DocResponse {doc = Just doc}
+      Nothing -> pure . Right $ DocResponse {doc = Nothing}
+  pure $ either Caching.toCached id result
   where
     cacheParams = [IDs.toText projectBranchShortHand]
     projectBranchShortHand = ProjectBranchShortHand {userHandle, projectSlug, contributorHandle, branchName}

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

@@ -286,28 +286,30 @@ 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 newCausalId, Caching.causalIdCacheKey oldCausalId]
-  Caching.conditionallyCachedResponse authZReceipt "contribution-diff" cacheKeys do
+  result <- Caching.conditionallyCachedResponse authZReceipt "contribution-diff" cacheKeys do
     (oldCausalHash, newCausalHash, maybeNamespaceDiff) <-
       PG.runTransaction do
         PG.pipelined do
           (,,)
             <$> CausalQ.expectCausalHashesByIdsOf id oldCausalId
             <*> CausalQ.expectCausalHashesByIdsOf id newCausalId
             <*> ContributionsQ.getPrecomputedNamespaceDiff (oldCodebase, oldCausalId) (newCodebase, newCausalId)
+
+    let diff = case maybeNamespaceDiff of
+          Just diff -> Right $ ShareNamespaceDiffStatus'Done (PreEncoded (ByteString.Lazy.fromStrict (Text.encodeUtf8 diff)))
+          Nothing -> Left $ ShareNamespaceDiffStatus'StillComputing
     let response =
-          ShareNamespaceDiffResponse
-            { project = projectShorthand,
-              newRef = IDs.IsBranchShortHand $ IDs.projectBranchShortHandToBranchShortHand newPBSH,
-              newRefHash = Just $ PrefixedHash newCausalHash,
-              oldRef = IDs.IsBranchShortHand $ IDs.projectBranchShortHandToBranchShortHand oldPBSH,
-              oldRefHash = Just $ PrefixedHash oldCausalHash,
-              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)
+          diff & bothMap \diff ->
+            ShareNamespaceDiffResponse
+              { project = projectShorthand,
+                newRef = IDs.IsBranchShortHand $ IDs.projectBranchShortHandToBranchShortHand newPBSH,
+                newRefHash = Just $ PrefixedHash newCausalHash,
+                oldRef = IDs.IsBranchShortHand $ IDs.projectBranchShortHandToBranchShortHand oldPBSH,
+                oldRefHash = Just $ PrefixedHash oldCausalHash,
+                diff
+              }
+    pure response
+  pure $ either Caching.toCached id result
   where
     projectShorthand = IDs.ProjectShortHand {userHandle, projectSlug}