From 78776496c34ee1aa34b5ef18f22c0512b8bf54bd Mon Sep 17 00:00:00 2001
From: Thomas Tuegel <ttuegel@gmail.com>
Date: Mon, 8 Dec 2014 13:56:11 -0600
Subject: [PATCH] getConfigStateFile: throw meaningful exceptions, recover old
 LBI

getConfigStateFile now throws meaningful exceptions which are caught by
tryGetConfigStateFile and friends, which are allowed to propagate,
rather than just calling 'die'. If the LocalBuildInfo was generated by
an older version of Cabal, an exception is still generated, but the
LocalBuildInfo is included if it is recoverable. This feature is used to
reduce code duplication between the library and the test suite.
---
 Cabal/Distribution/Simple/Configure.hs | 163 +++++++++++++------------
 Cabal/tests/PackageTests.hs            |  49 +++-----
 cabal-install/Main.hs                  |  27 ++--
 3 files changed, 112 insertions(+), 127 deletions(-)

diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs
index a7339748eb..69582cb392 100644
--- a/Cabal/Distribution/Simple/Configure.hs
+++ b/Cabal/Distribution/Simple/Configure.hs
@@ -1,4 +1,6 @@
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE OverloadedStrings #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Distribution.Simple.Configure
@@ -24,6 +26,7 @@
 
 module Distribution.Simple.Configure (configure,
                                       writePersistBuildConfig,
+                                      getConfigStateFile,
                                       getPersistBuildConfig,
                                       checkPersistBuildConfigOutdated,
                                       tryGetPersistBuildConfig,
@@ -35,9 +38,7 @@ module Distribution.Simple.Configure (configure,
                                       ccLdOptionsBuildInfo,
                                       checkForeignDeps,
                                       interpretPackageDbFlags,
-
-                                      ConfigStateFileErrorType(..),
-                                      ConfigStateFileError,
+                                      ConfigStateFileError(..),
                                       tryGetConfigStateFile,
                                       platformDefines,
                                      )
@@ -116,9 +117,11 @@ import qualified Distribution.Simple.HaskellSuite as HaskellSuite
 
 -- Prefer the more generic Data.Traversable.mapM to Prelude.mapM
 import Prelude hiding ( mapM )
+import Control.Exception
+    ( ErrorCall(..), Exception, evaluate, throw, throwIO, try )
 import Control.Monad
     ( liftM, when, unless, foldM, filterM )
-import Data.Binary ( Binary, decodeOrFail, encode )
+import Data.Binary ( decodeOrFail, encode )
 import Data.ByteString.Lazy (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as BS
 import Data.List
@@ -134,6 +137,7 @@ import qualified Data.Map as Map
 import Data.Map (Map)
 import Data.Traversable
     ( mapM )
+import Data.Typeable
 import System.Directory
     ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )
 import System.FilePath
@@ -149,83 +153,85 @@ import Text.PrettyPrint
     , quotes, punctuate, nest, sep, hsep )
 import Distribution.Compat.Exception ( catchExit, catchIO )
 
