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

Merge nix-local-build changes from 1.24

cabal-install/Distribution/Client/Glob.hs

-{-# 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

cabal-install/Distribution/Client/InstallPlan.hs

@@ -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
 -- ------------------------------------------------------------

cabal-install/Distribution/Client/PackageHash.hs

+{-# 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,
+