Merge pull request #2701 from unisonweb/21-12-01-db-open-fix

Handle failing to open a remote codebase better

parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs

@@ -13,7 +13,6 @@ module Unison.Codebase.SqliteCodebase
 where
 
 import qualified Control.Concurrent
-import qualified Control.Exception
 import Control.Monad (filterM, unless, when, (>=>))
 import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT, withExceptT)
 import qualified Control.Monad.Except as Except
@@ -110,7 +109,7 @@ import UnliftIO (MonadIO, catchIO, finally, liftIO, MonadUnliftIO, throwIO)
 import qualified UnliftIO
 import UnliftIO.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
 import UnliftIO.STM
-import UnliftIO.Exception (bracket)
+import UnliftIO.Exception (catch, bracket)
 import Control.Monad.Trans.Except (mapExceptT)
 
 debug, debugProcessBranches, debugCommitFailedTransaction :: Bool
@@ -210,17 +209,6 @@ initSchemaIfNotExist path = liftIO do
   unlessM (doesFileExist $ path </> codebasePath) $
     withConnection "initSchemaIfNotExist" path $ runReaderT Q.createSchema
 
--- checks if a db exists at `path` with the minimum schema
-codebaseExists :: MonadIO m => CodebasePath -> m Bool
-codebaseExists root = liftIO do
-  Monad.when debug $ traceM $ "codebaseExists " ++ root
-  Control.Exception.catch @Sqlite.SQLError
-    ( sqliteCodebase "codebaseExists" root (const $ pure ()) >>= \case
-        Left _ -> pure False
-        Right _ -> pure True
-    )
-    (const $ pure False)
-
 -- 1) buffer up the component
 -- 2) in the event that the component is complete, then what?
 --  * can write component provided all of its dependency components are complete.
@@ -1057,43 +1045,51 @@ viewRemoteBranch' ::
   ReadRemoteNamespace ->
   ((Branch m, CodebasePath) -> m r) ->
   m (Either C.GitError r)
-viewRemoteBranch' (repo, sbh, path) action = UnliftIO.try $ do
+viewRemoteBranch' (repo, sbh, path) action = UnliftIO.try do
   -- set up the cache dir