-data ConfigStateFileErrorType = ConfigStateFileCantParse
-                              | ConfigStateFileMissing
-                              | ConfigStateFileBadVersion
-                              deriving Eq
-type ConfigStateFileError = (String, ConfigStateFileErrorType)
-
-tryGetConfigStateFile :: (Binary a) => FilePath
-                      -> IO (Either ConfigStateFileError a)
-tryGetConfigStateFile filename = do
-    exists <- doesFileExist filename
-    if not exists
-      then return missing
-      else liftM decodeBody decodeHeader
-  where
-    decodeBody :: Binary a => Either ConfigStateFileError BS.ByteString
-               -> Either ConfigStateFileError a
-    decodeBody (Left err) = Left err
-    decodeBody (Right body) =
-        case decodeOrFail body of
-            Left _ -> cantParseBody
-            Right (_, _, x) -> Right x
-
-    decodeHeader :: IO (Either ConfigStateFileError BS.ByteString)
-    decodeHeader = do
-        (header, body) <- liftM (BS.span $ (/=) '\n') $ BS.readFile filename
-        return $ case parseHeader header of
-            Nothing -> cantParseHeader
-            Just (cabalId, compId)
-              | (cabalId /= currentCabalId) || (compId /= currentCompilerId) ->
-                  badVersion cabalId compId
-              | otherwise -> Right $ BS.tail body
-
-    missing   = Left ( "Run the 'configure' command first."
-                     , ConfigStateFileMissing )
-    cantParseHeader = Left
-        (  "Saved package config file header is corrupt."
+data ConfigStateFileError
+    = ConfigStateFileNoHeader
+    | ConfigStateFileBadHeader
+    | ConfigStateFileNoParse
+    | ConfigStateFileMissing
+    | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
+  deriving (Typeable)
+
+instance Show ConfigStateFileError where
+    show ConfigStateFileNoHeader =
+        "Saved package config file header is missing. "
+        ++ "Try re-running the 'configure' command."
+    show ConfigStateFileBadHeader =
+        "Saved package config file header is corrupt. "
         ++ "Try re-running the 'configure' command."
-        , ConfigStateFileCantParse
-        )
-    cantParseBody = Left
-        (  "Saved package config file body is corrupt."
+    show ConfigStateFileNoParse =
+        "Saved package config file body is corrupt. "
         ++ "Try re-running the 'configure' command."
-        , ConfigStateFileCantParse
-        )
-    badVersion cabalId compId
-              = Left (  "You need to re-run the 'configure' command. "
-                     ++ "The version of Cabal being used has changed (was "
-                     ++ display cabalId ++ ", now "
-                     ++ display currentCabalId ++ ")."
-                     ++ badcompiler compId
-                     , ConfigStateFileBadVersion )
-    badcompiler compId | compId == currentCompilerId = ""
-                       | otherwise
-              = " Additionally the compiler is different (was "
-             ++ display compId ++ ", now "
-             ++ display currentCompilerId
-             ++ ") which is probably the cause of the problem."
+    show ConfigStateFileMissing = "Run the 'configure' command first."
+    show (ConfigStateFileBadVersion oldCabal oldCompiler _) =
+        "You need to re-run the 'configure' command. "
+        ++ "The version of Cabal being used has changed (was "
+        ++ display oldCabal ++ ", now "
+        ++ display currentCabalId ++ ")."
+        ++ badCompiler
+      where
+        badCompiler
+          | oldCompiler == currentCompilerId = ""
+          | otherwise =
+              " Additionally the compiler is different (was "
+              ++ display oldCompiler ++ ", now "
+              ++ display currentCompilerId
+              ++ ") which is probably the cause of the problem."
+
+instance Exception ConfigStateFileError
+
+getConfigStateFile :: FilePath -> IO LocalBuildInfo
+getConfigStateFile filename = do
+    exists <- doesFileExist filename
+    unless exists $ throwIO ConfigStateFileMissing
+
+    (header, body) <- liftM (BS.span $ (/=) '\n') $ BS.readFile filename
+
+    headerParseResult <- try $ evaluate $ parseHeader header
+    let (cabalId, compId) =
+            case headerParseResult of
+              Left (ErrorCall _) -> throw ConfigStateFileBadHeader
+              Right x -> x
+
+    let getStoredValue = evaluate $
+            case decodeOrFail (BS.tail body) of
+              Left _ -> throw ConfigStateFileNoParse
+              Right (_, _, x) -> x
+        deferErrorIfBadVersion act
+          | cabalId /= currentCabalId || compId /= currentCompilerId = do
+              eResult <- try act
+              throw $ ConfigStateFileBadVersion cabalId compId eResult
+          | otherwise = act
+    deferErrorIfBadVersion getStoredValue
+
+tryGetConfigStateFile :: FilePath
+                      -> IO (Either ConfigStateFileError LocalBuildInfo)
+tryGetConfigStateFile = try . getConfigStateFile
 
 -- |Try to read the 'localBuildInfoFile'.
 tryGetPersistBuildConfig :: FilePath
-                            -> IO (Either ConfigStateFileError LocalBuildInfo)
-tryGetPersistBuildConfig distPref
-    = tryGetConfigStateFile (localBuildInfoFile distPref)
+                         -> IO (Either ConfigStateFileError LocalBuildInfo)
+tryGetPersistBuildConfig = try . getPersistBuildConfig
 
