Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
9ece664b
Commit
9ece664b
authored
Dec 08, 2014
by
ttuegel
Browse files
Merge pull request #2261 from ttuegel/binary-lbi
Use text header for persistent build config
parents
f9bec6b9
78776496
Changes
3
Hide whitespace changes
Inline
Side-by-side
Cabal/Distribution/Simple/Configure.hs
View file @
9ece664b
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Configure
...
...
@@ -23,6 +26,7 @@
module
Distribution.Simple.Configure
(
configure
,
writePersistBuildConfig
,
getConfigStateFile
,
getPersistBuildConfig
,
checkPersistBuildConfigOutdated
,
tryGetPersistBuildConfig
,
...
...
@@ -34,9 +38,7 @@ module Distribution.Simple.Configure (configure,
ccLdOptionsBuildInfo
,
checkForeignDeps
,
interpretPackageDbFlags
,
ConfigStateFileErrorType
(
..
),
ConfigStateFileError
,
ConfigStateFileError
(
..
),
tryGetConfigStateFile
,
platformDefines
,
)
...
...
@@ -115,10 +117,13 @@ 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
qualified
Data.ByteString.Lazy
as
BS
import
Data.Binary
(
decodeOrFail
,
encode
)
import
Data.ByteString.Lazy
(
ByteString
)
import
qualified
Data.ByteString.Lazy.Char8
as
BS
import
Data.List
(
(
\\
),
nub
,
partition
,
isPrefixOf
,
inits
)
import
Data.Maybe
...
...
@@ -132,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
...
...
@@ -147,109 +153,95 @@ 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
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
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
return
$
case
parseHeader
header
of
Nothing
->
cantParse
Just
(
cabalId
,
compId
)
->
badVersion
cabalId
compId
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
)
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."
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."
show
ConfigStateFileNoParse
=
"Saved package config file body is corrupt. "
++
"Try re-running the 'configure' command."
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 c
ontaining 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 c
annot 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'.
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 +250,25 @@ 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
->
(
PackageIdentifier
,
PackageIdentifier
)
parseHeader
header
=
case
BS
.
words
header
of
[
"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
[
"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.
...
...
Cabal/tests/PackageTests.hs
View file @
9ece664b
...
...
@@ -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
cabal-install/Main.hs
View file @
9ece664b
...
...
@@ -125,7 +125,7 @@ import Distribution.Simple.Compiler
(
Compiler
(
..
)
)
import
Distribution.Simple.Configure
(
checkPersistBuildConfigOutdated
,
configCompilerAuxEx
,
ConfigStateFileError
Type
(
..
),
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
)
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment