Fix Pantry #58 Handle [S-536] in Stack

Also does not suggestion an inappropriate workaround if the cause is the upstream bug discussed at #5851. Also updates the error documentation, generally. Also conforms the Haddock documentation of pretty exceptions in various modules. Also refactors some import lists, in passing, with a longer term view to a more consistent approach.
commercialhaskell · Nov 19, 2022 · 864d923 · 864d923
1 parent 025363b
commit 864d923
Show file tree

Hide file tree

Showing 13 changed files with 191 additions and 97 deletions.
diff --git a/doc/maintainers/stack_errors.md b/doc/maintainers/stack_errors.md
@@ -5,7 +5,7 @@
 In connection with considering Stack's support of the
 [Haskell Error Index](https://errors.haskell.org/) initiative, this page seeks
 to take stock of the errors that Stack itself can raise, by reference to the
-`master` branch of the Stack repository. Last updated: 2022-11-11.
+`master` branch of the Stack repository. Last updated: 2022-11-19.
 
 *   `Main.main`: catches exceptions from action `commandLineHandler`.
 
@@ -308,9 +308,6 @@ to take stock of the errors that Stack itself can raise, by reference to the
         [S-2154] | UnknownTargets (Set PackageName) (Map PackageName Version) (Path Abs File)
         [S-1995] | TestSuiteFailure PackageIdentifier (Map Text (Maybe ExitCode)) (Maybe (Path Abs File)) ByteString
         [S-3819] | TestSuiteTypeUnsupported TestSuiteInterface
-        [S-7011] | CabalExitedUnsuccessfully ExitCode PackageIdentifier (Path Abs File) [String] (Maybe (Path Abs File)) [Text]
-        [S-6374] | SetupHsBuildFailure ExitCode (Maybe PackageIdentifier) (Path Abs File) [String] (Maybe (Path Abs File)) [Text]
-        [S-7282] | ExecutionFailure [SomeException]
         [S-5797] | LocalPackageDoesn'tMatchTarget PackageName Version Version
         [S-3118] | NoSetupHsFound (Path Abs Dir)
         [S-8664] | InvalidFlagSpecification (Set UnusedFlags)
@@ -334,6 +331,9 @@ to take stock of the errors that Stack itself can raise, by reference to the
 
         ~~~haskell
         [S-4804] | ConstructPlanFailed [ConstructPlanException] (Path Abs File) (Path Abs Dir) ParentMap (Set PackageName) (Map PackageName [PackageName])
+        [S-7282] | ExecutionFailure [SomeException]
+        [S-7011] | CabalExitedUnsuccessfully ExitCode PackageIdentifier (Path Abs File) [String] (Maybe (Path Abs File)) [Text]
+        [S-6374] | SetupHsBuildFailure ExitCode (Maybe PackageIdentifier) (Path Abs File) [String] (Maybe (Path Abs File)) [Text]
         ~~~
 
     -   `Stack.Types.Compiler.CompilerException`
@@ -421,6 +421,12 @@ to take stock of the errors that Stack itself can raise, by reference to the
         [S-4865] | FilepathInDownloadedSnapshot Text
         ~~~
 
+    -   `Stack.Types.Storage.StoragePrettyException`
+
+        ~~~haskell
+        [S-8835] = StorageMigrationFailure Text (Path Abs File) SomeException
+        ~~~
+
     -   `Stack.Types.TemplateName.TypesTemplateNameException`
 
         ~~~haskell

diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs
@@ -19,58 +19,61 @@
 -- probably default to behaving like cabal, possibly with spitting out
 -- a warning that "you should run `stk init` to make things better".
 module Stack.Config
-  (loadConfig
-  ,loadConfigYaml
-  ,packagesParser
-  ,getImplicitGlobalProjectDir
-  ,getSnapshots
-  ,makeConcreteResolver
-  ,checkOwnership
-  ,getInContainer
-  ,getInNixShell
-  ,defaultConfigYaml
-  ,getProjectConfig
-  ,withBuildConfig
-  ,withNewLogFunc
+  ( loadConfig
+  , loadConfigYaml
+  , packagesParser
+  , getImplicitGlobalProjectDir
+  , getSnapshots
+  , makeConcreteResolver
+  , checkOwnership
+  , getInContainer
+  , getInNixShell
+  , defaultConfigYaml
+  , getProjectConfig
+  , withBuildConfig
+  , withNewLogFunc
   ) where
 
-import           Control.Monad.Extra (firstJustM)
-import           Stack.Prelude
-import           Pantry.Internal.AesonExtended
-import           Data.Array.IArray ((!), (//))
+import           Control.Monad.Extra ( firstJustM )
+import           Data.Array.IArray ( (!), (//) )
 import qualified Data.ByteString as S
-import           Data.ByteString.Builder (byteString)
-import           Data.Coerce (coerce)
+import           Data.ByteString.Builder ( byteString )
+import           Data.Coerce ( coerce )
 import qualified Data.IntMap as IntMap
 import qualified Data.Map as Map
 import qualified Data.Map.Merge.Strict as MS
 import qualified Data.Monoid
-import           Data.Monoid.Map (MonoidMap(..))
+import           Data.Monoid.Map ( MonoidMap (..) )
 import qualified Data.Text as T
 import qualified Data.Yaml as Yaml
-import           Distribution.System (OS (..), Platform (..), buildPlatform, Arch(OtherArch))
+import           Distribution.System
+                   ( Arch (OtherArch), OS (..), Platform (..), buildPlatform )
 import qualified Distribution.Text
-import           Distribution.Version (simplifyVersionRange, mkVersion')
-import           GHC.Conc (getNumProcessors)
-import           Network.HTTP.StackClient (httpJSON, parseUrlThrow, getResponseBody)
-import           Options.Applicative (Parser, help, long, metavar, strOption)
+import           Distribution.Version ( simplifyVersionRange, mkVersion' )
+import           GHC.Conc ( getNumProcessors )
+import           Network.HTTP.StackClient
+                   ( httpJSON, parseUrlThrow, getResponseBody )
+import           Options.Applicative ( Parser, help, long, metavar, strOption )
+import           Pantry.Internal.AesonExtended
 import           Path
-import           Path.Extra (toFilePathNoTrailingSep)
-import           Path.Find (findInParents)
+import           Path.Extra ( toFilePathNoTrailingSep )
+import           Path.Find ( findInParents )
 import           Path.IO
 import qualified Paths_stack as Meta
-import           RIO.List (unzip)
+import           RIO.List ( unzip )
 import           RIO.Process
-import           RIO.Time (toGregorian)
-import           Stack.Build.Haddock (shouldHaddockDeps)
+import           RIO.Time ( toGregorian )
+import           Stack.Build.Haddock ( shouldHaddockDeps )
 import           Stack.Config.Build
 import           Stack.Config.Docker
 import           Stack.Config.Nix
 import           Stack.Constants
-import           Stack.Lock (lockCachedWanted)
+import           Stack.Lock ( lockCachedWanted )
+import           Stack.Prelude
 import           Stack.SourceMap
-import           Stack.Storage.Project (initProjectStorage)
-import           Stack.Storage.User (initUserStorage)
+import           Stack.Storage.Project ( initProjectStorage )
+import           Stack.Storage.User ( initUserStorage )
+import           Stack.Storage.Util ( handleMigrationException )
 import           Stack.Types.Build
 import           Stack.Types.Compiler
 import           Stack.Types.Config
@@ -79,11 +82,12 @@ import           Stack.Types.Nix
 import           Stack.Types.Resolver
 import           Stack.Types.SourceMap
 import           Stack.Types.Version
-import           System.Console.ANSI (hSupportsANSIWithoutEmulation, setSGRCode)
+import           System.Console.ANSI
+                   ( hSupportsANSIWithoutEmulation, setSGRCode )
 import           System.Environment
-import           System.Info.ShortPathName (getShortPathName)
-import           System.PosixCompat.Files (fileOwner, getFileStatus)
-import           System.PosixCompat.User (getEffectiveUserID)
+import           System.Info.ShortPathName ( getShortPathName )
+import           System.PosixCompat.Files ( fileOwner, getFileStatus )
+import           System.PosixCompat.User ( getEffectiveUserID )
 
 -- | If deprecated path exists, use it and print a warning.
 -- Otherwise, return the new path.
@@ -406,17 +410,18 @@ configFromConfigMonoid
 
      withNewLogFunc go useColor'' stylesUpdate' $ \logFunc -> do
        let configRunner = configRunner'' & logFuncL .~ logFunc
-       withLocalLogFunc logFunc $ withPantryConfig
-         pantryRoot
-         pic
-         (maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack)
-         clConnectionCount
-         (fromFirst defaultCasaRepoPrefix configMonoidCasaRepoPrefix)
-         defaultCasaMaxPerRequest
-         snapLoc
-         (\configPantryConfig -> initUserStorage
-           (configStackRoot </> relFileStorage)
-           (\configUserStorage -> inner Config {..}))
+       withLocalLogFunc logFunc $ handleMigrationException $
+         withPantryConfig
+           pantryRoot
+           pic
+           (maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack)
+           clConnectionCount
+           (fromFirst defaultCasaRepoPrefix configMonoidCasaRepoPrefix)
+           defaultCasaMaxPerRequest
+           snapLoc
+           (\configPantryConfig -> initUserStorage
+             (configStackRoot </> relFileStorage)
+             (\configUserStorage -> inner Config {..}))
 
 -- | Runs the provided action with the given 'LogFunc' in the environment
 withLocalLogFunc :: HasLogFunc env => LogFunc -> RIO env a -> RIO env a

diff --git a/src/Stack/Prelude.hs b/src/Stack/Prelude.hs
@@ -85,14 +85,14 @@ import qualified Path.IO
 import           RIO as X
 import           RIO.File as X hiding ( writeBinaryFileAtomic )
 import           RIO.PrettyPrint
-                   ( HasStylesUpdate (..), HasTerm (..), Pretty (..)
-                   , Style (..), StyleDoc, (<+>), align, bulletedList
-                   , debugBracket, encloseSep, fillSep, flow, hang, hcat
-                   , indent, line, logLevelToStyle, parens, prettyDebugL
-                   , prettyError, prettyErrorL, prettyInfo, prettyInfoL
-                   , prettyInfoS, prettyNote, prettyWarn, prettyWarnL
-                   , prettyWarnS, punctuate, sep, softbreak, softline, style
-                   , stylesUpdateL, useColorL, vsep
+                   ( HasStylesUpdate (..), HasTerm (..), Pretty (..), Style (..)
+                   , StyleDoc, (<+>), align, bulletedList, debugBracket
+                   , encloseSep, fillSep, flow, hang, hcat, indent, line
+                   , logLevelToStyle, parens, prettyDebugL, prettyError
+                   , prettyErrorL, prettyInfo, prettyInfoL, prettyInfoS
+                   , prettyNote, prettyWarn, prettyWarnL, prettyWarnS, punctuate
+                   , sep, softbreak, softline, style, stylesUpdateL, useColorL
+                   , vsep
                    )
 import           RIO.PrettyPrint.DefaultStyles (defaultStyles)
 import           RIO.PrettyPrint.PrettyException ( PrettyException (..) )
@@ -317,6 +317,6 @@ bugDeclaration = "The impossible happened!"
 bugRequest :: String
 bugRequest =  "Please report this bug at Stack's repository."
 
--- | A 'pretty' blank line.
+-- | A \'pretty\' blank line.
 blankLine :: StyleDoc
 blankLine = line <> line
diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs
@@ -351,7 +351,7 @@ instance Show SetupException where
 
 instance Exception SetupException
 
--- | Type representing pretty exceptions thrown by functions exported by the
+-- | Type representing \'pretty\' exceptions thrown by functions exported by the
 -- "Stack.Setup" module
 data SetupPrettyException
     = GHCInstallFailed SomeException String String [String] (Path Abs Dir)

diff --git a/src/Stack/Storage/Project.hs b/src/Stack/Storage/Project.hs
@@ -28,16 +28,20 @@ module Stack.Storage.Project
 
 import qualified Data.ByteString as S
 import qualified Data.Set as Set
-import Database.Persist.Sqlite
-import Database.Persist.TH
+import           Database.Persist.Sqlite
+import           Database.Persist.TH
 import qualified Pantry.Internal as SQLite
-import Path
-import Stack.Prelude hiding (MigrationFailure)
-import Stack.Storage.Util
-import Stack.Types.Build
-import Stack.Types.Cache
-import Stack.Types.Config (HasBuildConfig, buildConfigL, bcProjectStorage, ProjectStorage (..))
-import Stack.Types.GhcPkgId
+import           Path
+import           Stack.Prelude
+import           Stack.Storage.Util
+                   ( handleMigrationException, updateList, updateSet )
+import           Stack.Types.Build
+import           Stack.Types.Cache
+import           Stack.Types.Config
+                   ( HasBuildConfig, ProjectStorage (..), bcProjectStorage
+                   , buildConfigL
+                   )
+import           Stack.Types.GhcPkgId
 
 share [ mkPersist sqlSettings
       , mkMigrate "migrateAll"
@@ -86,7 +90,8 @@ initProjectStorage ::
     => Path Abs File -- ^ storage file
     -> (ProjectStorage -> RIO env a)
     -> RIO env a
-initProjectStorage fp f = SQLite.initStorage "Stack" migrateAll fp $ f . ProjectStorage
+initProjectStorage fp f = handleMigrationException $
+    SQLite.initStorage "Stack" migrateAll fp $ f . ProjectStorage
 
 -- | Run an action in a database transaction
 withProjectStorage ::

diff --git a/src/Stack/Storage/User.hs b/src/Stack/Storage/User.hs
@@ -33,24 +33,28 @@ module Stack.Storage.User
 
 import qualified Data.Set as Set
 import qualified Data.Text as T
-import Data.Time.Clock (UTCTime)
-import Database.Persist.Sqlite
-import Database.Persist.TH
-import Distribution.Text (simpleParse, display)
-import Foreign.C.Types (CTime (..))
+import           Data.Time.Clock ( UTCTime )
+import           Database.Persist.Sqlite
+import           Database.Persist.TH
+import           Distribution.Text ( simpleParse, display )
+import           Foreign.C.Types ( CTime (..) )
 import qualified Pantry.Internal as SQLite
-import Path
-import Path.IO (resolveFile', resolveDir')
+import           Path
+import           Path.IO ( resolveFile', resolveDir' )
 import qualified RIO.FilePath as FP
-import Stack.Prelude hiding (MigrationFailure)
-import Stack.Storage.Util
-import Stack.Types.Build
-import Stack.Types.Cache
-import Stack.Types.Compiler
-import Stack.Types.CompilerBuild (CompilerBuild)
-import Stack.Types.Config (HasConfig, configL, configUserStorage, CompilerPaths (..), GhcPkgExe (..), UserStorage (..))
-import System.Posix.Types (COff (..))
-import System.PosixCompat.Files (getFileStatus, fileSize, modificationTime)
+import           Stack.Prelude hiding ( MigrationFailure )
+import           Stack.Storage.Util ( handleMigrationException, updateSet )
+import           Stack.Types.Build
+import           Stack.Types.Cache
+import           Stack.Types.Compiler
+import           Stack.Types.CompilerBuild ( CompilerBuild )
+import           Stack.Types.Config
+                   ( CompilerPaths (..), GhcPkgExe (..), HasConfig
+                   , UserStorage (..), configL, configUserStorage
+                   )
+import           System.Posix.Types ( COff (..) )
+import           System.PosixCompat.Files
+                   ( fileSize, getFileStatus, modificationTime )
 
 -- | Type representing exceptions thrown by functions exported by the
 -- "Stack.Storage.User" module.
@@ -154,7 +158,8 @@ initUserStorage ::
     => Path Abs File -- ^ storage file
     -> (UserStorage -> RIO env a)
     -> RIO env a
-initUserStorage fp f = SQLite.initStorage "Stack" migrateAll fp $ f . UserStorage
+initUserStorage fp f = handleMigrationException $
+    SQLite.initStorage "Stack" migrateAll fp $ f . UserStorage
 
 -- | Run an action in a database transaction
 withUserStorage ::

diff --git a/src/Stack/Storage/Util.hs b/src/Stack/Storage/Util.hs
@@ -7,13 +7,15 @@
 
 -- | Utils for the other Stack.Storage modules
 module Stack.Storage.Util
-    ( updateList
+    ( handleMigrationException
+    , updateList
     , updateSet
     ) where
 
 import qualified Data.Set as Set
-import Database.Persist
-import Stack.Prelude hiding (MigrationFailure)
+import           Database.Persist
+import           Stack.Prelude
+import           Stack.Types.Storage ( StoragePrettyException (..) )
 
 -- | Efficiently update a set of values stored in a database table
 updateSet ::
@@ -69,3 +71,16 @@ updateList recordCons parentFieldCons parentId indexFieldCons old new =
         insertMany_ $
             map (uncurry $ recordCons parentId) $
             Set.toList (Set.difference newSet oldSet)
+
+handleMigrationException :: HasLogFunc env => RIO env a -> RIO env a
+handleMigrationException inner = do
+    eres <- try inner
+    either
+        ( \e -> case e :: PantryException of
+                    MigrationFailure desc fp ex ->
+                        throwIO $
+                            PrettyException $ StorageMigrationFailure desc fp ex
+                    _ -> throwIO e
+        )
+        pure
+        eres
diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs
@@ -367,8 +367,8 @@ data BuildPrettyException
         [Text]     -- log contents
     deriving Typeable
 
--- | These exceptions are intended to be thrown only as 'pretty exceptions, so
--- their 'show' functions can be simple.
+-- | These exceptions are intended to be thrown only as \'pretty\' exceptions,
+-- so their \'show\' functions can be simple.
 instance Show BuildPrettyException where
     show (ConstructPlanFailed {}) = "ConstructPlanFailed"
     show (ExecutionFailure {}) = "ExecutionFailure"

diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs
@@ -422,7 +422,7 @@ instance Show ConfigException where
 
 instance Exception ConfigException
 
--- | Type representing 'pretty' exceptions thrown by functions exported by the
+-- | Type representing \'pretty\' exceptions thrown by functions exported by the
 -- "Stack.Config" module.
 data ConfigPrettyException
     = ParseConfigFileException (Path Abs File) ParseException