--- |Read the 'localBuildInfoFile'.  Error if it doesn't exist.  Also
--- fail if the file containing LocalBuildInfo is older than the .cabal
--- file, indicating that a re-configure is required.
+-- | Read the 'localBuildInfoFile'. Throw an exception if the file is
+-- missing, if the file cannot be read, or if the file was created by an older
+-- version of Cabal.
 getPersistBuildConfig :: FilePath -> IO LocalBuildInfo
-getPersistBuildConfig distPref = do
-  lbi <- tryGetPersistBuildConfig distPref
-  either (die . fst) return lbi
+getPersistBuildConfig = getConfigStateFile . localBuildInfoFile
 
 -- |Try to read the 'localBuildInfoFile'.
 maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo)
-maybeGetPersistBuildConfig distPref = do
-  lbi <- tryGetPersistBuildConfig distPref
-  return $ either (const Nothing) Just lbi
+maybeGetPersistBuildConfig =
+    liftM (either (const Nothing) Just) . tryGetPersistBuildConfig
 
 -- |After running configure, output the 'LocalBuildInfo' to the
 -- 'localBuildInfoFile'.
@@ -244,14 +250,15 @@ currentCompilerId :: PackageIdentifier
 currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName)
                                       System.Info.compilerVersion
 
-parseHeader :: ByteString -> Maybe (PackageIdentifier, PackageIdentifier)
+parseHeader :: ByteString -> (PackageIdentifier, PackageIdentifier)
 parseHeader header = case BS.words header of
-  ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId, "using", compId] -> do
-        _ <- simpleParse (BS.unpack pkgId) :: Maybe PackageIdentifier
-        cabalId' <- simpleParse (BS.unpack cabalId)
-        compId' <- simpleParse (BS.unpack compId)
-        return (cabalId', compId')
-  _ -> Nothing
+  ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId, "using", compId] ->
+      fromMaybe (throw ConfigStateFileBadHeader) $ do
+          _ <- simpleParse (BS.unpack pkgId) :: Maybe PackageIdentifier
+          cabalId' <- simpleParse (BS.unpack cabalId)
+          compId' <- simpleParse (BS.unpack compId)
+          return (cabalId', compId')
+  _ -> throw ConfigStateFileNoHeader
 
 showHeader :: PackageIdentifier -> ByteString
 showHeader pkgId = BS.unwords
diff --git a/Cabal/tests/PackageTests.hs b/Cabal/tests/PackageTests.hs
index b3f50705d2..b2a599146a 100644
--- a/Cabal/tests/PackageTests.hs
+++ b/Cabal/tests/PackageTests.hs
@@ -36,21 +36,21 @@ import PackageTests.TestSuiteExeV10.Check
 import PackageTests.OrderFlags.Check
 import PackageTests.ReexportedModules.Check
 
-import Distribution.Package (PackageIdentifier)
+import Distribution.Simple.Configure
+    ( ConfigStateFileError(..), getConfigStateFile )
 import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))
 import Distribution.Simple.Program.Types (programPath)
-import Distribution.Simple.Program.Builtin (ghcProgram, ghcPkgProgram,
-                                            haddockProgram)
+import Distribution.Simple.Program.Builtin
+    ( ghcProgram, ghcPkgProgram, haddockProgram )
 import Distribution.Simple.Program.Db (requireProgram)
-import Distribution.Simple.Utils (cabalVersion, die)
+import Distribution.Simple.Utils (cabalVersion)
 import Distribution.Text (display)
 import Distribution.Verbosity (normal)
 import Distribution.Version (Version(Version))
 
-import Data.Binary (Binary, decodeOrFail)
-import qualified Data.ByteString.Lazy as BS
-import System.Directory (doesFileExist, getCurrentDirectory,
-                         setCurrentDirectory)
+import Control.Exception (try, throw)
+import System.Directory
+    ( getCurrentDirectory, setCurrentDirectory )
 import System.FilePath ((</>))
 import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout)
 import Test.Framework (Test, TestName, defaultMain, testGroup)
@@ -169,30 +169,9 @@ main = do
 -- we run Cabal's own test suite, due to bootstrapping issues.
 getPersistBuildConfig_ :: FilePath -> IO LocalBuildInfo
 getPersistBuildConfig_ filename = do