-  remotePath <- (UnliftIO.fromEitherM . runExceptT . withExceptT C.GitProtocolError . time "Git fetch" $ pullBranch repo)
-  codebaseExists remotePath >>= \case
-    -- If there's no initialized codebase at this repo; we pretend there's an empty one.
-    -- I'm thinking we should probably return an error value instead.
-    False -> action (Branch.empty, remotePath)
-    True -> do
-      result <- sqliteCodebase "viewRemoteBranch.gitCache" remotePath $ \codebase -> do
-             -- try to load the requested branch from it
-             branch <- time "Git fetch (sbh)" $ case sbh of
-               -- no sub-branch was specified, so use the root.
-               Nothing ->
-                 (time "Get remote root branch" $ Codebase1.getRootBranch codebase) >>= \case
-                   -- this NoRootBranch case should probably be an error too.
-                   Left Codebase1.NoRootBranch -> pure Branch.empty
-                   Left (Codebase1.CouldntLoadRootBranch h) ->
-                     throwIO . C.GitCodebaseError $ GitError.CouldntLoadRootBranch repo h
-                   Left (Codebase1.CouldntParseRootBranch s) ->
-                     throwIO . C.GitSqliteCodebaseError $ GitError.GitCouldntParseRootBranchHash repo s
-                   Right b -> pure b
-               -- load from a specific `ShortBranchHash`
-               Just sbh -> do
-                 branchCompletions <- Codebase1.branchHashesByPrefix codebase sbh
-                 case toList branchCompletions of
-                   [] -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh
-                   [h] ->
-                     (Codebase1.getBranchForHash codebase h) >>= \case
-                       Just b -> pure b
-                       Nothing -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh
-                   _ -> throwIO . C.GitCodebaseError $ GitError.RemoteNamespaceHashAmbiguous repo sbh branchCompletions
-             case Branch.getAt path branch of
-               Just b -> action (b, remotePath)
-               Nothing -> throwIO . C.GitCodebaseError $ GitError.CouldntFindRemoteBranch repo path
-      case result of
-        Left schemaVersion -> throwIO . C.GitSqliteCodebaseError $ GitError.UnrecognizedSchemaVersion repo remotePath schemaVersion
-        Right inner -> pure inner
+  remotePath <- UnliftIO.fromEitherM . runExceptT . withExceptT C.GitProtocolError . time "Git fetch" $ pullBranch repo
+
+  -- Tickle the database before calling into `sqliteCodebase`; this covers the case that the database file either
+  -- doesn't exist at all or isn't a SQLite database file, but does not cover the case that the database file itself is
+  -- somehow corrupt, or not even a Unison database.
+  --
+  -- FIXME it would probably make more sense to define some proper preconditions on `sqliteCodebase`, and perhaps update
+  -- its output type, which currently indicates the only way it can fail is with an `UnknownSchemaVersion` error.
+  (withConnection "codebase exists check" remotePath \_ -> pure ()) `catch` \sqlError ->
+    case Sqlite.sqlError sqlError of
+      Sqlite.ErrorCan'tOpen -> throwIO (C.GitSqliteCodebaseError (GitError.NoDatabaseFile repo remotePath))
+      -- Unexpected error from sqlite
+      _ -> throwIO sqlError
+
+  result <- sqliteCodebase "viewRemoteBranch.gitCache" remotePath \codebase -> do
+    -- try to load the requested branch from it
+    branch <- time "Git fetch (sbh)" $ case sbh of
+      -- no sub-branch was specified, so use the root.
+      Nothing ->
+        (time "Get remote root branch" $ Codebase1.getRootBranch codebase) >>= \case
+          -- this NoRootBranch case should probably be an error too.
+          Left Codebase1.NoRootBranch -> pure Branch.empty
+          Left (Codebase1.CouldntLoadRootBranch h) ->
+            throwIO . C.GitCodebaseError $ GitError.CouldntLoadRootBranch repo h
+          Left (Codebase1.CouldntParseRootBranch s) ->
+            throwIO . C.GitSqliteCodebaseError $ GitError.GitCouldntParseRootBranchHash repo s
+          Right b -> pure b
+      -- load from a specific `ShortBranchHash`
+      Just sbh -> do
+        branchCompletions <- Codebase1.branchHashesByPrefix codebase sbh
+        case toList branchCompletions of
+          [] -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh
+          [h] ->
+            (Codebase1.getBranchForHash codebase h) >>= \case
+              Just b -> pure b
+              Nothing -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh
+          _ -> throwIO . C.GitCodebaseError $ GitError.RemoteNamespaceHashAmbiguous repo sbh branchCompletions
+    case Branch.getAt path branch of
+      Just b -> action (b, remotePath)
+      Nothing -> throwIO . C.GitCodebaseError $ GitError.CouldntFindRemoteBranch repo path
+  case result of
+    Left schemaVersion -> throwIO . C.GitSqliteCodebaseError $ GitError.UnrecognizedSchemaVersion repo remotePath schemaVersion
+    Right inner -> pure inner
 
 -- Push a branch to a repo. Optionally attempt to set the branch as the new root, which fails if the branch is not after
 -- the existing root.

parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs

@@ -1,11 +1,11 @@
-{- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted
 module Unison.Codebase.SqliteCodebase.GitError where
 
+import U.Codebase.Sqlite.DbId (SchemaVersion)
 import Unison.Codebase.Editor.RemoteRepo (ReadRepo)
 import Unison.CodebasePath (CodebasePath)
-import U.Codebase.Sqlite.DbId (SchemaVersion)
 
 data GitSqliteCodebaseError
   = GitCouldntParseRootBranchHash ReadRepo String
+  | NoDatabaseFile ReadRepo CodebasePath
   | UnrecognizedSchemaVersion ReadRepo CodebasePath SchemaVersion
-  deriving Show
+  deriving (Show)

unison-cli/src/Unison/Codebase/Editor/HandleInput.hs

@@ -11,7 +11,7 @@ where
 
 import qualified Control.Error.Util as ErrorUtil
 import Control.Lens
-import Control.Monad.Except (ExceptT (..), runExceptT, withExceptT)
+import Control.Monad.Except (ExceptT (..), runExceptT, throwError, withExceptT)
 import Control.Monad.State (StateT)
 import qualified Control.Monad.State as State
 import Data.Bifunctor (first, second)
@@ -71,11 +71,12 @@ import qualified Unison.Codebase.PushBehavior as PushBehavior
 import qualified Unison.Codebase.Reflog as Reflog
 import Unison.Codebase.ShortBranchHash (ShortBranchHash)
 import qualified Unison.Codebase.ShortBranchHash as SBH
+import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError(NoDatabaseFile))
 import qualified Unison.Codebase.SyncMode as SyncMode
 import Unison.Codebase.TermEdit (TermEdit (..))
 import qualified Unison.Codebase.TermEdit as TermEdit
 import qualified Unison.Codebase.TermEdit.Typing as TermEdit
