From 4806aba73d57bcbac08d697046e387af77bd2506 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 8 Dec 2014 11:15:05 -0600 Subject: [PATCH 1/2] Use text header for persistent build config --- Cabal/Distribution/Simple/Configure.hs | 114 ++++++++++++------------- 1 file changed, 53 insertions(+), 61 deletions(-) diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index 47836f23505..a7339748eb1 100644 --- a/Cabal/Distribution/Simple/Configure.hs +++ b/Cabal/Distribution/Simple/Configure.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Configure @@ -118,7 +119,8 @@ import Prelude hiding ( mapM ) import Control.Monad ( liftM, when, unless, foldM, filterM ) import Data.Binary ( Binary, decodeOrFail, encode ) -import qualified Data.ByteString.Lazy as BS +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Char8 as BS import Data.List ( (\\), nub, partition, isPrefixOf, inits ) import Data.Maybe @@ -156,58 +158,41 @@ 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 do - bin <- decodeBinHeader - liftM decodeBody $ case bin of - - -- Parsing the binary header may fail because the state file is in - -- the text format used by older versions of Cabal. When parsing the - -- header fails, try to parse the old text header so we can give the - -- user a meaningful message about their Cabal version having - -- changed. - Left (_, ConfigStateFileCantParse) -> do - txt <- decodeTextHeader - return $ case txt of - Left (_, ConfigStateFileBadVersion) -> txt - _ -> bin - - _ -> return bin - + exists <- doesFileExist filename + if not exists + then return missing + else liftM decodeBody decodeHeader where - decodeB :: Binary a => BS.ByteString - -> Either ConfigStateFileError (BS.ByteString, a) - decodeB str = either (const cantParse) return $ do - (next, _, x) <- decodeOrFail str - return (next, x) - decodeBody :: Binary a => Either ConfigStateFileError BS.ByteString -> Either ConfigStateFileError a decodeBody (Left err) = Left err - decodeBody (Right body) = fmap snd $ decodeB body - - decodeBinHeader :: IO (Either ConfigStateFileError BS.ByteString) - decodeBinHeader = do - pbc <- BS.readFile filename - return $ do - (body, (cabalId, compId)) <- decodeB pbc - when (cabalId /= currentCabalId) $ badVersion cabalId compId - return body - - decodeTextHeader :: IO (Either ConfigStateFileError BS.ByteString) - decodeTextHeader = do - header <- liftM (takeWhile $ (/=) '\n') $ readFile filename + 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 -> cantParse - Just (cabalId, compId) -> badVersion cabalId compId + 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 ) - cantParse = Left ( "Saved package config file seems to be corrupt. " - ++ "Try re-running the 'configure' command." - , ConfigStateFileCantParse ) + cantParseHeader = Left + ( "Saved package config file header is corrupt." + ++ "Try re-running the 'configure' command." + , ConfigStateFileCantParse + ) + cantParseBody = Left + ( "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 " @@ -246,10 +231,11 @@ maybeGetPersistBuildConfig distPref = do -- 'localBuildInfoFile'. writePersistBuildConfig :: FilePath -> LocalBuildInfo -> IO () writePersistBuildConfig distPref lbi = do - createDirectoryIfMissing False distPref - let header = (currentCabalId, currentCompilerId) - writeFileAtomic (localBuildInfoFile distPref) - $ BS.append (encode header) (encode lbi) + createDirectoryIfMissing False distPref + writeFileAtomic (localBuildInfoFile distPref) $ + BS.unlines [showHeader pkgId, encode lbi] + where + pkgId = packageId $ localPkgDescr lbi currentCabalId :: PackageIdentifier currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion @@ -258,18 +244,24 @@ currentCompilerId :: PackageIdentifier currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName) System.Info.compilerVersion -parseHeader :: String -> Maybe (PackageIdentifier, PackageIdentifier) -parseHeader header = case words header of - ["Saved", "package", "config", "for", pkgid, - "written", "by", cabalid, "using", compilerid] - -> case (simpleParse pkgid :: Maybe PackageIdentifier, - simpleParse cabalid, - simpleParse compilerid) of - (Just _, - Just cabalid', - Just compilerid') -> Just (cabalid', compilerid') - _ -> Nothing - _ -> Nothing +parseHeader :: ByteString -> Maybe (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 + +showHeader :: PackageIdentifier -> ByteString +showHeader pkgId = BS.unwords + [ "Saved", "package", "config", "for" + , BS.pack $ display pkgId + , "written", "by" + , BS.pack $ display currentCabalId + , "using" + , BS.pack $ display currentCompilerId + ] -- |Check that localBuildInfoFile is up-to-date with respect to the -- .cabal file. From 78776496c34ee1aa34b5ef18f22c0512b8bf54bd Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Mon, 8 Dec 2014 13:56:11 -0600 Subject: [PATCH 2/2] 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 a7339748eb1..69582cb392b 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 b3f50705d25..b2a599146ac 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 ea04c9b76ed..e2c29940cd4 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)