-  exists <- doesFileExist filename
-  if not exists
-    then die "Run the 'configure' command first."
-    else decodeBinHeader >>= decodeBody
-
-  where
-    decodeB :: Binary a => BS.ByteString -> Either String (BS.ByteString, a)
-    decodeB str = either (const cantParse) return $ do
-        (next, _, x) <- decodeOrFail str
-        return (next, x)
-
-    decodeBody :: Either String BS.ByteString -> IO LocalBuildInfo
-    decodeBody (Left msg) = die msg
-    decodeBody (Right body) = either die (return . snd) $ decodeB body
-
-    decodeBinHeader :: IO (Either String BS.ByteString)
-    decodeBinHeader = do
-        pbc <- BS.readFile filename
-        return $ do
-            (body, _) <- decodeB pbc :: Either String ( BS.ByteString
-                                                      , ( PackageIdentifier
-                                                      , PackageIdentifier )
-                                                      )
-            return body
-
-    cantParse = Left $  "Saved package config file seems to be corrupt. "
-                     ++ "Try re-running the 'configure' command."
+    eLBI <- try $ getConfigStateFile filename
+    case eLBI of
+      Left (ConfigStateFileBadVersion _ _ (Right lbi)) -> return lbi
+      Left (ConfigStateFileBadVersion _ _ (Left err)) -> throw err
+      Left err -> throw err
+      Right lbi -> return lbi
diff --git a/cabal-install/Main.hs b/cabal-install/Main.hs
index ea04c9b76e..e2c29940cd 100644
--- a/cabal-install/Main.hs
+++ b/cabal-install/Main.hs
@@ -125,7 +125,7 @@ import Distribution.Simple.Compiler
          ( Compiler(..) )
 import Distribution.Simple.Configure
          ( checkPersistBuildConfigOutdated, configCompilerAuxEx
-         , ConfigStateFileErrorType(..), localBuildInfoFile
+         , ConfigStateFileError(..), localBuildInfoFile
          , getPersistBuildConfig, tryGetPersistBuildConfig )
 import qualified Distribution.Simple.LocalBuildInfo as LBI
 import Distribution.Simple.Program (defaultProgramConfiguration)
@@ -468,8 +468,8 @@ reconfigure verbosity distPref     addConfigFlags extraArgs globalFlags
             skipAddSourceDepsCheck numJobsFlag    checkFlags = do
   eLbi <- tryGetPersistBuildConfig distPref
   case eLbi of
-    Left (err, errCode) -> onNoBuildConfig err errCode
-    Right lbi           -> onBuildConfig lbi
+    Left err  -> onNoBuildConfig err
+    Right lbi -> onBuildConfig lbi
 
   where
 
@@ -477,17 +477,16 @@ reconfigure verbosity distPref     addConfigFlags extraArgs globalFlags
     --
     -- If we're in a sandbox: add-source deps don't have to be reinstalled
     -- (since we don't know the compiler & platform).
-    onNoBuildConfig :: String -> ConfigStateFileErrorType
-                       -> IO (UseSandbox, SavedConfig)
-    onNoBuildConfig err errCode = do
-      let msg = case errCode of
-            ConfigStateFileMissing    -> "Package has never been configured."
-            ConfigStateFileCantParse  -> "Saved package config file seems "
-                                         ++ "to be corrupt."
-            ConfigStateFileBadVersion -> err
-      case errCode of
-        ConfigStateFileBadVersion -> info verbosity msg
-        _                         -> do
+    onNoBuildConfig :: ConfigStateFileError -> IO (UseSandbox, SavedConfig)
+    onNoBuildConfig err = do
+      let msg = case err of
+            ConfigStateFileMissing -> "Package has never been configured."
+            ConfigStateFileNoParse -> "Saved package config file seems "
+                                      ++ "to be corrupt."
+            _ -> show err
+      case err of
+        ConfigStateFileBadVersion _ _ _ -> info verbosity msg
+        _                               -> do
           notice verbosity
             $ msg ++ " Configuring with default flags." ++ configureManually
           configureAction (defaultFlags, defaultConfigExFlags)
-- 
GitLab