Commit aa4d30d7 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Merge pull request #3244 from 23Skidoo/merge-1.24

Merge nix-local-build changes from 1.24
parents 692d8bf4 ebb6c552
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE CPP, DeriveGeneric #-}
--TODO: [code cleanup] plausibly much of this module should be merged with
-- similar functionality in Cabal.
module Distribution.Client.Glob
( GlobAtom(..)
, Glob (..)
, globMatches
( FilePathGlob(..)
, FilePathRoot(..)
, FilePathGlobRel(..)
, Glob
, GlobPiece(..)
, matchFileGlob
, matchFileGlobRel
, matchGlob
, isTrivialFilePathGlob
, getFilePathRootDirectory
) where
import Data.List (stripPrefix)
import Control.Monad (liftM2)
import Distribution.Compat.Binary
import GHC.Generics (Generic)
import Data.Char (toUpper)
import Data.List (stripPrefix)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Monad
import Distribution.Compat.Binary
import GHC.Generics (Generic)
import Distribution.Text
import Distribution.Compat.ReadP
import Distribution.Text
import Distribution.Compat.ReadP (ReadP, (<++), (+++))
import qualified Distribution.Compat.ReadP as Parse
import qualified Text.PrettyPrint as Disp
import System.FilePath
import System.Directory
-- | A piece of a globbing pattern
data GlobAtom = WildCard
| Literal String
| Union [Glob]
-- | A file path specified by globbing
--
data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel
deriving (Eq, Show, Generic)
instance Binary GlobAtom
data FilePathGlobRel
= GlobDir !Glob !FilePathGlobRel
| GlobFile !Glob
| GlobDirTrailing -- ^ trailing dir, a glob ending in @/@
deriving (Eq, Show, Generic)
-- | A single directory or file component of a globbed path
newtype Glob = Glob [GlobAtom]
type Glob = [GlobPiece]
-- | A piece of a globbing pattern
data GlobPiece = WildCard
| Literal String
| Union [Glob]
deriving (Eq, Show, Generic)
instance Binary Glob
data FilePathRoot
= FilePathRelative
| FilePathUnixRoot
| FilePathWinDrive Char
| FilePathHomeDir
deriving (Eq, Show, Generic)
instance Binary FilePathGlob
instance Binary FilePathRoot
instance Binary FilePathGlobRel
instance Binary GlobPiece
-- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and
-- is in fact equivalent to a non-glob 'FilePath'.
--
-- If it is trivial in this sense then the result is the equivalent constant
-- 'FilePath'. On the other hand if it is not trivial (so could in principle
-- match more than one file) then the result is @Nothing@.
--
isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath
isTrivialFilePathGlob (FilePathGlob root pathglob) =
case root of
FilePathRelative -> go [] pathglob
FilePathUnixRoot -> go ["/"] pathglob
FilePathWinDrive drive -> go [drive:":"] pathglob
FilePathHomeDir -> Nothing
where
go paths (GlobDir [Literal path] globs) = go (path:paths) globs
go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path:paths)))
go paths GlobDirTrailing = Just (addTrailingPathSeparator
(joinPath (reverse paths)))
go _ _ = Nothing
-- | Get the 'FilePath' corresponding to a 'FilePathRoot'.
--
-- The 'FilePath' argument is required to supply the path for the
-- 'FilePathRelative' case.
--
getFilePathRootDirectory :: FilePathRoot
-> FilePath -- ^ root for relative paths
-> IO FilePath
getFilePathRootDirectory FilePathRelative root = return root
getFilePathRootDirectory FilePathUnixRoot _ = return "/"
getFilePathRootDirectory (FilePathWinDrive drive) _ = return (drive:":")
getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory
------------------------------------------------------------------------------
-- Matching
--
-- | Match a 'FilePathGlob' against the file system, starting from a given
-- root directory for relative paths. The results of relative globs are
-- relative to the given root. Matches for absolute globs are absolute.
--
matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath]
matchFileGlob relroot (FilePathGlob globroot glob) = do
root <- getFilePathRootDirectory globroot relroot
matches <- matchFileGlobRel root glob
case globroot of
FilePathRelative -> return matches
_ -> return (map (root </>) matches)
-- | Match a 'FilePathGlobRel' against the file system, starting from a
-- given root directory. The results are all relative to the given root.
--
matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath]
matchFileGlobRel root glob0 = go glob0 ""
where
go (GlobFile glob) dir = do
entries <- getDirectoryContents (root </> dir)
let files = filter (matchGlob glob) entries
return (map (dir </>) files)
go (GlobDir glob globPath) dir = do
entries <- getDirectoryContents (root </> dir)
subdirs <- filterM (\subdir -> doesDirectoryExist
(root </> dir </> subdir))
$ filter (matchGlob glob) entries
concat <$> mapM (\subdir -> go globPath (dir </> subdir)) subdirs
go GlobDirTrailing dir = return [dir]
-- | Test whether a file path component matches a globbing pattern
-- | Match a globbing pattern against a file path component
--
globMatches :: Glob -> String -> Bool
globMatches (Glob atoms) = goStart atoms
matchGlob :: Glob -> String -> Bool
matchGlob = goStart
where
-- From the man page, glob(7):
-- "If a filename starts with a '.', this character must be
-- matched explicitly."
go, goStart :: [GlobAtom] -> String -> Bool
go, goStart :: [GlobPiece] -> String -> Bool
goStart (WildCard:_) ('.':_) = False
goStart (Union globs:rest) cs = any (\(Glob glob) ->
goStart (glob ++ rest) cs) globs
goStart (Union globs:rest) cs = any (\glob -> goStart (glob ++ rest) cs)
globs
goStart rest cs = go rest cs
go [] "" = True
......@@ -54,53 +161,116 @@ globMatches (Glob atoms) = goStart atoms
| otherwise = False
go [WildCard] "" = True
go (WildCard:rest) (c:cs) = go rest (c:cs) || go (WildCard:rest) cs
go (Union globs:rest) cs = any (\(Glob glob) ->
go (glob ++ rest) cs) globs
go (Union globs:rest) cs = any (\glob -> go (glob ++ rest) cs) globs
go [] (_:_) = False
go (_:_) "" = False
instance Text Glob where
disp (Glob atoms) = Disp.hcat (map dispAtom atoms)
where
dispAtom WildCard = Disp.char '*'
dispAtom (Literal str) = Disp.text (escape str)
dispAtom (Union globs) = Disp.braces
(Disp.hcat (Disp.punctuate (Disp.char ',')
(map disp globs)))
escape [] = []
escape (c:cs)
| isGlobEscapedChar c = '\\' : c : escape cs
| otherwise = c : escape cs
parse = Glob `fmap` many1 globAtom
------------------------------------------------------------------------------
-- Parsing & printing
--
instance Text FilePathGlob where
disp (FilePathGlob root pathglob) = disp root Disp.<> disp pathglob
parse =
parse >>= \root ->
(FilePathGlob root <$> parse)
<++ (when (root == FilePathRelative) Parse.pfail >>
return (FilePathGlob root GlobDirTrailing))
instance Text FilePathRoot where
disp FilePathRelative = Disp.empty
disp FilePathUnixRoot = Disp.char '/'
disp (FilePathWinDrive c) = Disp.char c
Disp.<> Disp.char ':'
Disp.<> Disp.char '\\'
disp FilePathHomeDir = Disp.char '~'
Disp.<> Disp.char '/'
parse =
( (Parse.char '/' >> return FilePathUnixRoot)
+++ (Parse.char '~' >> Parse.char '/' >> return FilePathHomeDir)
+++ (do drive <- Parse.satisfy (\c -> (c >= 'a' && c <= 'z')
|| (c >= 'A' && c <= 'Z'))
_ <- Parse.char ':'
_ <- Parse.char '/' +++ Parse.char '\\'
return (FilePathWinDrive (toUpper drive)))
)
<++ return FilePathRelative
instance Text FilePathGlobRel where
disp (GlobDir glob pathglob) = dispGlob glob
Disp.<> Disp.char '/'
Disp.<> disp pathglob
disp (GlobFile glob) = dispGlob glob
disp GlobDirTrailing = Disp.empty
parse = parsePath
where
globAtom :: ReadP r GlobAtom
globAtom = literal +++ wildcard +++ union
parsePath :: ReadP r FilePathGlobRel
parsePath =
parseGlob >>= \globpieces ->
asDir globpieces
<++ asTDir globpieces
<++ asFile globpieces
asDir glob = do dirSep
globs <- parsePath
return (GlobDir glob globs)
asTDir glob = do dirSep
return (GlobDir glob GlobDirTrailing)
asFile glob = return (GlobFile glob)
dirSep = (Parse.char '/' >> return ())
+++ (do _ <- Parse.char '\\'
-- check this isn't an escape code
following <- Parse.look
case following of
(c:_) | isGlobEscapedChar c -> Parse.pfail
_ -> return ())
dispGlob :: Glob -> Disp.Doc
dispGlob = Disp.hcat . map dispPiece
where
dispPiece WildCard = Disp.char '*'
dispPiece (Literal str) = Disp.text (escape str)
dispPiece (Union globs) = Disp.braces
(Disp.hcat (Disp.punctuate
(Disp.char ',')
(map dispGlob globs)))
escape [] = []
escape (c:cs)
| isGlobEscapedChar c = '\\' : c : escape cs
| otherwise = c : escape cs
parseGlob :: ReadP r Glob
parseGlob = Parse.many1 parsePiece
where
parsePiece = literal +++ wildcard +++ union
wildcard = Parse.char '*' >> return WildCard
union = Parse.between (Parse.char '{') (Parse.char '}') $
fmap Union (Parse.sepBy1 parseGlob (Parse.char ','))
wildcard = char '*' >> return WildCard
literal = Literal `fmap` litchars1
union = between (char '{') (char '}')
(fmap (Union . map Glob) $ sepBy1 (many1 globAtom) (char ','))
litchar = normal +++ escape
literal = Literal `fmap` many1'
where
litchar = normal +++ escape
normal = satisfy (not . isGlobEscapedChar)
escape = char '\\' >> satisfy isGlobEscapedChar
normal = Parse.satisfy (\c -> not (isGlobEscapedChar c)
&& c /= '/' && c /= '\\')
escape = Parse.char '\\' >> Parse.satisfy isGlobEscapedChar
many1' :: ReadP r [Char]
many1' = liftM2 (:) litchar many'
litchars1 :: ReadP r [Char]
litchars1 = liftM2 (:) litchar litchars
many' :: ReadP r [Char]
many' = many1' <++ return []
litchars :: ReadP r [Char]
litchars = litchars1 <++ return []
isGlobEscapedChar :: Char -> Bool
isGlobEscapedChar '*' = True
isGlobEscapedChar '{' = True
isGlobEscapedChar '}' = True
isGlobEscapedChar ',' = True
isGlobEscapedChar '\\' = True
isGlobEscapedChar '/' = True
isGlobEscapedChar _ = False
\ No newline at end of file
isGlobEscapedChar _ = False
......@@ -22,11 +22,16 @@ module Distribution.Client.InstallPlan (
-- * Operations on 'InstallPlan's
new,
toList,
mapPreservingGraph,
ready,
processing,
completed,
failed,
remove,
preexisting,
preinstalled,
showPlanIndex,
showInstallPlan,
......@@ -72,9 +77,9 @@ import Distribution.Text
( display )
import Data.List
( intercalate )
( foldl', intercalate )
import Data.Maybe
( fromMaybe, maybeToList )
( fromMaybe, catMaybes )
import qualified Data.Graph as Graph
import Data.Graph (Graph)
import qualified Data.Tree as Tree
......@@ -82,7 +87,6 @@ import Distribution.Compat.Binary (Binary(..))
import GHC.Generics
import Control.Exception
( assert )
import Data.Maybe (catMaybes)
import qualified Data.Map as Map
import qualified Data.Traversable as T
......@@ -354,12 +358,17 @@ ready plan = assert check readyPackages
processingPackages = [ pkg | Processing pkg <- toList plan]
readyPackages :: [GenericReadyPackage srcpkg ipkg]
readyPackages =
[ ReadyPackage srcpkg deps
| srcpkg <- configuredPackages
-- select only the package that have all of their deps installed:
, deps <- maybeToList (hasAllInstalledDeps srcpkg)
]
readyPackages = catMaybes (map (lookupReadyPackage plan) configuredPackages)
lookupReadyPackage :: forall ipkg srcpkg iresult ifailure.
PackageFixedDeps srcpkg
=> GenericInstallPlan ipkg srcpkg iresult ifailure
-> srcpkg
-> Maybe (GenericReadyPackage srcpkg ipkg)
lookupReadyPackage plan pkg = do
deps <- hasAllInstalledDeps pkg
return (ReadyPackage pkg deps)
where
hasAllInstalledDeps :: srcpkg -> Maybe (ComponentDeps [ipkg])
hasAllInstalledDeps = T.mapM (mapM isInstalledDep) . depends
......@@ -487,6 +496,97 @@ checkConfiguredPackage (Failed _ _) = Nothing
checkConfiguredPackage pkg =
internalError $ "not configured or no such pkg " ++ display (packageId pkg)
-- | Replace a ready package with a pre-existing one. The pre-existing one
-- must have exactly the same dependencies as the source one was configured
-- with.
--
preexisting :: (HasUnitId ipkg, PackageFixedDeps ipkg,
HasUnitId srcpkg, PackageFixedDeps srcpkg)
=> UnitId
-> ipkg
-> GenericInstallPlan ipkg srcpkg iresult ifailure
-> GenericInstallPlan ipkg srcpkg iresult ifailure
preexisting pkgid ipkg plan = assert (invariant plan') plan'
where
plan' = plan {
-- NB: installation can change the IPID, so better
-- record it in the fake mapping...
planFakeMap = Map.insert pkgid
(installedUnitId ipkg)
(planFakeMap plan),
planIndex = PackageIndex.insert (PreExisting ipkg)
-- ...but be sure to use the *old* IPID for the lookup for
-- the preexisting record
. PackageIndex.deleteUnitId pkgid
$ planIndex plan
}
-- | Replace a ready package with an installed one. The installed one
-- must have exactly the same dependencies as the source one was configured
-- with.
--
preinstalled :: (HasUnitId ipkg, PackageFixedDeps ipkg,
HasUnitId srcpkg, PackageFixedDeps srcpkg)
=> UnitId
-> Maybe ipkg -> iresult
-> GenericInstallPlan ipkg srcpkg iresult ifailure
-> GenericInstallPlan ipkg srcpkg iresult ifailure
preinstalled pkgid mipkg buildResult plan = assert (invariant plan') plan'
where
plan' = plan { planIndex = PackageIndex.insert installed (planIndex plan) }
Just installed = do
Configured pkg <- PackageIndex.lookupUnitId (planIndex plan) pkgid
rpkg <- lookupReadyPackage plan pkg
return (Installed rpkg mipkg buildResult)
-- | Transform an install plan by mapping a function over all the packages in
-- the plan. It can consistently change the 'UnitId' of all the packages,
-- while preserving the same overall graph structure.
--
-- The mapping function has a few constraints on it for correct operation.
-- The mapping function /may/ change the 'UnitId' of the package, but it
-- /must/ also remap the 'UnitId's of its dependencies using ths supplied
-- remapping function. Apart from this consistent remapping it /may not/
-- change the structure of the dependencies.
--
mapPreservingGraph :: (HasUnitId ipkg,
HasUnitId srcpkg,
HasUnitId ipkg', PackageFixedDeps ipkg',
HasUnitId srcpkg', PackageFixedDeps srcpkg')
=> ( (UnitId -> UnitId)
-> GenericPlanPackage ipkg srcpkg iresult ifailure
-> GenericPlanPackage ipkg' srcpkg' iresult' ifailure')
-> GenericInstallPlan ipkg srcpkg iresult ifailure
-> GenericInstallPlan ipkg' srcpkg' iresult' ifailure'
mapPreservingGraph f plan =
mkInstallPlan (PackageIndex.fromList pkgs')
Map.empty -- empty fakeMap
(planIndepGoals plan)
where
-- The package mapping function may change the UnitId. So we
-- walk over the packages in dependency order keeping track of these
-- package id changes and use it to supply the correct set of package
-- dependencies as an extra input to the package mapping function.
--
-- Having fully remapped all the deps this also means we can use an empty
-- FakeMap for the resulting install plan.
(_, pkgs') = foldl' f' (Map.empty, []) (reverseTopologicalOrder plan)
f' (ipkgidMap, pkgs) pkg = (ipkgidMap', pkg' : pkgs)
where
pkg' = f (mapDep ipkgidMap) pkg
ipkgidMap'
| ipkgid /= ipkgid' = Map.insert ipkgid ipkgid' ipkgidMap
| otherwise = ipkgidMap
where
ipkgid = installedUnitId pkg
ipkgid' = installedUnitId pkg'
mapDep ipkgidMap ipkgid = Map.findWithDefault ipkgid ipkgid ipkgidMap
-- ------------------------------------------------------------
-- * Checking validity of plans
-- ------------------------------------------------------------
......
{-# LANGUAGE RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-}
-- | Functions to calculate nix-style hashes for package ids.
--
-- The basic idea is simple, hash the combination of:
--
-- * the package tarball
-- * the ids of all the direct dependencies
-- * other local configuration (flags, profiling, etc)
--
module Distribution.Client.PackageHash (
-- * Calculating package hashes
PackageHashInputs(..),
PackageHashConfigInputs(..),
PackageSourceHash,
hashedInstalledPackageId,
hashPackageHashInputs,
renderPackageHashInputs,
-- * Low level hash choice
HashValue,
hashValue,
showHashValue,
readFileHashValue
) where
import Distribution.Package
( PackageId, mkUnitId )
import Distribution.System
( Platform )
import Distribution.PackageDescription
( FlagName(..), FlagAssignment )
import Distribution.Simple.Compiler
( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)
, ProfDetailLevel(..), showProfDetailLevel )
import Distribution.Simple.InstallDirs
( PathTemplate, fromPathTemplate )
import Distribution.Text
( display )
import Distribution.Client.Types
( InstalledPackageId )
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Crypto.Hash as Hash
import qualified Data.Byteable as Hash
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Maybe (catMaybes)
import Data.List (sortBy, intercalate)
import Data.Function (on)
import Distribution.Compat.Binary (Binary(..))
import Control.Exception (evaluate)
import System.IO (withBinaryFile, IOMode(..))
-------------------------------
-- Calculating package hashes
--
-- | Calculate a 'InstalledPackageId' for a package using our nix-style
-- inputs hashing method.
--
hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId
hashedInstalledPackageId pkghashinputs@PackageHashInputs{pkgHashPkgId} =
mkUnitId $
display pkgHashPkgId -- to be a bit user friendly
++ "-"
++ showHashValue (hashPackageHashInputs pkghashinputs)
-- | All the information that contribues to a package's hash, and thus its
-- 'InstalledPackageId'.
--
data PackageHashInputs = PackageHashInputs {
pkgHashPkgId :: PackageId,
pkgHashSourceHash :: PackageSourceHash,
pkgHashDirectDeps :: Set InstalledPackageId,
pkgHashOtherConfig :: PackageHashConfigInputs
}
type PackageSourceHash = HashValue
-- | Those parts of the package configuration that contribute to the
-- package hash.
--
data PackageHashConfigInputs = PackageHashConfigInputs {
pkgHashCompilerId :: CompilerId,
pkgHashPlatform :: Platform,
pkgHashFlagAssignment :: FlagAssignment, -- complete not partial
pkgHashConfigureScriptArgs :: [String], -- just ./configure for build-type Configure
pkgHashVanillaLib :: Bool,
pkgHashSharedLib :: Bool,
pkgHashDynExe :: Bool,
pkgHashGHCiLib :: Bool,
pkgHashProfLib :: Bool,
pkgHashProfExe :: Bool,
pkgHashProfLibDetail :: ProfDetailLevel,
pkgHashProfExeDetail :: ProfDetailLevel,
pkgHashCoverage :: Bool,
pkgHashOptimization :: OptimisationLevel,
pkgHashSplitObjs :: Bool,
pkgHashStripLibs :: Bool,