-import Unison.Codebase.Type (GitError)
+import Unison.Codebase.Type (GitError(GitSqliteCodebaseError))
 import qualified Unison.Codebase.TypeEdit as TypeEdit
 import qualified Unison.Codebase.Verbosity as Verbosity
 import qualified Unison.CommandLine.DisplayValues as DisplayValues
@@ -1879,17 +1880,21 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do
           sbhLength <- (eval BranchHashLength)
           respond (GistCreated sbhLength repo (Branch.headHash sourceBranch))
         Just (remotePath, pushBehavior) -> do
-          ExceptT . viewRemoteBranch (writeToRead repo, Nothing, Path.empty) $ \remoteRoot -> do
-            let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this
-                -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already.
-                f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing
-            Branch.modifyAtM remotePath f remoteRoot & \case
-              Nothing -> respond (RefusedToPush pushBehavior)
-              Just newRemoteRoot -> do
-                let opts = PushGitBranchOpts {setRoot = True, syncMode}
-                runExceptT (syncRemoteBranch newRemoteRoot repo opts) >>= \case
-                  Left gitErr -> respond (Output.GitError gitErr)
-                  Right () -> respond Success
+          let withRemoteRoot remoteRoot = do
+                let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this
+                    -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already.
+                    f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing
+                Branch.modifyAtM remotePath f remoteRoot & \case
+                  Nothing -> respond (RefusedToPush pushBehavior)
+                  Just newRemoteRoot -> do
+                    let opts = PushGitBranchOpts {setRoot = True, syncMode}
+                    runExceptT (syncRemoteBranch newRemoteRoot repo opts) >>= \case
+                      Left gitErr -> respond (Output.GitError gitErr)
+                      Right () -> respond Success
+          viewRemoteBranch (writeToRead repo, Nothing, Path.empty) withRemoteRoot >>= \case
+            Left (GitSqliteCodebaseError NoDatabaseFile{}) -> withRemoteRoot Branch.empty
+            Left err -> throwError err
+            Right () -> pure ()
   where
     -- Per `pushBehavior`, we are either:
     --

unison-cli/src/Unison/CommandLine/OutputMessages.hs

@@ -50,7 +50,13 @@ import qualified Unison.Codebase.PushBehavior as PushBehavior
 import qualified Unison.Codebase.Runtime as Runtime
 import Unison.Codebase.ShortBranchHash (ShortBranchHash)
 import qualified Unison.Codebase.ShortBranchHash as SBH
-import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError (GitCouldntParseRootBranchHash, UnrecognizedSchemaVersion))
+import Unison.Codebase.SqliteCodebase.GitError
+  ( GitSqliteCodebaseError
+      ( GitCouldntParseRootBranchHash,
+        NoDatabaseFile,
+        UnrecognizedSchemaVersion
+      ),
+  )
 import qualified Unison.Codebase.TermEdit as TermEdit
 import Unison.Codebase.Type (GitError (GitCodebaseError, GitProtocolError, GitSqliteCodebaseError))
 import qualified Unison.Codebase.TypeEdit as TypeEdit
@@ -875,6 +881,12 @@ notifyUser dir o = case o of
   TodoOutput names todo -> pure (todoOutput names todo)
   GitError e -> pure $ case e of
     GitSqliteCodebaseError e -> case e of
+      NoDatabaseFile repo localPath ->
+        P.wrap $
+          "I didn't find a codebase in the repository at"
+            <> prettyReadRepo repo
+            <> "in the cache directory at"
+            <> P.backticked' (P.string localPath) "."
       UnrecognizedSchemaVersion repo localPath (SchemaVersion v) ->
         P.wrap $
           "I don't know how to interpret schema version " <> P.shown v